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 reverse -- whether to return the source/binary packages a
501 maintainer maintains instead
503 =item rehash -- whether to reread the maintainer and source maintainer
510 sub package_maintainer {
511 my %param = validate_with(params => \@_,
512 spec => {source => {type => SCALAR|ARRAYREF,
515 binary => {type => SCALAR|ARRAYREF,
518 maintainer => {type => SCALAR|ARRAYREF,
521 rehash => {type => BOOLEAN,
524 reverse => {type => BOOLEAN,
529 my @binary = make_list($param{binary});
530 my @source = make_list($param{source});
531 my @maintainers = make_list($param{maintainer});
532 if ((@binary or @source) and @maintainers) {
533 croak "It is nonsensical to pass both maintainers and source or binary";
535 if ($param{rehash}) {
536 $_source_maintainer = undef;
537 $_source_maintainer_rev = undef;
538 $_maintainer = undef;
539 $_maintainer_rev = undef;
541 if (not defined $_source_maintainer or
542 not defined $_source_maintainer_rev) {
543 $_source_maintainer = {};
544 $_source_maintainer_rev = {};
545 if (-e $config{spool_dir}.'/source_maintainers.idx' and
546 -e $config{spool_dir}.'/source_maintainers_reverse.idx'
548 tie %{$_source_maintainer},
549 MLDBM => $config{spool_dir}.'/source_maintainers.idx',
551 die "Unable to tie source maintainers: $!";
552 tie %{$_source_maintainer_rev},
553 MLDBM => $config{spool_dir}.'/source_maintainers_reverse.idx',
555 die "Unable to tie source maintainers reverse: $!";
557 for my $fn (@config{('source_maintainer_file',
558 'source_maintainer_file_override',
559 'pseudo_maint_file')}) {
560 next unless defined $fn and length $fn;
562 warn "Missing source maintainer file '$fn'";
565 __add_to_hash($fn,$_source_maintainer,
566 $_source_maintainer_rev);
570 if (not defined $_maintainer or
571 not defined $_maintainer_rev) {
573 $_maintainer_rev = {};
574 if (-e $config{spool_dir}.'/maintainers.idx' and
575 -e $config{spool_dir}.'/maintainers_reverse.idx'
578 MLDBM => $config{spool_dir}.'/binary_maintainers.idx',
580 die "Unable to tie binary maintainers: $!";
581 tie %{$_maintainer_rev},
582 MLDBM => $config{spool_dir}.'/binary_maintainers_reverse.idx',
584 die "Unable to binary maintainers reverse: $!";
586 for my $fn (@config{('maintainer_file',
587 'maintainer_file_override',
588 'pseudo_maint_file')}) {
589 next unless defined $fn and length $fn;
591 warn "Missing maintainer file '$fn'";
594 __add_to_hash($fn,$_maintainer,
600 for my $binary (@binary) {
601 if (not $param{reverse} and $binary =~ /^src:/) {
602 push @source,$binary;
605 push @return,grep {defined $_} make_list($_maintainer->{$binary});
607 for my $source (@source) {
608 $source =~ s/^src://;
609 push @return,grep {defined $_} make_list($_source_maintainer->{$source});
611 for my $maintainer (grep {defined $_} @maintainers) {
612 push @return,grep {defined $_}
613 make_list($_maintainer_rev->{$maintainer});
614 push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
616 make_list($_source_maintainer_rev->{$maintainer});
621 #=head2 __add_to_hash
623 # __add_to_hash($file,$forward_hash,$reverse_hash,'address');
625 # Reads a maintainer/source maintainer/pseudo desc file and adds the
626 # maintainers from it to the forward and reverse hashref; assumes that
627 # the forward is unique; makes no assumptions of the reverse.
632 my ($fn,$forward,$reverse,$type) = @_;
633 if (ref($forward) ne 'HASH') {
634 croak "__add_to_hash must be passed a hashref for the forward";
636 if (defined $reverse and not ref($reverse) eq 'HASH') {
637 croak "if reverse is passed to __add_to_hash, it must be a hashref";
640 my $fh = IO::File->new($fn,'r') or
641 croak "Unable to open $fn for reading: $!";
642 binmode($fh,':encoding(UTF-8)');
645 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
646 my ($key,$value)=($1,$2);
648 $forward->{$key}= $value;
649 if (defined $reverse) {
650 if ($type eq 'address') {
651 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
652 push @{$reverse->{$m}},$key;
656 push @{$reverse->{$value}}, $key;
665 my $pseudopkgdesc = getpseudodesc(...);
667 Returns the entry for a pseudo package from the
668 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
669 defined, returns an empty arrayref.
671 This function can be used to see if a particular package is a
672 pseudopackage or not.
676 our $_pseudodesc = undef;
678 return $_pseudodesc if defined $_pseudodesc;
680 __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
681 defined $config{pseudo_desc_file} and
682 length $config{pseudo_desc_file};
688 sort_versions('1.0-2','1.1-2');
690 Sorts versions using AptPkg::Versions::compare if it is available, or
691 Debbugs::Versions::Dpkg::vercmp if it isn't.
697 use Debbugs::Versions::Dpkg;
698 $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
700 # eventually we'll use AptPkg:::Version or similar, but the current
701 # implementation makes this *super* difficult.
704 # use AptPkg::Version;
705 # $vercmp=\&AptPkg::Version::compare;
710 return sort {$vercmp->($a,$b)} @_;
716 my $english = secs_to_english($seconds);
717 my ($days,$english) = secs_to_english($seconds);
719 XXX This should probably be changed to use Date::Calc
726 my $days = int($seconds / 86400);
727 my $years = int($days / 365);
731 push @age, "1 year" if ($years == 1);
732 push @age, "$years years" if ($years > 1);
733 push @age, "1 day" if ($days == 1);
734 push @age, "$days days" if ($days > 1);
735 $result .= join(" and ", @age);
737 return wantarray?(int($seconds/86400),$result):$result;
743 These functions are exported with the :lock tag
748 filelock($lockfile,$locks);
750 FLOCKs the passed file. Use unfilelock to unlock it.
752 Can be passed an optional $locks hashref, which is used to track which
753 files are locked (and how many times they have been locked) to allow
754 for cooperative locking.
763 # NB - NOT COMPATIBLE WITH `with-lock'
764 my ($lockfile,$locks) = @_;
765 if ($lockfile !~ m{^/}) {
766 $lockfile = cwd().'/'.$lockfile;
768 # This is only here to allow for relocking bugs inside of
769 # Debbugs::Control. Nothing else should be using it.
770 if (defined $locks and exists $locks->{locks}{$lockfile} and
771 $locks->{locks}{$lockfile} >= 1) {
772 if (exists $locks->{relockable} and
773 exists $locks->{relockable}{$lockfile}) {
774 $locks->{locks}{$lockfile}++;
775 # indicate that the bug for this lockfile needs to be reread
776 $locks->{relockable}{$lockfile} = 1;
777 push @{$locks->{lockorder}},$lockfile;
782 confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
785 my ($fh,$t_lockfile,$errors) =
786 simple_filelock($lockfile,10,1);
788 push @filelocks, {fh => $fh, file => $lockfile};
789 if (defined $locks) {
790 $locks->{locks}{$lockfile}++;
791 push @{$locks->{lockorder}},$lockfile;
795 croak "failed to get lock on $lockfile -- $errors".
796 (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
800 =head2 simple_filelock
802 my ($fh,$t_lockfile,$errors) =
803 simple_filelock($lockfile,$count,$wait);
805 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
806 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
809 In list context, returns the lockfile filehandle, lockfile name, and
810 any errors which occured.
812 When the lockfile filehandle is undef, locking failed.
814 These lockfiles must be unlocked manually at process end.
819 sub simple_filelock {
820 my ($lockfile,$count,$wait) = @_;
821 if (not defined $count) {
827 if (not defined $wait) {
834 my $fh2 = IO::File->new($lockfile,'w')
835 or die "Unable to open $lockfile for writing: $!";
836 # Do a blocking lock if count is zero
837 flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
838 or die "Unable to lock $lockfile $!";
847 # use usleep for fractional wait seconds
848 usleep($wait * 1_000_000);
850 last unless (--$count > 0);
853 return wantarray?($fh,$lockfile,$errors):$fh
855 return wantarray?(undef,$lockfile,$errors):undef;
858 # clean up all outstanding locks at end time
865 =head2 simple_unlockfile
867 simple_unlockfile($fh,$lockfile);
872 sub simple_unlockfile {
873 my ($fh,$lockfile) = @_;
875 or warn "Unable to unlock lockfile $lockfile: $!";
877 or warn "Unable to close lockfile $lockfile: $!";
879 or warn "Unable to unlink lockfile $lockfile: $!";
888 Unlocks the file most recently locked.
890 Note that it is not currently possible to unlock a specific file
891 locked with filelock.
897 if (@filelocks == 0) {
898 carp "unfilelock called with no active filelocks!\n";
901 if (defined $locks and ref($locks) ne 'HASH') {
902 croak "hash not passsed to unfilelock";
904 if (defined $locks and exists $locks->{lockorder} and
905 @{$locks->{lockorder}} and
906 exists $locks->{locks}{$locks->{lockorder}[-1]}) {
907 my $lockfile = pop @{$locks->{lockorder}};
908 $locks->{locks}{$lockfile}--;
909 if ($locks->{locks}{$lockfile} > 0) {
912 delete $locks->{locks}{$lockfile};
914 my %fl = %{pop(@filelocks)};
915 simple_unlockfile($fl{fh},$fl{file});
921 lockpid('/path/to/pidfile');
923 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
924 pid in the file does not respond to kill 0.
926 Returns 1 on success, false on failure; dies on unusual errors.
933 my $pid = checkpid($pidfile);
934 die "Unable to read pidfile $pidfile: $!" if not defined $pid;
935 return 0 if $pid != 0;
937 die "Unable to unlink stale pidfile $pidfile $!";
939 mkpath(dirname($pidfile));
940 my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
941 die "Unable to open $pidfile for writing: $!";
942 print {$pidfh} $$ or die "Unable to write to $pidfile $!";
943 close $pidfh or die "Unable to close $pidfile $!";
949 checkpid('/path/to/pidfile');
951 Checks a pid file and determines if the process listed in the pidfile
952 is still running. Returns the pid if it is, 0 if it isn't running, and
953 undef if the pidfile doesn't exist or cannot be read.
960 my $pidfh = IO::File->new($pidfile, 'r') or
965 ($pid) = $pid =~ /(\d+)/;
966 if (defined $pid and kill(0,$pid)) {
979 These functions are exported with the :quit tag.
985 Exits the program by calling die.
987 Usage of quit is deprecated; just call die instead.
992 print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
993 carp "quit() is deprecated; call die directly instead";
999 These functions are exported with the :misc tag
1003 LIST = make_list(@_);
1005 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
1008 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
1009 b)],[qw(c d)] returns qw(a b c d);
1014 return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
1020 print english_join(list => \@list);
1021 print english_join(\@list);
1023 Joins list properly to make an english phrase.
1027 =item normal -- how to separate most values; defaults to ', '
1029 =item last -- how to separate the last two values; defaults to ', and '
1031 =item only_two -- how to separate only two values; defaults to ' and '
1033 =item list -- ARRAYREF values to join; if the first argument is an
1034 ARRAYREF, it's assumed to be the list of values to join
1038 In cases where C<list> is empty, returns ''; when there is only one
1039 element, returns that element.
1044 if (ref $_[0] eq 'ARRAY') {
1045 return english_join(list=>$_[0]);
1047 my %param = validate_with(params => \@_,
1048 spec => {normal => {type => SCALAR,
1051 last => {type => SCALAR,
1052 default => ', and ',
1054 only_two => {type => SCALAR,
1057 list => {type => ARRAYREF,
1061 my @list = @{$param{list}};
1063 return @list?$list[0]:'';
1065 elsif (@list == 2) {
1066 return join($param{only_two},@list);
1068 my $ret = $param{last} . pop(@list);
1069 return join($param{normal},@list) . $ret;
1073 =head2 globify_scalar
1075 my $handle = globify_scalar(\$foo);
1077 if $foo isn't already a glob or a globref, turn it into one using
1078 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
1080 Will carp if given a scalar which isn't a scalarref or a glob (or
1081 globref), and return /dev/null. May return undef if IO::Scalar or
1082 IO::File fails. (Check $!)
1084 The scalar will fill with octets, not perl's internal encoding, so you
1085 must use decode_utf8() after on the scalar, and encode_utf8() on it
1086 before. This appears to be a bug in the underlying modules.
1090 sub globify_scalar {
1093 if (defined $scalar) {
1094 if (defined ref($scalar)) {
1095 if (ref($scalar) eq 'SCALAR' and
1096 not UNIVERSAL::isa($scalar,'GLOB')) {
1097 if (is_utf8(${$scalar})) {
1098 ${$scalar} = decode_utf8(${$scalar});
1099 carp(q(\$scalar must not be in perl's internal encoding));
1101 open $handle, '>:scalar:utf8', $scalar;
1108 elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
1112 carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
1115 return IO::File->new('/dev/null','>:encoding(UTF-8)');
1118 =head2 cleanup_eval_fail()
1120 print "Something failed with: ".cleanup_eval_fail($@);
1122 Does various bits of cleanup on the failure message from an eval (or
1123 any other die message)
1125 Takes at most two options; the first is the actual failure message
1126 (usually $@ and defaults to $@), the second is the debug level
1127 (defaults to $DEBUG).
1129 If debug is non-zero, the code at which the failure occured is output.
1133 sub cleanup_eval_fail {
1134 my ($error,$debug) = @_;
1135 if (not defined $error or not @_) {
1136 $error = $@ // 'unknown reason';
1139 $debug = $DEBUG // 0;
1141 $debug = 0 if not defined $debug;
1146 # ditch the "at foo/bar/baz.pm line 5"
1147 $error =~ s/\sat\s\S+\sline\s\d+//;
1148 # ditch croak messages
1149 $error =~ s/^\t+.+\n?//mg;
1150 # ditch trailing multiple periods in case there was a cascade of
1152 $error =~ s/\.+$/\./;
1158 hash_slice(%hash,qw(key1 key2 key3))
1160 For each key, returns matching values and keys of the hash if they exist
1165 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
1166 # hash without uselessly making a reference to first. DO NOT USE
1167 # PROTOTYPES USELESSLY ELSEWHERE.
1168 sub hash_slice(\%@) {
1169 my ($hashref,@keys) = @_;
1170 return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;