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