X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scripts%2Ferrorlib.in;h=a2e90161730a1454cb03134fca9efb458102cec2;hb=56ea016a6fbe733d25d474165ac0222d583e30ed;hp=92dd76f1bf49c5ec0bc2f4939a0b7e8f552751b2;hpb=c277a2a3ce76a68c4d59c4027487695a064c7d1d;p=debbugs.git

diff --git a/scripts/errorlib.in b/scripts/errorlib.in
index 92dd76f..a2e9016 100755
--- a/scripts/errorlib.in
+++ b/scripts/errorlib.in
@@ -1,17 +1,11 @@
 # -*- perl -*-
-# $Id: errorlib.in,v 1.50 2005/10/06 03:32:13 ajt Exp $
 
 use Mail::Address;
-use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
-use Debbugs::Packages;
-
-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 getmailbody);
+use Debbugs::Packages qw(:all);
+use Debbugs::Common qw(:all);
+use Debbugs::Status qw(:all);
+use Carp;
 
 sub unlockreadbugmerge {
     local ($rv) = @_;
@@ -19,499 +13,13 @@ 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";
-    }
-}
-
-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 readbug {
-    my ($lref, $location) = @_;
-    my $status = getbugcomponent($lref, 'summary', $location);
-    return undef unless defined $status;
-    if (!open(S,$status)) { return undef; }
-
-    my %data;
-    my @lines;
-    my $version = 2;
-    local $_;
-
-    while (<S>) {
-        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};
-    }
-
-    close(S);
-
-    $data{severity} = $gDefaultSeverity 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;
-}
-
-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.
-    }
-
-    # 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.
-    }
-
-    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.
-    }
-
-    # 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.
-    }
-
-    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 = <IDXDB>) {
-		@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(<IDXDB>);
-
-	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): $!");
-}
-
-sub getmailbody {
-	my $entity = shift;
-	my $type = $entity->effective_type;
-	if ($type =~ m#text/(?!html|enriched)# or
-	    $type eq 'application/pgp') {
-		return $entity->bodyhandle;
-	} elsif ($type eq 'multipart/alternative') {
-		# RFC 2046 says we should use the last part we recognize.
-		for my $part (reverse $entity->parts) {
-			my $ret = getmailbody($part);
-			return $ret if $ret;
-		}
-	} else {
-		# For other multipart types, we just pretend they're
-		# multipart/mixed and run through in order.
-		for my $part ($entity->parts) {
-			my $ret = getmailbody($part);
-			return $ret if $ret;
-		}
-	}
-	return undef;
+    my ($in) = @_;
+    carp "You should be using HTML::Entities instead.";
+    $in =~ s/([<>&"])/$saniarray{$1}/g;
+    return $in;
 }
 
 sub get_addresses {
@@ -520,19 +28,6 @@ sub get_addresses {
 	    map { Mail::Address->parse($_) } @_;
 }
 
-sub escapelog {
-	my @log = @_;
-	map { s/^([\01-\07\030])/\030$1/gm } @log;
-	return \@log;
-}
-
-sub isstrongseverity {
-    my $severity = shift;
-    $severity = $gDefaultSeverity if $severity eq '';
-    return grep { $_ eq $severity } @gStrongSeverities;
-}
-
-
 @severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
 @showseverities= @severities;
 grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);