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.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Common;
14 Debbugs::Common -- Common routines for all of Debbugs
18 use Debbugs::Common qw(:url :html);
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.
33 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
34 use Exporter qw(import);
38 $DEBUG = 0 unless defined $DEBUG;
41 %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
42 qw(appendfile overwritefile buglog getparsedaddrs getmaintainers),
43 qw(getsourcemaintainers getsourcemaintainers_reverse),
45 qw(getmaintainers_reverse),
47 qw(package_maintainer),
49 qw(open_compressed_file),
51 misc => [qw(make_list globify_scalar english_join checkpid),
52 qw(cleanup_eval_fail),
55 date => [qw(secs_to_english)],
57 lock => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)],
60 Exporter::export_ok_tags(keys %EXPORT_TAGS);
61 $EXPORT_TAGS{all} = [@EXPORT_OK];
64 #use Debbugs::Config qw(:globals);
69 use Debbugs::Config qw(:config);
72 use Debbugs::MIME qw(decode_rfc1522);
75 use Storable qw(dclone);
76 use Time::HiRes qw(usleep);
77 use File::Path qw(mkpath);
78 use File::Basename qw(dirname);
79 use MLDBM qw(DB_File Storable);
80 $MLDBM::DumpMeth='portable';
82 use Params::Validate qw(validate_with :types);
84 use Fcntl qw(:DEFAULT :flock);
85 use Encode qw(is_utf8 decode_utf8);
87 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
91 The following functions are exported by the C<:util> tag
93 =head2 getbugcomponent
95 my $file = getbugcomponent($bug_number,$extension,$location)
97 Returns the path to the bug file in location C<$location>, bug number
98 C<$bugnumber> and extension C<$extension>
102 sub getbugcomponent {
103 my ($bugnum, $ext, $location) = @_;
105 if (not defined $location) {
106 $location = getbuglocation($bugnum, $ext);
107 # Default to non-archived bugs only for now; CGI scripts want
108 # archived bugs but most of the backend scripts don't. For now,
109 # anything that is prepared to accept archived bugs should call
110 # getbuglocation() directly first.
111 return undef if defined $location and
112 ($location ne 'db' and $location ne 'db-h');
114 my $dir = getlocationpath($location);
115 return undef if not defined $dir;
116 if (defined $location and $location eq 'db') {
117 return "$dir/$bugnum.$ext";
119 my $hash = get_hashname($bugnum);
120 return "$dir/$hash/$bugnum.$ext";
124 =head2 getbuglocation
126 getbuglocation($bug_number,$extension)
128 Returns the the location in which a particular bug exists; valid
129 locations returned currently are archive, db-h, or db. If the bug does
130 not exist, returns undef.
135 my ($bugnum, $ext) = @_;
136 my $archdir = get_hashname($bugnum);
137 return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
138 return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
139 return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
144 =head2 getlocationpath
146 getlocationpath($location)
148 Returns the path to a specific location
152 sub getlocationpath {
154 if (defined $location and $location eq 'archive') {
155 return "$config{spool_dir}/archive";
156 } elsif (defined $location and $location eq 'db') {
157 return "$config{spool_dir}/db";
159 return "$config{spool_dir}/db-h";
168 Returns the hash of the bug which is the location within the archive
173 return "" if ( $_[ 0 ] < 0 );
174 return sprintf "%02d", $_[ 0 ] % 100;
181 Returns the path to the logfile corresponding to the bug.
183 Returns undef if the bug does not exist.
189 my $location = getbuglocation($bugnum, 'log');
190 return getbugcomponent($bugnum, 'log', $location) if ($location);
191 $location = getbuglocation($bugnum, 'log.gz');
192 return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
201 Returns the path to the summary file corresponding to the bug.
203 Returns undef if the bug does not exist.
209 my $location = getbuglocation($bugnum, 'summary');
210 return getbugcomponent($bugnum, 'summary', $location) if ($location);
216 appendfile($file,'data','to','append');
218 Opens a file for appending and writes data to it.
223 my ($file,@data) = @_;
224 my $fh = IO::File->new($file,'a') or
225 die "Unable top open $file for appending: $!";
226 print {$fh} @data or die "Unable to write to $file: $!";
227 close $fh or die "Unable to close $file: $!";
232 ovewritefile($file,'data','to','append');
234 Opens file.new, writes data to it, then moves file.new to file.
239 my ($file,@data) = @_;
240 my $fh = IO::File->new("${file}.new",'w') or
241 die "Unable top open ${file}.new for writing: $!";
242 print {$fh} @data or die "Unable to write to ${file}.new: $!";
243 close $fh or die "Unable to close ${file}.new: $!";
244 rename("${file}.new",$file) or
245 die "Unable to rename ${file}.new to $file: $!";
248 =head2 open_compressed_file
250 my $fh = open_compressed_file('foo.gz') or
251 die "Unable to open compressed file: $!";
254 Opens a file; if the file ends in .gz, .xz, or .bz2, the appropriate
255 decompression program is forked and output from it is read.
257 This routine by default opens the file with UTF-8 encoding; if you want some
258 other encoding, specify it with the second option.
261 sub open_compressed_file {
262 my ($file,$encoding) = @_;
263 $encoding //= ':encoding(UTF-8)';
265 my $mode = "<$encoding";
267 if ($file =~ /\.gz$/) {
268 $mode = "-|$encoding";
269 push @opts,'gzip','-dc';
271 if ($file =~ /\.xz$/) {
272 $mode = "-|$encoding";
273 push @opts,'xz','-dc';
275 if ($file =~ /\.bz2$/) {
276 $mode = "-|$encoding";
277 push @opts,'bzip2','-dc';
279 open($fh,$mode,@opts,$file);
285 =head2 getparsedaddrs
287 my $address = getparsedaddrs($address);
288 my @address = getparsedaddrs($address);
290 Returns the output from Mail::Address->parse, or the cached output if
291 this address has been parsed before. In SCALAR context returns the
292 first address parsed.
300 return () unless defined $addr;
301 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
302 if exists $_parsedaddrs{$addr};
304 # don't display the warnings from Mail::Address->parse
305 local $SIG{__WARN__} = sub { };
306 @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
308 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
311 =head2 getmaintainers
313 my $maintainer = getmaintainers()->{debbugs}
315 Returns a hashref of package => maintainer pairs.
319 our $_maintainer = undef;
320 our $_maintainer_rev = undef;
322 return $_maintainer if defined $_maintainer;
323 package_maintainer(rehash => 1);
327 =head2 getmaintainers_reverse
329 my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
331 Returns a hashref of maintainer => [qw(list of packages)] pairs.
335 sub getmaintainers_reverse{
336 return $_maintainer_rev if defined $_maintainer_rev;
337 package_maintainer(rehash => 1);
338 return $_maintainer_rev;
341 =head2 getsourcemaintainers
343 my $maintainer = getsourcemaintainers()->{debbugs}
345 Returns a hashref of src_package => maintainer pairs.
349 our $_source_maintainer = undef;
350 our $_source_maintainer_rev = undef;
351 sub getsourcemaintainers {
352 return $_source_maintainer if defined $_source_maintainer;
353 package_maintainer(rehash => 1);
354 return $_source_maintainer;
357 =head2 getsourcemaintainers_reverse
359 my @src_packages = @{getsourcemaintainers_reverse->{'don@debian.org'}||[]};
361 Returns a hashref of maintainer => [qw(list of source packages)] pairs.
365 sub getsourcemaintainers_reverse{
366 return $_source_maintainer_rev if defined $_source_maintainer_rev;
367 package_maintainer(rehash => 1);
368 return $_source_maintainer_rev;
371 =head2 package_maintainer
373 my @s = package_maintainer(source => [qw(foo bar baz)],
374 binary => [qw(bleh blah)],
379 =item source -- scalar or arrayref of source package names to return
380 maintainers for, defaults to the empty arrayref.
382 =item binary -- scalar or arrayref of binary package names to return
383 maintainers for; automatically returns source package maintainer if
384 the package name starts with 'src:', defaults to the empty arrayref.
386 =item reverse -- whether to return the source/binary packages a
387 maintainer maintains instead
389 =item rehash -- whether to reread the maintainer and source maintainer
396 sub package_maintainer {
397 my %param = validate_with(params => \@_,
398 spec => {source => {type => SCALAR|ARRAYREF,
401 binary => {type => SCALAR|ARRAYREF,
404 maintainer => {type => SCALAR|ARRAYREF,
407 rehash => {type => BOOLEAN,
410 reverse => {type => BOOLEAN,
415 my @binary = make_list($param{binary});
416 my @source = make_list($param{source});
417 my @maintainers = make_list($param{maintainer});
418 if ((@binary or @source) and @maintainers) {
419 croak "It is nonsensical to pass both maintainers and source or binary";
421 if ($param{rehash}) {
422 $_source_maintainer = undef;
423 $_source_maintainer_rev = undef;
424 $_maintainer = undef;
425 $_maintainer_rev = undef;
427 if (not defined $_source_maintainer or
428 not defined $_source_maintainer_rev) {
429 $_source_maintainer = {};
430 $_source_maintainer_rev = {};
431 if (-e $config{spool_dir}.'/source_maintainers.idx' and
432 -e $config{spool_dir}.'/source_maintainers_reverse.idx'
434 tie %{$_source_maintainer},
435 MLDBM => $config{spool_dir}.'/source_maintainers.idx',
437 die "Unable to tie source maintainers: $!";
438 tie %{$_source_maintainer_rev},
439 MLDBM => $config{spool_dir}.'/source_maintainers_reverse.idx',
441 die "Unable to tie source maintainers reverse: $!";
443 for my $fn (@config{('source_maintainer_file',
444 'source_maintainer_file_override',
445 'pseudo_maint_file')}) {
446 next unless defined $fn and length $fn;
448 warn "Missing source maintainer file '$fn'";
451 __add_to_hash($fn,$_source_maintainer,
452 $_source_maintainer_rev);
456 if (not defined $_maintainer or
457 not defined $_maintainer_rev) {
459 $_maintainer_rev = {};
460 if (-e $config{spool_dir}.'/maintainers.idx' and
461 -e $config{spool_dir}.'/maintainers_reverse.idx'
464 MLDBM => $config{spool_dir}.'/binary_maintainers.idx',
466 die "Unable to tie binary maintainers: $!";
467 tie %{$_maintainer_rev},
468 MLDBM => $config{spool_dir}.'/binary_maintainers_reverse.idx',
470 die "Unable to binary maintainers reverse: $!";
472 for my $fn (@config{('maintainer_file',
473 'maintainer_file_override',
474 'pseudo_maint_file')}) {
475 next unless defined $fn and length $fn;
477 warn "Missing maintainer file '$fn'";
480 __add_to_hash($fn,$_maintainer,
486 for my $binary (@binary) {
487 if (not $param{reverse} and $binary =~ /^src:/) {
488 push @source,$binary;
491 push @return,grep {defined $_} make_list($_maintainer->{$binary});
493 for my $source (@source) {
494 $source =~ s/^src://;
495 push @return,grep {defined $_} make_list($_source_maintainer->{$source});
497 for my $maintainer (grep {defined $_} @maintainers) {
498 push @return,grep {defined $_}
499 make_list($_maintainer_rev->{$maintainer});
500 push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
502 make_list($_source_maintainer_rev->{$maintainer});
507 #=head2 __add_to_hash
509 # __add_to_hash($file,$forward_hash,$reverse_hash,'address');
511 # Reads a maintainer/source maintainer/pseudo desc file and adds the
512 # maintainers from it to the forward and reverse hashref; assumes that
513 # the forward is unique; makes no assumptions of the reverse.
518 my ($fn,$forward,$reverse,$type) = @_;
519 if (ref($forward) ne 'HASH') {
520 croak "__add_to_hash must be passed a hashref for the forward";
522 if (defined $reverse and not ref($reverse) eq 'HASH') {
523 croak "if reverse is passed to __add_to_hash, it must be a hashref";
526 my $fh = IO::File->new($fn,'r') or
527 croak "Unable to open $fn for reading: $!";
528 binmode($fh,':encoding(UTF-8)');
531 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
532 my ($key,$value)=($1,$2);
534 $forward->{$key}= $value;
535 if (defined $reverse) {
536 if ($type eq 'address') {
537 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
538 push @{$reverse->{$m}},$key;
542 push @{$reverse->{$value}}, $key;
551 my $pseudopkgdesc = getpseudodesc(...);
553 Returns the entry for a pseudo package from the
554 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
555 defined, returns an empty arrayref.
557 This function can be used to see if a particular package is a
558 pseudopackage or not.
562 our $_pseudodesc = undef;
564 return $_pseudodesc if defined $_pseudodesc;
566 __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
567 defined $config{pseudo_desc_file} and
568 length $config{pseudo_desc_file};
574 sort_versions('1.0-2','1.1-2');
576 Sorts versions using AptPkg::Versions::compare if it is available, or
577 Debbugs::Versions::Dpkg::vercmp if it isn't.
583 use Debbugs::Versions::Dpkg;
584 $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
586 # eventually we'll use AptPkg:::Version or similar, but the current
587 # implementation makes this *super* difficult.
590 # use AptPkg::Version;
591 # $vercmp=\&AptPkg::Version::compare;
596 return sort {$vercmp->($a,$b)} @_;
602 my $english = secs_to_english($seconds);
603 my ($days,$english) = secs_to_english($seconds);
605 XXX This should probably be changed to use Date::Calc
612 my $days = int($seconds / 86400);
613 my $years = int($days / 365);
617 push @age, "1 year" if ($years == 1);
618 push @age, "$years years" if ($years > 1);
619 push @age, "1 day" if ($days == 1);
620 push @age, "$days days" if ($days > 1);
621 $result .= join(" and ", @age);
623 return wantarray?(int($seconds/86400),$result):$result;
629 These functions are exported with the :lock tag
634 filelock($lockfile,$locks);
636 FLOCKs the passed file. Use unfilelock to unlock it.
638 Can be passed an optional $locks hashref, which is used to track which
639 files are locked (and how many times they have been locked) to allow
640 for cooperative locking.
649 # NB - NOT COMPATIBLE WITH `with-lock'
650 my ($lockfile,$locks) = @_;
651 if ($lockfile !~ m{^/}) {
652 $lockfile = cwd().'/'.$lockfile;
654 # This is only here to allow for relocking bugs inside of
655 # Debbugs::Control. Nothing else should be using it.
656 if (defined $locks and exists $locks->{locks}{$lockfile} and
657 $locks->{locks}{$lockfile} >= 1) {
658 if (exists $locks->{relockable} and
659 exists $locks->{relockable}{$lockfile}) {
660 $locks->{locks}{$lockfile}++;
661 # indicate that the bug for this lockfile needs to be reread
662 $locks->{relockable}{$lockfile} = 1;
663 push @{$locks->{lockorder}},$lockfile;
668 confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
671 my ($fh,$t_lockfile,$errors) =
672 simple_filelock($lockfile,10,1);
674 push @filelocks, {fh => $fh, file => $lockfile};
675 if (defined $locks) {
676 $locks->{locks}{$lockfile}++;
677 push @{$locks->{lockorder}},$lockfile;
681 croak "failed to get lock on $lockfile -- $errors".
682 (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
686 =head2 simple_filelock
688 my ($fh,$t_lockfile,$errors) =
689 simple_filelock($lockfile,$count,$wait);
691 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
692 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
695 In list context, returns the lockfile filehandle, lockfile name, and
696 any errors which occured.
698 When the lockfile filehandle is undef, locking failed.
700 These lockfiles must be unlocked manually at process end.
705 sub simple_filelock {
706 my ($lockfile,$count,$wait) = @_;
707 if (not defined $count) {
713 if (not defined $wait) {
720 my $fh2 = IO::File->new($lockfile,'w')
721 or die "Unable to open $lockfile for writing: $!";
722 # Do a blocking lock if count is zero
723 flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
724 or die "Unable to lock $lockfile $!";
733 # use usleep for fractional wait seconds
734 usleep($wait * 1_000_000);
736 last unless (--$count > 0);
739 return wantarray?($fh,$lockfile,$errors):$fh
741 return wantarray?(undef,$lockfile,$errors):undef;
744 # clean up all outstanding locks at end time
751 =head2 simple_unlockfile
753 simple_unlockfile($fh,$lockfile);
758 sub simple_unlockfile {
759 my ($fh,$lockfile) = @_;
761 or warn "Unable to unlock lockfile $lockfile: $!";
763 or warn "Unable to close lockfile $lockfile: $!";
765 or warn "Unable to unlink lockfile $lockfile: $!";
774 Unlocks the file most recently locked.
776 Note that it is not currently possible to unlock a specific file
777 locked with filelock.
783 if (@filelocks == 0) {
784 carp "unfilelock called with no active filelocks!\n";
787 if (defined $locks and ref($locks) ne 'HASH') {
788 croak "hash not passsed to unfilelock";
790 if (defined $locks and exists $locks->{lockorder} and
791 @{$locks->{lockorder}} and
792 exists $locks->{locks}{$locks->{lockorder}[-1]}) {
793 my $lockfile = pop @{$locks->{lockorder}};
794 $locks->{locks}{$lockfile}--;
795 if ($locks->{locks}{$lockfile} > 0) {
798 delete $locks->{locks}{$lockfile};
800 my %fl = %{pop(@filelocks)};
801 simple_unlockfile($fl{fh},$fl{file});
807 lockpid('/path/to/pidfile');
809 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
810 pid in the file does not respond to kill 0.
812 Returns 1 on success, false on failure; dies on unusual errors.
819 my $pid = checkpid($pidfile);
820 die "Unable to read pidfile $pidfile: $!" if not defined $pid;
821 return 0 if $pid != 0;
823 die "Unable to unlink stale pidfile $pidfile $!";
825 mkpath(dirname($pidfile));
826 my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
827 die "Unable to open $pidfile for writing: $!";
828 print {$pidfh} $$ or die "Unable to write to $pidfile $!";
829 close $pidfh or die "Unable to close $pidfile $!";
835 checkpid('/path/to/pidfile');
837 Checks a pid file and determines if the process listed in the pidfile
838 is still running. Returns the pid if it is, 0 if it isn't running, and
839 undef if the pidfile doesn't exist or cannot be read.
846 my $pidfh = IO::File->new($pidfile, 'r') or
851 ($pid) = $pid =~ /(\d+)/;
852 if (defined $pid and kill(0,$pid)) {
865 These functions are exported with the :quit tag.
871 Exits the program by calling die.
873 Usage of quit is deprecated; just call die instead.
878 print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
879 carp "quit() is deprecated; call die directly instead";
885 These functions are exported with the :misc tag
889 LIST = make_list(@_);
891 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
894 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
895 b)],[qw(c d)] returns qw(a b c d);
900 return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
906 print english_join(list => \@list);
907 print english_join(\@list);
909 Joins list properly to make an english phrase.
913 =item normal -- how to separate most values; defaults to ', '
915 =item last -- how to separate the last two values; defaults to ', and '
917 =item only_two -- how to separate only two values; defaults to ' and '
919 =item list -- ARRAYREF values to join; if the first argument is an
920 ARRAYREF, it's assumed to be the list of values to join
924 In cases where C<list> is empty, returns ''; when there is only one
925 element, returns that element.
930 if (ref $_[0] eq 'ARRAY') {
931 return english_join(list=>$_[0]);
933 my %param = validate_with(params => \@_,
934 spec => {normal => {type => SCALAR,
937 last => {type => SCALAR,
940 only_two => {type => SCALAR,
943 list => {type => ARRAYREF,
947 my @list = @{$param{list}};
949 return @list?$list[0]:'';
952 return join($param{only_two},@list);
954 my $ret = $param{last} . pop(@list);
955 return join($param{normal},@list) . $ret;
959 =head2 globify_scalar
961 my $handle = globify_scalar(\$foo);
963 if $foo isn't already a glob or a globref, turn it into one using
964 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
966 Will carp if given a scalar which isn't a scalarref or a glob (or
967 globref), and return /dev/null. May return undef if IO::Scalar or
968 IO::File fails. (Check $!)
970 The scalar will fill with octets, not perl's internal encoding, so you
971 must use decode_utf8() after on the scalar, and encode_utf8() on it
972 before. This appears to be a bug in the underlying modules.
979 if (defined $scalar) {
980 if (defined ref($scalar)) {
981 if (ref($scalar) eq 'SCALAR' and
982 not UNIVERSAL::isa($scalar,'GLOB')) {
983 if (is_utf8(${$scalar})) {
984 ${$scalar} = decode_utf8(${$scalar});
985 carp(q(\$scalar must not be in perl's internal encoding));
987 open $handle, '>:scalar:utf8', $scalar;
994 elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
998 carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
1001 return IO::File->new('/dev/null','>:encoding(UTF-8)');
1004 =head2 cleanup_eval_fail()
1006 print "Something failed with: ".cleanup_eval_fail($@);
1008 Does various bits of cleanup on the failure message from an eval (or
1009 any other die message)
1011 Takes at most two options; the first is the actual failure message
1012 (usually $@ and defaults to $@), the second is the debug level
1013 (defaults to $DEBUG).
1015 If debug is non-zero, the code at which the failure occured is output.
1019 sub cleanup_eval_fail {
1020 my ($error,$debug) = @_;
1021 if (not defined $error or not @_) {
1022 $error = $@ // 'unknown reason';
1025 $debug = $DEBUG // 0;
1027 $debug = 0 if not defined $debug;
1032 # ditch the "at foo/bar/baz.pm line 5"
1033 $error =~ s/\sat\s\S+\sline\s\d+//;
1034 # ditch croak messages
1035 $error =~ s/^\t+.+\n?//mg;
1036 # ditch trailing multiple periods in case there was a cascade of
1038 $error =~ s/\.+$/\./;
1044 hash_slice(%hash,qw(key1 key2 key3))
1046 For each key, returns matching values and keys of the hash if they exist
1051 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
1052 # hash without uselessly making a reference to first. DO NOT USE
1053 # PROTOTYPES USELESSLY ELSEWHERE.
1054 sub hash_slice(\%@) {
1055 my ($hashref,@keys) = @_;
1056 return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;