scripts/errorlib.in

   1 # -*- perl -*-
   2 # $Id: errorlib.in,v 1.18 2003/02/16 15:20:26 cjwatson Exp $
   3
   4 sub F_SETLK { 6; } sub F_WRLCK{ 1; }
   5 $flockstruct= 'sslll'; # And there ought to be something for this too.
   6
   7 sub get_hashname {
   8     return "" if ( $_[ 0 ] < 0 );
   9     return sprintf "%02d", $_[ 0 ] % 100;
  10 }
  11
  12 sub unlockreadbugmerge {
  13     local ($rv) = @_;
  14     &unfilelock if $rv >= 2;
  15     &unfilelock if $rv >= 1;
  16 }
  17
  18 sub lockreadbugmerge {
  19     local ($lref) = @_;
  20     if (!&lockreadbug($lref)) { return 0; }
  21     if (!length($s_mergedwith)) { return 1; }
  22     &unfilelock;
  23     &filelock('lock/merge');
  24     if (!&lockreadbug($lref)) { &unfilelock; return 0; }
  25     return 2;
  26 }
  27
  28 sub lockreadbug {
  29     local ($lref) = @_;
  30     &filelock("lock/$lref");
  31     my $hash = get_hashname($lref);
  32     if (!open(S,"db-h/$hash/$lref.status")) { &unfilelock; return 0; }
  33     chop($s_originator= <S>);
  34     chop($s_date= <S>);
  35     chop($s_subject= <S>);
  36     chop($s_msgid= <S>);
  37     chop($s_package= <S>);
  38     chop($s_keywords= <S>);
  39     chop($s_done= <S>);
  40     chop($s_forwarded= <S>);
  41     chop($s_mergedwith= <S>);
  42     chop($s_severity= <S>);
  43     chop($s_versions= <S>);
  44     chop($s_fixed_versions= <S>);
  45     close(S);
  46         $s_severity = 'normal' if $s_severity eq '';
  47     return 1;
  48 }
  49
  50 sub filelock {
  51     # NB - NOT COMPATIBLE WITH `with-lock'
  52     local ($lockfile,$flockpushno,$evalstring,$count,$errors,@s1,@s2) = @_;
  53     $flockpushno= $#filelocks+1;
  54     $count= 10; $errors= '';
  55     for (;;) {
  56         $evalstring= "
  57             open(FLOCK${flockpushno},\"> \$lockfile\") || die \"open: \$!\";
  58             \$flockwant= pack(\$flockstruct,&F_WRLCK,0,0,1,0);".
  59                 ($] >= 5.000 ? "
  60             fcntl(FLOCK$flockpushno,&F_SETLK,\$flockwant) || die \"setlk: \$!\";" : "
  61             \$z= syscall(&SYS_fcntl,fileno(FLOCK$flockpushno),&F_SETLK,\$flockwant) < 0
  62                  && die \"syscall fcntl setlk: \$!\";") ."
  63             (\@s1= lstat(\$lockfile)) || die \"lstat: \$!\";
  64             (\@s2= stat(FLOCK$flockpushno)) || die \"fstat: \$!\";
  65             join(',',\@s1) eq join(',',\@s2) || die \"file switched\";
  66             1;
  67         ";
  68         last if eval $evalstring;
  69         $errors .= $@;
  70         eval "close(FLOCK$flockpushno);";
  71         if (--$count <=0) {
  72             $errors =~ s/\n+$//;
  73             &quit("failed to get lock on file $lockfile: $errors // $evalstring");
  74         }
  75         sleep 10;
  76     }
  77     push(@cleanups,'unfilelock');
  78     push(@filelocks,$lockfile);
  79 }
  80
  81 sub unfilelock {
  82     local ($lockfile) = pop(@filelocks);
  83     pop(@cleanups);
  84     eval 'close(FLOCK'.($#filelocks+1).');' || warn "failed to close lock file: $!";
  85     unlink($lockfile) || warn "failed to remove lock file: $!";
  86 }
  87
  88 sub quit {
  89     print DEBUG "quitting >$_[0]<\n";
  90     local ($u);
  91     while ($u= $cleanups[$#cleanups]) { &$u; }
  92     die "*** $_[0]\n";
  93 }
  94
  95 %saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
  96
  97 sub sani {
  98     local ($in) = @_;
  99     local ($out);
 100     while ($in =~ m/[<>&"]/) {
 101         $out.= $`. '&'. $saniarray{$&}. ';';
 102         $in=$';
 103     }
 104     $out.= $in;
 105     $out;
 106 }
 107
 108 sub update_realtime {
 109         my ($file, $bug, $new) = @_;
 110
 111         # update realtime index.db
 112
 113         open(IDXDB, "<$file") or die "Couldn't open $file";
 114         open(IDXNEW, ">$file.new");
 115
 116         my $line;
 117         while($line = <IDXDB>) {
 118                 my @line = split /\s/, $line;
 119                 last if ($line[1] == $ref);
 120                 print IDXNEW $line;
 121         }
 122
 123         if ($new eq "NOCHANGE") {
 124                 print IDXNEW $line;
 125         } elsif ($new eq "REMOVE") {
 126                 0;
 127         } else {
 128                 print IDXNEW $new;
 129         }
 130
 131         print IDXNEW while(<IDXDB>);
 132
 133         close(IDXNEW);
 134         close(IDXDB);
 135
 136         rename("$file.new", $file);
 137
 138         return $line;
 139 }
 140
 141 sub bughook_archive {
 142         my $ref = shift;
 143         &filelock("debbugs.trace.lock");
 144         &appendfile("debbugs.trace","archive $ref\n");
 145         my $line = update_realtime(
 146                 "$gSpoolDir/index.db.realtime",
 147                 $ref,
 148                 "REMOVE");
 149         update_realtime("$gSpoolDir/index.archive.realtime",
 150                 $ref, $line);
 151         &unfilelock;
 152 }
 153
 154 sub bughook {
 155         my ( $type, $ref ) = ( shift, shift );
 156         &filelock("debbugs.trace.lock");
 157
 158         &appendfile("debbugs.trace","$type $ref\n",@_);
 159
 160         my @stuff=split /\n/, "$_[0]\n\n\n\n\n\n\n";
 161
 162         my $firstpkg;
 163         my $whendone = "open";
 164         my $severity = $gDefaultSeverity;
 165         ($firstpkg = $stuff[4]) =~ s/[,\s].*$//;
 166         $whendone = "forwarded" if length $stuff[7];
 167         $whendone = "done" if length $stuff[6];
 168         $severity = $stuff[9] if length $stuff[9];
 169
 170         my $k = sprintf "%s %d %d %s [%s] %s %s\n",
 171                         $firstpkg, $ref, $stuff[1], $whendone, $stuff[0],
 172                         $severity, $stuff[5];
 173
 174         update_realtime("$gSpoolDir/index.db.realtime", $ref, $k);
 175
 176         &unfilelock;
 177 }
 178
 179 sub appendfile {
 180         my $file = shift;
 181         if (!open(AP,">>$file")) {
 182                 print DEBUG "failed open log<\n";
 183                 print DEBUG "failed open log err $!<\n";
 184                 &quit("opening $file (appendfile): $!");
 185         }
 186         print(AP @_) || &quit("writing $file (appendfile): $!");
 187         close(AP) || &quit("closing $file (appendfile): $!");
 188 }
 189
 190 sub getmailbody {
 191         my $entity = shift;
 192         my $type = $entity->effective_type;
 193         if ($type eq 'text/plain' or
 194             ($type =~ m#text/# and $type ne 'text/html') or
 195             $type eq 'application/pgp') {
 196                 return $entity->bodyhandle;
 197         } elsif ($type eq 'multipart/alternative') {
 198                 # RFC 2046 says we should use the last part we recognize.
 199                 for my $part (reverse $entity->parts) {
 200                         my $ret = getmailbody($part);
 201                         return $ret if $ret;
 202                 }
 203         } else {
 204                 # For other multipart types, we just pretend they're
 205                 # multipart/mixed and run through in order.
 206                 for my $part ($entity->parts) {
 207                         my $ret = getmailbody($part);
 208                         return $ret if $ret;
 209                 }
 210         }
 211         return undef;
 212 }
 213
 214 sub escapelog {
 215         my @log = @_;
 216         map { s/^([\01-\07\030])/\030$1/gm } @log;
 217         return \@log;
 218 }
 219
 220
 221 @severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
 222 @showseverities= @severities;
 223 grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
 224 @strongseverities= @gStrongSeverities;
 225 %displayshowseverities= %gSeverityDisplay;
 226
 227 1;