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),
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 and length $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 and length $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 croak "Unable to open $fn for reading: $!";
435 binmode($fh,':encoding(UTF-8)');
438 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
439 my ($key,$value)=($1,$2);
441 $forward->{$key}= $value;
442 if (defined $reverse) {
443 if ($type eq 'address') {
444 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
445 push @{$reverse->{$m}},$key;
449 push @{$reverse->{$value}}, $key;
458 my $pseudopkgdesc = getpseudodesc(...);
460 Returns the entry for a pseudo package from the
461 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
462 defined, returns an empty arrayref.
464 This function can be used to see if a particular package is a
465 pseudopackage or not.
469 our $_pseudodesc = undef;
471 return $_pseudodesc if defined $_pseudodesc;
473 __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
474 defined $config{pseudo_desc_file} and
475 length $config{pseudo_desc_file};
481 sort_versions('1.0-2','1.1-2');
483 Sorts versions using AptPkg::Versions::compare if it is available, or
484 Debbugs::Versions::Dpkg::vercmp if it isn't.
490 use Debbugs::Versions::Dpkg;
491 $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
493 # eventually we'll use AptPkg:::Version or similar, but the current
494 # implementation makes this *super* difficult.
497 # use AptPkg::Version;
498 # $vercmp=\&AptPkg::Version::compare;
503 return sort {$vercmp->($a,$b)} @_;
509 my $english = secs_to_english($seconds);
510 my ($days,$english) = secs_to_english($seconds);
512 XXX This should probably be changed to use Date::Calc
519 my $days = int($seconds / 86400);
520 my $years = int($days / 365);
524 push @age, "1 year" if ($years == 1);
525 push @age, "$years years" if ($years > 1);
526 push @age, "1 day" if ($days == 1);
527 push @age, "$days days" if ($days > 1);
528 $result .= join(" and ", @age);
530 return wantarray?(int($seconds/86400),$result):$result;
536 These functions are exported with the :lock tag
541 filelock($lockfile,$locks);
543 FLOCKs the passed file. Use unfilelock to unlock it.
545 Can be passed an optional $locks hashref, which is used to track which
546 files are locked (and how many times they have been locked) to allow
547 for cooperative locking.
556 # NB - NOT COMPATIBLE WITH `with-lock'
557 my ($lockfile,$locks) = @_;
558 if ($lockfile !~ m{^/}) {
559 $lockfile = cwd().'/'.$lockfile;
561 # This is only here to allow for relocking bugs inside of
562 # Debbugs::Control. Nothing else should be using it.
563 if (defined $locks and exists $locks->{locks}{$lockfile} and
564 $locks->{locks}{$lockfile} >= 1) {
565 if (exists $locks->{relockable} and
566 exists $locks->{relockable}{$lockfile}) {
567 $locks->{locks}{$lockfile}++;
568 # indicate that the bug for this lockfile needs to be reread
569 $locks->{relockable}{$lockfile} = 1;
570 push @{$locks->{lockorder}},$lockfile;
575 confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
578 my ($fh,$t_lockfile,$errors) =
579 simple_filelock($lockfile,10,1);
581 push @filelocks, {fh => $fh, file => $lockfile};
582 if (defined $locks) {
583 $locks->{locks}{$lockfile}++;
584 push @{$locks->{lockorder}},$lockfile;
588 croak "failed to get lock on $lockfile -- $errors".
589 (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
593 =head2 simple_filelock
595 my ($fh,$t_lockfile,$errors) =
596 simple_filelock($lockfile,$count,$wait);
598 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
599 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
602 In list context, returns the lockfile filehandle, lockfile name, and
603 any errors which occured.
605 When the lockfile filehandle is undef, locking failed.
607 These lockfiles must be unlocked manually at process end.
612 sub simple_filelock {
613 my ($lockfile,$count,$wait) = @_;
614 if (not defined $count) {
620 if (not defined $wait) {
627 my $fh2 = IO::File->new($lockfile,'w')
628 or die "Unable to open $lockfile for writing: $!";
629 # Do a blocking lock if count is zero
630 flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
631 or die "Unable to lock $lockfile $!";
640 # use usleep for fractional wait seconds
641 usleep($wait * 1_000_000);
643 last unless (--$count > 0);
646 return wantarray?($fh,$lockfile,$errors):$fh
648 return wantarray?(undef,$lockfile,$errors):undef;
651 # clean up all outstanding locks at end time
658 =head2 simple_unlockfile
660 simple_unlockfile($fh,$lockfile);
665 sub simple_unlockfile {
666 my ($fh,$lockfile) = @_;
668 or warn "Unable to unlock lockfile $lockfile: $!";
670 or warn "Unable to close lockfile $lockfile: $!";
672 or warn "Unable to unlink lockfile $lockfile: $!";
681 Unlocks the file most recently locked.
683 Note that it is not currently possible to unlock a specific file
684 locked with filelock.
690 if (@filelocks == 0) {
691 carp "unfilelock called with no active filelocks!\n";
694 if (defined $locks and ref($locks) ne 'HASH') {
695 croak "hash not passsed to unfilelock";
697 if (defined $locks and exists $locks->{lockorder} and
698 @{$locks->{lockorder}} and
699 exists $locks->{locks}{$locks->{lockorder}[-1]}) {
700 my $lockfile = pop @{$locks->{lockorder}};
701 $locks->{locks}{$lockfile}--;
702 if ($locks->{locks}{$lockfile} > 0) {
705 delete $locks->{locks}{$lockfile};
707 my %fl = %{pop(@filelocks)};
708 simple_unlockfile($fl{fh},$fl{file});
714 lockpid('/path/to/pidfile');
716 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
717 pid in the file does not respond to kill 0.
719 Returns 1 on success, false on failure; dies on unusual errors.
726 my $pid = checkpid($pidfile);
727 die "Unable to read pidfile $pidfile: $!" if not defined $pid;
728 return 0 if $pid != 0;
730 die "Unable to unlink stale pidfile $pidfile $!";
732 my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
733 die "Unable to open $pidfile for writing: $!";
734 print {$pidfh} $$ or die "Unable to write to $pidfile $!";
735 close $pidfh or die "Unable to close $pidfile $!";
741 checkpid('/path/to/pidfile');
743 Checks a pid file and determines if the process listed in the pidfile
744 is still running. Returns the pid if it is, 0 if it isn't running, and
745 undef if the pidfile doesn't exist or cannot be read.
752 my $pidfh = IO::File->new($pidfile, 'r') or
757 ($pid) = $pid =~ /(\d+)/;
758 if (defined $pid and kill(0,$pid)) {
771 These functions are exported with the :quit tag.
777 Exits the program by calling die.
779 Usage of quit is deprecated; just call die instead.
784 print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
785 carp "quit() is deprecated; call die directly instead";
791 These functions are exported with the :misc tag
795 LIST = make_list(@_);
797 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
800 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
801 b)],[qw(c d)] returns qw(a b c d);
806 return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
812 print english_join(list => \@list);
813 print english_join(\@list);
815 Joins list properly to make an english phrase.
819 =item normal -- how to separate most values; defaults to ', '
821 =item last -- how to separate the last two values; defaults to ', and '
823 =item only_two -- how to separate only two values; defaults to ' and '
825 =item list -- ARRAYREF values to join; if the first argument is an
826 ARRAYREF, it's assumed to be the list of values to join
830 In cases where C<list> is empty, returns ''; when there is only one
831 element, returns that element.
836 if (ref $_[0] eq 'ARRAY') {
837 return english_join(list=>$_[0]);
839 my %param = validate_with(params => \@_,
840 spec => {normal => {type => SCALAR,
843 last => {type => SCALAR,
846 only_two => {type => SCALAR,
849 list => {type => ARRAYREF,
853 my @list = @{$param{list}};
855 return @list?$list[0]:'';
858 return join($param{only_two},@list);
860 my $ret = $param{last} . pop(@list);
861 return join($param{normal},@list) . $ret;
865 =head2 globify_scalar
867 my $handle = globify_scalar(\$foo);
869 if $foo isn't already a glob or a globref, turn it into one using
870 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
872 Will carp if given a scalar which isn't a scalarref or a glob (or
873 globref), and return /dev/null. May return undef if IO::Scalar or
874 IO::File fails. (Check $!)
876 The scalar will fill with octets, not perl's internal encoding, so you
877 must use decode_utf8() after on the scalar, and encode_utf8() on it
878 before. This appears to be a bug in the underlying modules.
885 if (defined $scalar) {
886 if (defined ref($scalar)) {
887 if (ref($scalar) eq 'SCALAR' and
888 not UNIVERSAL::isa($scalar,'GLOB')) {
889 if (is_utf8(${$scalar})) {
890 ${$scalar} = decode_utf8(${$scalar});
891 carp(q(\$scalar must not be in perl's internal encoding));
893 open $handle, '>:scalar:utf8', $scalar;
900 elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
904 carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
907 return IO::File->new('/dev/null','>:encoding(UTF-8)');
910 =head2 cleanup_eval_fail()
912 print "Something failed with: ".cleanup_eval_fail($@);
914 Does various bits of cleanup on the failure message from an eval (or
915 any other die message)
917 Takes at most two options; the first is the actual failure message
918 (usually $@ and defaults to $@), the second is the debug level
919 (defaults to $DEBUG).
921 If debug is non-zero, the code at which the failure occured is output.
925 sub cleanup_eval_fail {
926 my ($error,$debug) = @_;
927 if (not defined $error or not @_) {
928 $error = $@ // 'unknown reason';
931 $debug = $DEBUG // 0;
933 $debug = 0 if not defined $debug;
938 # ditch the "at foo/bar/baz.pm line 5"
939 $error =~ s/\sat\s\S+\sline\s\d+//;
940 # ditch croak messages
941 $error =~ s/^\t+.+\n?//mg;
942 # ditch trailing multiple periods in case there was a cascade of
944 $error =~ s/\.+$/\./;
950 hash_slice(%hash,qw(key1 key2 key3))
952 For each key, returns matching values and keys of the hash if they exist
957 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
958 # hash without uselessly making a reference to first. DO NOT USE
959 # PROTOTYPES USELESSLY ELSEWHERE.
960 sub hash_slice(\%@) {
961 my ($hashref,@keys) = @_;
962 return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;