X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=b5842d1f6bcf9734655c3be575cff1099f18a713;hb=refs%2Fheads%2Fbugwalker_abstraction;hp=ae3c844936dcf26c09293d80e0a2bd3a77ac2074;hpb=d91858a335a8eba1d303261131ebb72ecc8b331a;p=debbugs.git diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index ae3c844..b5842d1 100644 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@ -39,7 +39,8 @@ BEGIN{ @EXPORT = (); %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), - qw(appendfile buglog getparsedaddrs getmaintainers), + qw(appendfile overwritefile buglog getparsedaddrs getmaintainers), + qw(getsourcemaintainers getsourcemaintainers_reverse), qw(bug_status), qw(getmaintainers_reverse), qw(getpseudodesc), @@ -52,10 +53,10 @@ BEGIN{ ], date => [qw(secs_to_english)], quit => [qw(quit)], - lock => [qw(filelock unfilelock lockpid)], + lock => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)], ); @EXPORT_OK = (); - Exporter::export_ok_tags(qw(lock quit date util misc)); + Exporter::export_ok_tags(keys %EXPORT_TAGS); $EXPORT_TAGS{all} = [@EXPORT_OK]; } @@ -70,10 +71,13 @@ use IO::Scalar; use Debbugs::MIME qw(decode_rfc1522); use Mail::Address; use Cwd qw(cwd); +use Storable qw(dclone); +use Time::HiRes qw(usleep); use Params::Validate qw(validate_with :types); use Fcntl qw(:DEFAULT :flock); +use Encode qw(is_utf8 decode_utf8); our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH; @@ -218,6 +222,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); @@ -274,6 +300,36 @@ sub getmaintainers_reverse{ return $_maintainer_rev; } +=head2 getsourcemaintainers + + my $maintainer = getsourcemaintainers()->{debbugs} + +Returns a hashref of src_package => maintainer pairs. + +=cut + +our $_source_maintainer = undef; +our $_source_maintainer_rev = undef; +sub getsourcemaintainers { + return $_source_maintainer if defined $_source_maintainer; + package_maintainer(rehash => 1); + return $_source_maintainer; +} + +=head2 getsourcemaintainers_reverse + + my @src_packages = @{getsourcemaintainers_reverse->{'don@debian.org'}||[]}; + +Returns a hashref of maintainer => [qw(list of source packages)] pairs. + +=cut + +sub getsourcemaintainers_reverse{ + return $_source_maintainer_rev if defined $_source_maintainer_rev; + package_maintainer(rehash => 1); + return $_source_maintainer_rev; +} + =head2 package_maintainer my @s = package_maintainer(source => [qw(foo bar baz)], @@ -299,8 +355,6 @@ files; defaults to 0 =cut -our $_source_maintainer = undef; -our $_source_maintainer_rev = undef; sub package_maintainer { my %param = validate_with(params => \@_, spec => {source => {type => SCALAR|ARRAYREF, @@ -407,10 +461,11 @@ sub __add_to_hash { $type //= 'address'; my $fh = IO::File->new($fn,'r') or die "Unable to open $fn for reading: $!"; + binmode($fh,':encoding(UTF-8)'); while (<$fh>) { chomp; - next unless m/^(\S+)\s+(\S.*\S)\s*$/; - my ($key,$value)=($1,$2); + next unless m/^(\S+)\s+(\S.*\S)\s*$/; + my ($key,$value)=($1,$2); $key = lc $key; $forward->{$key}= $value; if (defined $reverse) { @@ -548,35 +603,77 @@ sub filelock { confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]); } } - my ($count,$errors); - $count= 10; $errors= ''; - for (;;) { - my $fh = eval { + my ($fh,$t_lockfile,$errors) = + simple_filelock($lockfile,10,1); + if ($fh) { + push @filelocks, {fh => $fh, file => $lockfile}; + if (defined $locks) { + $locks->{locks}{$lockfile}++; + push @{$locks->{lockorder}},$lockfile; + } + } else { + use Data::Dumper; + croak "failed to get lock on $lockfile -- $errors". + (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):''); + } +} + +=head2 simple_filelock + + my ($fh,$t_lockfile,$errors) = + simple_filelock($lockfile,$count,$wait); + +Does a flock of lockfile. If C<$count> is zero, does a blocking lock. +Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait> +seconds in between. + +In list context, returns the lockfile filehandle, lockfile name, and +any errors which occured. + +When the lockfile filehandle is undef, locking failed. + +These lockfiles must be unlocked manually at process end. + + +=cut + +sub simple_filelock { + my ($lockfile,$count,$wait) = @_; + if (not defined $count) { + $count = 10; + } + if ($count < 0) { + $count = 0; + } + if (not defined $wait) { + $wait = 1; + } + my $errors= ''; + my $fh; + while (1) { + $fh = eval { my $fh2 = IO::File->new($lockfile,'w') or die "Unable to open $lockfile for writing: $!"; - flock($fh2,LOCK_EX|LOCK_NB) + # Do a blocking lock if count is zero + flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB)) or die "Unable to lock $lockfile $!"; return $fh2; }; if ($@) { $errors .= $@; } - 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+$//; - use Data::Dumper; - croak "failed to get lock on $lockfile -- $errors". - (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):''); + if ($fh) { + last; } -# sleep 10; + # use usleep for fractional wait seconds + usleep($wait * 1_000_000); + } continue { + last unless (--$count > 0); + } + if ($fh) { + return wantarray?($fh,$lockfile,$errors):$fh } + return wantarray?(undef,$lockfile,$errors):undef; } # clean up all outstanding locks at end time @@ -586,6 +683,23 @@ END { } } +=head2 simple_unlockfile + + simple_unlockfile($fh,$lockfile); + + +=cut + +sub simple_unlockfile { + my ($fh,$lockfile) = @_; + flock($fh,LOCK_UN) + or warn "Unable to unlock lockfile $lockfile: $!"; + close($fh) + or warn "Unable to close lockfile $lockfile: $!"; + unlink($lockfile) + or warn "Unable to unlink lockfile $lockfile: $!"; +} + =head2 unfilelock @@ -619,12 +733,7 @@ sub unfilelock { delete $locks->{locks}{$lockfile}; } my %fl = %{pop(@filelocks)}; - flock($fl{fh},LOCK_UN) - or warn "Unable to unlock lockfile $fl{file}: $!"; - close($fl{fh}) - or warn "Unable to close lockfile $fl{file}: $!"; - unlink($fl{file}) - or warn "Unable to unlink lockfile $fl{file}: $!"; + simple_unlockfile($fl{fh},$fl{file}); } @@ -792,6 +901,10 @@ Will carp if given a scalar which isn't a scalarref or a glob (or globref), and return /dev/null. May return undef if IO::Scalar or IO::File fails. (Check $!) +The scalar will fill with octets, not perl's internal encoding, so you +must use decode_utf8() after on the scalar, and encode_utf8() on it +before. This appears to be a bug in the underlying modules. + =cut sub globify_scalar { @@ -801,7 +914,12 @@ sub globify_scalar { if (defined ref($scalar)) { if (ref($scalar) eq 'SCALAR' and not UNIVERSAL::isa($scalar,'GLOB')) { - return IO::Scalar->new($scalar); + if (is_utf8(${$scalar})) { + ${$scalar} = decode_utf8(${$scalar}); + carp(q(\$scalar must not be in perl's internal encoding)); + } + open $handle, '>:scalar:utf8', $scalar; + return $handle; } else { return $scalar; @@ -814,7 +932,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','>:encoding(UTF-8)'); } =head2 cleanup_eval_fail() @@ -847,6 +965,8 @@ 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/\.+$/\./; @@ -870,6 +990,7 @@ sub hash_slice(\%@) { return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys; } + 1; __END__