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