scripts/errorlib.in

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