]> git.donarmstrong.com Git - debbugs.git/blob - scripts/errorlib.in
20a09807d1690c95a25801f3239662439f7022f4
[debbugs.git] / scripts / errorlib.in
1 # -*- perl -*-
2 # $Id: errorlib.in,v 1.26 2003/05/26 12:30:04 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, $location) = @_;
20     local $data;
21     if (!($data = &lockreadbug($lref, $location))) { return ( 0, undef ); }
22     if (!length($data{mergedwith})) { return ( 1, $data ); }
23     &unfilelock;
24     &filelock('lock/merge');
25     if (!&lockreadbug($lref, $location)) { &unfilelock; return ( 0, undef ); }
26     return ( 2, $data );
27 }
28
29 sub getbuglocation {
30     my ( $bugnum, $ext ) = @_;
31     my $archdir = sprintf "%02d", $bugnum % 100;
32     return 'archive' if ( -r "$gSpoolDir/archive/$archdir/$bugnum.$ext" );
33     return 'db' if ( -r "$gSpoolDir/db/$bugnum.$ext" );
34     return 'db-h' if ( -r "$gSpoolDir/db-h/$archdir/$bugnum.$ext" );
35     return undef;
36 }
37
38 sub getlocationpath {
39     my ($location) = @_;
40     if ($location eq 'archive') {
41         return "$gSpoolDir/archive";
42     } elsif ($location eq 'db') {
43         return "$gSpoolDir/db";
44     } else {
45         return "$gSpoolDir/db-h";
46     }
47 }
48
49 sub readbug {
50     local ($lref, $location) = @_;
51     my $hash = get_hashname($lref);
52     $path = getlocationpath($location);
53     if (!open(S,"$path/$hash/$lref.status")) { &unfilelock; return undef; }
54     my %data;
55     chop($data{originator}= <S>);
56     chop($data{date}= <S>);
57     chop($data{subject}= <S>);
58     chop($data{msgid}= <S>);
59     chop($data{package}= <S>);
60     chop($data{keywords}= <S>);
61     chop($data{done}= <S>);
62     chop($data{forwarded}= <S>);
63     chop($data{mergedwith}= <S>);
64     chop($data{severity}= <S>);
65     chop($data{versions}= <S>);
66     chop($data{fixed_versions}= <S>);
67     close(S);
68         $data{severity} = 'normal' if $data{severity} eq '';
69     return \%data;
70 }
71
72 sub lockreadbug {
73     local ($lref, $location) = @_;
74     &filelock("lock/$lref");
75     return readbug($lref, $location);
76 }
77
78 sub writebug {
79     local ($ref, $data, $location) = @_;
80     my $hash = get_hashname($ref);
81     my $change;
82     $path = getlocationpath($location);
83     open(S,">$path/$hash/$ref.status.new") || &quit("opening $path/$hash/$ref.status.new: $!");
84     print(S
85           "$data->{originator}\n".
86           "$data->{date}\n".
87           "$data->{subject}\n".
88           "$data->{msgid}\n".
89           "$data->{package}\n".
90           "$data->{keywords}\n".
91           "$data->{done}\n".
92           "$data->{forwarded}\n".
93           "$data->{mergedwith}\n".
94           "$data->{severity}\n".
95           "$data->{versions}\n".
96           "$data->{fixed_versions}\n") || &quit("writing $path/$hash/$ref.status.new: $!");
97     close(S) || &quit("closing $path/$hash/$ref.status.new: $!");
98     if (-e "$path/$hash/$ref.status") {
99         $change = 'change';
100     } else {
101         $change = 'new';
102     }
103     rename("$path/$hash/$ref.status.new","$path/$hash/$ref.status") ||
104         &quit("installing new $path/$hash/$ref.status: $!");
105         &bughook($change,$ref,
106           "$data->{originator}\n".
107           "$data->{date}\n".
108           "$data->{subject}\n".
109           "$data->{msgid}\n".
110           "$data->{package}\n".
111           "$data->{keywords}\n".
112           "$data->{done}\n".
113           "$data->{forwarded}\n".
114           "$data->{mergedwith}\n".
115           "$data->{severity}\n".
116           "$data->{versions}\n".
117           "$data->{fixed_versions}\n");
118 }
119
120 sub unlockwritebug {
121     writebug(@_);
122     &unfilelock;
123 }
124
125 sub filelock {
126     # NB - NOT COMPATIBLE WITH `with-lock'
127     local ($lockfile,$flockpushno,$evalstring,$count,$errors,@s1,@s2) = @_;
128     $flockpushno= $#filelocks+1;
129     $count= 10; $errors= '';
130     for (;;) {
131         $evalstring= "
132             open(FLOCK${flockpushno},\"> \$lockfile\") || die \"open: \$!\";
133             \$flockwant= pack(\$flockstruct,&F_WRLCK,0,0,1,0);".
134                 ($] >= 5.000 ? "
135             fcntl(FLOCK$flockpushno,&F_SETLK,\$flockwant) || die \"setlk: \$!\";" : "
136             \$z= syscall(&SYS_fcntl,fileno(FLOCK$flockpushno),&F_SETLK,\$flockwant) < 0
137                  && die \"syscall fcntl setlk: \$!\";") ."
138             (\@s1= lstat(\$lockfile)) || die \"lstat: \$!\";
139             (\@s2= stat(FLOCK$flockpushno)) || die \"fstat: \$!\";
140             join(',',\@s1) eq join(',',\@s2) || die \"file switched\";
141             1;
142         ";
143         last if eval $evalstring;
144         $errors .= $@;
145         eval "close(FLOCK$flockpushno);";
146         if (--$count <=0) {
147             $errors =~ s/\n+$//;
148             &quit("failed to get lock on file $lockfile: $errors // $evalstring");
149         }
150         sleep 10;
151     }
152     push(@cleanups,'unfilelock');
153     push(@filelocks,$lockfile);
154 }
155
156 sub unfilelock {
157     if (@filelocks == 0) {
158         warn "unfilelock called with no active filelocks!\n";
159         return;
160     }
161     local ($lockfile) = pop(@filelocks);
162     pop(@cleanups);
163     eval 'close(FLOCK'.($#filelocks+1).');' || warn "failed to close lock file $lockfile: $!";
164     unlink($lockfile) || warn "failed to remove lock file $lockfile: $!";
165 }
166
167 sub quit {
168     print DEBUG "quitting >$_[0]<\n";
169     local ($u);
170     while ($u= $cleanups[$#cleanups]) { &$u; }
171     die "*** $_[0]\n";
172 }
173
174 %saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
175
176 sub sani {
177     local ($in) = @_;
178     local ($out);
179     while ($in =~ m/[<>&"]/) {
180         $out.= $`. '&'. $saniarray{$&}. ';';
181         $in=$';
182     }
183     $out.= $in;
184     $out;
185 }
186
187 sub update_realtime {
188         my ($file, $bug, $new) = @_;
189
190         # update realtime index.db
191
192         open(IDXDB, "<$file") or die "Couldn't open $file";
193         open(IDXNEW, ">$file.new");
194
195         my $line;
196         my @line;
197         while($line = <IDXDB>) {
198                 @line = split /\s/, $line;
199                 last if ($line[1] >= $bug);
200                 print IDXNEW $line;
201                 $line = "";
202         }
203
204         if ($new eq "NOCHANGE") {
205                 print IDXNEW $line if ($line ne "" && $line[1] == $ref);
206         } elsif ($new eq "REMOVE") {
207                 0;
208         } else {
209                 print IDXNEW $new;
210         }
211         if ($line ne "" && $line[1] > $bug) {
212                 print IDXNEW $line;
213                 $line = "";
214         }
215
216         print IDXNEW while(<IDXDB>);
217
218         close(IDXNEW);
219         close(IDXDB);
220
221         rename("$file.new", $file);
222
223         return $line;
224 }
225
226 sub bughook_archive {
227         my $ref = shift;
228         &filelock("debbugs.trace.lock");
229         &appendfile("debbugs.trace","archive $ref\n");
230         my $line = update_realtime(
231                 "$gSpoolDir/index.db.realtime", 
232                 $ref,
233                 "REMOVE");
234         update_realtime("$gSpoolDir/index.archive.realtime",
235                 $ref, $line);
236         &unfilelock;
237 }       
238
239 sub bughook {
240         my ( $type, $ref ) = ( shift, shift );
241         &filelock("debbugs.trace.lock");
242
243         &appendfile("debbugs.trace","$type $ref\n",@_);
244
245         my @stuff=split /\n/, "$_[0]\n\n\n\n\n\n\n";
246
247         my $firstpkg;
248         my $whendone = "open";
249         my $severity = $gDefaultSeverity;
250         ($firstpkg = $stuff[4]) =~ s/[,\s].*$//;
251         $whendone = "forwarded" if length $stuff[7];
252         $whendone = "done" if length $stuff[6];
253         $severity = $stuff[9] if length $stuff[9];
254
255         my $k = sprintf "%s %d %d %s [%s] %s %s\n",
256                         $firstpkg, $ref, $stuff[1], $whendone, $stuff[0],
257                         $severity, $stuff[5];
258
259         update_realtime("$gSpoolDir/index.db.realtime", $ref, $k);
260
261         &unfilelock;
262 }
263
264 sub appendfile {
265         my $file = shift;
266         if (!open(AP,">>$file")) {
267                 print DEBUG "failed open log<\n";
268                 print DEBUG "failed open log err $!<\n";
269                 &quit("opening $file (appendfile): $!");
270         }
271         print(AP @_) || &quit("writing $file (appendfile): $!");
272         close(AP) || &quit("closing $file (appendfile): $!");
273 }
274
275 sub getmailbody {
276         my $entity = shift;
277         my $type = $entity->effective_type;
278         if ($type eq 'text/plain' or
279             ($type =~ m#text/# and $type ne 'text/html') or
280             $type eq 'application/pgp') {
281                 return $entity->bodyhandle;
282         } elsif ($type eq 'multipart/alternative') {
283                 # RFC 2046 says we should use the last part we recognize.
284                 for my $part (reverse $entity->parts) {
285                         my $ret = getmailbody($part);
286                         return $ret if $ret;
287                 }
288         } else {
289                 # For other multipart types, we just pretend they're
290                 # multipart/mixed and run through in order.
291                 for my $part ($entity->parts) {
292                         my $ret = getmailbody($part);
293                         return $ret if $ret;
294                 }
295         }
296         return undef;
297 }
298
299 sub escapelog {
300         my @log = @_;
301         map { s/^([\01-\07\030])/\030$1/gm } @log;
302         return \@log;
303 }
304
305
306 @severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
307 @showseverities= @severities;
308 grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
309 @strongseverities= @gStrongSeverities;
310 %displayshowseverities= %gSeverityDisplay;
311
312 1;