* 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 fd20168865e1d93411ffc4b4056e77f781b594f8..a86460b0b82a8ad1ffbb42f8cf679c3012cfd1d9 100644 (file)
--- 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.
 
 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
 =head1 FUNCTIONS
 
 =cut


@@ -36,10 +30,11 @@ BEGIN{
      $DEBUG = 0 unless defined $DEBUG;
 
      @EXPORT = ();
      $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));
                    );
      @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);
 
 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</getbugcomponent>
-
-=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
 
 
 =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;
 
 
 1;

diff --git a/scripts/errorlib.in b/scripts/errorlib.in
index 2c33a9636ae069953d201615fa1f46276e16c587..e0e70e7dda2d1ea6b9a62fff7736b5b3f0b0ee28 100755 (executable)
--- a/scripts/errorlib.in
+++ b/scripts/errorlib.in
@@ -3,17 +3,13 @@
 
 use Mail::Address;
 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
 
 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::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 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;
 sub unlockreadbugmerge {
     local ($rv) = @_;
     &unfilelock if $rv >= 2;


@@ -31,381 +27,13 @@ sub lockreadbugmerge {
     return ( 2, $data );
 }
 
     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 {
 %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): $!");
+    my ($in) = @_;
+    warn "You should be using HTML::Entities instead.";
+    $in =~ s/([<>&"])/$saniarray{$1}/g;
+    return $in;

 }
 
 sub getmailbody {
 }
 
 sub getmailbody {