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