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