scripts/errorlib.in

   1 # -*- perl -*-
   2 # $Id: errorlib.in,v 1.7 2002/10/06 22:54:48 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     if (!open(S,"db/$lref.status")) { &unfilelock; return 0; }
  32     chop($s_originator= <S>);
  33     chop($s_date= <S>);
  34     chop($s_subject= <S>);
  35     chop($s_msgid= <S>);
  36     chop($s_package= <S>);
  37     chop($s_keywords= <S>);
  38     chop($s_done= <S>);
  39     chop($s_forwarded= <S>);
  40     chop($s_mergedwith= <S>);
  41     chop($s_severity= <S>);
  42     close(S);
  43         $s_severity = 'normal' if $s_severity eq '';
  44     return 1;
  45 }
  46
  47 sub filelock {
  48     # NB - NOT COMPATIBLE WITH `with-lock'
  49     local ($lockfile,$flockpushno,$evalstring,$count,$errors,@s1,@s2) = @_;
  50     $flockpushno= $#filelocks+1;
  51     $count= 10; $errors= '';
  52     for (;;) {
  53         $evalstring= "
  54             open(FLOCK${flockpushno},\"> \$lockfile\") || die \"open: \$!\";
  55             \$flockwant= pack(\$flockstruct,&F_WRLCK,0,0,1,0);".
  56                 ($] >= 5.000 ? "
  57             fcntl(FLOCK$flockpushno,&F_SETLK,\$flockwant) || die \"setlk: \$!\";" : "
  58             \$z= syscall(&SYS_fcntl,fileno(FLOCK$flockpushno),&F_SETLK,\$flockwant) < 0
  59                  && die \"syscall fcntl setlk: \$!\";") ."
  60             (\@s1= lstat(\$lockfile)) || die \"lstat: \$!\";
  61             (\@s2= stat(FLOCK$flockpushno)) || die \"fstat: \$!\";
  62             join(',',\@s1) eq join(',',\@s2) || die \"file switched\";
  63             1;
  64         ";
  65         last if eval $evalstring;
  66         $errors .= $@;
  67         eval "close(FLOCK$flockpushno);";
  68         if (--$count <=0) {
  69             $errors =~ s/\n+$//;
  70             &quit("failed to get lock on file $lockfile: $errors // $evalstring");
  71         }
  72         sleep 10;
  73     }
  74     push(@cleanups,'unfilelock');
  75     push(@filelocks,$lockfile);
  76 }
  77
  78 sub unfilelock {
  79     local ($lockfile) = pop(@filelocks);
  80     pop(@cleanups);
  81     eval 'close(FLOCK'.($#filelocks+1).');' || warn "failed to close lock file: $!";
  82     unlink($lockfile) || warn "failed to remove lock file: $!";
  83 }
  84
  85 sub quit {
  86     print DEBUG "quitting >$_[0]<\n";
  87     local ($u);
  88     while ($u= $cleanups[$#cleanups]) { &$u; }
  89     die "*** $_[0]\n";
  90 }
  91
  92 %saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
  93
  94 sub sani {
  95     local ($in) = @_;
  96     local ($out);
  97     while ($in =~ m/[<>&"]/) {
  98         $out.= $`. '&'. $saniarray{$&}. ';';
  99         $in=$';
 100     }
 101     $out.= $in;
 102     $out;
 103 }
 104
 105 sub bughook {
 106         my ( $type, $ref ) = ( shift, shift );
 107         &filelock("debbugs.trace.lock");
 108         &appendfile("debbugs.trace","$type $ref\n",@_);
 109         my @stuff=split/\n/, "$_[0]\n\n\n\n\n\n\n";
 110         # XXX: bug: this'll only keep the most recent update until index.db
 111         #      starts getting overwritten by index.db.realtime after update
 112         my $hash = get_hashname($ref);
 113         unlink("$gSpoolDir/db/$ref.status.new");
 114         link("$gSpoolDir/db-h/$hash/$ref.status", "$gSpoolDir/db/$ref.status.new");
 115         rename("$gSpoolDir/db/$ref.status.new", "$gSpoolDir/db/$ref.status");
 116         open(IDXDB, "</org/bugs.debian.org/spool/index.db.realtime")
 117                 or open(IDXDB, "</org/bugs.debian.org/spool/index.db");
 118         open(IDXNEW, ">/org/bugs.debian.org/spool/index.db.realtime.new");
 119         while(my $line = <IDXDB>) {
 120                 @line = split /\s/, $line;
 121                 last if ($line[1] == $ref);
 122                 print IDXNEW $line;
 123         }
 124         my $firstpkg;
 125         my $whendone = "open";
 126         my $severity = $gDefaultSeverity;
 127         ($firstpkg = $stuff[4]) =~ s/[,\s].*$//;
 128         $whendone = "forwarded" if length $stuff[7];
 129         $whendone = "done" if length $stuff[6];
 130         $severity = $stuff[9] if length $stuff[9];
 131
 132         printf IDXNEW "%s %d %d %s [%s] %s %s\n",
 133                         $firstpkg, $ref, $stuff[1], $whendone, $stuff[0],
 134                         $severity, $stuff[5];
 135         print IDXNEW while(<IDXDB>);
 136         close(IDXNEW);
 137         close(IDXDB);
 138         rename("/org/bugs.debian.org/spool/index.db.realtime.new",
 139                 "/org/bugs.debian.org/spool/index.db.realtime");
 140         &unfilelock;
 141 }
 142
 143 sub appendfile {
 144         my $file = shift;
 145         if (!open(AP,">>$file")) {
 146                 print DEBUG "failed open log<\n";
 147                 print DEBUG "failed open log err $!<\n";
 148                 &quit("opening $file (appendfile): $!");
 149         }
 150         print(AP @_) || &quit("writing $file (appendfile): $!");
 151         close(AP) || &quit("closing $file (appendfile): $!");
 152 }
 153
 154 sub getmailbody {
 155         my $entity = shift;
 156         my $type = $entity->effective_type;
 157         if ($type eq 'text/plain' or
 158             ($type =~ m#text/# and $type ne 'text/html')) {
 159                 return $entity->bodyhandle;
 160         } elsif ($type eq 'multipart/alternative') {
 161                 # RFC 2046 says we should use the last part we recognize.
 162                 for my $part (reverse $entity->parts) {
 163                         my $ret = getmailbody($part);
 164                         return $ret if $ret;
 165                 }
 166         } else {
 167                 # For other multipart types, we just pretend they're
 168                 # multipart/mixed and run through in order.
 169                 for my $part ($entity->parts) {
 170                         my $ret = getmailbody($part);
 171                         return $ret if $ret;
 172                 }
 173         }
 174         return undef;
 175 }
 176
 177
 178 @severities= @gSeverityList;
 179 @showseverities= @severities;
 180 grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
 181 @strongseverities= @gStrongSeverities;
 182 %displayshowseverities= %gSeverityDisplay;
 183
 184 1;