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