X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=b59e6fa88b5985287e319af836de7aafb31113db;hb=106724733322c2bedb9d63aadd733bc7a8fee801;hp=ad8742d54f9825a1fe3622cbe1c010475f9b8ef6;hpb=91ae418e5738511a87b6a970e3ca8508cb798c22;p=debbugs.git diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index ad8742d..b59e6fa 100644 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@ -39,27 +39,31 @@ BEGIN{ @EXPORT = (); %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), - qw(appendfile buglog getparsedaddrs getmaintainers), + qw(appendfile overwritefile buglog getparsedaddrs getmaintainers), qw(bug_status), qw(getmaintainers_reverse), qw(getpseudodesc), qw(package_maintainer), + qw(sort_versions), ], misc => [qw(make_list globify_scalar english_join checkpid), qw(cleanup_eval_fail), + qw(hash_slice), ], + utf8 => [qw(encode_utf8_structure)], date => [qw(secs_to_english)], quit => [qw(quit)], lock => [qw(filelock unfilelock lockpid)], ); @EXPORT_OK = (); - Exporter::export_ok_tags(qw(lock quit date util misc)); + Exporter::export_ok_tags(keys %EXPORT_TAGS); $EXPORT_TAGS{all} = [@EXPORT_OK]; } #use Debbugs::Config qw(:globals); use Carp; +$Carp::Verbose = 1; use Debbugs::Config qw(:config); use IO::File; @@ -67,10 +71,12 @@ use IO::Scalar; use Debbugs::MIME qw(decode_rfc1522); use Mail::Address; use Cwd qw(cwd); +use Encode qw(encode_utf8 is_utf8); +use Storable qw(dclone); use Params::Validate qw(validate_with :types); -use Fcntl qw(:flock); +use Fcntl qw(:DEFAULT :flock); our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH; @@ -215,6 +221,28 @@ sub appendfile { close $fh or die "Unable to close $file: $!"; } +=head2 overwritefile + + ovewritefile($file,'data','to','append'); + +Opens file.new, writes data to it, then moves file.new to file. + +=cut + +sub overwritefile { + my ($file,@data) = @_; + my $fh = IO::File->new("${file}.new",'w') or + die "Unable top open ${file}.new for writing: $!"; + print {$fh} @data or die "Unable to write to ${file}.new: $!"; + close $fh or die "Unable to close ${file}.new: $!"; + rename("${file}.new",$file) or + die "Unable to rename ${file}.new to $file: $!"; +} + + + + + =head2 getparsedaddrs my $address = getparsedaddrs($address); @@ -306,6 +334,9 @@ sub package_maintainer { binary => {type => SCALAR|ARRAYREF, default => [], }, + maintainer => {type => SCALAR|ARRAYREF, + default => [], + }, rehash => {type => BOOLEAN, default => 0, }, @@ -314,6 +345,12 @@ sub package_maintainer { }, }, ); + my @binary = make_list($param{binary}); + my @source = make_list($param{source}); + my @maintainers = make_list($param{maintainer}); + if ((@binary or @source) and @maintainers) { + croak "It is nonsensical to pass both maintainers and source or binary"; + } if ($param{rehash}) { $_source_maintainer = undef; $_source_maintainer_rev = undef; @@ -326,8 +363,12 @@ sub package_maintainer { $_source_maintainer_rev = {}; for my $fn (@config{('source_maintainer_file', 'source_maintainer_file_override', - 'pseduo_maint_file')}) { + 'pseudo_maint_file')}) { next unless defined $fn; + if (not -e $fn) { + warn "Missing source maintainer file '$fn'"; + next; + } __add_to_hash($fn,$_source_maintainer, $_source_maintainer_rev); } @@ -338,26 +379,34 @@ sub package_maintainer { $_maintainer_rev = {}; for my $fn (@config{('maintainer_file', 'maintainer_file_override', - 'pseduo_maint_file')}) { + 'pseudo_maint_file')}) { next unless defined $fn; + if (not -e $fn) { + warn "Missing maintainer file '$fn'"; + next; + } __add_to_hash($fn,$_maintainer, $_maintainer_rev); } } my @return; - my @extra_source; - my $b = $param{reverse}?$_maintainer_rev:$_maintainer; - for my $binary (make_list($param{binary})) { + for my $binary (@binary) { if (not $param{reverse} and $binary =~ /^src:/) { - push @extra_source,$binary; + push @source,$binary; next; } - push @return,grep {defined $_} make_list($b->{$binary}); + push @return,grep {defined $_} make_list($_maintainer->{$binary}); } - my $s = $param{reverse}?$_source_maintainer_rev:$_source_maintainer; - for my $source (make_list($param{source},@extra_source)) { + for my $source (@source) { $source =~ s/^src://; - push @return,grep {defined $_} make_list($s->{$source}); + push @return,grep {defined $_} make_list($_source_maintainer->{$source}); + } + for my $maintainer (grep {defined $_} @maintainers) { + push @return,grep {defined $_} + make_list($_maintainer_rev->{$maintainer}); + push @return,map {$_ !~ /^src:/?'src:'.$_:$_} + grep {defined $_} + make_list($_source_maintainer_rev->{$maintainer}); } return @return; } @@ -425,6 +474,33 @@ sub getpseudodesc { return $_pseudodesc; } +=head2 sort_versions + + sort_versions('1.0-2','1.1-2'); + +Sorts versions using AptPkg::Versions::compare if it is available, or +Debbugs::Versions::Dpkg::vercmp if it isn't. + +=cut + +our $vercmp; +BEGIN{ + use Debbugs::Versions::Dpkg; + $vercmp=\&Debbugs::Versions::Dpkg::vercmp; + +# eventually we'll use AptPkg:::Version or similar, but the current +# implementation makes this *super* difficult. + +# eval { +# use AptPkg::Version; +# $vercmp=\&AptPkg::Version::compare; +# }; +} + +sub sort_versions{ + return sort {$vercmp->($a,$b)} @_; +} + =head1 DATE @@ -459,20 +535,44 @@ These functions are exported with the :lock tag =head2 filelock - filelock + filelock($lockfile); + filelock($lockfile,$locks); FLOCKs the passed file. Use unfilelock to unlock it. +Can be passed an optional $locks hashref, which is used to track which +files are locked (and how many times they have been locked) to allow +for cooperative locking. + =cut our @filelocks; +use Carp qw(cluck); + sub filelock { # NB - NOT COMPATIBLE WITH `with-lock' - my ($lockfile) = @_; + my ($lockfile,$locks) = @_; if ($lockfile !~ m{^/}) { $lockfile = cwd().'/'.$lockfile; } + # This is only here to allow for relocking bugs inside of + # Debbugs::Control. Nothing else should be using it. + if (defined $locks and exists $locks->{locks}{$lockfile} and + $locks->{locks}{$lockfile} >= 1) { + if (exists $locks->{relockable} and + exists $locks->{relockable}{$lockfile}) { + $locks->{locks}{$lockfile}++; + # indicate that the bug for this lockfile needs to be reread + $locks->{relockable}{$lockfile} = 1; + push @{$locks->{lockorder}},$lockfile; + return; + } + else { + use Data::Dumper; + confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]); + } + } my ($count,$errors); $count= 10; $errors= ''; for (;;) { @@ -488,13 +588,19 @@ sub filelock { } if ($fh) { push @filelocks, {fh => $fh, file => $lockfile}; + if (defined $locks) { + $locks->{locks}{$lockfile}++; + push @{$locks->{lockorder}},$lockfile; + } last; } if (--$count <=0) { $errors =~ s/\n+$//; - die "failed to get lock on $lockfile -- $errors"; + use Data::Dumper; + croak "failed to get lock on $lockfile -- $errors". + (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):''); } - sleep 10; +# sleep 10; } } @@ -509,6 +615,7 @@ END { =head2 unfilelock unfilelock() + unfilelock($locks); Unlocks the file most recently locked. @@ -518,10 +625,24 @@ locked with filelock. =cut sub unfilelock { + my ($locks) = @_; if (@filelocks == 0) { - warn "unfilelock called with no active filelocks!\n"; + carp "unfilelock called with no active filelocks!\n"; return; } + if (defined $locks and ref($locks) ne 'HASH') { + croak "hash not passsed to unfilelock"; + } + if (defined $locks and exists $locks->{lockorder} and + @{$locks->{lockorder}} and + exists $locks->{locks}{$locks->{lockorder}[-1]}) { + my $lockfile = pop @{$locks->{lockorder}}; + $locks->{locks}{$lockfile}--; + if ($locks->{locks}{$lockfile} > 0) { + return + } + delete $locks->{locks}{$lockfile}; + } my %fl = %{pop(@filelocks)}; flock($fl{fh},LOCK_UN) or warn "Unable to unlock lockfile $fl{file}: $!"; @@ -552,7 +673,7 @@ sub lockpid { unlink $pidfile or die "Unable to unlink stale pidfile $pidfile $!"; } - my $pidfh = IO::File->new($pidfile,'w') or + my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or die "Unable to open $pidfile for writing: $!"; print {$pidfh} $$ or die "Unable to write to $pidfile $!"; close $pidfh or die "Unable to close $pidfile $!"; @@ -705,7 +826,8 @@ sub globify_scalar { if (defined ref($scalar)) { if (ref($scalar) eq 'SCALAR' and not UNIVERSAL::isa($scalar,'GLOB')) { - return IO::Scalar->new($scalar); + open $handle, '>:scalar:utf8', $scalar; + return $handle; } else { return $scalar; @@ -718,7 +840,7 @@ sub globify_scalar { carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle"; } } - return IO::File->new('/dev/null','w'); + return IO::File->new('/dev/null','>:utf8'); } =head2 cleanup_eval_fail() @@ -751,12 +873,80 @@ sub cleanup_eval_fail { } # ditch the "at foo/bar/baz.pm line 5" $error =~ s/\sat\s\S+\sline\s\d+//; + # ditch croak messages + $error =~ s/^\t+.+\n?//g; # ditch trailing multiple periods in case there was a cascade of # die messages. $error =~ s/\.+$/\./; return $error; } +=head2 hash_slice + + hash_slice(%hash,qw(key1 key2 key3)) + +For each key, returns matching values and keys of the hash if they exist + +=cut + + +# NB: We use prototypes here SPECIFICALLY so that we can be passed a +# hash without uselessly making a reference to first. DO NOT USE +# PROTOTYPES USELESSLY ELSEWHERE. +sub hash_slice(\%@) { + my ($hashref,@keys) = @_; + return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys; +} + + +=head1 UTF-8 + +These functions are exported with the :utf8 tag + +=head2 encode_utf8_structure + + %newdata = encode_utf8_structure(%newdata); + +Takes a complex data structure and encodes any strings with is_utf8 +set into their constituent octets. + +=cut + +our $depth = 0; +sub encode_utf8_structure { + ++$depth; + my @ret; + for my $_ (@_) { + if (ref($_) eq 'HASH') { + push @ret, {encode_utf8_structure(%{$depth == 1 ? dclone($_):$_})}; + } + elsif (ref($_) eq 'ARRAY') { + push @ret, [encode_utf8_structure(@{$depth == 1 ? dclone($_):$_})]; + } + elsif (ref($_)) { + # we don't know how to handle non hash or non arrays + push @ret,$_; + } + else { + push @ret,__encode_utf8($_); + } + } + --$depth; + return @ret; +} + +sub __encode_utf8 { + my @ret; + for my $r (@_) { + if (not ref($r) and is_utf8($r)) { + $r = encode_utf8($r); + } + push @ret,$r; + } + return @ret; +} + + 1;