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