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 base qw(Exporter);
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),
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);
77 use Params::Validate qw(validate_with :types);
79 use Fcntl qw(:DEFAULT :flock);
80 use Encode qw(is_utf8 decode_utf8);
82 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
86 The following functions are exported by the C<:util> tag
88 =head2 getbugcomponent
90 my $file = getbugcomponent($bug_number,$extension,$location)
92 Returns the path to the bug file in location C<$location>, bug number
93 C<$bugnumber> and extension C<$extension>
98 my ($bugnum, $ext, $location) = @_;
100 if (not defined $location) {
101 $location = getbuglocation($bugnum, $ext);
102 # Default to non-archived bugs only for now; CGI scripts want
103 # archived bugs but most of the backend scripts don't. For now,
104 # anything that is prepared to accept archived bugs should call
105 # getbuglocation() directly first.
106 return undef if defined $location and
107 ($location ne 'db' and $location ne 'db-h');
109 my $dir = getlocationpath($location);
110 return undef if not defined $dir;
111 if (defined $location and $location eq 'db') {
112 return "$dir/$bugnum.$ext";
114 my $hash = get_hashname($bugnum);
115 return "$dir/$hash/$bugnum.$ext";
119 =head2 getbuglocation
121 getbuglocation($bug_number,$extension)
123 Returns the the location in which a particular bug exists; valid
124 locations returned currently are archive, db-h, or db. If the bug does
125 not exist, returns undef.
130 my ($bugnum, $ext) = @_;
131 my $archdir = get_hashname($bugnum);
132 return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
133 return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
134 return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
139 =head2 getlocationpath
141 getlocationpath($location)
143 Returns the path to a specific location
147 sub getlocationpath {
149 if (defined $location and $location eq 'archive') {
150 return "$config{spool_dir}/archive";
151 } elsif (defined $location and $location eq 'db') {
152 return "$config{spool_dir}/db";
154 return "$config{spool_dir}/db-h";
163 Returns the hash of the bug which is the location within the archive
168 return "" if ( $_[ 0 ] < 0 );
169 return sprintf "%02d", $_[ 0 ] % 100;
176 Returns the path to the logfile corresponding to the bug.
178 Returns undef if the bug does not exist.
184 my $location = getbuglocation($bugnum, 'log');
185 return getbugcomponent($bugnum, 'log', $location) if ($location);
186 $location = getbuglocation($bugnum, 'log.gz');
187 return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
196 Returns the path to the summary file corresponding to the bug.
198 Returns undef if the bug does not exist.
204 my $location = getbuglocation($bugnum, 'summary');
205 return getbugcomponent($bugnum, 'summary', $location) if ($location);
211 appendfile($file,'data','to','append');
213 Opens a file for appending and writes data to it.
218 my ($file,@data) = @_;
219 my $fh = IO::File->new($file,'a') or
220 die "Unable top open $file for appending: $!";
221 print {$fh} @data or die "Unable to write to $file: $!";
222 close $fh or die "Unable to close $file: $!";
227 ovewritefile($file,'data','to','append');
229 Opens file.new, writes data to it, then moves file.new to file.
234 my ($file,@data) = @_;
235 my $fh = IO::File->new("${file}.new",'w') or
236 die "Unable top open ${file}.new for writing: $!";
237 print {$fh} @data or die "Unable to write to ${file}.new: $!";
238 close $fh or die "Unable to close ${file}.new: $!";
239 rename("${file}.new",$file) or
240 die "Unable to rename ${file}.new to $file: $!";
247 =head2 getparsedaddrs
249 my $address = getparsedaddrs($address);
250 my @address = getparsedaddrs($address);
252 Returns the output from Mail::Address->parse, or the cached output if
253 this address has been parsed before. In SCALAR context returns the
254 first address parsed.
262 return () unless defined $addr;
263 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
264 if exists $_parsedaddrs{$addr};
266 # don't display the warnings from Mail::Address->parse
267 local $SIG{__WARN__} = sub { };
268 @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
270 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
273 =head2 getmaintainers
275 my $maintainer = getmaintainers()->{debbugs}
277 Returns a hashref of package => maintainer pairs.
281 our $_maintainer = undef;
282 our $_maintainer_rev = undef;
284 return $_maintainer if defined $_maintainer;
285 package_maintainer(rehash => 1);
289 =head2 getmaintainers_reverse
291 my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
293 Returns a hashref of maintainer => [qw(list of packages)] pairs.
297 sub getmaintainers_reverse{
298 return $_maintainer_rev if defined $_maintainer_rev;
299 package_maintainer(rehash => 1);
300 return $_maintainer_rev;
303 =head2 getsourcemaintainers
305 my $maintainer = getsourcemaintainers()->{debbugs}
307 Returns a hashref of src_package => maintainer pairs.
311 our $_source_maintainer = undef;
312 our $_source_maintainer_rev = undef;
313 sub getsourcemaintainers {
314 return $_source_maintainer if defined $_source_maintainer;
315 package_maintainer(rehash => 1);
316 return $_source_maintainer;
319 =head2 getsourcemaintainers_reverse
321 my @src_packages = @{getsourcemaintainers_reverse->{'don@debian.org'}||[]};
323 Returns a hashref of maintainer => [qw(list of source packages)] pairs.
327 sub getsourcemaintainers_reverse{
328 return $_source_maintainer_rev if defined $_source_maintainer_rev;
329 package_maintainer(rehash => 1);
330 return $_source_maintainer_rev;
333 =head2 package_maintainer
335 my @s = package_maintainer(source => [qw(foo bar baz)],
336 binary => [qw(bleh blah)],
341 =item source -- scalar or arrayref of source package names to return
342 maintainers for, defaults to the empty arrayref.
344 =item binary -- scalar or arrayref of binary package names to return
345 maintainers for; automatically returns source package maintainer if
346 the package name starts with 'src:', defaults to the empty arrayref.
348 =item reverse -- whether to return the source/binary packages a
349 maintainer maintains instead
351 =item rehash -- whether to reread the maintainer and source maintainer
358 sub package_maintainer {
359 my %param = validate_with(params => \@_,
360 spec => {source => {type => SCALAR|ARRAYREF,
363 binary => {type => SCALAR|ARRAYREF,
366 maintainer => {type => SCALAR|ARRAYREF,
369 rehash => {type => BOOLEAN,
372 reverse => {type => BOOLEAN,
377 my @binary = make_list($param{binary});
378 my @source = make_list($param{source});
379 my @maintainers = make_list($param{maintainer});
380 if ((@binary or @source) and @maintainers) {
381 croak "It is nonsensical to pass both maintainers and source or binary";
383 if ($param{rehash}) {
384 $_source_maintainer = undef;
385 $_source_maintainer_rev = undef;
386 $_maintainer = undef;
387 $_maintainer_rev = undef;
389 if (not defined $_source_maintainer or
390 not defined $_source_maintainer_rev) {
391 $_source_maintainer = {};
392 $_source_maintainer_rev = {};
393 for my $fn (@config{('source_maintainer_file',
394 'source_maintainer_file_override',
395 'pseudo_maint_file')}) {
396 next unless defined $fn;
398 warn "Missing source maintainer file '$fn'";
401 __add_to_hash($fn,$_source_maintainer,
402 $_source_maintainer_rev);
405 if (not defined $_maintainer or
406 not defined $_maintainer_rev) {
408 $_maintainer_rev = {};
409 for my $fn (@config{('maintainer_file',
410 'maintainer_file_override',
411 'pseudo_maint_file')}) {
412 next unless defined $fn;
414 warn "Missing maintainer file '$fn'";
417 __add_to_hash($fn,$_maintainer,
422 for my $binary (@binary) {
423 if (not $param{reverse} and $binary =~ /^src:/) {
424 push @source,$binary;
427 push @return,grep {defined $_} make_list($_maintainer->{$binary});
429 for my $source (@source) {
430 $source =~ s/^src://;
431 push @return,grep {defined $_} make_list($_source_maintainer->{$source});
433 for my $maintainer (grep {defined $_} @maintainers) {
434 push @return,grep {defined $_}
435 make_list($_maintainer_rev->{$maintainer});
436 push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
438 make_list($_source_maintainer_rev->{$maintainer});
443 #=head2 __add_to_hash
445 # __add_to_hash($file,$forward_hash,$reverse_hash,'address');
447 # Reads a maintainer/source maintainer/pseudo desc file and adds the
448 # maintainers from it to the forward and reverse hashref; assumes that
449 # the forward is unique; makes no assumptions of the reverse.
454 my ($fn,$forward,$reverse,$type) = @_;
455 if (ref($forward) ne 'HASH') {
456 croak "__add_to_hash must be passed a hashref for the forward";
458 if (defined $reverse and not ref($reverse) eq 'HASH') {
459 croak "if reverse is passed to __add_to_hash, it must be a hashref";
462 my $fh = IO::File->new($fn,'r') or
463 die "Unable to open $fn for reading: $!";
464 binmode($fh,':encoding(UTF-8)');
467 my @elements = split /\t/;
468 next unless @elements >=2;
469 # we do this because the source maintainer file contains the
470 # archive location, which we don't care about
471 my ($key,$value)=($elements[0],$elements[-1]);
473 $forward->{$key}= $value;
474 if (defined $reverse) {
475 if ($type eq 'address') {
476 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
477 push @{$reverse->{$m}},$key;
481 push @{$reverse->{$value}}, $key;
490 my $pseudopkgdesc = getpseudodesc(...);
492 Returns the entry for a pseudo package from the
493 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
494 defined, returns an empty arrayref.
496 This function can be used to see if a particular package is a
497 pseudopackage or not.
501 our $_pseudodesc = undef;
503 return $_pseudodesc if defined $_pseudodesc;
505 __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
506 defined $config{pseudo_desc_file};
512 sort_versions('1.0-2','1.1-2');
514 Sorts versions using AptPkg::Versions::compare if it is available, or
515 Debbugs::Versions::Dpkg::vercmp if it isn't.
521 use Debbugs::Versions::Dpkg;
522 $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
524 # eventually we'll use AptPkg:::Version or similar, but the current
525 # implementation makes this *super* difficult.
528 # use AptPkg::Version;
529 # $vercmp=\&AptPkg::Version::compare;
534 return sort {$vercmp->($a,$b)} @_;
540 my $english = secs_to_english($seconds);
541 my ($days,$english) = secs_to_english($seconds);
543 XXX This should probably be changed to use Date::Calc
550 my $days = int($seconds / 86400);
551 my $years = int($days / 365);
555 push @age, "1 year" if ($years == 1);
556 push @age, "$years years" if ($years > 1);
557 push @age, "1 day" if ($days == 1);
558 push @age, "$days days" if ($days > 1);
559 $result .= join(" and ", @age);
561 return wantarray?(int($seconds/86400),$result):$result;
567 These functions are exported with the :lock tag
572 filelock($lockfile,$locks);
574 FLOCKs the passed file. Use unfilelock to unlock it.
576 Can be passed an optional $locks hashref, which is used to track which
577 files are locked (and how many times they have been locked) to allow
578 for cooperative locking.
587 # NB - NOT COMPATIBLE WITH `with-lock'
588 my ($lockfile,$locks) = @_;
589 if ($lockfile !~ m{^/}) {
590 $lockfile = cwd().'/'.$lockfile;
592 # This is only here to allow for relocking bugs inside of
593 # Debbugs::Control. Nothing else should be using it.
594 if (defined $locks and exists $locks->{locks}{$lockfile} and
595 $locks->{locks}{$lockfile} >= 1) {
596 if (exists $locks->{relockable} and
597 exists $locks->{relockable}{$lockfile}) {
598 $locks->{locks}{$lockfile}++;
599 # indicate that the bug for this lockfile needs to be reread
600 $locks->{relockable}{$lockfile} = 1;
601 push @{$locks->{lockorder}},$lockfile;
606 confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
609 my ($fh,$t_lockfile,$errors) =
610 simple_filelock($lockfile,10,1);
612 push @filelocks, {fh => $fh, file => $lockfile};
613 if (defined $locks) {
614 $locks->{locks}{$lockfile}++;
615 push @{$locks->{lockorder}},$lockfile;
619 croak "failed to get lock on $lockfile -- $errors".
620 (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
624 =head2 simple_filelock
626 my ($fh,$t_lockfile,$errors) =
627 simple_filelock($lockfile,$count,$wait);
629 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
630 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
633 In list context, returns the lockfile filehandle, lockfile name, and
634 any errors which occured.
636 When the lockfile filehandle is undef, locking failed.
638 These lockfiles must be unlocked manually at process end.
643 sub simple_filelock {
644 my ($lockfile,$count,$wait) = @_;
645 if (not defined $count) {
651 if (not defined $wait) {
658 my $fh2 = IO::File->new($lockfile,'w')
659 or die "Unable to open $lockfile for writing: $!";
660 # Do a blocking lock if count is zero
661 flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
662 or die "Unable to lock $lockfile $!";
671 # use usleep for fractional wait seconds
672 usleep($wait * 1_000_000);
674 last unless (--$count > 0);
677 return wantarray?($fh,$lockfile,$errors):$fh
679 return wantarray?(undef,$lockfile,$errors):undef;
682 # clean up all outstanding locks at end time
689 =head2 simple_unlockfile
691 simple_unlockfile($fh,$lockfile);
696 sub simple_unlockfile {
697 my ($fh,$lockfile) = @_;
699 or warn "Unable to unlock lockfile $lockfile: $!";
701 or warn "Unable to close lockfile $lockfile: $!";
703 or warn "Unable to unlink lockfile $lockfile: $!";
712 Unlocks the file most recently locked.
714 Note that it is not currently possible to unlock a specific file
715 locked with filelock.
721 if (@filelocks == 0) {
722 carp "unfilelock called with no active filelocks!\n";
725 if (defined $locks and ref($locks) ne 'HASH') {
726 croak "hash not passsed to unfilelock";
728 if (defined $locks and exists $locks->{lockorder} and
729 @{$locks->{lockorder}} and
730 exists $locks->{locks}{$locks->{lockorder}[-1]}) {
731 my $lockfile = pop @{$locks->{lockorder}};
732 $locks->{locks}{$lockfile}--;
733 if ($locks->{locks}{$lockfile} > 0) {
736 delete $locks->{locks}{$lockfile};
738 my %fl = %{pop(@filelocks)};
739 simple_unlockfile($fl{fh},$fl{file});
745 lockpid('/path/to/pidfile');
747 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
748 pid in the file does not respond to kill 0.
750 Returns 1 on success, false on failure; dies on unusual errors.
757 my $pid = checkpid($pidfile);
758 die "Unable to read pidfile $pidfile: $!" if not defined $pid;
759 return 0 if $pid != 0;
761 die "Unable to unlink stale pidfile $pidfile $!";
763 my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
764 die "Unable to open $pidfile for writing: $!";
765 print {$pidfh} $$ or die "Unable to write to $pidfile $!";
766 close $pidfh or die "Unable to close $pidfile $!";
772 checkpid('/path/to/pidfile');
774 Checks a pid file and determines if the process listed in the pidfile
775 is still running. Returns the pid if it is, 0 if it isn't running, and
776 undef if the pidfile doesn't exist or cannot be read.
783 my $pidfh = IO::File->new($pidfile, 'r') or
788 ($pid) = $pid =~ /(\d+)/;
789 if (defined $pid and kill(0,$pid)) {
802 These functions are exported with the :quit tag.
808 Exits the program by calling die.
810 Usage of quit is deprecated; just call die instead.
815 print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
816 carp "quit() is deprecated; call die directly instead";
822 These functions are exported with the :misc tag
826 LIST = make_list(@_);
828 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
831 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
832 b)],[qw(c d)] returns qw(a b c d);
837 return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
843 print english_join(list => \@list);
844 print english_join(\@list);
846 Joins list properly to make an english phrase.
850 =item normal -- how to separate most values; defaults to ', '
852 =item last -- how to separate the last two values; defaults to ', and '
854 =item only_two -- how to separate only two values; defaults to ' and '
856 =item list -- ARRAYREF values to join; if the first argument is an
857 ARRAYREF, it's assumed to be the list of values to join
861 In cases where C<list> is empty, returns ''; when there is only one
862 element, returns that element.
867 if (ref $_[0] eq 'ARRAY') {
868 return english_join(list=>$_[0]);
870 my %param = validate_with(params => \@_,
871 spec => {normal => {type => SCALAR,
874 last => {type => SCALAR,
877 only_two => {type => SCALAR,
880 list => {type => ARRAYREF,
884 my @list = @{$param{list}};
886 return @list?$list[0]:'';
889 return join($param{only_two},@list);
891 my $ret = $param{last} . pop(@list);
892 return join($param{normal},@list) . $ret;
896 =head2 globify_scalar
898 my $handle = globify_scalar(\$foo);
900 if $foo isn't already a glob or a globref, turn it into one using
901 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
903 Will carp if given a scalar which isn't a scalarref or a glob (or
904 globref), and return /dev/null. May return undef if IO::Scalar or
905 IO::File fails. (Check $!)
907 The scalar will fill with octets, not perl's internal encoding, so you
908 must use decode_utf8() after on the scalar, and encode_utf8() on it
909 before. This appears to be a bug in the underlying modules.
916 if (defined $scalar) {
917 if (defined ref($scalar)) {
918 if (ref($scalar) eq 'SCALAR' and
919 not UNIVERSAL::isa($scalar,'GLOB')) {
920 if (is_utf8(${$scalar})) {
921 ${$scalar} = decode_utf8(${$scalar});
922 carp(q(\$scalar must not be in perl's internal encoding));
924 open $handle, '>:scalar:utf8', $scalar;
931 elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
935 carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
938 return IO::File->new('/dev/null','>:encoding(UTF-8)');
941 =head2 cleanup_eval_fail()
943 print "Something failed with: ".cleanup_eval_fail($@);
945 Does various bits of cleanup on the failure message from an eval (or
946 any other die message)
948 Takes at most two options; the first is the actual failure message
949 (usually $@ and defaults to $@), the second is the debug level
950 (defaults to $DEBUG).
952 If debug is non-zero, the code at which the failure occured is output.
956 sub cleanup_eval_fail {
957 my ($error,$debug) = @_;
958 if (not defined $error or not @_) {
959 $error = $@ // 'unknown reason';
962 $debug = $DEBUG // 0;
964 $debug = 0 if not defined $debug;
969 # ditch the "at foo/bar/baz.pm line 5"
970 $error =~ s/\sat\s\S+\sline\s\d+//;
971 # ditch croak messages
972 $error =~ s/^\t+.+\n?//g;
973 # ditch trailing multiple periods in case there was a cascade of
975 $error =~ s/\.+$/\./;
981 hash_slice(%hash,qw(key1 key2 key3))
983 For each key, returns matching values and keys of the hash if they exist
988 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
989 # hash without uselessly making a reference to first. DO NOT USE
990 # PROTOTYPES USELESSLY ELSEWHERE.
991 sub hash_slice(\%@) {
992 my ($hashref,@keys) = @_;
993 return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;