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 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};
480 sort_versions('1.0-2','1.1-2');
482 Sorts versions using AptPkg::Versions::compare if it is available, or
483 Debbugs::Versions::Dpkg::vercmp if it isn't.
489 use Debbugs::Versions::Dpkg;
490 $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
492 # eventually we'll use AptPkg:::Version or similar, but the current
493 # implementation makes this *super* difficult.
496 # use AptPkg::Version;
497 # $vercmp=\&AptPkg::Version::compare;
502 return sort {$vercmp->($a,$b)} @_;
508 my $english = secs_to_english($seconds);
509 my ($days,$english) = secs_to_english($seconds);
511 XXX This should probably be changed to use Date::Calc
518 my $days = int($seconds / 86400);
519 my $years = int($days / 365);
523 push @age, "1 year" if ($years == 1);
524 push @age, "$years years" if ($years > 1);
525 push @age, "1 day" if ($days == 1);
526 push @age, "$days days" if ($days > 1);
527 $result .= join(" and ", @age);
529 return wantarray?(int($seconds/86400),$result):$result;
535 These functions are exported with the :lock tag
540 filelock($lockfile,$locks);
542 FLOCKs the passed file. Use unfilelock to unlock it.
544 Can be passed an optional $locks hashref, which is used to track which
545 files are locked (and how many times they have been locked) to allow
546 for cooperative locking.
555 # NB - NOT COMPATIBLE WITH `with-lock'
556 my ($lockfile,$locks) = @_;
557 if ($lockfile !~ m{^/}) {
558 $lockfile = cwd().'/'.$lockfile;
560 # This is only here to allow for relocking bugs inside of
561 # Debbugs::Control. Nothing else should be using it.
562 if (defined $locks and exists $locks->{locks}{$lockfile} and
563 $locks->{locks}{$lockfile} >= 1) {
564 if (exists $locks->{relockable} and
565 exists $locks->{relockable}{$lockfile}) {
566 $locks->{locks}{$lockfile}++;
567 # indicate that the bug for this lockfile needs to be reread
568 $locks->{relockable}{$lockfile} = 1;
569 push @{$locks->{lockorder}},$lockfile;
574 confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
577 my ($fh,$t_lockfile,$errors) =
578 simple_filelock($lockfile,10,1);
580 push @filelocks, {fh => $fh, file => $lockfile};
581 if (defined $locks) {
582 $locks->{locks}{$lockfile}++;
583 push @{$locks->{lockorder}},$lockfile;
587 croak "failed to get lock on $lockfile -- $errors".
588 (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
592 =head2 simple_filelock
594 my ($fh,$t_lockfile,$errors) =
595 simple_filelock($lockfile,$count,$wait);
597 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
598 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
601 In list context, returns the lockfile filehandle, lockfile name, and
602 any errors which occured.
604 When the lockfile filehandle is undef, locking failed.
606 These lockfiles must be unlocked manually at process end.
611 sub simple_filelock {
612 my ($lockfile,$count,$wait) = @_;
613 if (not defined $count) {
619 if (not defined $wait) {
626 my $fh2 = IO::File->new($lockfile,'w')
627 or die "Unable to open $lockfile for writing: $!";
628 # Do a blocking lock if count is zero
629 flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
630 or die "Unable to lock $lockfile $!";
639 # use usleep for fractional wait seconds
640 usleep($wait * 1_000_000);
642 last unless (--$count > 0);
645 return wantarray?($fh,$lockfile,$errors):$fh
647 return wantarray?(undef,$lockfile,$errors):undef;
650 # clean up all outstanding locks at end time
657 =head2 simple_unlockfile
659 simple_unlockfile($fh,$lockfile);
664 sub simple_unlockfile {
665 my ($fh,$lockfile) = @_;
667 or warn "Unable to unlock lockfile $lockfile: $!";
669 or warn "Unable to close lockfile $lockfile: $!";
671 or warn "Unable to unlink lockfile $lockfile: $!";
680 Unlocks the file most recently locked.
682 Note that it is not currently possible to unlock a specific file
683 locked with filelock.
689 if (@filelocks == 0) {
690 carp "unfilelock called with no active filelocks!\n";
693 if (defined $locks and ref($locks) ne 'HASH') {
694 croak "hash not passsed to unfilelock";
696 if (defined $locks and exists $locks->{lockorder} and
697 @{$locks->{lockorder}} and
698 exists $locks->{locks}{$locks->{lockorder}[-1]}) {
699 my $lockfile = pop @{$locks->{lockorder}};
700 $locks->{locks}{$lockfile}--;
701 if ($locks->{locks}{$lockfile} > 0) {
704 delete $locks->{locks}{$lockfile};
706 my %fl = %{pop(@filelocks)};
707 simple_unlockfile($fl{fh},$fl{file});
713 lockpid('/path/to/pidfile');
715 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
716 pid in the file does not respond to kill 0.
718 Returns 1 on success, false on failure; dies on unusual errors.
725 my $pid = checkpid($pidfile);
726 die "Unable to read pidfile $pidfile: $!" if not defined $pid;
727 return 0 if $pid != 0;
729 die "Unable to unlink stale pidfile $pidfile $!";
731 my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
732 die "Unable to open $pidfile for writing: $!";
733 print {$pidfh} $$ or die "Unable to write to $pidfile $!";
734 close $pidfh or die "Unable to close $pidfile $!";
740 checkpid('/path/to/pidfile');
742 Checks a pid file and determines if the process listed in the pidfile
743 is still running. Returns the pid if it is, 0 if it isn't running, and
744 undef if the pidfile doesn't exist or cannot be read.
751 my $pidfh = IO::File->new($pidfile, 'r') or
756 ($pid) = $pid =~ /(\d+)/;
757 if (defined $pid and kill(0,$pid)) {
770 These functions are exported with the :quit tag.
776 Exits the program by calling die.
778 Usage of quit is deprecated; just call die instead.
783 print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
784 carp "quit() is deprecated; call die directly instead";
790 These functions are exported with the :misc tag
794 LIST = make_list(@_);
796 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
799 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
800 b)],[qw(c d)] returns qw(a b c d);
805 return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
811 print english_join(list => \@list);
812 print english_join(\@list);
814 Joins list properly to make an english phrase.
818 =item normal -- how to separate most values; defaults to ', '
820 =item last -- how to separate the last two values; defaults to ', and '
822 =item only_two -- how to separate only two values; defaults to ' and '
824 =item list -- ARRAYREF values to join; if the first argument is an
825 ARRAYREF, it's assumed to be the list of values to join
829 In cases where C<list> is empty, returns ''; when there is only one
830 element, returns that element.
835 if (ref $_[0] eq 'ARRAY') {
836 return english_join(list=>$_[0]);
838 my %param = validate_with(params => \@_,
839 spec => {normal => {type => SCALAR,
842 last => {type => SCALAR,
845 only_two => {type => SCALAR,
848 list => {type => ARRAYREF,
852 my @list = @{$param{list}};
854 return @list?$list[0]:'';
857 return join($param{only_two},@list);
859 my $ret = $param{last} . pop(@list);
860 return join($param{normal},@list) . $ret;
864 =head2 globify_scalar
866 my $handle = globify_scalar(\$foo);
868 if $foo isn't already a glob or a globref, turn it into one using
869 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
871 Will carp if given a scalar which isn't a scalarref or a glob (or
872 globref), and return /dev/null. May return undef if IO::Scalar or
873 IO::File fails. (Check $!)
875 The scalar will fill with octets, not perl's internal encoding, so you
876 must use decode_utf8() after on the scalar, and encode_utf8() on it
877 before. This appears to be a bug in the underlying modules.
884 if (defined $scalar) {
885 if (defined ref($scalar)) {
886 if (ref($scalar) eq 'SCALAR' and
887 not UNIVERSAL::isa($scalar,'GLOB')) {
888 if (is_utf8(${$scalar})) {
889 ${$scalar} = decode_utf8(${$scalar});
890 carp(q(\$scalar must not be in perl's internal encoding));
892 open $handle, '>:scalar:utf8', $scalar;
899 elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
903 carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
906 return IO::File->new('/dev/null','>:encoding(UTF-8)');
909 =head2 cleanup_eval_fail()
911 print "Something failed with: ".cleanup_eval_fail($@);
913 Does various bits of cleanup on the failure message from an eval (or
914 any other die message)
916 Takes at most two options; the first is the actual failure message
917 (usually $@ and defaults to $@), the second is the debug level
918 (defaults to $DEBUG).
920 If debug is non-zero, the code at which the failure occured is output.
924 sub cleanup_eval_fail {
925 my ($error,$debug) = @_;
926 if (not defined $error or not @_) {
927 $error = $@ // 'unknown reason';
930 $debug = $DEBUG // 0;
932 $debug = 0 if not defined $debug;
937 # ditch the "at foo/bar/baz.pm line 5"
938 $error =~ s/\sat\s\S+\sline\s\d+//;
939 # ditch croak messages
940 $error =~ s/^\t+.+\n?//g;
941 # ditch trailing multiple periods in case there was a cascade of
943 $error =~ s/\.+$/\./;
949 hash_slice(%hash,qw(key1 key2 key3))
951 For each key, returns matching values and keys of the hash if they exist
956 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
957 # hash without uselessly making a reference to first. DO NOT USE
958 # PROTOTYPES USELESSLY ELSEWHERE.
959 sub hash_slice(\%@) {
960 my ($hashref,@keys) = @_;
961 return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;