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),
44 qw(getmaintainers_reverse),
46 qw(package_maintainer),
48 qw(open_compressed_file),
50 misc => [qw(make_list globify_scalar english_join checkpid),
51 qw(cleanup_eval_fail),
54 date => [qw(secs_to_english)],
56 lock => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)],
59 Exporter::export_ok_tags(keys %EXPORT_TAGS);
60 $EXPORT_TAGS{all} = [@EXPORT_OK];
63 #use Debbugs::Config qw(:globals);
68 use Debbugs::Config qw(:config);
71 use Debbugs::MIME qw(decode_rfc1522);
74 use Storable qw(dclone);
75 use Time::HiRes qw(usleep);
76 use MLDBM qw(DB_File Storable);
77 $MLDBM::DumpMeth='portable';
79 use Params::Validate qw(validate_with :types);
81 use Fcntl qw(:DEFAULT :flock);
82 use Encode qw(is_utf8 decode_utf8);
84 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
88 The following functions are exported by the C<:util> tag
90 =head2 getbugcomponent
92 my $file = getbugcomponent($bug_number,$extension,$location)
94 Returns the path to the bug file in location C<$location>, bug number
95 C<$bugnumber> and extension C<$extension>
100 my ($bugnum, $ext, $location) = @_;
102 if (not defined $location) {
103 $location = getbuglocation($bugnum, $ext);
104 # Default to non-archived bugs only for now; CGI scripts want
105 # archived bugs but most of the backend scripts don't. For now,
106 # anything that is prepared to accept archived bugs should call
107 # getbuglocation() directly first.
108 return undef if defined $location and
109 ($location ne 'db' and $location ne 'db-h');
111 my $dir = getlocationpath($location);
112 return undef if not defined $dir;
113 if (defined $location and $location eq 'db') {
114 return "$dir/$bugnum.$ext";
116 my $hash = get_hashname($bugnum);
117 return "$dir/$hash/$bugnum.$ext";
121 =head2 getbuglocation
123 getbuglocation($bug_number,$extension)
125 Returns the the location in which a particular bug exists; valid
126 locations returned currently are archive, db-h, or db. If the bug does
127 not exist, returns undef.
132 my ($bugnum, $ext) = @_;
133 my $archdir = get_hashname($bugnum);
134 return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
135 return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
136 return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
141 =head2 getlocationpath
143 getlocationpath($location)
145 Returns the path to a specific location
149 sub getlocationpath {
151 if (defined $location and $location eq 'archive') {
152 return "$config{spool_dir}/archive";
153 } elsif (defined $location and $location eq 'db') {
154 return "$config{spool_dir}/db";
156 return "$config{spool_dir}/db-h";
165 Returns the hash of the bug which is the location within the archive
170 return "" if ( $_[ 0 ] < 0 );
171 return sprintf "%02d", $_[ 0 ] % 100;
178 Returns the path to the logfile corresponding to the bug.
180 Returns undef if the bug does not exist.
186 my $location = getbuglocation($bugnum, 'log');
187 return getbugcomponent($bugnum, 'log', $location) if ($location);
188 $location = getbuglocation($bugnum, 'log.gz');
189 return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
198 Returns the path to the summary file corresponding to the bug.
200 Returns undef if the bug does not exist.
206 my $location = getbuglocation($bugnum, 'summary');
207 return getbugcomponent($bugnum, 'summary', $location) if ($location);
213 appendfile($file,'data','to','append');
215 Opens a file for appending and writes data to it.
220 my ($file,@data) = @_;
221 my $fh = IO::File->new($file,'a') or
222 die "Unable top open $file for appending: $!";
223 print {$fh} @data or die "Unable to write to $file: $!";
224 close $fh or die "Unable to close $file: $!";
229 ovewritefile($file,'data','to','append');
231 Opens file.new, writes data to it, then moves file.new to file.
236 my ($file,@data) = @_;
237 my $fh = IO::File->new("${file}.new",'w') or
238 die "Unable top open ${file}.new for writing: $!";
239 print {$fh} @data or die "Unable to write to ${file}.new: $!";
240 close $fh or die "Unable to close ${file}.new: $!";
241 rename("${file}.new",$file) or
242 die "Unable to rename ${file}.new to $file: $!";
245 =head2 open_compressed_file
247 my $fh = open_compressed_file('foo.gz') or
248 die "Unable to open compressed file: $!";
251 Opens a file; if the file ends in .gz, .xz, or .bz2, the appropriate
252 decompression program is forked and output from it is read.
254 This routine by default opens the file with UTF-8 encoding; if you want some
255 other encoding, specify it with the second option.
258 sub open_compressed_file {
259 my ($file,$encoding) = @_;
260 $encoding //= ':encoding(UTF-8)';
262 my $mode = "<$encoding";
264 if ($file =~ /\.gz$/) {
265 $mode = "-|$encoding";
266 push @opts,'gzip','-dc';
268 if ($file =~ /\.xz$/) {
269 $mode = "-|$encoding";
270 push @opts,'xz','-dc';
272 if ($file =~ /\.bz2$/) {
273 $mode = "-|$encoding";
274 push @opts,'bzip2','-dc';
276 open($fh,$mode,@opts,$file);
282 =head2 getparsedaddrs
284 my $address = getparsedaddrs($address);
285 my @address = getparsedaddrs($address);
287 Returns the output from Mail::Address->parse, or the cached output if
288 this address has been parsed before. In SCALAR context returns the
289 first address parsed.
297 return () unless defined $addr;
298 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
299 if exists $_parsedaddrs{$addr};
301 # don't display the warnings from Mail::Address->parse
302 local $SIG{__WARN__} = sub { };
303 @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
305 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
308 =head2 getmaintainers
310 my $maintainer = getmaintainers()->{debbugs}
312 Returns a hashref of package => maintainer pairs.
316 our $_maintainer = undef;
317 our $_maintainer_rev = undef;
319 return $_maintainer if defined $_maintainer;
320 package_maintainer(rehash => 1);
324 =head2 getmaintainers_reverse
326 my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
328 Returns a hashref of maintainer => [qw(list of packages)] pairs.
332 sub getmaintainers_reverse{
333 return $_maintainer_rev if defined $_maintainer_rev;
334 package_maintainer(rehash => 1);
335 return $_maintainer_rev;
338 =head2 package_maintainer
340 my @s = package_maintainer(source => [qw(foo bar baz)],
341 binary => [qw(bleh blah)],
346 =item source -- scalar or arrayref of source package names to return
347 maintainers for, defaults to the empty arrayref.
349 =item binary -- scalar or arrayref of binary package names to return
350 maintainers for; automatically returns source package maintainer if
351 the package name starts with 'src:', defaults to the empty arrayref.
353 =item reverse -- whether to return the source/binary packages a
354 maintainer maintains instead
356 =item rehash -- whether to reread the maintainer and source maintainer
363 our $_source_maintainer = undef;
364 our $_source_maintainer_rev = undef;
365 sub package_maintainer {
366 my %param = validate_with(params => \@_,
367 spec => {source => {type => SCALAR|ARRAYREF,
370 binary => {type => SCALAR|ARRAYREF,
373 maintainer => {type => SCALAR|ARRAYREF,
376 rehash => {type => BOOLEAN,
379 reverse => {type => BOOLEAN,
384 my @binary = make_list($param{binary});
385 my @source = make_list($param{source});
386 my @maintainers = make_list($param{maintainer});
387 if ((@binary or @source) and @maintainers) {
388 croak "It is nonsensical to pass both maintainers and source or binary";
390 if ($param{rehash}) {
391 $_source_maintainer = undef;
392 $_source_maintainer_rev = undef;
393 $_maintainer = undef;
394 $_maintainer_rev = undef;
396 if (not defined $_source_maintainer or
397 not defined $_source_maintainer_rev) {
398 $_source_maintainer = {};
399 $_source_maintainer_rev = {};
400 if (-e $config{spool_dir}.'/source_maintainers.idx' and
401 -e $config{spool_dir}.'/source_maintainers_reverse.idx'
403 tie %{$_source_maintainer},
404 MLDBM => $config{spool_dir}.'/source_maintainers.idx',
406 die "Unable to tie source maintainers: $!";
407 tie %{$_source_maintainer_rev},
408 MLDBM => $config{spool_dir}.'/source_maintainers_reverse.idx',
410 die "Unable to tie source maintainers reverse: $!";
412 for my $fn (@config{('source_maintainer_file',
413 'source_maintainer_file_override',
414 'pseudo_maint_file')}) {
415 next unless defined $fn and length $fn;
417 warn "Missing source maintainer file '$fn'";
420 __add_to_hash($fn,$_source_maintainer,
421 $_source_maintainer_rev);
425 if (not defined $_maintainer or
426 not defined $_maintainer_rev) {
428 $_maintainer_rev = {};
429 if (-e $config{spool_dir}.'/maintainers.idx' and
430 -e $config{spool_dir}.'/maintainers_reverse.idx'
433 MLDBM => $config{spool_dir}.'/binary_maintainers.idx',
435 die "Unable to tie binary maintainers: $!";
436 tie %{$_maintainer_rev},
437 MLDBM => $config{spool_dir}.'/binary_maintainers_reverse.idx',
439 die "Unable to binary maintainers reverse: $!";
441 for my $fn (@config{('maintainer_file',
442 'maintainer_file_override',
443 'pseudo_maint_file')}) {
444 next unless defined $fn and length $fn;
446 warn "Missing maintainer file '$fn'";
449 __add_to_hash($fn,$_maintainer,
455 for my $binary (@binary) {
456 if (not $param{reverse} and $binary =~ /^src:/) {
457 push @source,$binary;
460 push @return,grep {defined $_} make_list($_maintainer->{$binary});
462 for my $source (@source) {
463 $source =~ s/^src://;
464 push @return,grep {defined $_} make_list($_source_maintainer->{$source});
466 for my $maintainer (grep {defined $_} @maintainers) {
467 push @return,grep {defined $_}
468 make_list($_maintainer_rev->{$maintainer});
469 push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
471 make_list($_source_maintainer_rev->{$maintainer});
476 #=head2 __add_to_hash
478 # __add_to_hash($file,$forward_hash,$reverse_hash,'address');
480 # Reads a maintainer/source maintainer/pseudo desc file and adds the
481 # maintainers from it to the forward and reverse hashref; assumes that
482 # the forward is unique; makes no assumptions of the reverse.
487 my ($fn,$forward,$reverse,$type) = @_;
488 if (ref($forward) ne 'HASH') {
489 croak "__add_to_hash must be passed a hashref for the forward";
491 if (defined $reverse and not ref($reverse) eq 'HASH') {
492 croak "if reverse is passed to __add_to_hash, it must be a hashref";
495 my $fh = IO::File->new($fn,'r') or
496 croak "Unable to open $fn for reading: $!";
497 binmode($fh,':encoding(UTF-8)');
500 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
501 my ($key,$value)=($1,$2);
503 $forward->{$key}= $value;
504 if (defined $reverse) {
505 if ($type eq 'address') {
506 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
507 push @{$reverse->{$m}},$key;
511 push @{$reverse->{$value}}, $key;
520 my $pseudopkgdesc = getpseudodesc(...);
522 Returns the entry for a pseudo package from the
523 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
524 defined, returns an empty arrayref.
526 This function can be used to see if a particular package is a
527 pseudopackage or not.
531 our $_pseudodesc = undef;
533 return $_pseudodesc if defined $_pseudodesc;
535 __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
536 defined $config{pseudo_desc_file} and
537 length $config{pseudo_desc_file};
543 sort_versions('1.0-2','1.1-2');
545 Sorts versions using AptPkg::Versions::compare if it is available, or
546 Debbugs::Versions::Dpkg::vercmp if it isn't.
552 use Debbugs::Versions::Dpkg;
553 $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
555 # eventually we'll use AptPkg:::Version or similar, but the current
556 # implementation makes this *super* difficult.
559 # use AptPkg::Version;
560 # $vercmp=\&AptPkg::Version::compare;
565 return sort {$vercmp->($a,$b)} @_;
571 my $english = secs_to_english($seconds);
572 my ($days,$english) = secs_to_english($seconds);
574 XXX This should probably be changed to use Date::Calc
581 my $days = int($seconds / 86400);
582 my $years = int($days / 365);
586 push @age, "1 year" if ($years == 1);
587 push @age, "$years years" if ($years > 1);
588 push @age, "1 day" if ($days == 1);
589 push @age, "$days days" if ($days > 1);
590 $result .= join(" and ", @age);
592 return wantarray?(int($seconds/86400),$result):$result;
598 These functions are exported with the :lock tag
603 filelock($lockfile,$locks);
605 FLOCKs the passed file. Use unfilelock to unlock it.
607 Can be passed an optional $locks hashref, which is used to track which
608 files are locked (and how many times they have been locked) to allow
609 for cooperative locking.
618 # NB - NOT COMPATIBLE WITH `with-lock'
619 my ($lockfile,$locks) = @_;
620 if ($lockfile !~ m{^/}) {
621 $lockfile = cwd().'/'.$lockfile;
623 # This is only here to allow for relocking bugs inside of
624 # Debbugs::Control. Nothing else should be using it.
625 if (defined $locks and exists $locks->{locks}{$lockfile} and
626 $locks->{locks}{$lockfile} >= 1) {
627 if (exists $locks->{relockable} and
628 exists $locks->{relockable}{$lockfile}) {
629 $locks->{locks}{$lockfile}++;
630 # indicate that the bug for this lockfile needs to be reread
631 $locks->{relockable}{$lockfile} = 1;
632 push @{$locks->{lockorder}},$lockfile;
637 confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
640 my ($fh,$t_lockfile,$errors) =
641 simple_filelock($lockfile,10,1);
643 push @filelocks, {fh => $fh, file => $lockfile};
644 if (defined $locks) {
645 $locks->{locks}{$lockfile}++;
646 push @{$locks->{lockorder}},$lockfile;
650 croak "failed to get lock on $lockfile -- $errors".
651 (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
655 =head2 simple_filelock
657 my ($fh,$t_lockfile,$errors) =
658 simple_filelock($lockfile,$count,$wait);
660 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
661 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
664 In list context, returns the lockfile filehandle, lockfile name, and
665 any errors which occured.
667 When the lockfile filehandle is undef, locking failed.
669 These lockfiles must be unlocked manually at process end.
674 sub simple_filelock {
675 my ($lockfile,$count,$wait) = @_;
676 if (not defined $count) {
682 if (not defined $wait) {
689 my $fh2 = IO::File->new($lockfile,'w')
690 or die "Unable to open $lockfile for writing: $!";
691 # Do a blocking lock if count is zero
692 flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
693 or die "Unable to lock $lockfile $!";
702 # use usleep for fractional wait seconds
703 usleep($wait * 1_000_000);
705 last unless (--$count > 0);
708 return wantarray?($fh,$lockfile,$errors):$fh
710 return wantarray?(undef,$lockfile,$errors):undef;
713 # clean up all outstanding locks at end time
720 =head2 simple_unlockfile
722 simple_unlockfile($fh,$lockfile);
727 sub simple_unlockfile {
728 my ($fh,$lockfile) = @_;
730 or warn "Unable to unlock lockfile $lockfile: $!";
732 or warn "Unable to close lockfile $lockfile: $!";
734 or warn "Unable to unlink lockfile $lockfile: $!";
743 Unlocks the file most recently locked.
745 Note that it is not currently possible to unlock a specific file
746 locked with filelock.
752 if (@filelocks == 0) {
753 carp "unfilelock called with no active filelocks!\n";
756 if (defined $locks and ref($locks) ne 'HASH') {
757 croak "hash not passsed to unfilelock";
759 if (defined $locks and exists $locks->{lockorder} and
760 @{$locks->{lockorder}} and
761 exists $locks->{locks}{$locks->{lockorder}[-1]}) {
762 my $lockfile = pop @{$locks->{lockorder}};
763 $locks->{locks}{$lockfile}--;
764 if ($locks->{locks}{$lockfile} > 0) {
767 delete $locks->{locks}{$lockfile};
769 my %fl = %{pop(@filelocks)};
770 simple_unlockfile($fl{fh},$fl{file});
776 lockpid('/path/to/pidfile');
778 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
779 pid in the file does not respond to kill 0.
781 Returns 1 on success, false on failure; dies on unusual errors.
788 my $pid = checkpid($pidfile);
789 die "Unable to read pidfile $pidfile: $!" if not defined $pid;
790 return 0 if $pid != 0;
792 die "Unable to unlink stale pidfile $pidfile $!";
794 my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
795 die "Unable to open $pidfile for writing: $!";
796 print {$pidfh} $$ or die "Unable to write to $pidfile $!";
797 close $pidfh or die "Unable to close $pidfile $!";
803 checkpid('/path/to/pidfile');
805 Checks a pid file and determines if the process listed in the pidfile
806 is still running. Returns the pid if it is, 0 if it isn't running, and
807 undef if the pidfile doesn't exist or cannot be read.
814 my $pidfh = IO::File->new($pidfile, 'r') or
819 ($pid) = $pid =~ /(\d+)/;
820 if (defined $pid and kill(0,$pid)) {
833 These functions are exported with the :quit tag.
839 Exits the program by calling die.
841 Usage of quit is deprecated; just call die instead.
846 print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
847 carp "quit() is deprecated; call die directly instead";
853 These functions are exported with the :misc tag
857 LIST = make_list(@_);
859 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
862 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
863 b)],[qw(c d)] returns qw(a b c d);
868 return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
874 print english_join(list => \@list);
875 print english_join(\@list);
877 Joins list properly to make an english phrase.
881 =item normal -- how to separate most values; defaults to ', '
883 =item last -- how to separate the last two values; defaults to ', and '
885 =item only_two -- how to separate only two values; defaults to ' and '
887 =item list -- ARRAYREF values to join; if the first argument is an
888 ARRAYREF, it's assumed to be the list of values to join
892 In cases where C<list> is empty, returns ''; when there is only one
893 element, returns that element.
898 if (ref $_[0] eq 'ARRAY') {
899 return english_join(list=>$_[0]);
901 my %param = validate_with(params => \@_,
902 spec => {normal => {type => SCALAR,
905 last => {type => SCALAR,
908 only_two => {type => SCALAR,
911 list => {type => ARRAYREF,
915 my @list = @{$param{list}};
917 return @list?$list[0]:'';
920 return join($param{only_two},@list);
922 my $ret = $param{last} . pop(@list);
923 return join($param{normal},@list) . $ret;
927 =head2 globify_scalar
929 my $handle = globify_scalar(\$foo);
931 if $foo isn't already a glob or a globref, turn it into one using
932 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
934 Will carp if given a scalar which isn't a scalarref or a glob (or
935 globref), and return /dev/null. May return undef if IO::Scalar or
936 IO::File fails. (Check $!)
938 The scalar will fill with octets, not perl's internal encoding, so you
939 must use decode_utf8() after on the scalar, and encode_utf8() on it
940 before. This appears to be a bug in the underlying modules.
947 if (defined $scalar) {
948 if (defined ref($scalar)) {
949 if (ref($scalar) eq 'SCALAR' and
950 not UNIVERSAL::isa($scalar,'GLOB')) {
951 if (is_utf8(${$scalar})) {
952 ${$scalar} = decode_utf8(${$scalar});
953 carp(q(\$scalar must not be in perl's internal encoding));
955 open $handle, '>:scalar:utf8', $scalar;
962 elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
966 carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
969 return IO::File->new('/dev/null','>:encoding(UTF-8)');
972 =head2 cleanup_eval_fail()
974 print "Something failed with: ".cleanup_eval_fail($@);
976 Does various bits of cleanup on the failure message from an eval (or
977 any other die message)
979 Takes at most two options; the first is the actual failure message
980 (usually $@ and defaults to $@), the second is the debug level
981 (defaults to $DEBUG).
983 If debug is non-zero, the code at which the failure occured is output.
987 sub cleanup_eval_fail {
988 my ($error,$debug) = @_;
989 if (not defined $error or not @_) {
990 $error = $@ // 'unknown reason';
993 $debug = $DEBUG // 0;
995 $debug = 0 if not defined $debug;
1000 # ditch the "at foo/bar/baz.pm line 5"
1001 $error =~ s/\sat\s\S+\sline\s\d+//;
1002 # ditch croak messages
1003 $error =~ s/^\t+.+\n?//mg;
1004 # ditch trailing multiple periods in case there was a cascade of
1006 $error =~ s/\.+$/\./;
1012 hash_slice(%hash,qw(key1 key2 key3))
1014 For each key, returns matching values and keys of the hash if they exist
1019 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
1020 # hash without uselessly making a reference to first. DO NOT USE
1021 # PROTOTYPES USELESSLY ELSEWHERE.
1022 sub hash_slice(\%@) {
1023 my ($hashref,@keys) = @_;
1024 return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;