From: Don Armstrong Date: Sat, 23 Sep 2006 08:50:04 +0000 (-0700) Subject: * Move functions in errorlib.in to Debbugs::Common X-Git-Tag: release/2.6.0~585^2^2~86 X-Git-Url: https://git.donarmstrong.com/?p=debbugs.git;a=commitdiff_plain;h=be7b9935921b713b25dc1d01bea960d9eb88f13d * Move functions in errorlib.in to Debbugs::Common * Rewrite the lockfile routines to use flock() and be less manic. * Use Debbugs::Config whereever possible --- diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index fd20168..a86460b 100644 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@ -16,12 +16,6 @@ This module is a replacement for the general parts of errorlib.pl. subroutines in errorlib.pl will be gradually phased out and replaced with equivalent (or better) functionality here. -=head1 BUGS - -This module currently requires /etc/debbugs/config; it should use a -general configuration module so that more intelligent things can be -done. - =head1 FUNCTIONS =cut @@ -36,10 +30,11 @@ BEGIN{ $DEBUG = 0 unless defined $DEBUG; @EXPORT = (); - %EXPORT_TAGS = (#status => [qw(getbugstatus)], - read => [qw(readbug)], - util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), + %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), + qw(appendfile), ], + quit => [qw(quit)], + lock => [qw(filelock unfilelock)], ); @EXPORT_OK = (); Exporter::export_ok_tags(qw(read util)); @@ -51,81 +46,7 @@ use Debbugs::Config qw(:config); use IO::File; use Debbugs::MIME qw(decode_rfc1522); -=head2 readbug - - readbug($bug_number,$location) - -Reads a summary file from the archive given a bug number and a bug -location. Valid locations are those understood by L - -=cut - - -my %fields = (originator => 'submitter', - date => 'date', - subject => 'subject', - msgid => 'message-id', - 'package' => 'package', - keywords => 'tags', - done => 'done', - forwarded => 'forwarded-to', - mergedwith => 'merged-with', - severity => 'severity', - owner => 'owner', - found_versions => 'found-in', - fixed_versions => 'fixed-in', - blocks => 'blocks', - blockedby => 'blocked-by', - ); - -# Fields which need to be RFC1522-decoded in format versions earlier than 3. -my @rfc1522_fields = qw(originator subject done forwarded owner); - -sub readbug { - my ($lref, $location) = @_; - my $status = getbugcomponent($lref, 'summary', $location); - return undef unless defined $status; - my $status_fh = new IO::File $status, 'r' or - warn "Unable to open $status for reading: $!" and return undef; - - my %data; - my @lines; - my $version = 2; - local $_; - - while (<$status_fh>) { - chomp; - push @lines, $_; - $version = $1 if /^Format-Version: ([0-9]+)/i; - } - - # Version 3 is the latest format version currently supported. - return undef if $version > 3; - - my %namemap = reverse %fields; - for my $line (@lines) { - if ($line =~ /(\S+?): (.*)/) { - my ($name, $value) = (lc $1, $2); - $data{$namemap{$name}} = $value if exists $namemap{$name}; - } - } - for my $field (keys %fields) { - $data{$field} = '' unless exists $data{$field}; - } - - $data{severity} = $config{default_severity} if $data{severity} eq ''; - $data{found_versions} = [split ' ', $data{found_versions}]; - $data{fixed_versions} = [split ' ', $data{fixed_versions}]; - - if ($version < 3) { - for my $field (@rfc1522_fields) { - $data{$field} = decode_rfc1522($data{$field}); - } - } - - return \%data; -} - +use Fcntl qw(:flock); =head1 UTILITIES @@ -217,6 +138,120 @@ sub get_hashname { } +=head2 appendfile + + appendfile($file,'data','to','append'); + +Opens a file for appending and writes data to it. + +=cut + +sub appendfile { + my $file = shift; + if (!open(AP,">>$file")) { + print DEBUG "failed open log<\n"; + print DEBUG "failed open log err $!<\n"; + &quit("opening $file (appendfile): $!"); + } + print(AP @_) || &quit("writing $file (appendfile): $!"); + close(AP) || &quit("closing $file (appendfile): $!"); +} + +=head1 LOCK + +These functions are exported with the :lock tag + +=head2 filelock + + filelock + +FLOCKs the passed file. Use unfilelock to unlock it. + +=cut + +my @filelocks; + +sub filelock { + # NB - NOT COMPATIBLE WITH `with-lock' + my ($lockfile) = @_; + my ($count,$errors) = @_; + $count= 10; $errors= ''; + for (;;) { + my $fh = eval { + my $fh = new IO::File $lockfile,'w' + or die "Unable to open $lockfile for writing: $!"; + flock($fh,LOCK_EX|LOCK_NB) + or die "Unable to lock $lockfile $!"; + return $fh; + }; + if ($@) { + $errors .= $@; + } + if ($fh) { + push @filelocks, {fh => $fh, file => $lockfile}; + last; + } + if (--$count <=0) { + $errors =~ s/\n+$//; + &quit("failed to get lock on $lockfile -- $errors"); + } + sleep 10; + } + push(@cleanups,\&unfilelock); +} + + +=head2 unfilelock + + unfilelock() + +Unlocks the file most recently locked. + +Note that it is not currently possible to unlock a specific file +locked with filelock. + +=cut + +sub unfilelock { + if (@filelocks == 0) { + warn "unfilelock called with no active filelocks!\n"; + return; + } + my %fl = %{pop(@filelocks)}; + pop(@cleanups); + 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 locfile $fl{file}: $!"; +} + + + +=head1 QUIT + +These functions are exported with the :quit tag. + +=head2 quit + + quit() + +Exits the program by calling die after running some cleanups. + +This should be replaced with an END handler which runs the cleanups +instead. (Or possibly a die handler, if the cleanups are important) + +=cut + +sub quit { + print DEBUG "quitting >$_[0]<\n"; + local ($u); + while ($u= $cleanups[$#cleanups]) { &$u; } + die "*** $_[0]\n"; +} + + 1; diff --git a/scripts/errorlib.in b/scripts/errorlib.in index 2c33a96..e0e70e7 100755 --- a/scripts/errorlib.in +++ b/scripts/errorlib.in @@ -3,17 +3,13 @@ use Mail::Address; use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522); -use Debbugs::Packages; +use Debbugs::Packages qw(:all); use Debbugs::Common qw(:all); +use Debbugs::Status qw(:all); sub F_SETLK { 6; } sub F_WRLCK{ 1; } $flockstruct= 'sslll'; # And there ought to be something for this too. -sub get_hashname { - return "" if ( $_[ 0 ] < 0 ); - return sprintf "%02d", $_[ 0 ] % 100; -} - sub unlockreadbugmerge { local ($rv) = @_; &unfilelock if $rv >= 2; @@ -31,381 +27,13 @@ sub lockreadbugmerge { return ( 2, $data ); } -my @v1fieldorder = qw(originator date subject msgid package - keywords done forwarded mergedwith severity); - -my %fields = (originator => 'submitter', - date => 'date', - subject => 'subject', - msgid => 'message-id', - 'package' => 'package', - keywords => 'tags', - done => 'done', - forwarded => 'forwarded-to', - mergedwith => 'merged-with', - severity => 'severity', - owner => 'owner', - found_versions => 'found-in', - fixed_versions => 'fixed-in', - blocks => 'blocks', - blockedby => 'blocked-by', - ); - -# Fields which need to be RFC1522-decoded in format versions earlier than 3. -my @rfc1522_fields = qw(originator subject done forwarded owner); - -sub lockreadbug { - local ($lref, $location) = @_; - &filelock("lock/$lref"); - my $data = readbug($lref, $location); - &unfilelock unless defined $data; - return $data; -} - -sub makestatus { - my $data = shift; - my $version = shift; - $version = 2 unless defined $version; - - local $data->{found_versions} = join ' ', @{$data->{found_versions}}; - local $data->{fixed_versions} = join ' ', @{$data->{fixed_versions}}; - - my $contents = ''; - - my %newdata = %$data; - if ($version < 3) { - for my $field (@rfc1522_fields) { - $newdata{$field} = encode_rfc1522($newdata{$field}); - } - } - - if ($version == 1) { - for my $field (@v1fieldorder) { - if (exists $newdata{$field}) { - $contents .= "$newdata{$field}\n"; - } else { - $contents .= "\n"; - } - } - } elsif ($version == 2 or $version == 3) { - # Version 2 or 3. Add a file format version number for the sake of - # further extensibility in the future. - $contents .= "Format-Version: $version\n"; - for my $field (keys %fields) { - if (exists $newdata{$field} and $newdata{$field} ne '') { - # Output field names in proper case, e.g. 'Merged-With'. - my $properfield = $fields{$field}; - $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g; - $contents .= "$properfield: $newdata{$field}\n"; - } - } - } - - return $contents; -} - -sub writebug { - my ($ref, $data, $location, $minversion, $disablebughook) = @_; - my $change; - - my %outputs = (1 => 'status', 2 => 'summary'); - for my $version (keys %outputs) { - next if defined $minversion and $version < $minversion; - my $status = getbugcomponent($ref, $outputs{$version}, $location); - &quit("can't find location for $ref") unless defined $status; - open(S,"> $status.new") || &quit("opening $status.new: $!"); - print(S makestatus($data, $version)) || - &quit("writing $status.new: $!"); - close(S) || &quit("closing $status.new: $!"); - if (-e $status) { - $change = 'change'; - } else { - $change = 'new'; - } - rename("$status.new",$status) || &quit("installing new $status: $!"); - } - - # $disablebughook is a bit of a hack to let format migration scripts use - # this function rather than having to duplicate it themselves. - &bughook($change,$ref,$data) unless $disablebughook; -} - -sub unlockwritebug { - writebug(@_); - &unfilelock; -} - -sub filelock { - # NB - NOT COMPATIBLE WITH `with-lock' - local ($lockfile,$flockpushno,$evalstring,$count,$errors,@s1,@s2) = @_; - $flockpushno= $#filelocks+1; - $count= 10; $errors= ''; - for (;;) { - $evalstring= " - open(FLOCK${flockpushno},\"> \$lockfile\") || die \"open: \$!\"; - \$flockwant= pack(\$flockstruct,&F_WRLCK,0,0,1,0);". - ($] >= 5.000 ? " - fcntl(FLOCK$flockpushno,&F_SETLK,\$flockwant) || die \"setlk: \$!\";" : " - \$z= syscall(&SYS_fcntl,fileno(FLOCK$flockpushno),&F_SETLK,\$flockwant) < 0 - && die \"syscall fcntl setlk: \$!\";") ." - (\@s1= lstat(\$lockfile)) || die \"lstat: \$!\"; - (\@s2= stat(FLOCK$flockpushno)) || die \"fstat: \$!\"; - join(',',\@s1) eq join(',',\@s2) || die \"file switched\"; - 1; - "; - last if eval $evalstring; - $errors .= $@; - eval "close(FLOCK$flockpushno);"; - if (--$count <=0) { - $errors =~ s/\n+$//; - &quit("failed to get lock on file $lockfile: $errors // $evalstring"); - } - sleep 10; - } - push(@cleanups,'unfilelock'); - push(@filelocks,$lockfile); -} - -sub unfilelock { - if (@filelocks == 0) { - warn "unfilelock called with no active filelocks!\n"; - return; - } - local ($lockfile) = pop(@filelocks); - pop(@cleanups); - eval 'close(FLOCK'.($#filelocks+1).');' || warn "failed to close lock file $lockfile: $!"; - unlink($lockfile) || warn "failed to remove lock file $lockfile: $!"; -} - -sub addfoundversions { - my $data = shift; - my $package = shift; - my $version = shift; - my $isbinary = shift; - return unless defined $version; - undef $package if $package =~ m[(?:\s|/)]; - my $source = $package; - - if (defined $package and $isbinary) { - my @srcinfo = binarytosource($package, $version, undef); - if (@srcinfo) { - # We know the source package(s). Use a fully-qualified version. - addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo; - return; - } - # Otherwise, an unqualified version will have to do. - undef $source; - } - - # Strip off various kinds of brain-damage. - $version =~ s/;.*//; - $version =~ s/ *\(.*\)//; - $version =~ s/ +[A-Za-z].*//; - - foreach my $ver (split /[,\s]+/, $version) { - my $sver = defined($source) ? "$source/$ver" : ''; - unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) { - push @{$data->{found_versions}}, defined($source) ? $sver : $ver; - } - @{$data->{fixed_versions}} = - grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}}; - } -} - -sub removefoundversions { - my $data = shift; - my $package = shift; - my $version = shift; - my $isbinary = shift; - return unless defined $version; - undef $package if $package =~ m[(?:\s|/)]; - my $source = $package; - - if (defined $package and $isbinary) { - my @srcinfo = binarytosource($package, $version, undef); - if (@srcinfo) { - # We know the source package(s). Use a fully-qualified version. - removefoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo; - return; - } - # Otherwise, an unqualified version will have to do. - undef $source; - } - - foreach my $ver (split /[,\s]+/, $version) { - my $sver = defined($source) ? "$source/$ver" : ''; - @{$data->{found_versions}} = - grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}}; - } -} - -sub addfixedversions { - my $data = shift; - my $package = shift; - my $version = shift; - my $isbinary = shift; - return unless defined $version; - undef $package if $package =~ m[(?:\s|/)]; - my $source = $package; - - if (defined $package and $isbinary) { - my @srcinfo = binarytosource($package, $version, undef); - if (@srcinfo) { - # We know the source package(s). Use a fully-qualified version. - addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo; - return; - } - # Otherwise, an unqualified version will have to do. - undef $source; - } - - # Strip off various kinds of brain-damage. - $version =~ s/;.*//; - $version =~ s/ *\(.*\)//; - $version =~ s/ +[A-Za-z].*//; - - foreach my $ver (split /[,\s]+/, $version) { - my $sver = defined($source) ? "$source/$ver" : ''; - unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) { - push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver; - } - @{$data->{found_versions}} = - grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}}; - } -} - -sub removefixedversions { - my $data = shift; - my $package = shift; - my $version = shift; - my $isbinary = shift; - return unless defined $version; - undef $package if $package =~ m[(?:\s|/)]; - my $source = $package; - - if (defined $package and $isbinary) { - my @srcinfo = binarytosource($package, $version, undef); - if (@srcinfo) { - # We know the source package(s). Use a fully-qualified version. - removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo; - return; - } - # Otherwise, an unqualified version will have to do. - undef $source; - } - - foreach my $ver (split /[,\s]+/, $version) { - my $sver = defined($source) ? "$source/$ver" : ''; - @{$data->{fixed_versions}} = - grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}}; - } -} - -sub quit { - print DEBUG "quitting >$_[0]<\n"; - local ($u); - while ($u= $cleanups[$#cleanups]) { &$u; } - die "*** $_[0]\n"; -} - %saniarray= ('<','lt', '>','gt', '&','amp', '"','quot'); sub sani { - local ($in) = @_; - local ($out); - while ($in =~ m/[<>&"]/) { - $out.= $`. '&'. $saniarray{$&}. ';'; - $in=$'; - } - $out.= $in; - $out; -} - -sub update_realtime { - my ($file, $bug, $new) = @_; - - # update realtime index.db - - open(IDXDB, "<$file") or die "Couldn't open $file"; - open(IDXNEW, ">$file.new"); - - my $line; - my @line; - while($line = ) { - @line = split /\s/, $line; - last if ($line[1] >= $bug); - print IDXNEW $line; - $line = ""; - } - - if ($new eq "NOCHANGE") { - print IDXNEW $line if ($line ne "" && $line[1] == $ref); - } elsif ($new eq "REMOVE") { - 0; - } else { - print IDXNEW $new; - } - if ($line ne "" && $line[1] > $bug) { - print IDXNEW $line; - $line = ""; - } - - print IDXNEW while(); - - close(IDXNEW); - close(IDXDB); - - rename("$file.new", $file); - - return $line; -} - -sub bughook_archive { - my $ref = shift; - &filelock("debbugs.trace.lock"); - &appendfile("debbugs.trace","archive $ref\n"); - my $line = update_realtime( - "$gSpoolDir/index.db.realtime", - $ref, - "REMOVE"); - update_realtime("$gSpoolDir/index.archive.realtime", - $ref, $line); - &unfilelock; -} - -sub bughook { - my ( $type, $ref, $data ) = @_; - &filelock("debbugs.trace.lock"); - - &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1)); - - my $whendone = "open"; - my $severity = $gDefaultSeverity; - (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g; - $pkglist =~ s/^,+//; - $pkglist =~ s/,+$//; - $whendone = "forwarded" if length $data->{forwarded}; - $whendone = "done" if length $data->{done}; - $severity = $data->{severity} if length $data->{severity}; - - my $k = sprintf "%s %d %d %s [%s] %s %s\n", - $pkglist, $ref, $data->{date}, $whendone, - $data->{originator}, $severity, $data->{keywords}; - - update_realtime("$gSpoolDir/index.db.realtime", $ref, $k); - - &unfilelock; -} - -sub appendfile { - my $file = shift; - if (!open(AP,">>$file")) { - print DEBUG "failed open log<\n"; - print DEBUG "failed open log err $!<\n"; - &quit("opening $file (appendfile): $!"); - } - print(AP @_) || &quit("writing $file (appendfile): $!"); - close(AP) || &quit("closing $file (appendfile): $!"); + my ($in) = @_; + warn "You should be using HTML::Entities instead."; + $in =~ s/([<>&"])/$saniarray{$1}/g; + return $in; } sub getmailbody {