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