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     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 =cut
 821
 822 sub globify_scalar {
 823      my ($scalar) = @_;
 824      my $handle;
 825      if (defined $scalar) {
 826           if (defined ref($scalar)) {
 827                if (ref($scalar) eq 'SCALAR' and
 828                    not UNIVERSAL::isa($scalar,'GLOB')) {
 829                     open $handle, '>:scalar:utf8', $scalar;
 830                     return $handle;
 831                }
 832                else {
 833                     return $scalar;
 834                }
 835           }
 836           elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
 837                return $scalar;
 838           }
 839           else {
 840                carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
 841           }
 842      }
 843      return IO::File->new('/dev/null','>:utf8');
 844 }
 845
 846 =head2 cleanup_eval_fail()
 847
 848      print "Something failed with: ".cleanup_eval_fail($@);
 849
 850 Does various bits of cleanup on the failure message from an eval (or
 851 any other die message)
 852
 853 Takes at most two options; the first is the actual failure message
 854 (usually $@ and defaults to $@), the second is the debug level
 855 (defaults to $DEBUG).
 856
 857 If debug is non-zero, the code at which the failure occured is output.
 858
 859 =cut
 860
 861 sub cleanup_eval_fail {
 862     my ($error,$debug) = @_;
 863     if (not defined $error or not @_) {
 864         $error = $@ // 'unknown reason';
 865     }
 866     if (@_ <= 1) {
 867         $debug = $DEBUG // 0;
 868     }
 869     $debug = 0 if not defined $debug;
 870
 871     if ($debug > 0) {
 872         return $error;
 873     }
 874     # ditch the "at foo/bar/baz.pm line 5"
 875     $error =~ s/\sat\s\S+\sline\s\d+//;
 876     # ditch croak messages
 877     $error =~ s/^\t+.+\n?//g;
 878     # ditch trailing multiple periods in case there was a cascade of
 879     # die messages.
 880     $error =~ s/\.+$/\./;
 881     return $error;
 882 }
 883
 884 =head2 hash_slice
 885
 886      hash_slice(%hash,qw(key1 key2 key3))
 887
 888 For each key, returns matching values and keys of the hash if they exist
 889
 890 =cut
 891
 892
 893 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
 894 # hash without uselessly making a reference to first. DO NOT USE
 895 # PROTOTYPES USELESSLY ELSEWHERE.
 896 sub hash_slice(\%@) {
 897     my ($hashref,@keys) = @_;
 898     return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;
 899 }
 900
 901
 902 =head1 UTF-8
 903
 904 These functions are exported with the :utf8 tag
 905
 906 =head2 encode_utf8_structure
 907
 908      %newdata = encode_utf8_structure(%newdata);
 909
 910 Takes a complex data structure and encodes any strings with is_utf8
 911 set into their constituent octets.
 912
 913 =cut
 914
 915 our $depth = 0;
 916 sub encode_utf8_structure {
 917     ++$depth;
 918     my @ret;
 919     for my $_ (@_) {
 920         if (ref($_) eq 'HASH') {
 921             push @ret, {encode_utf8_structure(%{$depth == 1 ? dclone($_):$_})};
 922         }
 923         elsif (ref($_) eq 'ARRAY') {
 924             push @ret, [encode_utf8_structure(@{$depth == 1 ? dclone($_):$_})];
 925         }
 926         elsif (ref($_)) {
 927             # we don't know how to handle non hash or non arrays
 928             push @ret,$_;
 929         }
 930         else {
 931             push @ret,__encode_utf8($_);
 932         }
 933     }
 934     --$depth;
 935     return @ret;
 936 }
 937
 938 sub __encode_utf8 {
 939     my @ret;
 940     for my $r (@_) {
 941         if (not ref($r) and is_utf8($r)) {
 942             $r = encode_utf8($r);
 943         }
 944         push @ret,$r;
 945     }
 946     return @ret;
 947 }
 948
 949
 950
 951 1;
 952
 953 __END__