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),
48 qw(open_compressed_file),
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: $!";
243 =head2 open_compressed_file
245 my $fh = open_compressed_file('foo.gz') or
246 die "Unable to open compressed file: $!";
249 Opens a file; if the file ends in .gz, .xz, or .bz2, the appropriate
250 decompression program is forked and output from it is read.
252 This routine by default opens the file with UTF-8 encoding; if you want some
253 other encoding, specify it with the second option.
256 sub open_compressed_file {
257 my ($file,$encoding) = @_;
258 $encoding //= ':encoding(UTF-8)';
260 my $mode = "<$encoding";
262 if ($file =~ /\.gz$/) {
263 $mode = "-|$encoding";
264 push @opts,'gzip','-dc';
266 if ($file =~ /\.xz$/) {
267 $mode = "-|$encoding";
268 push @opts,'xz','-dc';
270 if ($file =~ /\.bz2$/) {
271 $mode = "-|$encoding";
272 push @opts,'bzip2','-dc';
274 open($fh,$mode,@opts,$file);
280 =head2 getparsedaddrs
282 my $address = getparsedaddrs($address);
283 my @address = getparsedaddrs($address);
285 Returns the output from Mail::Address->parse, or the cached output if
286 this address has been parsed before. In SCALAR context returns the
287 first address parsed.
295 return () unless defined $addr;
296 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
297 if exists $_parsedaddrs{$addr};
299 # don't display the warnings from Mail::Address->parse
300 local $SIG{__WARN__} = sub { };
301 @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
303 return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
306 =head2 getmaintainers
308 my $maintainer = getmaintainers()->{debbugs}
310 Returns a hashref of package => maintainer pairs.
314 our $_maintainer = undef;
315 our $_maintainer_rev = undef;
317 return $_maintainer if defined $_maintainer;
318 package_maintainer(rehash => 1);
322 =head2 getmaintainers_reverse
324 my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
326 Returns a hashref of maintainer => [qw(list of packages)] pairs.
330 sub getmaintainers_reverse{
331 return $_maintainer_rev if defined $_maintainer_rev;
332 package_maintainer(rehash => 1);
333 return $_maintainer_rev;
336 =head2 package_maintainer
338 my @s = package_maintainer(source => [qw(foo bar baz)],
339 binary => [qw(bleh blah)],
344 =item source -- scalar or arrayref of source package names to return
345 maintainers for, defaults to the empty arrayref.
347 =item binary -- scalar or arrayref of binary package names to return
348 maintainers for; automatically returns source package maintainer if
349 the package name starts with 'src:', defaults to the empty arrayref.
351 =item reverse -- whether to return the source/binary packages a
352 maintainer maintains instead
354 =item rehash -- whether to reread the maintainer and source maintainer
361 our $_source_maintainer = undef;
362 our $_source_maintainer_rev = undef;
363 sub package_maintainer {
364 my %param = validate_with(params => \@_,
365 spec => {source => {type => SCALAR|ARRAYREF,
368 binary => {type => SCALAR|ARRAYREF,
371 maintainer => {type => SCALAR|ARRAYREF,
374 rehash => {type => BOOLEAN,
377 reverse => {type => BOOLEAN,
382 my @binary = make_list($param{binary});
383 my @source = make_list($param{source});
384 my @maintainers = make_list($param{maintainer});
385 if ((@binary or @source) and @maintainers) {
386 croak "It is nonsensical to pass both maintainers and source or binary";
388 if ($param{rehash}) {
389 $_source_maintainer = undef;
390 $_source_maintainer_rev = undef;
391 $_maintainer = undef;
392 $_maintainer_rev = undef;
394 if (not defined $_source_maintainer or
395 not defined $_source_maintainer_rev) {
396 $_source_maintainer = {};
397 $_source_maintainer_rev = {};
398 for my $fn (@config{('source_maintainer_file',
399 'source_maintainer_file_override',
400 'pseudo_maint_file')}) {
401 next unless defined $fn and length $fn;
403 warn "Missing source maintainer file '$fn'";
406 __add_to_hash($fn,$_source_maintainer,
407 $_source_maintainer_rev);
410 if (not defined $_maintainer or
411 not defined $_maintainer_rev) {
413 $_maintainer_rev = {};
414 for my $fn (@config{('maintainer_file',
415 'maintainer_file_override',
416 'pseudo_maint_file')}) {
417 next unless defined $fn and length $fn;
419 warn "Missing maintainer file '$fn'";
422 __add_to_hash($fn,$_maintainer,
427 for my $binary (@binary) {
428 if (not $param{reverse} and $binary =~ /^src:/) {
429 push @source,$binary;
432 push @return,grep {defined $_} make_list($_maintainer->{$binary});
434 for my $source (@source) {
435 $source =~ s/^src://;
436 push @return,grep {defined $_} make_list($_source_maintainer->{$source});
438 for my $maintainer (grep {defined $_} @maintainers) {
439 push @return,grep {defined $_}
440 make_list($_maintainer_rev->{$maintainer});
441 push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
443 make_list($_source_maintainer_rev->{$maintainer});
448 #=head2 __add_to_hash
450 # __add_to_hash($file,$forward_hash,$reverse_hash,'address');
452 # Reads a maintainer/source maintainer/pseudo desc file and adds the
453 # maintainers from it to the forward and reverse hashref; assumes that
454 # the forward is unique; makes no assumptions of the reverse.
459 my ($fn,$forward,$reverse,$type) = @_;
460 if (ref($forward) ne 'HASH') {
461 croak "__add_to_hash must be passed a hashref for the forward";
463 if (defined $reverse and not ref($reverse) eq 'HASH') {
464 croak "if reverse is passed to __add_to_hash, it must be a hashref";
467 my $fh = IO::File->new($fn,'r') or
468 croak "Unable to open $fn for reading: $!";
469 binmode($fh,':encoding(UTF-8)');
472 next unless m/^(\S+)\s+(\S.*\S)\s*$/;
473 my ($key,$value)=($1,$2);
475 $forward->{$key}= $value;
476 if (defined $reverse) {
477 if ($type eq 'address') {
478 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
479 push @{$reverse->{$m}},$key;
483 push @{$reverse->{$value}}, $key;
492 my $pseudopkgdesc = getpseudodesc(...);
494 Returns the entry for a pseudo package from the
495 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
496 defined, returns an empty arrayref.
498 This function can be used to see if a particular package is a
499 pseudopackage or not.
503 our $_pseudodesc = undef;
505 return $_pseudodesc if defined $_pseudodesc;
507 __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
508 defined $config{pseudo_desc_file} and
509 length $config{pseudo_desc_file};
515 sort_versions('1.0-2','1.1-2');
517 Sorts versions using AptPkg::Versions::compare if it is available, or
518 Debbugs::Versions::Dpkg::vercmp if it isn't.
524 use Debbugs::Versions::Dpkg;
525 $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
527 # eventually we'll use AptPkg:::Version or similar, but the current
528 # implementation makes this *super* difficult.
531 # use AptPkg::Version;
532 # $vercmp=\&AptPkg::Version::compare;
537 return sort {$vercmp->($a,$b)} @_;
543 my $english = secs_to_english($seconds);
544 my ($days,$english) = secs_to_english($seconds);
546 XXX This should probably be changed to use Date::Calc
553 my $days = int($seconds / 86400);
554 my $years = int($days / 365);
558 push @age, "1 year" if ($years == 1);
559 push @age, "$years years" if ($years > 1);
560 push @age, "1 day" if ($days == 1);
561 push @age, "$days days" if ($days > 1);
562 $result .= join(" and ", @age);
564 return wantarray?(int($seconds/86400),$result):$result;
570 These functions are exported with the :lock tag
575 filelock($lockfile,$locks);
577 FLOCKs the passed file. Use unfilelock to unlock it.
579 Can be passed an optional $locks hashref, which is used to track which
580 files are locked (and how many times they have been locked) to allow
581 for cooperative locking.
590 # NB - NOT COMPATIBLE WITH `with-lock'
591 my ($lockfile,$locks) = @_;
592 if ($lockfile !~ m{^/}) {
593 $lockfile = cwd().'/'.$lockfile;
595 # This is only here to allow for relocking bugs inside of
596 # Debbugs::Control. Nothing else should be using it.
597 if (defined $locks and exists $locks->{locks}{$lockfile} and
598 $locks->{locks}{$lockfile} >= 1) {
599 if (exists $locks->{relockable} and
600 exists $locks->{relockable}{$lockfile}) {
601 $locks->{locks}{$lockfile}++;
602 # indicate that the bug for this lockfile needs to be reread
603 $locks->{relockable}{$lockfile} = 1;
604 push @{$locks->{lockorder}},$lockfile;
609 confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
612 my ($fh,$t_lockfile,$errors) =
613 simple_filelock($lockfile,10,1);
615 push @filelocks, {fh => $fh, file => $lockfile};
616 if (defined $locks) {
617 $locks->{locks}{$lockfile}++;
618 push @{$locks->{lockorder}},$lockfile;
622 croak "failed to get lock on $lockfile -- $errors".
623 (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
627 =head2 simple_filelock
629 my ($fh,$t_lockfile,$errors) =
630 simple_filelock($lockfile,$count,$wait);
632 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
633 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
636 In list context, returns the lockfile filehandle, lockfile name, and
637 any errors which occured.
639 When the lockfile filehandle is undef, locking failed.
641 These lockfiles must be unlocked manually at process end.
646 sub simple_filelock {
647 my ($lockfile,$count,$wait) = @_;
648 if (not defined $count) {
654 if (not defined $wait) {
661 my $fh2 = IO::File->new($lockfile,'w')
662 or die "Unable to open $lockfile for writing: $!";
663 # Do a blocking lock if count is zero
664 flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
665 or die "Unable to lock $lockfile $!";
674 # use usleep for fractional wait seconds
675 usleep($wait * 1_000_000);
677 last unless (--$count > 0);
680 return wantarray?($fh,$lockfile,$errors):$fh
682 return wantarray?(undef,$lockfile,$errors):undef;
685 # clean up all outstanding locks at end time
692 =head2 simple_unlockfile
694 simple_unlockfile($fh,$lockfile);
699 sub simple_unlockfile {
700 my ($fh,$lockfile) = @_;
702 or warn "Unable to unlock lockfile $lockfile: $!";
704 or warn "Unable to close lockfile $lockfile: $!";
706 or warn "Unable to unlink lockfile $lockfile: $!";
715 Unlocks the file most recently locked.
717 Note that it is not currently possible to unlock a specific file
718 locked with filelock.
724 if (@filelocks == 0) {
725 carp "unfilelock called with no active filelocks!\n";
728 if (defined $locks and ref($locks) ne 'HASH') {
729 croak "hash not passsed to unfilelock";
731 if (defined $locks and exists $locks->{lockorder} and
732 @{$locks->{lockorder}} and
733 exists $locks->{locks}{$locks->{lockorder}[-1]}) {
734 my $lockfile = pop @{$locks->{lockorder}};
735 $locks->{locks}{$lockfile}--;
736 if ($locks->{locks}{$lockfile} > 0) {
739 delete $locks->{locks}{$lockfile};
741 my %fl = %{pop(@filelocks)};
742 simple_unlockfile($fl{fh},$fl{file});
748 lockpid('/path/to/pidfile');
750 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
751 pid in the file does not respond to kill 0.
753 Returns 1 on success, false on failure; dies on unusual errors.
760 my $pid = checkpid($pidfile);
761 die "Unable to read pidfile $pidfile: $!" if not defined $pid;
762 return 0 if $pid != 0;
764 die "Unable to unlink stale pidfile $pidfile $!";
766 my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
767 die "Unable to open $pidfile for writing: $!";
768 print {$pidfh} $$ or die "Unable to write to $pidfile $!";
769 close $pidfh or die "Unable to close $pidfile $!";
775 checkpid('/path/to/pidfile');
777 Checks a pid file and determines if the process listed in the pidfile
778 is still running. Returns the pid if it is, 0 if it isn't running, and
779 undef if the pidfile doesn't exist or cannot be read.
786 my $pidfh = IO::File->new($pidfile, 'r') or
791 ($pid) = $pid =~ /(\d+)/;
792 if (defined $pid and kill(0,$pid)) {
805 These functions are exported with the :quit tag.
811 Exits the program by calling die.
813 Usage of quit is deprecated; just call die instead.
818 print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
819 carp "quit() is deprecated; call die directly instead";
825 These functions are exported with the :misc tag
829 LIST = make_list(@_);
831 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
834 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
835 b)],[qw(c d)] returns qw(a b c d);
840 return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
846 print english_join(list => \@list);
847 print english_join(\@list);
849 Joins list properly to make an english phrase.
853 =item normal -- how to separate most values; defaults to ', '
855 =item last -- how to separate the last two values; defaults to ', and '
857 =item only_two -- how to separate only two values; defaults to ' and '
859 =item list -- ARRAYREF values to join; if the first argument is an
860 ARRAYREF, it's assumed to be the list of values to join
864 In cases where C<list> is empty, returns ''; when there is only one
865 element, returns that element.
870 if (ref $_[0] eq 'ARRAY') {
871 return english_join(list=>$_[0]);
873 my %param = validate_with(params => \@_,
874 spec => {normal => {type => SCALAR,
877 last => {type => SCALAR,
880 only_two => {type => SCALAR,
883 list => {type => ARRAYREF,
887 my @list = @{$param{list}};
889 return @list?$list[0]:'';
892 return join($param{only_two},@list);
894 my $ret = $param{last} . pop(@list);
895 return join($param{normal},@list) . $ret;
899 =head2 globify_scalar
901 my $handle = globify_scalar(\$foo);
903 if $foo isn't already a glob or a globref, turn it into one using
904 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
906 Will carp if given a scalar which isn't a scalarref or a glob (or
907 globref), and return /dev/null. May return undef if IO::Scalar or
908 IO::File fails. (Check $!)
910 The scalar will fill with octets, not perl's internal encoding, so you
911 must use decode_utf8() after on the scalar, and encode_utf8() on it
912 before. This appears to be a bug in the underlying modules.
919 if (defined $scalar) {
920 if (defined ref($scalar)) {
921 if (ref($scalar) eq 'SCALAR' and
922 not UNIVERSAL::isa($scalar,'GLOB')) {
923 if (is_utf8(${$scalar})) {
924 ${$scalar} = decode_utf8(${$scalar});
925 carp(q(\$scalar must not be in perl's internal encoding));
927 open $handle, '>:scalar:utf8', $scalar;
934 elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
938 carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
941 return IO::File->new('/dev/null','>:encoding(UTF-8)');
944 =head2 cleanup_eval_fail()
946 print "Something failed with: ".cleanup_eval_fail($@);
948 Does various bits of cleanup on the failure message from an eval (or
949 any other die message)
951 Takes at most two options; the first is the actual failure message
952 (usually $@ and defaults to $@), the second is the debug level
953 (defaults to $DEBUG).
955 If debug is non-zero, the code at which the failure occured is output.
959 sub cleanup_eval_fail {
960 my ($error,$debug) = @_;
961 if (not defined $error or not @_) {
962 $error = $@ // 'unknown reason';
965 $debug = $DEBUG // 0;
967 $debug = 0 if not defined $debug;
972 # ditch the "at foo/bar/baz.pm line 5"
973 $error =~ s/\sat\s\S+\sline\s\d+//;
974 # ditch croak messages
975 $error =~ s/^\t+.+\n?//mg;
976 # ditch trailing multiple periods in case there was a cascade of
978 $error =~ s/\.+$/\./;
984 hash_slice(%hash,qw(key1 key2 key3))
986 For each key, returns matching values and keys of the hash if they exist
991 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
992 # hash without uselessly making a reference to first. DO NOT USE
993 # PROTOTYPES USELESSLY ELSEWHERE.
994 sub hash_slice(\%@) {
995 my ($hashref,@keys) = @_;
996 return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;