]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/Common.pm
fix how e-mails are passed to the avatar script
[debbugs.git] / Debbugs / Common.pm
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.
5 #
6 # [Other people have contributed to this file; their copyrights should
7 # go here too.]
8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
9
10 package Debbugs::Common;
11
12 =head1 NAME
13
14 Debbugs::Common -- Common routines for all of Debbugs
15
16 =head1 SYNOPSIS
17
18 use Debbugs::Common qw(:url :html);
19
20
21 =head1 DESCRIPTION
22
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.
26
27 =head1 FUNCTIONS
28
29 =cut
30
31 use warnings;
32 use strict;
33 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
34 use base qw(Exporter);
35
36 BEGIN{
37      $VERSION = 1.00;
38      $DEBUG = 0 unless defined $DEBUG;
39
40      @EXPORT = ();
41      %EXPORT_TAGS = (util   => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
42                                 qw(appendfile overwritefile buglog getparsedaddrs getmaintainers),
43                                 qw(bug_status),
44                                 qw(getmaintainers_reverse),
45                                 qw(getpseudodesc),
46                                 qw(package_maintainer),
47                                 qw(sort_versions),
48                                ],
49                      misc   => [qw(make_list globify_scalar english_join checkpid),
50                                 qw(cleanup_eval_fail),
51                                 qw(hash_slice),
52                                ],
53                      date   => [qw(secs_to_english)],
54                      quit   => [qw(quit)],
55                      lock   => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)],
56                     );
57      @EXPORT_OK = ();
58      Exporter::export_ok_tags(keys %EXPORT_TAGS);
59      $EXPORT_TAGS{all} = [@EXPORT_OK];
60 }
61
62 #use Debbugs::Config qw(:globals);
63
64 use Carp;
65 $Carp::Verbose = 1;
66
67 use Debbugs::Config qw(:config);
68 use IO::File;
69 use IO::Scalar;
70 use Debbugs::MIME qw(decode_rfc1522);
71 use Mail::Address;
72 use Cwd qw(cwd);
73 use Storable qw(dclone);
74 use Time::HiRes qw(usleep);
75
76 use Params::Validate qw(validate_with :types);
77
78 use Fcntl qw(:DEFAULT :flock);
79 use Encode qw(is_utf8 decode_utf8);
80
81 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
82
83 =head1 UTILITIES
84
85 The following functions are exported by the C<:util> tag
86
87 =head2 getbugcomponent
88
89      my $file = getbugcomponent($bug_number,$extension,$location)
90
91 Returns the path to the bug file in location C<$location>, bug number
92 C<$bugnumber> and extension C<$extension>
93
94 =cut
95
96 sub getbugcomponent {
97     my ($bugnum, $ext, $location) = @_;
98
99     if (not defined $location) {
100         $location = getbuglocation($bugnum, $ext);
101         # Default to non-archived bugs only for now; CGI scripts want
102         # archived bugs but most of the backend scripts don't. For now,
103         # anything that is prepared to accept archived bugs should call
104         # getbuglocation() directly first.
105         return undef if defined $location and
106                         ($location ne 'db' and $location ne 'db-h');
107     }
108     my $dir = getlocationpath($location);
109     return undef if not defined $dir;
110     if (defined $location and $location eq 'db') {
111         return "$dir/$bugnum.$ext";
112     } else {
113         my $hash = get_hashname($bugnum);
114         return "$dir/$hash/$bugnum.$ext";
115     }
116 }
117
118 =head2 getbuglocation
119
120      getbuglocation($bug_number,$extension)
121
122 Returns the the location in which a particular bug exists; valid
123 locations returned currently are archive, db-h, or db. If the bug does
124 not exist, returns undef.
125
126 =cut
127
128 sub getbuglocation {
129     my ($bugnum, $ext) = @_;
130     my $archdir = get_hashname($bugnum);
131     return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
132     return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
133     return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
134     return undef;
135 }
136
137
138 =head2 getlocationpath
139
140      getlocationpath($location)
141
142 Returns the path to a specific location
143
144 =cut
145
146 sub getlocationpath {
147      my ($location) = @_;
148      if (defined $location and $location eq 'archive') {
149           return "$config{spool_dir}/archive";
150      } elsif (defined $location and $location eq 'db') {
151           return "$config{spool_dir}/db";
152      } else {
153           return "$config{spool_dir}/db-h";
154      }
155 }
156
157
158 =head2 get_hashname
159
160      get_hashname
161
162 Returns the hash of the bug which is the location within the archive
163
164 =cut
165
166 sub get_hashname {
167     return "" if ( $_[ 0 ] < 0 );
168     return sprintf "%02d", $_[ 0 ] % 100;
169 }
170
171 =head2 buglog
172
173      buglog($bugnum);
174
175 Returns the path to the logfile corresponding to the bug.
176
177 Returns undef if the bug does not exist.
178
179 =cut
180
181 sub buglog {
182     my $bugnum = shift;
183     my $location = getbuglocation($bugnum, 'log');
184     return getbugcomponent($bugnum, 'log', $location) if ($location);
185     $location = getbuglocation($bugnum, 'log.gz');
186     return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
187     return undef;
188 }
189
190 =head2 bug_status
191
192      bug_status($bugnum)
193
194
195 Returns the path to the summary file corresponding to the bug.
196
197 Returns undef if the bug does not exist.
198
199 =cut
200
201 sub bug_status{
202     my ($bugnum) = @_;
203     my $location = getbuglocation($bugnum, 'summary');
204     return getbugcomponent($bugnum, 'summary', $location) if ($location);
205     return undef;
206 }
207
208 =head2 appendfile
209
210      appendfile($file,'data','to','append');
211
212 Opens a file for appending and writes data to it.
213
214 =cut
215
216 sub appendfile {
217         my ($file,@data) = @_;
218         my $fh = IO::File->new($file,'a') or
219              die "Unable top open $file for appending: $!";
220         print {$fh} @data or die "Unable to write to $file: $!";
221         close $fh or die "Unable to close $file: $!";
222 }
223
224 =head2 overwritefile
225
226      ovewritefile($file,'data','to','append');
227
228 Opens file.new, writes data to it, then moves file.new to file.
229
230 =cut
231
232 sub overwritefile {
233         my ($file,@data) = @_;
234         my $fh = IO::File->new("${file}.new",'w') or
235              die "Unable top open ${file}.new for writing: $!";
236         print {$fh} @data or die "Unable to write to ${file}.new: $!";
237         close $fh or die "Unable to close ${file}.new: $!";
238         rename("${file}.new",$file) or
239             die "Unable to rename ${file}.new to $file: $!";
240 }
241
242
243
244
245
246 =head2 getparsedaddrs
247
248      my $address = getparsedaddrs($address);
249      my @address = getparsedaddrs($address);
250
251 Returns the output from Mail::Address->parse, or the cached output if
252 this address has been parsed before. In SCALAR context returns the
253 first address parsed.
254
255 =cut
256
257
258 our %_parsedaddrs;
259 sub getparsedaddrs {
260     my $addr = shift;
261     return () unless defined $addr;
262     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
263          if exists $_parsedaddrs{$addr};
264     {
265          # don't display the warnings from Mail::Address->parse
266          local $SIG{__WARN__} = sub { };
267          @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
268     }
269     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
270 }
271
272 =head2 getmaintainers
273
274      my $maintainer = getmaintainers()->{debbugs}
275
276 Returns a hashref of package => maintainer pairs.
277
278 =cut
279
280 our $_maintainer = undef;
281 our $_maintainer_rev = undef;
282 sub getmaintainers {
283     return $_maintainer if defined $_maintainer;
284     package_maintainer(rehash => 1);
285     return $_maintainer;
286 }
287
288 =head2 getmaintainers_reverse
289
290      my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
291
292 Returns a hashref of maintainer => [qw(list of packages)] pairs.
293
294 =cut
295
296 sub getmaintainers_reverse{
297      return $_maintainer_rev if defined $_maintainer_rev;
298      package_maintainer(rehash => 1);
299      return $_maintainer_rev;
300 }
301
302 =head2 package_maintainer
303
304      my @s = package_maintainer(source => [qw(foo bar baz)],
305                                 binary => [qw(bleh blah)],
306                                );
307
308 =over
309
310 =item source -- scalar or arrayref of source package names to return
311 maintainers for, defaults to the empty arrayref.
312
313 =item binary -- scalar or arrayref of binary package names to return
314 maintainers for; automatically returns source package maintainer if
315 the package name starts with 'src:', defaults to the empty arrayref.
316
317 =item reverse -- whether to return the source/binary packages a
318 maintainer maintains instead
319
320 =item rehash -- whether to reread the maintainer and source maintainer
321 files; defaults to 0
322
323 =back
324
325 =cut
326
327 our $_source_maintainer = undef;
328 our $_source_maintainer_rev = undef;
329 sub package_maintainer {
330     my %param = validate_with(params => \@_,
331                               spec   => {source => {type => SCALAR|ARRAYREF,
332                                                     default => [],
333                                                    },
334                                          binary => {type => SCALAR|ARRAYREF,
335                                                     default => [],
336                                                    },
337                                          maintainer => {type => SCALAR|ARRAYREF,
338                                                         default => [],
339                                                        },
340                                          rehash => {type => BOOLEAN,
341                                                     default => 0,
342                                                    },
343                                          reverse => {type => BOOLEAN,
344                                                      default => 0,
345                                                     },
346                                         },
347                              );
348     my @binary = make_list($param{binary});
349     my @source = make_list($param{source});
350     my @maintainers = make_list($param{maintainer});
351     if ((@binary or @source) and @maintainers) {
352         croak "It is nonsensical to pass both maintainers and source or binary";
353     }
354     if ($param{rehash}) {
355         $_source_maintainer = undef;
356         $_source_maintainer_rev = undef;
357         $_maintainer = undef;
358         $_maintainer_rev = undef;
359     }
360     if (not defined $_source_maintainer or
361         not defined $_source_maintainer_rev) {
362         $_source_maintainer = {};
363         $_source_maintainer_rev = {};
364         for my $fn (@config{('source_maintainer_file',
365                              'source_maintainer_file_override',
366                              'pseudo_maint_file')}) {
367             next unless defined $fn;
368             if (not -e $fn) {
369                 warn "Missing source maintainer file '$fn'";
370                 next;
371             }
372             __add_to_hash($fn,$_source_maintainer,
373                           $_source_maintainer_rev);
374         }
375     }
376     if (not defined $_maintainer or
377         not defined $_maintainer_rev) {
378         $_maintainer = {};
379         $_maintainer_rev = {};
380         for my $fn (@config{('maintainer_file',
381                              'maintainer_file_override',
382                              'pseudo_maint_file')}) {
383             next unless defined $fn;
384             if (not -e $fn) {
385                 warn "Missing maintainer file '$fn'";
386                 next;
387             }
388             __add_to_hash($fn,$_maintainer,
389                               $_maintainer_rev);
390         }
391     }
392     my @return;
393     for my $binary (@binary) {
394         if (not $param{reverse} and $binary =~ /^src:/) {
395             push @source,$binary;
396             next;
397         }
398         push @return,grep {defined $_} make_list($_maintainer->{$binary});
399     }
400     for my $source (@source) {
401         $source =~ s/^src://;
402         push @return,grep {defined $_} make_list($_source_maintainer->{$source});
403     }
404     for my $maintainer (grep {defined $_} @maintainers) {
405         push @return,grep {defined $_}
406             make_list($_maintainer_rev->{$maintainer});
407         push @return,map {$_ !~ /^src:/?'src:'.$_:$_} 
408             grep {defined $_}
409                 make_list($_source_maintainer_rev->{$maintainer});
410     }
411     return @return;
412 }
413
414 #=head2 __add_to_hash
415 #
416 #     __add_to_hash($file,$forward_hash,$reverse_hash,'address');
417 #
418 # Reads a maintainer/source maintainer/pseudo desc file and adds the
419 # maintainers from it to the forward and reverse hashref; assumes that
420 # the forward is unique; makes no assumptions of the reverse.
421 #
422 #=cut
423
424 sub __add_to_hash {
425     my ($fn,$forward,$reverse,$type) = @_;
426     if (ref($forward) ne 'HASH') {
427         croak "__add_to_hash must be passed a hashref for the forward";
428     }
429     if (defined $reverse and not ref($reverse) eq 'HASH') {
430         croak "if reverse is passed to __add_to_hash, it must be a hashref";
431     }
432     $type //= 'address';
433     my $fh = IO::File->new($fn,'r') or
434         die "Unable to open $fn for reading: $!";
435     binmode($fh,':encoding(UTF-8)');
436     while (<$fh>) {
437         chomp;
438         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
439         my ($key,$value)=($1,$2);
440         $key = lc $key;
441         $forward->{$key}= $value;
442         if (defined $reverse) {
443             if ($type eq 'address') {
444                 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
445                     push @{$reverse->{$m}},$key;
446                 }
447             }
448             else {
449                 push @{$reverse->{$value}}, $key;
450             }
451         }
452     }
453 }
454
455
456 =head2 getpseudodesc
457
458      my $pseudopkgdesc = getpseudodesc(...);
459
460 Returns the entry for a pseudo package from the
461 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
462 defined, returns an empty arrayref.
463
464 This function can be used to see if a particular package is a
465 pseudopackage or not.
466
467 =cut
468
469 our $_pseudodesc = undef;
470 sub getpseudodesc {
471     return $_pseudodesc if defined $_pseudodesc;
472     $_pseudodesc = {};
473     __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
474         defined $config{pseudo_desc_file};
475     return $_pseudodesc;
476 }
477
478 =head2 sort_versions
479
480      sort_versions('1.0-2','1.1-2');
481
482 Sorts versions using AptPkg::Versions::compare if it is available, or
483 Debbugs::Versions::Dpkg::vercmp if it isn't.
484
485 =cut
486
487 our $vercmp;
488 BEGIN{
489     use Debbugs::Versions::Dpkg;
490     $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
491
492 # eventually we'll use AptPkg:::Version or similar, but the current
493 # implementation makes this *super* difficult.
494
495 #     eval {
496 #       use AptPkg::Version;
497 #       $vercmp=\&AptPkg::Version::compare;
498 #     };
499 }
500
501 sub sort_versions{
502     return sort {$vercmp->($a,$b)} @_;
503 }
504
505
506 =head1 DATE
507
508     my $english = secs_to_english($seconds);
509     my ($days,$english) = secs_to_english($seconds);
510
511 XXX This should probably be changed to use Date::Calc
512
513 =cut
514
515 sub secs_to_english{
516      my ($seconds) = @_;
517
518      my $days = int($seconds / 86400);
519      my $years = int($days / 365);
520      $days %= 365;
521      my $result;
522      my @age;
523      push @age, "1 year" if ($years == 1);
524      push @age, "$years years" if ($years > 1);
525      push @age, "1 day" if ($days == 1);
526      push @age, "$days days" if ($days > 1);
527      $result .= join(" and ", @age);
528
529      return wantarray?(int($seconds/86400),$result):$result;
530 }
531
532
533 =head1 LOCK
534
535 These functions are exported with the :lock tag
536
537 =head2 filelock
538
539      filelock($lockfile);
540      filelock($lockfile,$locks);
541
542 FLOCKs the passed file. Use unfilelock to unlock it.
543
544 Can be passed an optional $locks hashref, which is used to track which
545 files are locked (and how many times they have been locked) to allow
546 for cooperative locking.
547
548 =cut
549
550 our @filelocks;
551
552 use Carp qw(cluck);
553
554 sub filelock {
555     # NB - NOT COMPATIBLE WITH `with-lock'
556     my ($lockfile,$locks) = @_;
557     if ($lockfile !~ m{^/}) {
558          $lockfile = cwd().'/'.$lockfile;
559     }
560     # This is only here to allow for relocking bugs inside of
561     # Debbugs::Control. Nothing else should be using it.
562     if (defined $locks and exists $locks->{locks}{$lockfile} and
563         $locks->{locks}{$lockfile} >= 1) {
564         if (exists $locks->{relockable} and
565             exists $locks->{relockable}{$lockfile}) {
566             $locks->{locks}{$lockfile}++;
567             # indicate that the bug for this lockfile needs to be reread
568             $locks->{relockable}{$lockfile} = 1;
569             push @{$locks->{lockorder}},$lockfile;
570             return;
571         }
572         else {
573             use Data::Dumper;
574             confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
575         }
576     }
577     my ($fh,$t_lockfile,$errors) =
578         simple_filelock($lockfile,10,1);
579     if ($fh) {
580         push @filelocks, {fh => $fh, file => $lockfile};
581         if (defined $locks) {
582             $locks->{locks}{$lockfile}++;
583             push @{$locks->{lockorder}},$lockfile;
584         }
585     } else {
586         use Data::Dumper;
587         croak "failed to get lock on $lockfile -- $errors".
588             (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
589     }
590 }
591
592 =head2 simple_filelock
593
594     my ($fh,$t_lockfile,$errors) =
595         simple_filelock($lockfile,$count,$wait);
596
597 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
598 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
599 seconds in between.
600
601 In list context, returns the lockfile filehandle, lockfile name, and
602 any errors which occured.
603
604 When the lockfile filehandle is undef, locking failed.
605
606 These lockfiles must be unlocked manually at process end.
607
608
609 =cut
610
611 sub simple_filelock {
612     my ($lockfile,$count,$wait) = @_;
613     if (not defined $count) {
614         $count = 10;
615     }
616     if ($count < 0) {
617         $count = 0;
618     }
619     if (not defined $wait) {
620         $wait = 1;
621     }
622     my $errors= '';
623     my $fh;
624     while (1) {
625         $fh = eval {
626              my $fh2 = IO::File->new($lockfile,'w')
627                   or die "Unable to open $lockfile for writing: $!";
628              # Do a blocking lock if count is zero
629              flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
630                   or die "Unable to lock $lockfile $!";
631              return $fh2;
632         };
633         if ($@) {
634              $errors .= $@;
635         }
636         if ($fh) {
637             last;
638         }
639         # use usleep for fractional wait seconds
640         usleep($wait * 1_000_000);
641     } continue {
642         last unless (--$count > 0);
643     } 
644     if ($fh) {
645         return wantarray?($fh,$lockfile,$errors):$fh
646     }
647     return wantarray?(undef,$lockfile,$errors):undef;
648 }
649
650 # clean up all outstanding locks at end time
651 END {
652      while (@filelocks) {
653           unfilelock();
654      }
655 }
656
657 =head2 simple_unlockfile
658
659      simple_unlockfile($fh,$lockfile);
660
661
662 =cut
663
664 sub simple_unlockfile {
665     my ($fh,$lockfile) = @_;
666     flock($fh,LOCK_UN)
667         or warn "Unable to unlock lockfile $lockfile: $!";
668     close($fh)
669         or warn "Unable to close lockfile $lockfile: $!";
670     unlink($lockfile)
671         or warn "Unable to unlink lockfile $lockfile: $!";
672 }
673
674
675 =head2 unfilelock
676
677      unfilelock()
678      unfilelock($locks);
679
680 Unlocks the file most recently locked.
681
682 Note that it is not currently possible to unlock a specific file
683 locked with filelock.
684
685 =cut
686
687 sub unfilelock {
688     my ($locks) = @_;
689     if (@filelocks == 0) {
690         carp "unfilelock called with no active filelocks!\n";
691         return;
692     }
693     if (defined $locks and ref($locks) ne 'HASH') {
694         croak "hash not passsed to unfilelock";
695     }
696     if (defined $locks and exists $locks->{lockorder} and
697         @{$locks->{lockorder}} and
698         exists $locks->{locks}{$locks->{lockorder}[-1]}) {
699         my $lockfile = pop @{$locks->{lockorder}};
700         $locks->{locks}{$lockfile}--;
701         if ($locks->{locks}{$lockfile} > 0) {
702             return
703         }
704         delete $locks->{locks}{$lockfile};
705     }
706     my %fl = %{pop(@filelocks)};
707     simple_unlockfile($fl{fh},$fl{file});
708 }
709
710
711 =head2 lockpid
712
713       lockpid('/path/to/pidfile');
714
715 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
716 pid in the file does not respond to kill 0.
717
718 Returns 1 on success, false on failure; dies on unusual errors.
719
720 =cut
721
722 sub lockpid {
723      my ($pidfile) = @_;
724      if (-e $pidfile) {
725           my $pid = checkpid($pidfile);
726           die "Unable to read pidfile $pidfile: $!" if not defined $pid;
727           return 0 if $pid != 0;
728           unlink $pidfile or
729                die "Unable to unlink stale pidfile $pidfile $!";
730      }
731      my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
732           die "Unable to open $pidfile for writing: $!";
733      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
734      close $pidfh or die "Unable to close $pidfile $!";
735      return 1;
736 }
737
738 =head2 checkpid
739
740      checkpid('/path/to/pidfile');
741
742 Checks a pid file and determines if the process listed in the pidfile
743 is still running. Returns the pid if it is, 0 if it isn't running, and
744 undef if the pidfile doesn't exist or cannot be read.
745
746 =cut
747
748 sub checkpid{
749      my ($pidfile) = @_;
750      if (-e $pidfile) {
751           my $pidfh = IO::File->new($pidfile, 'r') or
752                return undef;
753           local $/;
754           my $pid = <$pidfh>;
755           close $pidfh;
756           ($pid) = $pid =~ /(\d+)/;
757           if (defined $pid and kill(0,$pid)) {
758                return $pid;
759           }
760           return 0;
761      }
762      else {
763           return undef;
764      }
765 }
766
767
768 =head1 QUIT
769
770 These functions are exported with the :quit tag.
771
772 =head2 quit
773
774      quit()
775
776 Exits the program by calling die.
777
778 Usage of quit is deprecated; just call die instead.
779
780 =cut
781
782 sub quit {
783      print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
784      carp "quit() is deprecated; call die directly instead";
785 }
786
787
788 =head1 MISC
789
790 These functions are exported with the :misc tag
791
792 =head2 make_list
793
794      LIST = make_list(@_);
795
796 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
797 into a list.
798
799 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
800 b)],[qw(c d)] returns qw(a b c d);
801
802 =cut
803
804 sub make_list {
805      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
806 }
807
808
809 =head2 english_join
810
811      print english_join(list => \@list);
812      print english_join(\@list);
813
814 Joins list properly to make an english phrase.
815
816 =over
817
818 =item normal -- how to separate most values; defaults to ', '
819
820 =item last -- how to separate the last two values; defaults to ', and '
821
822 =item only_two -- how to separate only two values; defaults to ' and '
823
824 =item list -- ARRAYREF values to join; if the first argument is an
825 ARRAYREF, it's assumed to be the list of values to join
826
827 =back
828
829 In cases where C<list> is empty, returns ''; when there is only one
830 element, returns that element.
831
832 =cut
833
834 sub english_join {
835     if (ref $_[0] eq 'ARRAY') {
836         return english_join(list=>$_[0]);
837     }
838     my %param = validate_with(params => \@_,
839                               spec  => {normal => {type => SCALAR,
840                                                    default => ', ',
841                                                   },
842                                         last   => {type => SCALAR,
843                                                    default => ', and ',
844                                                   },
845                                         only_two => {type => SCALAR,
846                                                      default => ' and ',
847                                                     },
848                                         list     => {type => ARRAYREF,
849                                                     },
850                                        },
851                              );
852     my @list = @{$param{list}};
853     if (@list <= 1) {
854         return @list?$list[0]:'';
855     }
856     elsif (@list == 2) {
857         return join($param{only_two},@list);
858     }
859     my $ret = $param{last} . pop(@list);
860     return join($param{normal},@list) . $ret;
861 }
862
863
864 =head2 globify_scalar
865
866      my $handle = globify_scalar(\$foo);
867
868 if $foo isn't already a glob or a globref, turn it into one using
869 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
870
871 Will carp if given a scalar which isn't a scalarref or a glob (or
872 globref), and return /dev/null. May return undef if IO::Scalar or
873 IO::File fails. (Check $!)
874
875 The scalar will fill with octets, not perl's internal encoding, so you
876 must use decode_utf8() after on the scalar, and encode_utf8() on it
877 before. This appears to be a bug in the underlying modules.
878
879 =cut
880
881 sub globify_scalar {
882      my ($scalar) = @_;
883      my $handle;
884      if (defined $scalar) {
885           if (defined ref($scalar)) {
886                if (ref($scalar) eq 'SCALAR' and
887                    not UNIVERSAL::isa($scalar,'GLOB')) {
888                    if (is_utf8(${$scalar})) {
889                        ${$scalar} = decode_utf8(${$scalar});
890                        carp(q(\$scalar must not be in perl's internal encoding));
891                    }
892                     open $handle, '>:scalar:utf8', $scalar;
893                     return $handle;
894                }
895                else {
896                     return $scalar;
897                }
898           }
899           elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
900                return $scalar;
901           }
902           else {
903                carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
904           }
905      }
906      return IO::File->new('/dev/null','>:encoding(UTF-8)');
907 }
908
909 =head2 cleanup_eval_fail()
910
911      print "Something failed with: ".cleanup_eval_fail($@);
912
913 Does various bits of cleanup on the failure message from an eval (or
914 any other die message)
915
916 Takes at most two options; the first is the actual failure message
917 (usually $@ and defaults to $@), the second is the debug level
918 (defaults to $DEBUG).
919
920 If debug is non-zero, the code at which the failure occured is output.
921
922 =cut
923
924 sub cleanup_eval_fail {
925     my ($error,$debug) = @_;
926     if (not defined $error or not @_) {
927         $error = $@ // 'unknown reason';
928     }
929     if (@_ <= 1) {
930         $debug = $DEBUG // 0;
931     }
932     $debug = 0 if not defined $debug;
933
934     if ($debug > 0) {
935         return $error;
936     }
937     # ditch the "at foo/bar/baz.pm line 5"
938     $error =~ s/\sat\s\S+\sline\s\d+//;
939     # ditch croak messages
940     $error =~ s/^\t+.+\n?//g;
941     # ditch trailing multiple periods in case there was a cascade of
942     # die messages.
943     $error =~ s/\.+$/\./;
944     return $error;
945 }
946
947 =head2 hash_slice
948
949      hash_slice(%hash,qw(key1 key2 key3))
950
951 For each key, returns matching values and keys of the hash if they exist
952
953 =cut
954
955
956 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
957 # hash without uselessly making a reference to first. DO NOT USE
958 # PROTOTYPES USELESSLY ELSEWHERE.
959 sub hash_slice(\%@) {
960     my ($hashref,@keys) = @_;
961     return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;
962 }
963
964
965 1;
966
967 __END__