scripts/errorlib.in

   1 # -*- perl -*-
   2 # $Id: errorlib.in,v 1.33 2003/08/06 18:45:41 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 sub readbug {
  74     local ($lref, $location) = @_;
  75     my $status = getbugcomponent($lref, 'status', $location);
  76     return undef unless defined $status;
  77     if (!open(S,$status)) { return undef; }
  78     my %data;
  79     chop($data{originator}= <S>);
  80     chop($data{date}= <S>);
  81     chop($data{subject}= <S>);
  82     chop($data{msgid}= <S>);
  83     chop($data{package}= <S>);
  84     chop($data{keywords}= <S>);
  85     chop($data{done}= <S>);
  86     chop($data{forwarded}= <S>);
  87     chop($data{mergedwith}= <S>);
  88     chop($data{severity}= <S>);
  89     chop($data{versions}= <S>);
  90     chop($data{fixed_versions}= <S>);
  91     close(S);
  92         $data{severity} = 'normal' if $data{severity} eq '';
  93     return \%data;
  94 }
  95
  96 sub lockreadbug {
  97     local ($lref, $location) = @_;
  98     &filelock("lock/$lref");
  99     my $data = readbug($lref, $location);
 100     &unfilelock unless defined $data;
 101     return $data;
 102 }
 103
 104 sub makestatus {
 105     my $data = shift;
 106     my $contents =
 107           "$data->{originator}\n".
 108           "$data->{date}\n".
 109           "$data->{subject}\n".
 110           "$data->{msgid}\n".
 111           "$data->{package}\n".
 112           "$data->{keywords}\n".
 113           "$data->{done}\n".
 114           "$data->{forwarded}\n".
 115           "$data->{mergedwith}\n".
 116           "$data->{severity}\n".
 117           "$data->{versions}\n".
 118           "$data->{fixed_versions}\n";
 119     return $contents;
 120 }
 121
 122 sub writebug {
 123     local ($ref, $data, $location) = @_;
 124     my $change;
 125     my $status = getbugcomponent($ref, 'status', $location);
 126     &quit("can't find location for $ref") unless defined $status;
 127     open(S,"> $status.new") || &quit("opening $status.new: $!");
 128     print(S makestatus($data)) || &quit("writing $status.new: $!");
 129     close(S) || &quit("closing $status.new: $!");
 130     if (-e $status) {
 131         $change = 'change';
 132     } else {
 133         $change = 'new';
 134     }
 135     rename("$status.new",$status) || &quit("installing new $status: $!");
 136     &bughook($change,$ref,$data);
 137 }
 138
 139 sub unlockwritebug {
 140     writebug(@_);
 141     &unfilelock;
 142 }
 143
 144 sub filelock {
 145     # NB - NOT COMPATIBLE WITH `with-lock'
 146     local ($lockfile,$flockpushno,$evalstring,$count,$errors,@s1,@s2) = @_;
 147     $flockpushno= $#filelocks+1;
 148     $count= 10; $errors= '';
 149     for (;;) {
 150         $evalstring= "
 151             open(FLOCK${flockpushno},\"> \$lockfile\") || die \"open: \$!\";
 152             \$flockwant= pack(\$flockstruct,&F_WRLCK,0,0,1,0);".
 153                 ($] >= 5.000 ? "
 154             fcntl(FLOCK$flockpushno,&F_SETLK,\$flockwant) || die \"setlk: \$!\";" : "
 155             \$z= syscall(&SYS_fcntl,fileno(FLOCK$flockpushno),&F_SETLK,\$flockwant) < 0
 156                  && die \"syscall fcntl setlk: \$!\";") ."
 157             (\@s1= lstat(\$lockfile)) || die \"lstat: \$!\";
 158             (\@s2= stat(FLOCK$flockpushno)) || die \"fstat: \$!\";
 159             join(',',\@s1) eq join(',',\@s2) || die \"file switched\";
 160             1;
 161         ";
 162         last if eval $evalstring;
 163         $errors .= $@;
 164         eval "close(FLOCK$flockpushno);";
 165         if (--$count <=0) {
 166             $errors =~ s/\n+$//;
 167             &quit("failed to get lock on file $lockfile: $errors // $evalstring");
 168         }
 169         sleep 10;
 170     }
 171     push(@cleanups,'unfilelock');
 172     push(@filelocks,$lockfile);
 173 }
 174
 175 sub unfilelock {
 176     if (@filelocks == 0) {
 177         warn "unfilelock called with no active filelocks!\n";
 178         return;
 179     }
 180     local ($lockfile) = pop(@filelocks);
 181     pop(@cleanups);
 182     eval 'close(FLOCK'.($#filelocks+1).');' || warn "failed to close lock file $lockfile: $!";
 183     unlink($lockfile) || warn "failed to remove lock file $lockfile: $!";
 184 }
 185
 186 sub quit {
 187     print DEBUG "quitting >$_[0]<\n";
 188     local ($u);
 189     while ($u= $cleanups[$#cleanups]) { &$u; }
 190     die "*** $_[0]\n";
 191 }
 192
 193 %saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
 194
 195 sub sani {
 196     local ($in) = @_;
 197     local ($out);
 198     while ($in =~ m/[<>&"]/) {
 199         $out.= $`. '&'. $saniarray{$&}. ';';
 200         $in=$';
 201     }
 202     $out.= $in;
 203     $out;
 204 }
 205
 206 sub update_realtime {
 207         my ($file, $bug, $new) = @_;
 208
 209         # update realtime index.db
 210
 211         open(IDXDB, "<$file") or die "Couldn't open $file";
 212         open(IDXNEW, ">$file.new");
 213
 214         my $line;
 215         my @line;
 216         while($line = <IDXDB>) {
 217                 @line = split /\s/, $line;
 218                 last if ($line[1] >= $bug);
 219                 print IDXNEW $line;
 220                 $line = "";
 221         }
 222
 223         if ($new eq "NOCHANGE") {
 224                 print IDXNEW $line if ($line ne "" && $line[1] == $ref);
 225         } elsif ($new eq "REMOVE") {
 226                 0;
 227         } else {
 228                 print IDXNEW $new;
 229         }
 230         if ($line ne "" && $line[1] > $bug) {
 231                 print IDXNEW $line;
 232                 $line = "";
 233         }
 234
 235         print IDXNEW while(<IDXDB>);
 236
 237         close(IDXNEW);
 238         close(IDXDB);
 239
 240         rename("$file.new", $file);
 241
 242         return $line;
 243 }
 244
 245 sub bughook_archive {
 246         my $ref = shift;
 247         &filelock("debbugs.trace.lock");
 248         &appendfile("debbugs.trace","archive $ref\n");
 249         my $line = update_realtime(
 250                 "$gSpoolDir/index.db.realtime",
 251                 $ref,
 252                 "REMOVE");
 253         update_realtime("$gSpoolDir/index.archive.realtime",
 254                 $ref, $line);
 255         &unfilelock;
 256 }
 257
 258 sub bughook {
 259         my ( $type, $ref, $data ) = @_;
 260         &filelock("debbugs.trace.lock");
 261
 262         &appendfile("debbugs.trace","$type $ref\n",makestatus($data));
 263
 264         my $whendone = "open";
 265         my $severity = $gDefaultSeverity;
 266         (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
 267         $pkglist =~ s/^,+//;
 268         $pkglist =~ s/,+$//;
 269         $whendone = "forwarded" if length $data->{forwarded};
 270         $whendone = "done" if length $data->{done};
 271         $severity = $data->{severity} if length $data->{severity};
 272
 273         my $k = sprintf "%s %d %d %s [%s] %s %s\n",
 274                         $pkglist, $ref, $data->{date}, $whendone,
 275                         $data->{originator}, $severity, $data->{keywords};
 276
 277         update_realtime("$gSpoolDir/index.db.realtime", $ref, $k);
 278
 279         &unfilelock;
 280 }
 281
 282 sub appendfile {
 283         my $file = shift;
 284         if (!open(AP,">>$file")) {
 285                 print DEBUG "failed open log<\n";
 286                 print DEBUG "failed open log err $!<\n";
 287                 &quit("opening $file (appendfile): $!");
 288         }
 289         print(AP @_) || &quit("writing $file (appendfile): $!");
 290         close(AP) || &quit("closing $file (appendfile): $!");
 291 }
 292
 293 sub getmailbody {
 294         my $entity = shift;
 295         my $type = $entity->effective_type;
 296         if ($type eq 'text/plain' or
 297             ($type =~ m#text/# and $type ne 'text/html') or
 298             $type eq 'application/pgp') {
 299                 return $entity->bodyhandle;
 300         } elsif ($type eq 'multipart/alternative') {
 301                 # RFC 2046 says we should use the last part we recognize.
 302                 for my $part (reverse $entity->parts) {
 303                         my $ret = getmailbody($part);
 304                         return $ret if $ret;
 305                 }
 306         } else {
 307                 # For other multipart types, we just pretend they're
 308                 # multipart/mixed and run through in order.
 309                 for my $part ($entity->parts) {
 310                         my $ret = getmailbody($part);
 311                         return $ret if $ret;
 312                 }
 313         }
 314         return undef;
 315 }
 316
 317 sub get_addresses {
 318         return
 319             map { $_->address() }
 320             map { Mail::Address->parse($_) } @_;
 321 }
 322
 323 sub escapelog {
 324         my @log = @_;
 325         map { s/^([\01-\07\030])/\030$1/gm } @log;
 326         return \@log;
 327 }
 328
 329
 330 @severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
 331 @showseverities= @severities;
 332 grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
 333 @strongseverities= @gStrongSeverities;
 334 %displayshowseverities= %gSeverityDisplay;
 335
 336 1;