scripts/errorlib.in

   1 # -*- perl -*-
   2 # $Id: errorlib.in,v 1.37 2003/08/23 13:50:45 cjwatson Exp $
   3
   4 use Mail::Address;
   5
   6 sub F_SETLK { 6; } sub F_WRLCK{ 1; }
   7 $flockstruct= 'sslll'; # And there ought to be something for this too.
   8
   9 sub get_hashname {
  10     return "" if ( $_[ 0 ] < 0 );
  11     return sprintf "%02d", $_[ 0 ] % 100;
  12 }
  13
  14 sub unlockreadbugmerge {
  15     local ($rv) = @_;
  16     &unfilelock if $rv >= 2;
  17     &unfilelock if $rv >= 1;
  18 }
  19
  20 sub lockreadbugmerge {
  21     local ($lref, $location) = @_;
  22     local $data;
  23     if (!($data = &lockreadbug($lref, $location))) { return ( 0, undef ); }
  24     if (!length($data{mergedwith})) { return ( 1, $data ); }
  25     &unfilelock;
  26     &filelock('lock/merge');
  27     if (!&lockreadbug($lref, $location)) { &unfilelock; return ( 0, undef ); }
  28     return ( 2, $data );
  29 }
  30
  31 sub getbuglocation {
  32     my ( $bugnum, $ext ) = @_;
  33     my $archdir = sprintf "%02d", $bugnum % 100;
  34     return 'archive' if ( -r "$gSpoolDir/archive/$archdir/$bugnum.$ext" );
  35     return 'db-h' if ( -r "$gSpoolDir/db-h/$archdir/$bugnum.$ext" );
  36     return 'db' if ( -r "$gSpoolDir/db/$bugnum.$ext" );
  37     return undef;
  38 }
  39
  40 sub getlocationpath {
  41     my ($location) = @_;
  42     if ($location eq 'archive') {
  43         return "$gSpoolDir/archive";
  44     } elsif ($location eq 'db') {
  45         return "$gSpoolDir/db";
  46     } else {
  47         return "$gSpoolDir/db-h";
  48     }
  49 }
  50
  51 sub getbugcomponent {
  52     my ($bugnum, $ext, $location) = @_;
  53
  54     unless (defined $location) {
  55         $location = getbuglocation($bugnum, $ext);
  56         # Default to non-archived bugs only for now; CGI scripts want
  57         # archived bugs but most of the backend scripts don't. For now,
  58         # anything that is prepared to accept archived bugs should call
  59         # getbuglocation() directly first.
  60         return undef if defined $location and
  61                         ($location ne 'db' and $location ne 'db-h');
  62     }
  63     my $dir = getlocationpath($location);
  64     return undef unless $dir;
  65     if ($location eq 'db') {
  66         return "$dir/$bugnum.$ext";
  67     } else {
  68         my $hash = get_hashname($bugnum);
  69         return "$dir/$hash/$bugnum.$ext";
  70     }
  71 }
  72
  73 my @v1fieldorder = qw(originator date subject msgid package
  74                       keywords done forwarded mergedwith severity);
  75
  76 my %fields = (originator => 'submitter',
  77               date => 'date',
  78               subject => 'subject',
  79               msgid => 'message-id',
  80               'package' => 'package',
  81               keywords => 'tags',
  82               done => 'done',
  83               forwarded => 'forwarded-to',
  84               mergedwith => 'merged-with',
  85               severity => 'severity',
  86              );
  87
  88 sub readbug {
  89     my ($lref, $location) = @_;
  90     my $status = getbugcomponent($lref, 'db', $location);
  91     return undef unless defined $status;
  92     if (!open(S,$status)) { return undef; }
  93
  94     my %data;
  95     my @lines;
  96     my $version = 2;
  97     local $_;
  98
  99     while (<S>) {
 100         chomp;
 101         push @lines, $_;
 102         $version = $1 if /^Format-Version: (.*)/i;
 103     }
 104
 105     # Version 2 is the latest format version currently supported.
 106     return undef if $version > 2;
 107
 108     my %namemap = reverse %fields;
 109     for my $line (@lines) {
 110         if ($line =~ /(\S+?): (.*)/) {
 111             my ($name, $value) = (lc $1, $2);
 112             $data{$namemap{$name}} = $value if exists $namemap{$name};
 113         }
 114     }
 115     for my $field (keys %fields) {
 116         $data{$field} = '' unless exists $data{$field};
 117     }
 118
 119     close(S);
 120
 121     $data{severity} = 'normal' if $data{severity} eq '';
 122
 123     return \%data;
 124 }
 125
 126 sub lockreadbug {
 127     local ($lref, $location) = @_;
 128     &filelock("lock/$lref");
 129     my $data = readbug($lref, $location);
 130     &unfilelock unless defined $data;
 131     return $data;
 132 }
 133
 134 sub makestatus {
 135     my $data = shift;
 136     my $version = shift;
 137     $version = 2 unless defined $version;
 138
 139     my $contents = '';
 140
 141     if ($version == 1) {
 142         for my $field (@v1fieldorder) {
 143             if (exists $data->{$field}) {
 144                 $contents .= "$data->{$field}\n";
 145             } else {
 146                 $contents .= "\n";
 147             }
 148         }
 149     } elsif ($version == 2) {
 150         # Version 2. Add a file format version number for the sake of
 151         # further extensibility in the future.
 152         $contents .= "Format-Version: 2\n";
 153         for my $field (keys %fields) {
 154             if (exists $data->{$field} and $data->{$field} ne '') {
 155                 # Output field names in proper case, e.g. 'Merged-With'.
 156                 my $properfield = $fields{$field};
 157                 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
 158                 $contents .= "$properfield: $data->{$field}\n";
 159             }
 160         }
 161     }
 162
 163     return $contents;
 164 }
 165
 166 sub writebug {
 167     my ($ref, $data, $location, $minversion, $disablebughook) = @_;
 168     my $change;
 169
 170     my %outputs = (1 => 'status', 2 => 'db');
 171     for my $version (keys %outputs) {
 172         next if defined $minversion and $version < $minversion;
 173         my $status = getbugcomponent($ref, $outputs{$version}, $location);
 174         &quit("can't find location for $ref") unless defined $status;
 175         open(S,"> $status.new") || &quit("opening $status.new: $!");
 176         print(S makestatus($data, $version)) ||
 177             &quit("writing $status.new: $!");
 178         close(S) || &quit("closing $status.new: $!");
 179         if (-e $status) {
 180             $change = 'change';
 181         } else {
 182             $change = 'new';
 183         }
 184         rename("$status.new",$status) || &quit("installing new $status: $!");
 185     }
 186
 187     # $disablebughook is a bit of a hack to let format migration scripts use
 188     # this function rather than having to duplicate it themselves.
 189     &bughook($change,$ref,$data) unless $disablebughook;
 190 }
 191
 192 sub unlockwritebug {
 193     writebug(@_);
 194     &unfilelock;
 195 }
 196
 197 sub filelock {
 198     # NB - NOT COMPATIBLE WITH `with-lock'
 199     local ($lockfile,$flockpushno,$evalstring,$count,$errors,@s1,@s2) = @_;
 200     $flockpushno= $#filelocks+1;
 201     $count= 10; $errors= '';
 202     for (;;) {
 203         $evalstring= "
 204             open(FLOCK${flockpushno},\"> \$lockfile\") || die \"open: \$!\";
 205             \$flockwant= pack(\$flockstruct,&F_WRLCK,0,0,1,0);".
 206                 ($] >= 5.000 ? "
 207             fcntl(FLOCK$flockpushno,&F_SETLK,\$flockwant) || die \"setlk: \$!\";" : "
 208             \$z= syscall(&SYS_fcntl,fileno(FLOCK$flockpushno),&F_SETLK,\$flockwant) < 0
 209                  && die \"syscall fcntl setlk: \$!\";") ."
 210             (\@s1= lstat(\$lockfile)) || die \"lstat: \$!\";
 211             (\@s2= stat(FLOCK$flockpushno)) || die \"fstat: \$!\";
 212             join(',',\@s1) eq join(',',\@s2) || die \"file switched\";
 213             1;
 214         ";
 215         last if eval $evalstring;
 216         $errors .= $@;
 217         eval "close(FLOCK$flockpushno);";
 218         if (--$count <=0) {
 219             $errors =~ s/\n+$//;
 220             &quit("failed to get lock on file $lockfile: $errors // $evalstring");
 221         }
 222         sleep 10;
 223     }
 224     push(@cleanups,'unfilelock');
 225     push(@filelocks,$lockfile);
 226 }
 227
 228 sub unfilelock {
 229     if (@filelocks == 0) {
 230         warn "unfilelock called with no active filelocks!\n";
 231         return;
 232     }
 233     local ($lockfile) = pop(@filelocks);
 234     pop(@cleanups);
 235     eval 'close(FLOCK'.($#filelocks+1).');' || warn "failed to close lock file $lockfile: $!";
 236     unlink($lockfile) || warn "failed to remove lock file $lockfile: $!";
 237 }
 238
 239 sub quit {
 240     print DEBUG "quitting >$_[0]<\n";
 241     local ($u);
 242     while ($u= $cleanups[$#cleanups]) { &$u; }
 243     die "*** $_[0]\n";
 244 }
 245
 246 %saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
 247
 248 sub sani {
 249     local ($in) = @_;
 250     local ($out);
 251     while ($in =~ m/[<>&"]/) {
 252         $out.= $`. '&'. $saniarray{$&}. ';';
 253         $in=$';
 254     }
 255     $out.= $in;
 256     $out;
 257 }
 258
 259 sub update_realtime {
 260         my ($file, $bug, $new) = @_;
 261
 262         # update realtime index.db
 263
 264         open(IDXDB, "<$file") or die "Couldn't open $file";
 265         open(IDXNEW, ">$file.new");
 266
 267         my $line;
 268         my @line;
 269         while($line = <IDXDB>) {
 270                 @line = split /\s/, $line;
 271                 last if ($line[1] >= $bug);
 272                 print IDXNEW $line;
 273                 $line = "";
 274         }
 275
 276         if ($new eq "NOCHANGE") {
 277                 print IDXNEW $line if ($line ne "" && $line[1] == $ref);
 278         } elsif ($new eq "REMOVE") {
 279                 0;
 280         } else {
 281                 print IDXNEW $new;
 282         }
 283         if ($line ne "" && $line[1] > $bug) {
 284                 print IDXNEW $line;
 285                 $line = "";
 286         }
 287
 288         print IDXNEW while(<IDXDB>);
 289
 290         close(IDXNEW);
 291         close(IDXDB);
 292
 293         rename("$file.new", $file);
 294
 295         return $line;
 296 }
 297
 298 sub bughook_archive {
 299         my $ref = shift;
 300         &filelock("debbugs.trace.lock");
 301         &appendfile("debbugs.trace","archive $ref\n");
 302         my $line = update_realtime(
 303                 "$gSpoolDir/index.db.realtime",
 304                 $ref,
 305                 "REMOVE");
 306         update_realtime("$gSpoolDir/index.archive.realtime",
 307                 $ref, $line);
 308         &unfilelock;
 309 }
 310
 311 sub bughook {
 312         my ( $type, $ref, $data ) = @_;
 313         &filelock("debbugs.trace.lock");
 314
 315         &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
 316
 317         my $whendone = "open";
 318         my $severity = $gDefaultSeverity;
 319         (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
 320         $pkglist =~ s/^,+//;
 321         $pkglist =~ s/,+$//;
 322         $whendone = "forwarded" if length $data->{forwarded};
 323         $whendone = "done" if length $data->{done};
 324         $severity = $data->{severity} if length $data->{severity};
 325
 326         my $k = sprintf "%s %d %d %s [%s] %s %s\n",
 327                         $pkglist, $ref, $data->{date}, $whendone,
 328                         $data->{originator}, $severity, $data->{keywords};
 329
 330         update_realtime("$gSpoolDir/index.db.realtime", $ref, $k);
 331
 332         &unfilelock;
 333 }
 334
 335 sub appendfile {
 336         my $file = shift;
 337         if (!open(AP,">>$file")) {
 338                 print DEBUG "failed open log<\n";
 339                 print DEBUG "failed open log err $!<\n";
 340                 &quit("opening $file (appendfile): $!");
 341         }
 342         print(AP @_) || &quit("writing $file (appendfile): $!");
 343         close(AP) || &quit("closing $file (appendfile): $!");
 344 }
 345
 346 sub getmailbody {
 347         my $entity = shift;
 348         my $type = $entity->effective_type;
 349         if ($type eq 'text/plain' or
 350             ($type =~ m#text/# and $type ne 'text/html') or
 351             $type eq 'application/pgp') {
 352                 return $entity->bodyhandle;
 353         } elsif ($type eq 'multipart/alternative') {
 354                 # RFC 2046 says we should use the last part we recognize.
 355                 for my $part (reverse $entity->parts) {
 356                         my $ret = getmailbody($part);
 357                         return $ret if $ret;
 358                 }
 359         } else {
 360                 # For other multipart types, we just pretend they're
 361                 # multipart/mixed and run through in order.
 362                 for my $part ($entity->parts) {
 363                         my $ret = getmailbody($part);
 364                         return $ret if $ret;
 365                 }
 366         }
 367         return undef;
 368 }
 369
 370 sub get_addresses {
 371         return
 372             map { $_->address() }
 373             map { Mail::Address->parse($_) } @_;
 374 }
 375
 376 sub escapelog {
 377         my @log = @_;
 378         map { s/^([\01-\07\030])/\030$1/gm } @log;
 379         return \@log;
 380 }
 381
 382 sub isstrongseverity {
 383     my $severity = shift;
 384     $severity = $gDefaultSeverity if $severity eq '';
 385     return grep { $_ eq $severity } @gStrongSeverities;
 386 }
 387
 388
 389 @severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
 390 @showseverities= @severities;
 391 grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
 392 %displayshowseverities= %gSeverityDisplay;
 393
 394 # compatibility
 395 if (defined $gFowardList and not defined $gForwardList) {
 396     $gForwardList = $gFowardList;
 397 }
 398
 399 1;