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),
44 qw(getmaintainers_reverse),
46 qw(package_maintainer),
49 misc => [qw(make_list globify_scalar english_join checkpid),
50 qw(cleanup_eval_fail),
53 date => [qw(secs_to_english)],
55 lock => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)],
58 Exporter::export_ok_tags(keys %EXPORT_TAGS);
59 $EXPORT_TAGS{all} = [@EXPORT_OK];
62 #use Debbugs::Config qw(:globals);
67 use Debbugs::Config qw(:config);
70 use Debbugs::MIME qw(decode_rfc1522);
73 use Storable qw(dclone);
74 use Time::HiRes qw(usleep);
76 use Params::Validate qw(validate_with :types);
78 use Fcntl qw(:DEFAULT :flock);
79 use Encode qw(is_utf8 decode_utf8);
81 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
85 The following functions are exported by the C<:util> tag
87 =head2 getbugcomponent
89 my $file = getbugcomponent($bug_number,$extension,$location)
91 Returns the path to the bug file in location C<$location>, bug number
92 C<$bugnumber> and extension C<$extension>
97 my ($bugnum, $ext, $location) = @_;
99 if (not defined $location) {
100 $location = getbuglocation($bugnum, $ext);
101 # Default to non-archived bugs only for now; CGI scripts want
102 # archived bugs but most of the backend scripts don't. For now,
103 # anything that is prepared to accept archived bugs should call
104 # getbuglocation() directly first.
105 return undef if defined $location and
106 ($location ne 'db' and $location ne 'db-h');
108 my $dir = getlocationpath($location);
109 return undef if not defined $dir;
110 if (defined $location and $location eq 'db') {
111 return "$dir/$bugnum.$ext";
113 my $hash = get_hashname($bugnum);
114 return "$dir/$hash/$bugnum.$ext";
118 =head2 getbuglocation
120 getbuglocation($bug_number,$extension)
122 Returns the the location in which a particular bug exists; valid
123 locations returned currently are archive, db-h, or db. If the bug does
124 not exist, returns undef.
129 my ($bugnum, $ext) = @_;
130 my $archdir = get_hashname($bugnum);
131 return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
132 return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
133 return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
138 =head2 getlocationpath
140 getlocationpath($location)
142 Returns the path to a specific location
146 sub getlocationpath {
148 if (defined $location and $location eq 'archive') {
149 return "$config{spool_dir}/archive";
150 } elsif (defined $location and $location eq 'db') {
151 return "$config{spool_dir}/db";
153 return "$config{spool_dir}/db-h";
162 Returns the hash of the bug which is the location within the archive
167 return "" if ( $_[ 0 ] < 0 );
168 return sprintf "%02d", $_[ 0 ] % 100;
175 Returns the path to the logfile corresponding to the bug.
177 Returns undef if the bug does not exist.
183 my $location = getbuglocation($bugnum, 'log');
184 return getbugcomponent($bugnum, 'log', $location) if ($location);
185 $location = getbuglocation($bugnum, 'log.gz');
186 return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
195 Returns the path to the summary file corresponding to the bug.
197 Returns undef if the bug does not exist.
203 my $location = getbuglocation($bugnum, 'summary');
204 return getbugcomponent($bugnum, 'summary', $location) if ($location);
210 appendfile($file,'data','to','append');
212 Opens a file for appending and writes data to it.
217 my ($file,@data) = @_;
218 my $fh = IO::File->new($file,'a') or
219 die "Unable top open $file for appending: $!";
220 print {$fh} @data or die "Unable to write to $file: $!";
221 close $fh or die "Unable to close $file: $!";
226 ovewritefile($file,'data','to','append');
228 Opens file.new, writes data to it, then moves file.new to file.
233 my ($file,@data) = @_;
234 my $fh = IO::File->new("${file}.new",'w') or
235 die "Unable top open ${file}.new for writing: $!";
236 print {$fh} @data or die "Unable to write to ${file}.new: $!";
237 close $fh or die "Unable to close ${file}.new: $!";
238 rename("${file}.new",$file) or
239 die "Unable to rename ${file}.new to $file: $!";
246 =head2 getparsedaddrs
248 my $address = getparsedaddrs($address);
249 my @address = getparsedaddrs($address);
251 Returns the output from Mail::Address->parse, or the cached output if
252 this address has been parsed before. In SCALAR context returns the
253 first address parsed.
261 return () unless defined $addr;
262 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
263 if exists $_parsedaddrs{$addr};
265 # don't display the warnings from Mail::Address->parse
266 local $SIG{__WARN__} = sub { };
267 @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
269 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
272 =head2 getmaintainers
274 my $maintainer = getmaintainers()->{debbugs}
276 Returns a hashref of package => maintainer pairs.
280 our $_maintainer = undef;
281 our $_maintainer_rev = undef;
283 return $_maintainer if defined $_maintainer;
284 package_maintainer(rehash => 1);
288 =head2 getmaintainers_reverse
290 my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
292 Returns a hashref of maintainer => [qw(list of packages)] pairs.
296 sub getmaintainers_reverse{
297 return $_maintainer_rev if defined $_maintainer_rev;
298 package_maintainer(rehash => 1);
299 return $_maintainer_rev;
302 =head2 package_maintainer
304 my @s = package_maintainer(source => [qw(foo bar baz)],
305 binary => [qw(bleh blah)],
310 =item source -- scalar or arrayref of source package names to return
311 maintainers for, defaults to the empty arrayref.
313 =item binary -- scalar or arrayref of binary package names to return
314 maintainers for; automatically returns source package maintainer if
315 the package name starts with 'src:', defaults to the empty arrayref.
317 =item reverse -- whether to return the source/binary packages a
318 maintainer maintains instead
320 =item rehash -- whether to reread the maintainer and source maintainer
327 our $_source_maintainer = undef;
328 our $_source_maintainer_rev = undef;
329 sub package_maintainer {
330 my %param = validate_with(params => \@_,
331 spec => {source => {type => SCALAR|ARRAYREF,
334 binary => {type => SCALAR|ARRAYREF,
337 maintainer => {type => SCALAR|ARRAYREF,
340 rehash => {type => BOOLEAN,
343 reverse => {type => BOOLEAN,
348 my @binary = make_list($param{binary});
349 my @source = make_list($param{source});
350 my @maintainers = make_list($param{maintainer});
351 if ((@binary or @source) and @maintainers) {
352 croak "It is nonsensical to pass both maintainers and source or binary";
354 if ($param{rehash}) {
355 $_source_maintainer = undef;
356 $_source_maintainer_rev = undef;
357 $_maintainer = undef;
358 $_maintainer_rev = undef;
360 if (not defined $_source_maintainer or
361 not defined $_source_maintainer_rev) {
362 $_source_maintainer = {};
363 $_source_maintainer_rev = {};
364 for my $fn (@config{('source_maintainer_file',
365 'source_maintainer_file_override',
366 'pseudo_maint_file')}) {
367 next unless defined $fn;
369 warn "Missing source maintainer file '$fn'";
372 __add_to_hash($fn,$_source_maintainer,
373 $_source_maintainer_rev);
376 if (not defined $_maintainer or
377 not defined $_maintainer_rev) {
379 $_maintainer_rev = {};
380 for my $fn (@config{('maintainer_file',
381 'maintainer_file_override',
382 'pseudo_maint_file')}) {
383 next unless defined $fn;
385 warn "Missing maintainer file '$fn'";
388 __add_to_hash($fn,$_maintainer,
393 for my $binary (@binary) {
394 if (not $param{reverse} and $binary =~ /^src:/) {
395 push @source,$binary;
398 push @return,grep {defined $_} make_list($_maintainer->{$binary});
400 for my $source (@source) {
401 $source =~ s/^src://;
402 push @return,grep {defined $_} make_list($_source_maintainer->{$source});
404 for my $maintainer (grep {defined $_} @maintainers) {
405 push @return,grep {defined $_}
406 make_list($_maintainer_rev->{$maintainer});
407 push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
409 make_list($_source_maintainer_rev->{$maintainer});
414 #=head2 __add_to_hash
416 # __add_to_hash($file,$forward_hash,$reverse_hash,'address');
418 # Reads a maintainer/source maintainer/pseudo desc file and adds the
419 # maintainers from it to the forward and reverse hashref; assumes that
420 # the forward is unique; makes no assumptions of the reverse.
425 my ($fn,$forward,$reverse,$type) = @_;
426 if (ref($forward) ne 'HASH') {
427 croak "__add_to_hash must be passed a hashref for the forward";
429 if (defined $reverse and not ref($reverse) eq 'HASH') {
430 croak "if reverse is passed to __add_to_hash, it must be a hashref";
433 my $fh = IO::File->new($fn,'r') or
434 die "Unable to open $fn for reading: $!";
435 binmode($fh,':encoding(UTF-8)');
438 my @elements = split /\t/;
439 next unless @elements >=2;
440 # we do this because the source maintainer file contains the
441 # archive location, which we don't care about
442 my ($key,$value)=($elements[0],$elements[-1]);
444 $forward->{$key}= $value;
445 if (defined $reverse) {
446 if ($type eq 'address') {
447 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
448 push @{$reverse->{$m}},$key;
452 push @{$reverse->{$value}}, $key;
461 my $pseudopkgdesc = getpseudodesc(...);
463 Returns the entry for a pseudo package from the
464 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
465 defined, returns an empty arrayref.
467 This function can be used to see if a particular package is a
468 pseudopackage or not.
472 our $_pseudodesc = undef;
474 return $_pseudodesc if defined $_pseudodesc;
476 __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
477 defined $config{pseudo_desc_file};
483 sort_versions('1.0-2','1.1-2');
485 Sorts versions using AptPkg::Versions::compare if it is available, or
486 Debbugs::Versions::Dpkg::vercmp if it isn't.
492 use Debbugs::Versions::Dpkg;
493 $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
495 # eventually we'll use AptPkg:::Version or similar, but the current
496 # implementation makes this *super* difficult.
499 # use AptPkg::Version;
500 # $vercmp=\&AptPkg::Version::compare;
505 return sort {$vercmp->($a,$b)} @_;
511 my $english = secs_to_english($seconds);
512 my ($days,$english) = secs_to_english($seconds);
514 XXX This should probably be changed to use Date::Calc
521 my $days = int($seconds / 86400);
522 my $years = int($days / 365);
526 push @age, "1 year" if ($years == 1);
527 push @age, "$years years" if ($years > 1);
528 push @age, "1 day" if ($days == 1);
529 push @age, "$days days" if ($days > 1);
530 $result .= join(" and ", @age);
532 return wantarray?(int($seconds/86400),$result):$result;
538 These functions are exported with the :lock tag
543 filelock($lockfile,$locks);
545 FLOCKs the passed file. Use unfilelock to unlock it.
547 Can be passed an optional $locks hashref, which is used to track which
548 files are locked (and how many times they have been locked) to allow
549 for cooperative locking.
558 # NB - NOT COMPATIBLE WITH `with-lock'
559 my ($lockfile,$locks) = @_;
560 if ($lockfile !~ m{^/}) {
561 $lockfile = cwd().'/'.$lockfile;
563 # This is only here to allow for relocking bugs inside of
564 # Debbugs::Control. Nothing else should be using it.
565 if (defined $locks and exists $locks->{locks}{$lockfile} and
566 $locks->{locks}{$lockfile} >= 1) {
567 if (exists $locks->{relockable} and
568 exists $locks->{relockable}{$lockfile}) {
569 $locks->{locks}{$lockfile}++;
570 # indicate that the bug for this lockfile needs to be reread
571 $locks->{relockable}{$lockfile} = 1;
572 push @{$locks->{lockorder}},$lockfile;
577 confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
580 my ($fh,$t_lockfile,$errors) =
581 simple_filelock($lockfile,10,1);
583 push @filelocks, {fh => $fh, file => $lockfile};
584 if (defined $locks) {
585 $locks->{locks}{$lockfile}++;
586 push @{$locks->{lockorder}},$lockfile;
590 croak "failed to get lock on $lockfile -- $errors".
591 (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
595 =head2 simple_filelock
597 my ($fh,$t_lockfile,$errors) =
598 simple_filelock($lockfile,$count,$wait);
600 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
601 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
604 In list context, returns the lockfile filehandle, lockfile name, and
605 any errors which occured.
607 When the lockfile filehandle is undef, locking failed.
609 These lockfiles must be unlocked manually at process end.
614 sub simple_filelock {
615 my ($lockfile,$count,$wait) = @_;
616 if (not defined $count) {
622 if (not defined $wait) {
629 my $fh2 = IO::File->new($lockfile,'w')
630 or die "Unable to open $lockfile for writing: $!";
631 # Do a blocking lock if count is zero
632 flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
633 or die "Unable to lock $lockfile $!";
642 # use usleep for fractional wait seconds
643 usleep($wait * 1_000_000);
645 last unless (--$count > 0);
648 return wantarray?($fh,$lockfile,$errors):$fh
650 return wantarray?(undef,$lockfile,$errors):undef;
653 # clean up all outstanding locks at end time
660 =head2 simple_unlockfile
662 simple_unlockfile($fh,$lockfile);
667 sub simple_unlockfile {
668 my ($fh,$lockfile) = @_;
670 or warn "Unable to unlock lockfile $lockfile: $!";
672 or warn "Unable to close lockfile $lockfile: $!";
674 or warn "Unable to unlink lockfile $lockfile: $!";
683 Unlocks the file most recently locked.
685 Note that it is not currently possible to unlock a specific file
686 locked with filelock.
692 if (@filelocks == 0) {
693 carp "unfilelock called with no active filelocks!\n";
696 if (defined $locks and ref($locks) ne 'HASH') {
697 croak "hash not passsed to unfilelock";
699 if (defined $locks and exists $locks->{lockorder} and
700 @{$locks->{lockorder}} and
701 exists $locks->{locks}{$locks->{lockorder}[-1]}) {
702 my $lockfile = pop @{$locks->{lockorder}};
703 $locks->{locks}{$lockfile}--;
704 if ($locks->{locks}{$lockfile} > 0) {
707 delete $locks->{locks}{$lockfile};
709 my %fl = %{pop(@filelocks)};
710 simple_unlockfile($fl{fh},$fl{file});
716 lockpid('/path/to/pidfile');
718 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
719 pid in the file does not respond to kill 0.
721 Returns 1 on success, false on failure; dies on unusual errors.
728 my $pid = checkpid($pidfile);
729 die "Unable to read pidfile $pidfile: $!" if not defined $pid;
730 return 0 if $pid != 0;
732 die "Unable to unlink stale pidfile $pidfile $!";
734 my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
735 die "Unable to open $pidfile for writing: $!";
736 print {$pidfh} $$ or die "Unable to write to $pidfile $!";
737 close $pidfh or die "Unable to close $pidfile $!";
743 checkpid('/path/to/pidfile');
745 Checks a pid file and determines if the process listed in the pidfile
746 is still running. Returns the pid if it is, 0 if it isn't running, and
747 undef if the pidfile doesn't exist or cannot be read.
754 my $pidfh = IO::File->new($pidfile, 'r') or
759 ($pid) = $pid =~ /(\d+)/;
760 if (defined $pid and kill(0,$pid)) {
773 These functions are exported with the :quit tag.
779 Exits the program by calling die.
781 Usage of quit is deprecated; just call die instead.
786 print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
787 carp "quit() is deprecated; call die directly instead";
793 These functions are exported with the :misc tag
797 LIST = make_list(@_);
799 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
802 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
803 b)],[qw(c d)] returns qw(a b c d);
808 return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
814 print english_join(list => \@list);
815 print english_join(\@list);
817 Joins list properly to make an english phrase.
821 =item normal -- how to separate most values; defaults to ', '
823 =item last -- how to separate the last two values; defaults to ', and '
825 =item only_two -- how to separate only two values; defaults to ' and '
827 =item list -- ARRAYREF values to join; if the first argument is an
828 ARRAYREF, it's assumed to be the list of values to join
832 In cases where C<list> is empty, returns ''; when there is only one
833 element, returns that element.
838 if (ref $_[0] eq 'ARRAY') {
839 return english_join(list=>$_[0]);
841 my %param = validate_with(params => \@_,
842 spec => {normal => {type => SCALAR,
845 last => {type => SCALAR,
848 only_two => {type => SCALAR,
851 list => {type => ARRAYREF,
855 my @list = @{$param{list}};
857 return @list?$list[0]:'';
860 return join($param{only_two},@list);
862 my $ret = $param{last} . pop(@list);
863 return join($param{normal},@list) . $ret;
867 =head2 globify_scalar
869 my $handle = globify_scalar(\$foo);
871 if $foo isn't already a glob or a globref, turn it into one using
872 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
874 Will carp if given a scalar which isn't a scalarref or a glob (or
875 globref), and return /dev/null. May return undef if IO::Scalar or
876 IO::File fails. (Check $!)
878 The scalar will fill with octets, not perl's internal encoding, so you
879 must use decode_utf8() after on the scalar, and encode_utf8() on it
880 before. This appears to be a bug in the underlying modules.
887 if (defined $scalar) {
888 if (defined ref($scalar)) {
889 if (ref($scalar) eq 'SCALAR' and
890 not UNIVERSAL::isa($scalar,'GLOB')) {
891 if (is_utf8(${$scalar})) {
892 ${$scalar} = decode_utf8(${$scalar});
893 carp(q(\$scalar must not be in perl's internal encoding));
895 open $handle, '>:scalar:utf8', $scalar;
902 elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
906 carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
909 return IO::File->new('/dev/null','>:encoding(UTF-8)');
912 =head2 cleanup_eval_fail()
914 print "Something failed with: ".cleanup_eval_fail($@);
916 Does various bits of cleanup on the failure message from an eval (or
917 any other die message)
919 Takes at most two options; the first is the actual failure message
920 (usually $@ and defaults to $@), the second is the debug level
921 (defaults to $DEBUG).
923 If debug is non-zero, the code at which the failure occured is output.
927 sub cleanup_eval_fail {
928 my ($error,$debug) = @_;
929 if (not defined $error or not @_) {
930 $error = $@ // 'unknown reason';
933 $debug = $DEBUG // 0;
935 $debug = 0 if not defined $debug;
940 # ditch the "at foo/bar/baz.pm line 5"
941 $error =~ s/\sat\s\S+\sline\s\d+//;
942 # ditch croak messages
943 $error =~ s/^\t+.+\n?//g;
944 # ditch trailing multiple periods in case there was a cascade of
946 $error =~ s/\.+$/\./;
952 hash_slice(%hash,qw(key1 key2 key3))
954 For each key, returns matching values and keys of the hash if they exist
959 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
960 # hash without uselessly making a reference to first. DO NOT USE
961 # PROTOTYPES USELESSLY ELSEWHERE.
962 sub hash_slice(\%@) {
963 my ($hashref,@keys) = @_;
964 return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;