Debbugs/Common.pm

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