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),
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 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
468 my ($key,$value)=($1,$2);
470 $forward->{$key}= $value;
471 if (defined $reverse) {
472 if ($type eq 'address') {
473 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
474 push @{$reverse->{$m}},$key;
478 push @{$reverse->{$value}}, $key;
487 my $pseudopkgdesc = getpseudodesc(...);
489 Returns the entry for a pseudo package from the
490 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
491 defined, returns an empty arrayref.
493 This function can be used to see if a particular package is a
494 pseudopackage or not.
498 our $_pseudodesc = undef;
500 return $_pseudodesc if defined $_pseudodesc;
502 __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
503 defined $config{pseudo_desc_file};
509 sort_versions('1.0-2','1.1-2');
511 Sorts versions using AptPkg::Versions::compare if it is available, or
512 Debbugs::Versions::Dpkg::vercmp if it isn't.
518 use Debbugs::Versions::Dpkg;
519 $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
521 # eventually we'll use AptPkg:::Version or similar, but the current
522 # implementation makes this *super* difficult.
525 # use AptPkg::Version;
526 # $vercmp=\&AptPkg::Version::compare;
531 return sort {$vercmp->($a,$b)} @_;
537 my $english = secs_to_english($seconds);
538 my ($days,$english) = secs_to_english($seconds);
540 XXX This should probably be changed to use Date::Calc
547 my $days = int($seconds / 86400);
548 my $years = int($days / 365);
552 push @age, "1 year" if ($years == 1);
553 push @age, "$years years" if ($years > 1);
554 push @age, "1 day" if ($days == 1);
555 push @age, "$days days" if ($days > 1);
556 $result .= join(" and ", @age);
558 return wantarray?(int($seconds/86400),$result):$result;
564 These functions are exported with the :lock tag
569 filelock($lockfile,$locks);
571 FLOCKs the passed file. Use unfilelock to unlock it.
573 Can be passed an optional $locks hashref, which is used to track which
574 files are locked (and how many times they have been locked) to allow
575 for cooperative locking.
584 # NB - NOT COMPATIBLE WITH `with-lock'
585 my ($lockfile,$locks) = @_;
586 if ($lockfile !~ m{^/}) {
587 $lockfile = cwd().'/'.$lockfile;
589 # This is only here to allow for relocking bugs inside of
590 # Debbugs::Control. Nothing else should be using it.
591 if (defined $locks and exists $locks->{locks}{$lockfile} and
592 $locks->{locks}{$lockfile} >= 1) {
593 if (exists $locks->{relockable} and
594 exists $locks->{relockable}{$lockfile}) {
595 $locks->{locks}{$lockfile}++;
596 # indicate that the bug for this lockfile needs to be reread
597 $locks->{relockable}{$lockfile} = 1;
598 push @{$locks->{lockorder}},$lockfile;
603 confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
606 my ($fh,$t_lockfile,$errors) =
607 simple_filelock($lockfile,10,1);
609 push @filelocks, {fh => $fh, file => $lockfile};
610 if (defined $locks) {
611 $locks->{locks}{$lockfile}++;
612 push @{$locks->{lockorder}},$lockfile;
616 croak "failed to get lock on $lockfile -- $errors".
617 (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
621 =head2 simple_filelock
623 my ($fh,$t_lockfile,$errors) =
624 simple_filelock($lockfile,$count,$wait);
626 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
627 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
630 In list context, returns the lockfile filehandle, lockfile name, and
631 any errors which occured.
633 When the lockfile filehandle is undef, locking failed.
635 These lockfiles must be unlocked manually at process end.
640 sub simple_filelock {
641 my ($lockfile,$count,$wait) = @_;
642 if (not defined $count) {
648 if (not defined $wait) {
655 my $fh2 = IO::File->new($lockfile,'w')
656 or die "Unable to open $lockfile for writing: $!";
657 # Do a blocking lock if count is zero
658 flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
659 or die "Unable to lock $lockfile $!";
668 # use usleep for fractional wait seconds
669 usleep($wait * 1_000_000);
671 last unless (--$count > 0);
674 return wantarray?($fh,$lockfile,$errors):$fh
676 return wantarray?(undef,$lockfile,$errors):undef;
679 # clean up all outstanding locks at end time
686 =head2 simple_unlockfile
688 simple_unlockfile($fh,$lockfile);
693 sub simple_unlockfile {
694 my ($fh,$lockfile) = @_;
696 or warn "Unable to unlock lockfile $lockfile: $!";
698 or warn "Unable to close lockfile $lockfile: $!";
700 or warn "Unable to unlink lockfile $lockfile: $!";
709 Unlocks the file most recently locked.
711 Note that it is not currently possible to unlock a specific file
712 locked with filelock.
718 if (@filelocks == 0) {
719 carp "unfilelock called with no active filelocks!\n";
722 if (defined $locks and ref($locks) ne 'HASH') {
723 croak "hash not passsed to unfilelock";
725 if (defined $locks and exists $locks->{lockorder} and
726 @{$locks->{lockorder}} and
727 exists $locks->{locks}{$locks->{lockorder}[-1]}) {
728 my $lockfile = pop @{$locks->{lockorder}};
729 $locks->{locks}{$lockfile}--;
730 if ($locks->{locks}{$lockfile} > 0) {
733 delete $locks->{locks}{$lockfile};
735 my %fl = %{pop(@filelocks)};
736 simple_unlockfile($fl{fh},$fl{file});
742 lockpid('/path/to/pidfile');
744 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
745 pid in the file does not respond to kill 0.
747 Returns 1 on success, false on failure; dies on unusual errors.
754 my $pid = checkpid($pidfile);
755 die "Unable to read pidfile $pidfile: $!" if not defined $pid;
756 return 0 if $pid != 0;
758 die "Unable to unlink stale pidfile $pidfile $!";
760 my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
761 die "Unable to open $pidfile for writing: $!";
762 print {$pidfh} $$ or die "Unable to write to $pidfile $!";
763 close $pidfh or die "Unable to close $pidfile $!";
769 checkpid('/path/to/pidfile');
771 Checks a pid file and determines if the process listed in the pidfile
772 is still running. Returns the pid if it is, 0 if it isn't running, and
773 undef if the pidfile doesn't exist or cannot be read.
780 my $pidfh = IO::File->new($pidfile, 'r') or
785 ($pid) = $pid =~ /(\d+)/;
786 if (defined $pid and kill(0,$pid)) {
799 These functions are exported with the :quit tag.
805 Exits the program by calling die.
807 Usage of quit is deprecated; just call die instead.
812 print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
813 carp "quit() is deprecated; call die directly instead";
819 These functions are exported with the :misc tag
823 LIST = make_list(@_);
825 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
828 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
829 b)],[qw(c d)] returns qw(a b c d);
834 return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
840 print english_join(list => \@list);
841 print english_join(\@list);
843 Joins list properly to make an english phrase.
847 =item normal -- how to separate most values; defaults to ', '
849 =item last -- how to separate the last two values; defaults to ', and '
851 =item only_two -- how to separate only two values; defaults to ' and '
853 =item list -- ARRAYREF values to join; if the first argument is an
854 ARRAYREF, it's assumed to be the list of values to join
858 In cases where C<list> is empty, returns ''; when there is only one
859 element, returns that element.
864 if (ref $_[0] eq 'ARRAY') {
865 return english_join(list=>$_[0]);
867 my %param = validate_with(params => \@_,
868 spec => {normal => {type => SCALAR,
871 last => {type => SCALAR,
874 only_two => {type => SCALAR,
877 list => {type => ARRAYREF,
881 my @list = @{$param{list}};
883 return @list?$list[0]:'';
886 return join($param{only_two},@list);
888 my $ret = $param{last} . pop(@list);
889 return join($param{normal},@list) . $ret;
893 =head2 globify_scalar
895 my $handle = globify_scalar(\$foo);
897 if $foo isn't already a glob or a globref, turn it into one using
898 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
900 Will carp if given a scalar which isn't a scalarref or a glob (or
901 globref), and return /dev/null. May return undef if IO::Scalar or
902 IO::File fails. (Check $!)
904 The scalar will fill with octets, not perl's internal encoding, so you
905 must use decode_utf8() after on the scalar, and encode_utf8() on it
906 before. This appears to be a bug in the underlying modules.
913 if (defined $scalar) {
914 if (defined ref($scalar)) {
915 if (ref($scalar) eq 'SCALAR' and
916 not UNIVERSAL::isa($scalar,'GLOB')) {
917 if (is_utf8(${$scalar})) {
918 ${$scalar} = decode_utf8(${$scalar});
919 carp(q(\$scalar must not be in perl's internal encoding));
921 open $handle, '>:scalar:utf8', $scalar;
928 elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
932 carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
935 return IO::File->new('/dev/null','>:encoding(UTF-8)');
938 =head2 cleanup_eval_fail()
940 print "Something failed with: ".cleanup_eval_fail($@);
942 Does various bits of cleanup on the failure message from an eval (or
943 any other die message)
945 Takes at most two options; the first is the actual failure message
946 (usually $@ and defaults to $@), the second is the debug level
947 (defaults to $DEBUG).
949 If debug is non-zero, the code at which the failure occured is output.
953 sub cleanup_eval_fail {
954 my ($error,$debug) = @_;
955 if (not defined $error or not @_) {
956 $error = $@ // 'unknown reason';
959 $debug = $DEBUG // 0;
961 $debug = 0 if not defined $debug;
966 # ditch the "at foo/bar/baz.pm line 5"
967 $error =~ s/\sat\s\S+\sline\s\d+//;
968 # ditch croak messages
969 $error =~ s/^\t+.+\n?//mg;
970 # ditch trailing multiple periods in case there was a cascade of
972 $error =~ s/\.+$/\./;
978 hash_slice(%hash,qw(key1 key2 key3))
980 For each key, returns matching values and keys of the hash if they exist
985 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
986 # hash without uselessly making a reference to first. DO NOT USE
987 # PROTOTYPES USELESSLY ELSEWHERE.
988 sub hash_slice(\%@) {
989 my ($hashref,@keys) = @_;
990 return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;