X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scripts%2Ferrorlib.in;h=85bc9ba66f9349573a0561aa8053dcc5602541df;hb=2d519e5e0338c5b23356454c16ae1b6349c55c51;hp=3eba877ddf41296488c9684c1d203eadcca4e482;hpb=5b296d6c10e21442db973ee676cdf54b47e4a3de;p=debbugs.git diff --git a/scripts/errorlib.in b/scripts/errorlib.in index 3eba877..85bc9ba 100755 --- a/scripts/errorlib.in +++ b/scripts/errorlib.in @@ -1,15 +1,11 @@ # -*- perl -*- -# $Id: errorlib.in,v 1.32 2003/06/23 11:23:35 cjwatson Exp $ use Mail::Address; - -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; -} +use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522); +use Debbugs::Packages qw(:all); +use Debbugs::Common qw(:all); +use Debbugs::Status qw(:all); +use Carp; sub unlockreadbugmerge { local ($rv) = @_; @@ -17,293 +13,19 @@ sub unlockreadbugmerge { &unfilelock if $rv >= 1; } -sub lockreadbugmerge { - local ($lref, $location) = @_; - local $data; - if (!($data = &lockreadbug($lref, $location))) { return ( 0, undef ); } - if (!length($data{mergedwith})) { return ( 1, $data ); } - &unfilelock; - &filelock('lock/merge'); - if (!&lockreadbug($lref, $location)) { &unfilelock; return ( 0, undef ); } - return ( 2, $data ); -} - -sub getbuglocation { - my ( $bugnum, $ext ) = @_; - my $archdir = sprintf "%02d", $bugnum % 100; - return 'archive' if ( -r "$gSpoolDir/archive/$archdir/$bugnum.$ext" ); - return 'db-h' if ( -r "$gSpoolDir/db-h/$archdir/$bugnum.$ext" ); - return 'db' if ( -r "$gSpoolDir/db/$bugnum.$ext" ); - return undef; -} - -sub getlocationpath { - my ($location) = @_; - if ($location eq 'archive') { - return "$gSpoolDir/archive"; - } elsif ($location eq 'db') { - return "$gSpoolDir/db"; - } else { - return "$gSpoolDir/db-h"; - } -} - -sub getbugcomponent { - my ($bugnum, $ext, $location) = @_; - - unless (defined $location) { - $location = getbuglocation($bugnum, $ext); - # Default to non-archived bugs only for now; CGI scripts want - # archived bugs but most of the backend scripts don't. For now, - # anything that is prepared to accept archived bugs should call - # getbuglocation() directly first. - return undef if defined $location and - ($location ne 'db' and $location ne 'db-h'); - } - my $dir = getlocationpath($location); - return undef unless $dir; - if ($location eq 'db') { - return "$dir/$bugnum.$ext"; - } else { - my $hash = get_hashname($bugnum); - return "$dir/$hash/$bugnum.$ext"; - } -} - -sub readbug { - local ($lref, $location) = @_; - my $status = getbugcomponent($lref, 'status', $location); - return undef unless defined $status; - if (!open(S,$status)) { return undef; } - my %data; - chop($data{originator}= ); - chop($data{date}= ); - chop($data{subject}= ); - chop($data{msgid}= ); - chop($data{package}= ); - chop($data{keywords}= ); - chop($data{done}= ); - chop($data{forwarded}= ); - chop($data{mergedwith}= ); - chop($data{severity}= ); - chop($data{versions}= ); - chop($data{fixed_versions}= ); - close(S); - $data{severity} = 'normal' if $data{severity} eq ''; - return \%data; -} - -sub lockreadbug { - local ($lref, $location) = @_; - &filelock("lock/$lref"); - my $data = readbug($lref, $location); - &unfilelock unless defined $data; - return $data; -} - -sub writebug { - local ($ref, $data, $location) = @_; - my $change; - my $status = getbugcomponent($ref, 'status', $location); - &quit("can't find location for $ref") unless defined $status; - open(S,"> $status.new") || &quit("opening $status.new: $!"); - print(S - "$data->{originator}\n". - "$data->{date}\n". - "$data->{subject}\n". - "$data->{msgid}\n". - "$data->{package}\n". - "$data->{keywords}\n". - "$data->{done}\n". - "$data->{forwarded}\n". - "$data->{mergedwith}\n". - "$data->{severity}\n". - "$data->{versions}\n". - "$data->{fixed_versions}\n") || &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: $!"); - &bughook($change,$ref, - "$data->{originator}\n". - "$data->{date}\n". - "$data->{subject}\n". - "$data->{msgid}\n". - "$data->{package}\n". - "$data->{keywords}\n". - "$data->{done}\n". - "$data->{forwarded}\n". - "$data->{mergedwith}\n". - "$data->{severity}\n". - "$data->{versions}\n". - "$data->{fixed_versions}\n"); -} - -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 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 ) = ( shift, shift ); - &filelock("debbugs.trace.lock"); - - &appendfile("debbugs.trace","$type $ref\n",@_); - - my @stuff=split /\n/, "$_[0]\n\n\n\n\n\n\n"; - - my $whendone = "open"; - my $severity = $gDefaultSeverity; - (my $pkglist = $stuff[4]) =~ s/[,\s]+/,/g; - $pkglist =~ s/^,+//; - $pkglist =~ s/,+$//; - $whendone = "forwarded" if length $stuff[7]; - $whendone = "done" if length $stuff[6]; - $severity = $stuff[9] if length $stuff[9]; - - my $k = sprintf "%s %d %d %s [%s] %s %s\n", - $pkglist, $ref, $stuff[1], $whendone, $stuff[0], - $severity, $stuff[5]; - - 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) = @_; + carp "You should be using HTML::Entities instead."; + $in =~ s/([<>&"])/$saniarray{$1}/g; + return $in; } sub getmailbody { my $entity = shift; my $type = $entity->effective_type; - if ($type eq 'text/plain' or - ($type =~ m#text/# and $type ne 'text/html') or + if ($type =~ m#text/(?!html|enriched)# or $type eq 'application/pgp') { return $entity->bodyhandle; } elsif ($type eq 'multipart/alternative') { @@ -329,17 +51,14 @@ sub get_addresses { map { Mail::Address->parse($_) } @_; } -sub escapelog { - my @log = @_; - map { s/^([\01-\07\030])/\030$1/gm } @log; - return \@log; -} - - @severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList; @showseverities= @severities; grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities); -@strongseverities= @gStrongSeverities; %displayshowseverities= %gSeverityDisplay; +# compatibility +if (defined $gFowardList and not defined $gForwardList) { + $gForwardList = $gFowardList; +} + 1;