1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Common;
14 Debbugs::Common -- Common routines for all of Debbugs
18 use Debbugs::Common qw(:url :html);
23 This module is a replacement for the general parts of errorlib.pl.
24 subroutines in errorlib.pl will be gradually phased out and replaced
25 with equivalent (or better) functionality here.
33 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
34 use Exporter qw(import);
39 $DEBUG = 0 unless defined $DEBUG;
42 %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
43 qw(appendfile overwritefile buglog getparsedaddrs getmaintainers),
44 qw(getsourcemaintainers getsourcemaintainers_reverse),
46 qw(getmaintainers_reverse),
48 qw(package_maintainer),
50 qw(open_compressed_file),
53 misc => [qw(make_list globify_scalar english_join checkpid),
54 qw(cleanup_eval_fail),
57 date => [qw(secs_to_english)],
59 lock => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)],
62 Exporter::export_ok_tags(keys %EXPORT_TAGS);
63 $EXPORT_TAGS{all} = [@EXPORT_OK];
66 #use Debbugs::Config qw(:globals);
71 use Debbugs::Config qw(:config);
74 use Debbugs::MIME qw(decode_rfc1522);
77 use Storable qw(dclone);
78 use Time::HiRes qw(usleep);
79 use File::Path qw(mkpath);
80 use File::Basename qw(dirname);
81 use MLDBM qw(DB_File Storable);
82 $MLDBM::DumpMeth='portable';
83 use List::AllUtils qw(natatime);
85 use Params::Validate qw(validate_with :types);
87 use Fcntl qw(:DEFAULT :flock);
88 use Encode qw(is_utf8 decode_utf8);
90 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
94 The following functions are exported by the C<:util> tag
96 =head2 getbugcomponent
98 my $file = getbugcomponent($bug_number,$extension,$location)
100 Returns the path to the bug file in location C<$location>, bug number
101 C<$bugnumber> and extension C<$extension>
105 sub getbugcomponent {
106 my ($bugnum, $ext, $location) = @_;
108 if (not defined $location) {
109 $location = getbuglocation($bugnum, $ext);
110 # Default to non-archived bugs only for now; CGI scripts want
111 # archived bugs but most of the backend scripts don't. For now,
112 # anything that is prepared to accept archived bugs should call
113 # getbuglocation() directly first.
114 return undef if defined $location and
115 ($location ne 'db' and $location ne 'db-h');
117 my $dir = getlocationpath($location);
118 return undef if not defined $dir;
119 if (defined $location and $location eq 'db') {
120 return "$dir/$bugnum.$ext";
122 my $hash = get_hashname($bugnum);
123 return "$dir/$hash/$bugnum.$ext";
127 =head2 getbuglocation
129 getbuglocation($bug_number,$extension)
131 Returns the the location in which a particular bug exists; valid
132 locations returned currently are archive, db-h, or db. If the bug does
133 not exist, returns undef.
138 my ($bugnum, $ext) = @_;
139 my $archdir = get_hashname($bugnum);
140 return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
141 return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
142 return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
147 =head2 getlocationpath
149 getlocationpath($location)
151 Returns the path to a specific location
155 sub getlocationpath {
157 if (defined $location and $location eq 'archive') {
158 return "$config{spool_dir}/archive";
159 } elsif (defined $location and $location eq 'db') {
160 return "$config{spool_dir}/db";
162 return "$config{spool_dir}/db-h";
171 Returns the hash of the bug which is the location within the archive
176 return "" if ( $_[ 0 ] < 0 );
177 return sprintf "%02d", $_[ 0 ] % 100;
184 Returns the path to the logfile corresponding to the bug.
186 Returns undef if the bug does not exist.
192 my $location = getbuglocation($bugnum, 'log');
193 return getbugcomponent($bugnum, 'log', $location) if ($location);
194 $location = getbuglocation($bugnum, 'log.gz');
195 return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
204 Returns the path to the summary file corresponding to the bug.
206 Returns undef if the bug does not exist.
212 my $location = getbuglocation($bugnum, 'summary');
213 return getbugcomponent($bugnum, 'summary', $location) if ($location);
219 appendfile($file,'data','to','append');
221 Opens a file for appending and writes data to it.
226 my ($file,@data) = @_;
227 my $fh = IO::File->new($file,'a') or
228 die "Unable top open $file for appending: $!";
229 print {$fh} @data or die "Unable to write to $file: $!";
230 close $fh or die "Unable to close $file: $!";
235 ovewritefile($file,'data','to','append');
237 Opens file.new, writes data to it, then moves file.new to file.
242 my ($file,@data) = @_;
243 my $fh = IO::File->new("${file}.new",'w') or
244 die "Unable top open ${file}.new for writing: $!";
245 print {$fh} @data or die "Unable to write to ${file}.new: $!";
246 close $fh or die "Unable to close ${file}.new: $!";
247 rename("${file}.new",$file) or
248 die "Unable to rename ${file}.new to $file: $!";
251 =head2 open_compressed_file
253 my $fh = open_compressed_file('foo.gz') or
254 die "Unable to open compressed file: $!";
257 Opens a file; if the file ends in .gz, .xz, or .bz2, the appropriate
258 decompression program is forked and output from it is read.
260 This routine by default opens the file with UTF-8 encoding; if you want some
261 other encoding, specify it with the second option.
264 sub open_compressed_file {
265 my ($file,$encoding) = @_;
266 $encoding //= ':encoding(UTF-8)';
268 my $mode = "<$encoding";
270 if ($file =~ /\.gz$/) {
271 $mode = "-|$encoding";
272 push @opts,'gzip','-dc';
274 if ($file =~ /\.xz$/) {
275 $mode = "-|$encoding";
276 push @opts,'xz','-dc';
278 if ($file =~ /\.bz2$/) {
279 $mode = "-|$encoding";
280 push @opts,'bzip2','-dc';
282 open($fh,$mode,@opts,$file);
288 Walk through directories of bugs, calling a subroutine with a list of bugs
291 C<walk_bugs(callback => sub {print map {qq($_\n)} @_},dirs => [qw(db-h)];>
295 =item callback -- CODEREF of a subroutine to call with a list of bugs
297 =item dirs -- ARRAYREF of directories to get bugs from. Like C<[qw(db-h archive)]>.
299 =item bugs -- ARRAYREF of bugs to walk through. If both C<dirs> and C<bugs> are
300 provided, both are walked through.
302 =item bugs_per_call -- maximum number of bugs to provide to callback
304 =item progress_bar -- optional L<Term::ProgressBar>
306 =item bug_file -- bug file to look for (generally C<summary>)
308 =item logging -- optional filehandle to output logging information
316 {dirs => {type => ARRAYREF,
319 bugs => {type => ARRAYREF,
322 progress_bar => {type => OBJECT|UNDEF,
325 bug_file => {type => SCALAR,
326 default => 'summary',
328 logging => {type => HANDLE,
331 callback => {type => CODEREF,
333 bugs_per_call => {type => SCALAR,
337 my %param = validate_with(params => \@_,
340 my @dirs = @{$param{dirs}};
341 my @initial_bugs = ();
342 if (@{$param{bugs}}) {
344 @initial_bugs = @{$param{bugs}};
346 my $tot_dirs = @dirs;
348 my $avg_subfiles = 0;
349 my $completed_files = 0;
351 while ($dir = shift @dirs or defined $dir) {
354 if (not length $dir and @initial_bugs) {
355 push @list,@initial_bugs;
358 printf {$param{verbose}} "Doing dir %s ...\n", $dir
359 if defined $param{verbose};
360 opendir(my $DIR, "$dir/.") or
361 die "opendir $dir: $!";
362 @subdirs = readdir($DIR) or
363 die "Unable to readdir $dir: $!";
365 die "Unable to closedir $dir: $!";
367 @list = map { m/^(\d+)\.$param{bug_file}$/?($1):() } @subdirs;
370 push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
372 if ($param{progress_bar}) {
373 if ($avg_subfiles == 0) {
374 $avg_subfiles = @list;
376 $param{progress_bar}->
377 target($avg_subfiles*($tot_dirs-$done_dirs)+$completed_files+@list);
378 $avg_subfiles = ($avg_subfiles * $done_dirs + @list) / ($done_dirs+1);
382 my $it = natatime $param{bugs_per_call},@list;
383 while (my @bugs = $it->()) {
384 $param{callback}->(@bugs);
385 $completed_files += scalar @bugs;
386 if ($param{progress_bar}) {
387 $param{progress_bar}->update($completed_files) if $param{progress_bar};
389 if ($completed_files % 100 == 0 and
390 defined $param{verbose}) {
391 print {$param{verbose}} "Up to $completed_files bugs...\n"
395 $param{progress_bar}->remove() if $param{progress_bar};
399 =head2 getparsedaddrs
401 my $address = getparsedaddrs($address);
402 my @address = getparsedaddrs($address);
404 Returns the output from Mail::Address->parse, or the cached output if
405 this address has been parsed before. In SCALAR context returns the
406 first address parsed.
414 return () unless defined $addr;
415 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
416 if exists $_parsedaddrs{$addr};
418 # don't display the warnings from Mail::Address->parse
419 local $SIG{__WARN__} = sub { };
420 @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
422 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
425 =head2 getmaintainers
427 my $maintainer = getmaintainers()->{debbugs}
429 Returns a hashref of package => maintainer pairs.
433 our $_maintainer = undef;
434 our $_maintainer_rev = undef;
436 return $_maintainer if defined $_maintainer;
437 package_maintainer(rehash => 1);
441 =head2 getmaintainers_reverse
443 my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
445 Returns a hashref of maintainer => [qw(list of packages)] pairs.
449 sub getmaintainers_reverse{
450 return $_maintainer_rev if defined $_maintainer_rev;
451 package_maintainer(rehash => 1);
452 return $_maintainer_rev;
455 =head2 getsourcemaintainers
457 my $maintainer = getsourcemaintainers()->{debbugs}
459 Returns a hashref of src_package => maintainer pairs.
463 our $_source_maintainer = undef;
464 our $_source_maintainer_rev = undef;
465 sub getsourcemaintainers {
466 return $_source_maintainer if defined $_source_maintainer;
467 package_maintainer(rehash => 1);
468 return $_source_maintainer;
471 =head2 getsourcemaintainers_reverse
473 my @src_packages = @{getsourcemaintainers_reverse->{'don@debian.org'}||[]};
475 Returns a hashref of maintainer => [qw(list of source packages)] pairs.
479 sub getsourcemaintainers_reverse{
480 return $_source_maintainer_rev if defined $_source_maintainer_rev;
481 package_maintainer(rehash => 1);
482 return $_source_maintainer_rev;
485 =head2 package_maintainer
487 my @s = package_maintainer(source => [qw(foo bar baz)],
488 binary => [qw(bleh blah)],
493 =item source -- scalar or arrayref of source package names to return
494 maintainers for, defaults to the empty arrayref.
496 =item binary -- scalar or arrayref of binary package names to return
497 maintainers for; automatically returns source package maintainer if
498 the package name starts with 'src:', defaults to the empty arrayref.
500 =item maintainer -- scalar or arrayref of maintainers to return source packages
501 for. If given, binary and source cannot be given.
503 =item rehash -- whether to reread the maintainer and source maintainer
506 =item schema -- Debbugs::DB schema. If set, uses the database for maintainer
513 sub package_maintainer {
514 my %param = validate_with(params => \@_,
515 spec => {source => {type => SCALAR|ARRAYREF,
518 binary => {type => SCALAR|ARRAYREF,
521 maintainer => {type => SCALAR|ARRAYREF,
524 rehash => {type => BOOLEAN,
527 reverse => {type => BOOLEAN,
530 schema => {type => OBJECT,
535 my @binary = make_list($param{binary});
536 my @source = make_list($param{source});
537 my @maintainers = make_list($param{maintainer});
538 if ((@binary or @source) and @maintainers) {
539 croak "It is nonsensical to pass both maintainers and source or binary";
542 @source = grep {/^src:/} @binary;
543 @binary = grep {!/^src:/} @binary;
545 # remove leading src: from source package names
546 s/^src:// foreach @source;
547 if ($param{schema}) {
548 my $s = $param{schema};
550 my $m_rs = $s->resultset('SrcPkg')->
551 search({'correspondent.addr' => [@maintainers]},
552 {join => {src_vers =>
557 group_by => [qw(me.pkg)],
559 return $m_rs->get_column('pkg')->all();
560 } elsif (@binary or @source) {
561 my $rs = $s->resultset('Maintainer');
564 $rs->search({'bin_pkg.pkg' => [@binary]},
565 {join => {src_vers =>
566 {bin_vers => 'bin_pkg'},
569 group_by => [qw(me.name)],
575 $rs->search({'src_pkg.pkg' => [@source]},
576 {join => {src_vers =>
580 group_by => [qw(me.name)],
584 return $rs->get_column('name')->all();
588 if ($param{rehash}) {
589 $_source_maintainer = undef;
590 $_source_maintainer_rev = undef;
591 $_maintainer = undef;
592 $_maintainer_rev = undef;
594 if (not defined $_source_maintainer or
595 not defined $_source_maintainer_rev) {
596 $_source_maintainer = {};
597 $_source_maintainer_rev = {};
598 if (-e $config{spool_dir}.'/source_maintainers.idx' and
599 -e $config{spool_dir}.'/source_maintainers_reverse.idx'
601 tie %{$_source_maintainer},
602 MLDBM => $config{spool_dir}.'/source_maintainers.idx',
604 die "Unable to tie source maintainers: $!";
605 tie %{$_source_maintainer_rev},
606 MLDBM => $config{spool_dir}.'/source_maintainers_reverse.idx',
608 die "Unable to tie source maintainers reverse: $!";
610 for my $fn (@config{('source_maintainer_file',
611 'source_maintainer_file_override',
612 'pseudo_maint_file')}) {
613 next unless defined $fn and length $fn;
615 warn "Missing source maintainer file '$fn'";
618 __add_to_hash($fn,$_source_maintainer,
619 $_source_maintainer_rev);
623 if (not defined $_maintainer or
624 not defined $_maintainer_rev) {
626 $_maintainer_rev = {};
627 if (-e $config{spool_dir}.'/maintainers.idx' and
628 -e $config{spool_dir}.'/maintainers_reverse.idx'
631 MLDBM => $config{spool_dir}.'/binary_maintainers.idx',
633 die "Unable to tie binary maintainers: $!";
634 tie %{$_maintainer_rev},
635 MLDBM => $config{spool_dir}.'/binary_maintainers_reverse.idx',
637 die "Unable to binary maintainers reverse: $!";
639 for my $fn (@config{('maintainer_file',
640 'maintainer_file_override',
641 'pseudo_maint_file')}) {
642 next unless defined $fn and length $fn;
644 warn "Missing maintainer file '$fn'";
647 __add_to_hash($fn,$_maintainer,
653 for my $binary (@binary) {
654 if ($binary =~ /^src:/) {
655 push @source,$binary;
658 push @return,grep {defined $_} make_list($_maintainer->{$binary});
660 for my $source (@source) {
661 $source =~ s/^src://;
662 push @return,grep {defined $_} make_list($_source_maintainer->{$source});
664 for my $maintainer (grep {defined $_} @maintainers) {
665 push @return,grep {defined $_}
666 make_list($_maintainer_rev->{$maintainer});
667 push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
669 make_list($_source_maintainer_rev->{$maintainer});
674 #=head2 __add_to_hash
676 # __add_to_hash($file,$forward_hash,$reverse_hash,'address');
678 # Reads a maintainer/source maintainer/pseudo desc file and adds the
679 # maintainers from it to the forward and reverse hashref; assumes that
680 # the forward is unique; makes no assumptions of the reverse.
685 my ($fn,$forward,$reverse,$type) = @_;
686 if (ref($forward) ne 'HASH') {
687 croak "__add_to_hash must be passed a hashref for the forward";
689 if (defined $reverse and not ref($reverse) eq 'HASH') {
690 croak "if reverse is passed to __add_to_hash, it must be a hashref";
693 my $fh = IO::File->new($fn,'r') or
694 croak "Unable to open $fn for reading: $!";
695 binmode($fh,':encoding(UTF-8)');
698 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
699 my ($key,$value)=($1,$2);
701 $forward->{$key}= $value;
702 if (defined $reverse) {
703 if ($type eq 'address') {
704 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
705 push @{$reverse->{$m}},$key;
709 push @{$reverse->{$value}}, $key;
718 my $pseudopkgdesc = getpseudodesc(...);
720 Returns the entry for a pseudo package from the
721 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
722 defined, returns an empty arrayref.
724 This function can be used to see if a particular package is a
725 pseudopackage or not.
729 our $_pseudodesc = undef;
731 return $_pseudodesc if defined $_pseudodesc;
733 __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
734 defined $config{pseudo_desc_file} and
735 length $config{pseudo_desc_file};
741 sort_versions('1.0-2','1.1-2');
743 Sorts versions using AptPkg::Versions::compare if it is available, or
744 Debbugs::Versions::Dpkg::vercmp if it isn't.
750 use Debbugs::Versions::Dpkg;
751 $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
753 # eventually we'll use AptPkg:::Version or similar, but the current
754 # implementation makes this *super* difficult.
757 # use AptPkg::Version;
758 # $vercmp=\&AptPkg::Version::compare;
763 return sort {$vercmp->($a,$b)} @_;
769 my $english = secs_to_english($seconds);
770 my ($days,$english) = secs_to_english($seconds);
772 XXX This should probably be changed to use Date::Calc
779 my $days = int($seconds / 86400);
780 my $years = int($days / 365);
784 push @age, "1 year" if ($years == 1);
785 push @age, "$years years" if ($years > 1);
786 push @age, "1 day" if ($days == 1);
787 push @age, "$days days" if ($days > 1);
788 $result .= join(" and ", @age);
790 return wantarray?(int($seconds/86400),$result):$result;
796 These functions are exported with the :lock tag
801 filelock($lockfile,$locks);
803 FLOCKs the passed file. Use unfilelock to unlock it.
805 Can be passed an optional $locks hashref, which is used to track which
806 files are locked (and how many times they have been locked) to allow
807 for cooperative locking.
816 # NB - NOT COMPATIBLE WITH `with-lock'
817 my ($lockfile,$locks) = @_;
818 if ($lockfile !~ m{^/}) {
819 $lockfile = cwd().'/'.$lockfile;
821 # This is only here to allow for relocking bugs inside of
822 # Debbugs::Control. Nothing else should be using it.
823 if (defined $locks and exists $locks->{locks}{$lockfile} and
824 $locks->{locks}{$lockfile} >= 1) {
825 if (exists $locks->{relockable} and
826 exists $locks->{relockable}{$lockfile}) {
827 $locks->{locks}{$lockfile}++;
828 # indicate that the bug for this lockfile needs to be reread
829 $locks->{relockable}{$lockfile} = 1;
830 push @{$locks->{lockorder}},$lockfile;
835 confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
838 my ($fh,$t_lockfile,$errors) =
839 simple_filelock($lockfile,10,1);
841 push @filelocks, {fh => $fh, file => $lockfile};
842 if (defined $locks) {
843 $locks->{locks}{$lockfile}++;
844 push @{$locks->{lockorder}},$lockfile;
848 croak "failed to get lock on $lockfile -- $errors".
849 (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
853 =head2 simple_filelock
855 my ($fh,$t_lockfile,$errors) =
856 simple_filelock($lockfile,$count,$wait);
858 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
859 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
862 In list context, returns the lockfile filehandle, lockfile name, and
863 any errors which occured.
865 When the lockfile filehandle is undef, locking failed.
867 These lockfiles must be unlocked manually at process end.
872 sub simple_filelock {
873 my ($lockfile,$count,$wait) = @_;
874 if (not defined $count) {
880 if (not defined $wait) {
887 my $fh2 = IO::File->new($lockfile,'w')
888 or die "Unable to open $lockfile for writing: $!";
889 # Do a blocking lock if count is zero
890 flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
891 or die "Unable to lock $lockfile $!";
900 # use usleep for fractional wait seconds
901 usleep($wait * 1_000_000);
903 last unless (--$count > 0);
906 return wantarray?($fh,$lockfile,$errors):$fh
908 return wantarray?(undef,$lockfile,$errors):undef;
911 # clean up all outstanding locks at end time
918 =head2 simple_unlockfile
920 simple_unlockfile($fh,$lockfile);
925 sub simple_unlockfile {
926 my ($fh,$lockfile) = @_;
928 or warn "Unable to unlock lockfile $lockfile: $!";
930 or warn "Unable to close lockfile $lockfile: $!";
932 or warn "Unable to unlink lockfile $lockfile: $!";
941 Unlocks the file most recently locked.
943 Note that it is not currently possible to unlock a specific file
944 locked with filelock.
950 if (@filelocks == 0) {
951 carp "unfilelock called with no active filelocks!\n";
954 if (defined $locks and ref($locks) ne 'HASH') {
955 croak "hash not passsed to unfilelock";
957 if (defined $locks and exists $locks->{lockorder} and
958 @{$locks->{lockorder}} and
959 exists $locks->{locks}{$locks->{lockorder}[-1]}) {
960 my $lockfile = pop @{$locks->{lockorder}};
961 $locks->{locks}{$lockfile}--;
962 if ($locks->{locks}{$lockfile} > 0) {
965 delete $locks->{locks}{$lockfile};
967 my %fl = %{pop(@filelocks)};
968 simple_unlockfile($fl{fh},$fl{file});
974 lockpid('/path/to/pidfile');
976 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
977 pid in the file does not respond to kill 0.
979 Returns 1 on success, false on failure; dies on unusual errors.
986 my $pid = checkpid($pidfile);
987 die "Unable to read pidfile $pidfile: $!" if not defined $pid;
988 return 0 if $pid != 0;
990 die "Unable to unlink stale pidfile $pidfile $!";
992 mkpath(dirname($pidfile));
993 my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
994 die "Unable to open $pidfile for writing: $!";
995 print {$pidfh} $$ or die "Unable to write to $pidfile $!";
996 close $pidfh or die "Unable to close $pidfile $!";
1002 checkpid('/path/to/pidfile');
1004 Checks a pid file and determines if the process listed in the pidfile
1005 is still running. Returns the pid if it is, 0 if it isn't running, and
1006 undef if the pidfile doesn't exist or cannot be read.
1013 my $pidfh = IO::File->new($pidfile, 'r') or
1018 ($pid) = $pid =~ /(\d+)/;
1019 if (defined $pid and kill(0,$pid)) {
1032 These functions are exported with the :quit tag.
1038 Exits the program by calling die.
1040 Usage of quit is deprecated; just call die instead.
1045 print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
1046 carp "quit() is deprecated; call die directly instead";
1052 These functions are exported with the :misc tag
1056 LIST = make_list(@_);
1058 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
1061 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
1062 b)],[qw(c d)] returns qw(a b c d);
1067 return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
1073 print english_join(list => \@list);
1074 print english_join(\@list);
1076 Joins list properly to make an english phrase.
1080 =item normal -- how to separate most values; defaults to ', '
1082 =item last -- how to separate the last two values; defaults to ', and '
1084 =item only_two -- how to separate only two values; defaults to ' and '
1086 =item list -- ARRAYREF values to join; if the first argument is an
1087 ARRAYREF, it's assumed to be the list of values to join
1091 In cases where C<list> is empty, returns ''; when there is only one
1092 element, returns that element.
1097 if (ref $_[0] eq 'ARRAY') {
1098 return english_join(list=>$_[0]);
1100 my %param = validate_with(params => \@_,
1101 spec => {normal => {type => SCALAR,
1104 last => {type => SCALAR,
1105 default => ', and ',
1107 only_two => {type => SCALAR,
1110 list => {type => ARRAYREF,
1114 my @list = @{$param{list}};
1116 return @list?$list[0]:'';
1118 elsif (@list == 2) {
1119 return join($param{only_two},@list);
1121 my $ret = $param{last} . pop(@list);
1122 return join($param{normal},@list) . $ret;
1126 =head2 globify_scalar
1128 my $handle = globify_scalar(\$foo);
1130 if $foo isn't already a glob or a globref, turn it into one using
1131 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
1133 Will carp if given a scalar which isn't a scalarref or a glob (or
1134 globref), and return /dev/null. May return undef if IO::Scalar or
1135 IO::File fails. (Check $!)
1137 The scalar will fill with octets, not perl's internal encoding, so you
1138 must use decode_utf8() after on the scalar, and encode_utf8() on it
1139 before. This appears to be a bug in the underlying modules.
1145 sub globify_scalar {
1148 if (defined $scalar) {
1149 if (defined ref($scalar)) {
1150 if (ref($scalar) eq 'SCALAR' and
1151 not UNIVERSAL::isa($scalar,'GLOB')) {
1152 if (is_utf8(${$scalar})) {
1153 ${$scalar} = decode_utf8(${$scalar});
1154 carp(q(\$scalar must not be in perl's internal encoding));
1156 open $handle, '>:scalar:utf8', $scalar;
1163 elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
1167 carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
1170 if (not defined $_NULL_HANDLE or
1171 not $_NULL_HANDLE->opened()
1174 IO::File->new('/dev/null','>:encoding(UTF-8)') or
1175 die "Unable to open /dev/null for writing: $!";
1177 return $_NULL_HANDLE;
1180 =head2 cleanup_eval_fail()
1182 print "Something failed with: ".cleanup_eval_fail($@);
1184 Does various bits of cleanup on the failure message from an eval (or
1185 any other die message)
1187 Takes at most two options; the first is the actual failure message
1188 (usually $@ and defaults to $@), the second is the debug level
1189 (defaults to $DEBUG).
1191 If debug is non-zero, the code at which the failure occured is output.
1195 sub cleanup_eval_fail {
1196 my ($error,$debug) = @_;
1197 if (not defined $error or not @_) {
1198 $error = $@ // 'unknown reason';
1201 $debug = $DEBUG // 0;
1203 $debug = 0 if not defined $debug;
1208 # ditch the "at foo/bar/baz.pm line 5"
1209 $error =~ s/\sat\s\S+\sline\s\d+//;
1210 # ditch croak messages
1211 $error =~ s/^\t+.+\n?//mg;
1212 # ditch trailing multiple periods in case there was a cascade of
1214 $error =~ s/\.+$/\./;
1220 hash_slice(%hash,qw(key1 key2 key3))
1222 For each key, returns matching values and keys of the hash if they exist
1227 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
1228 # hash without uselessly making a reference to first. DO NOT USE
1229 # PROTOTYPES USELESSLY ELSEWHERE.
1230 sub hash_slice(\%@) {
1231 my ($hashref,@keys) = @_;
1232 return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;