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 getsourcemaintainers
304 my $maintainer = getsourcemaintainers()->{debbugs}
306 Returns a hashref of src_package => maintainer pairs.
310 our $_source_maintainer = undef;
311 our $_source_maintainer_rev = undef;
312 sub getsourcemaintainers {
313 return $_source_maintainer if defined $_source_maintainer;
314 package_maintainer(rehash => 1);
315 return $_source_maintainer;
318 =head2 getsourcemaintainers_reverse
320 my @src_packages = @{getsourcemaintainers_reverse->{'don@debian.org'}||[]};
322 Returns a hashref of maintainer => [qw(list of source packages)] pairs.
326 sub getsourcemaintainers_reverse{
327 return $_source_maintainer_rev if defined $_source_maintainer_rev;
328 package_maintainer(rehash => 1);
329 return $_source_maintainer_rev;
332 =head2 package_maintainer
334 my @s = package_maintainer(source => [qw(foo bar baz)],
335 binary => [qw(bleh blah)],
340 =item source -- scalar or arrayref of source package names to return
341 maintainers for, defaults to the empty arrayref.
343 =item binary -- scalar or arrayref of binary package names to return
344 maintainers for; automatically returns source package maintainer if
345 the package name starts with 'src:', defaults to the empty arrayref.
347 =item reverse -- whether to return the source/binary packages a
348 maintainer maintains instead
350 =item rehash -- whether to reread the maintainer and source maintainer
357 sub package_maintainer {
358 my %param = validate_with(params => \@_,
359 spec => {source => {type => SCALAR|ARRAYREF,
362 binary => {type => SCALAR|ARRAYREF,
365 maintainer => {type => SCALAR|ARRAYREF,
368 rehash => {type => BOOLEAN,
371 reverse => {type => BOOLEAN,
376 my @binary = make_list($param{binary});
377 my @source = make_list($param{source});
378 my @maintainers = make_list($param{maintainer});
379 if ((@binary or @source) and @maintainers) {
380 croak "It is nonsensical to pass both maintainers and source or binary";
382 if ($param{rehash}) {
383 $_source_maintainer = undef;
384 $_source_maintainer_rev = undef;
385 $_maintainer = undef;
386 $_maintainer_rev = undef;
388 if (not defined $_source_maintainer or
389 not defined $_source_maintainer_rev) {
390 $_source_maintainer = {};
391 $_source_maintainer_rev = {};
392 for my $fn (@config{('source_maintainer_file',
393 'source_maintainer_file_override',
394 'pseudo_maint_file')}) {
395 next unless defined $fn;
397 warn "Missing source maintainer file '$fn'";
400 __add_to_hash($fn,$_source_maintainer,
401 $_source_maintainer_rev);
404 if (not defined $_maintainer or
405 not defined $_maintainer_rev) {
407 $_maintainer_rev = {};
408 for my $fn (@config{('maintainer_file',
409 'maintainer_file_override',
410 'pseudo_maint_file')}) {
411 next unless defined $fn;
413 warn "Missing maintainer file '$fn'";
416 __add_to_hash($fn,$_maintainer,
421 for my $binary (@binary) {
422 if (not $param{reverse} and $binary =~ /^src:/) {
423 push @source,$binary;
426 push @return,grep {defined $_} make_list($_maintainer->{$binary});
428 for my $source (@source) {
429 $source =~ s/^src://;
430 push @return,grep {defined $_} make_list($_source_maintainer->{$source});
432 for my $maintainer (grep {defined $_} @maintainers) {
433 push @return,grep {defined $_}
434 make_list($_maintainer_rev->{$maintainer});
435 push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
437 make_list($_source_maintainer_rev->{$maintainer});
442 #=head2 __add_to_hash
444 # __add_to_hash($file,$forward_hash,$reverse_hash,'address');
446 # Reads a maintainer/source maintainer/pseudo desc file and adds the
447 # maintainers from it to the forward and reverse hashref; assumes that
448 # the forward is unique; makes no assumptions of the reverse.
453 my ($fn,$forward,$reverse,$type) = @_;
454 if (ref($forward) ne 'HASH') {
455 croak "__add_to_hash must be passed a hashref for the forward";
457 if (defined $reverse and not ref($reverse) eq 'HASH') {
458 croak "if reverse is passed to __add_to_hash, it must be a hashref";
461 my $fh = IO::File->new($fn,'r') or
462 die "Unable to open $fn for reading: $!";
463 binmode($fh,':encoding(UTF-8)');
466 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
467 my ($key,$value)=($1,$2);
469 $forward->{$key}= $value;
470 if (defined $reverse) {
471 if ($type eq 'address') {
472 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
473 push @{$reverse->{$m}},$key;
477 push @{$reverse->{$value}}, $key;
486 my $pseudopkgdesc = getpseudodesc(...);
488 Returns the entry for a pseudo package from the
489 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
490 defined, returns an empty arrayref.
492 This function can be used to see if a particular package is a
493 pseudopackage or not.
497 our $_pseudodesc = undef;
499 return $_pseudodesc if defined $_pseudodesc;
501 __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
502 defined $config{pseudo_desc_file};
508 sort_versions('1.0-2','1.1-2');
510 Sorts versions using AptPkg::Versions::compare if it is available, or
511 Debbugs::Versions::Dpkg::vercmp if it isn't.
517 use Debbugs::Versions::Dpkg;
518 $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
520 # eventually we'll use AptPkg:::Version or similar, but the current
521 # implementation makes this *super* difficult.
524 # use AptPkg::Version;
525 # $vercmp=\&AptPkg::Version::compare;
530 return sort {$vercmp->($a,$b)} @_;
536 my $english = secs_to_english($seconds);
537 my ($days,$english) = secs_to_english($seconds);
539 XXX This should probably be changed to use Date::Calc
546 my $days = int($seconds / 86400);
547 my $years = int($days / 365);
551 push @age, "1 year" if ($years == 1);
552 push @age, "$years years" if ($years > 1);
553 push @age, "1 day" if ($days == 1);
554 push @age, "$days days" if ($days > 1);
555 $result .= join(" and ", @age);
557 return wantarray?(int($seconds/86400),$result):$result;
563 These functions are exported with the :lock tag
568 filelock($lockfile,$locks);
570 FLOCKs the passed file. Use unfilelock to unlock it.
572 Can be passed an optional $locks hashref, which is used to track which
573 files are locked (and how many times they have been locked) to allow
574 for cooperative locking.
583 # NB - NOT COMPATIBLE WITH `with-lock'
584 my ($lockfile,$locks) = @_;
585 if ($lockfile !~ m{^/}) {
586 $lockfile = cwd().'/'.$lockfile;
588 # This is only here to allow for relocking bugs inside of
589 # Debbugs::Control. Nothing else should be using it.
590 if (defined $locks and exists $locks->{locks}{$lockfile} and
591 $locks->{locks}{$lockfile} >= 1) {
592 if (exists $locks->{relockable} and
593 exists $locks->{relockable}{$lockfile}) {
594 $locks->{locks}{$lockfile}++;
595 # indicate that the bug for this lockfile needs to be reread
596 $locks->{relockable}{$lockfile} = 1;
597 push @{$locks->{lockorder}},$lockfile;
602 confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
605 my ($fh,$t_lockfile,$errors) =
606 simple_filelock($lockfile,10,1);
608 push @filelocks, {fh => $fh, file => $lockfile};
609 if (defined $locks) {
610 $locks->{locks}{$lockfile}++;
611 push @{$locks->{lockorder}},$lockfile;
615 croak "failed to get lock on $lockfile -- $errors".
616 (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
620 =head2 simple_filelock
622 my ($fh,$t_lockfile,$errors) =
623 simple_filelock($lockfile,$count,$wait);
625 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
626 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
629 In list context, returns the lockfile filehandle, lockfile name, and
630 any errors which occured.
632 When the lockfile filehandle is undef, locking failed.
634 These lockfiles must be unlocked manually at process end.
639 sub simple_filelock {
640 my ($lockfile,$count,$wait) = @_;
641 if (not defined $count) {
647 if (not defined $wait) {
654 my $fh2 = IO::File->new($lockfile,'w')
655 or die "Unable to open $lockfile for writing: $!";
656 # Do a blocking lock if count is zero
657 flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
658 or die "Unable to lock $lockfile $!";
667 # use usleep for fractional wait seconds
668 usleep($wait * 1_000_000);
670 last unless (--$count > 0);
673 return wantarray?($fh,$lockfile,$errors):$fh
675 return wantarray?(undef,$lockfile,$errors):undef;
678 # clean up all outstanding locks at end time
685 =head2 simple_unlockfile
687 simple_unlockfile($fh,$lockfile);
692 sub simple_unlockfile {
693 my ($fh,$lockfile) = @_;
695 or warn "Unable to unlock lockfile $lockfile: $!";
697 or warn "Unable to close lockfile $lockfile: $!";
699 or warn "Unable to unlink lockfile $lockfile: $!";
708 Unlocks the file most recently locked.
710 Note that it is not currently possible to unlock a specific file
711 locked with filelock.
717 if (@filelocks == 0) {
718 carp "unfilelock called with no active filelocks!\n";
721 if (defined $locks and ref($locks) ne 'HASH') {
722 croak "hash not passsed to unfilelock";
724 if (defined $locks and exists $locks->{lockorder} and
725 @{$locks->{lockorder}} and
726 exists $locks->{locks}{$locks->{lockorder}[-1]}) {
727 my $lockfile = pop @{$locks->{lockorder}};
728 $locks->{locks}{$lockfile}--;
729 if ($locks->{locks}{$lockfile} > 0) {
732 delete $locks->{locks}{$lockfile};
734 my %fl = %{pop(@filelocks)};
735 simple_unlockfile($fl{fh},$fl{file});
741 lockpid('/path/to/pidfile');
743 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
744 pid in the file does not respond to kill 0.
746 Returns 1 on success, false on failure; dies on unusual errors.
753 my $pid = checkpid($pidfile);
754 die "Unable to read pidfile $pidfile: $!" if not defined $pid;
755 return 0 if $pid != 0;
757 die "Unable to unlink stale pidfile $pidfile $!";
759 my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
760 die "Unable to open $pidfile for writing: $!";
761 print {$pidfh} $$ or die "Unable to write to $pidfile $!";
762 close $pidfh or die "Unable to close $pidfile $!";
768 checkpid('/path/to/pidfile');
770 Checks a pid file and determines if the process listed in the pidfile
771 is still running. Returns the pid if it is, 0 if it isn't running, and
772 undef if the pidfile doesn't exist or cannot be read.
779 my $pidfh = IO::File->new($pidfile, 'r') or
784 ($pid) = $pid =~ /(\d+)/;
785 if (defined $pid and kill(0,$pid)) {
798 These functions are exported with the :quit tag.
804 Exits the program by calling die.
806 Usage of quit is deprecated; just call die instead.
811 print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
812 carp "quit() is deprecated; call die directly instead";
818 These functions are exported with the :misc tag
822 LIST = make_list(@_);
824 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
827 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
828 b)],[qw(c d)] returns qw(a b c d);
833 return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
839 print english_join(list => \@list);
840 print english_join(\@list);
842 Joins list properly to make an english phrase.
846 =item normal -- how to separate most values; defaults to ', '
848 =item last -- how to separate the last two values; defaults to ', and '
850 =item only_two -- how to separate only two values; defaults to ' and '
852 =item list -- ARRAYREF values to join; if the first argument is an
853 ARRAYREF, it's assumed to be the list of values to join
857 In cases where C<list> is empty, returns ''; when there is only one
858 element, returns that element.
863 if (ref $_[0] eq 'ARRAY') {
864 return english_join(list=>$_[0]);
866 my %param = validate_with(params => \@_,
867 spec => {normal => {type => SCALAR,
870 last => {type => SCALAR,
873 only_two => {type => SCALAR,
876 list => {type => ARRAYREF,
880 my @list = @{$param{list}};
882 return @list?$list[0]:'';
885 return join($param{only_two},@list);
887 my $ret = $param{last} . pop(@list);
888 return join($param{normal},@list) . $ret;
892 =head2 globify_scalar
894 my $handle = globify_scalar(\$foo);
896 if $foo isn't already a glob or a globref, turn it into one using
897 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
899 Will carp if given a scalar which isn't a scalarref or a glob (or
900 globref), and return /dev/null. May return undef if IO::Scalar or
901 IO::File fails. (Check $!)
903 The scalar will fill with octets, not perl's internal encoding, so you
904 must use decode_utf8() after on the scalar, and encode_utf8() on it
905 before. This appears to be a bug in the underlying modules.
912 if (defined $scalar) {
913 if (defined ref($scalar)) {
914 if (ref($scalar) eq 'SCALAR' and
915 not UNIVERSAL::isa($scalar,'GLOB')) {
916 if (is_utf8(${$scalar})) {
917 ${$scalar} = decode_utf8(${$scalar});
918 carp(q(\$scalar must not be in perl's internal encoding));
920 open $handle, '>:scalar:utf8', $scalar;
927 elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
931 carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
934 return IO::File->new('/dev/null','>:encoding(UTF-8)');
937 =head2 cleanup_eval_fail()
939 print "Something failed with: ".cleanup_eval_fail($@);
941 Does various bits of cleanup on the failure message from an eval (or
942 any other die message)
944 Takes at most two options; the first is the actual failure message
945 (usually $@ and defaults to $@), the second is the debug level
946 (defaults to $DEBUG).
948 If debug is non-zero, the code at which the failure occured is output.
952 sub cleanup_eval_fail {
953 my ($error,$debug) = @_;
954 if (not defined $error or not @_) {
955 $error = $@ // 'unknown reason';
958 $debug = $DEBUG // 0;
960 $debug = 0 if not defined $debug;
965 # ditch the "at foo/bar/baz.pm line 5"
966 $error =~ s/\sat\s\S+\sline\s\d+//;
967 # ditch croak messages
968 $error =~ s/^\t+.+\n?//g;
969 # ditch trailing multiple periods in case there was a cascade of
971 $error =~ s/\.+$/\./;
977 hash_slice(%hash,qw(key1 key2 key3))
979 For each key, returns matching values and keys of the hash if they exist
984 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
985 # hash without uselessly making a reference to first. DO NOT USE
986 # PROTOTYPES USELESSLY ELSEWHERE.
987 sub hash_slice(\%@) {
988 my ($hashref,@keys) = @_;
989 return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;