2 # $Id: errorlib.in,v 1.17 2002/11/17 22:45:16 cjwatson Exp $
4 sub F_SETLK { 6; } sub F_WRLCK{ 1; }
5 $flockstruct= 'sslll'; # And there ought to be something for this too.
8 return "" if ( $_[ 0 ] < 0 );
9 return sprintf "%02d", $_[ 0 ] % 100;
12 sub unlockreadbugmerge {
14 &unfilelock if $rv >= 2;
15 &unfilelock if $rv >= 1;
18 sub lockreadbugmerge {
20 if (!&lockreadbug($lref)) { return 0; }
21 if (!length($s_mergedwith)) { return 1; }
23 &filelock('lock/merge');
24 if (!&lockreadbug($lref)) { &unfilelock; return 0; }
30 &filelock("lock/$lref");
31 my $hash = get_hashname($lref);
32 if (!open(S,"db-h/$hash/$lref.status")) { &unfilelock; return 0; }
33 chop($s_originator= <S>);
35 chop($s_subject= <S>);
37 chop($s_package= <S>);
38 chop($s_keywords= <S>);
40 chop($s_forwarded= <S>);
41 chop($s_mergedwith= <S>);
42 chop($s_severity= <S>);
43 chop($s_versions= <S>);
44 chop($s_fixed_versions= <S>);
46 $s_severity = 'normal' if $s_severity eq '';
51 # NB - NOT COMPATIBLE WITH `with-lock'
52 local ($lockfile,$flockpushno,$evalstring,$count,$errors,@s1,@s2) = @_;
53 $flockpushno= $#filelocks+1;
54 $count= 10; $errors= '';
57 open(FLOCK${flockpushno},\"> \$lockfile\") || die \"open: \$!\";
58 \$flockwant= pack(\$flockstruct,&F_WRLCK,0,0,1,0);".
60 fcntl(FLOCK$flockpushno,&F_SETLK,\$flockwant) || die \"setlk: \$!\";" : "
61 \$z= syscall(&SYS_fcntl,fileno(FLOCK$flockpushno),&F_SETLK,\$flockwant) < 0
62 && die \"syscall fcntl setlk: \$!\";") ."
63 (\@s1= lstat(\$lockfile)) || die \"lstat: \$!\";
64 (\@s2= stat(FLOCK$flockpushno)) || die \"fstat: \$!\";
65 join(',',\@s1) eq join(',',\@s2) || die \"file switched\";
68 last if eval $evalstring;
70 eval "close(FLOCK$flockpushno);";
73 &quit("failed to get lock on file $lockfile: $errors // $evalstring");
77 push(@cleanups,'unfilelock');
78 push(@filelocks,$lockfile);
82 local ($lockfile) = pop(@filelocks);
84 eval 'close(FLOCK'.($#filelocks+1).');' || warn "failed to close lock file: $!";
85 unlink($lockfile) || warn "failed to remove lock file: $!";
89 print DEBUG "quitting >$_[0]<\n";
91 while ($u= $cleanups[$#cleanups]) { &$u; }
95 %saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
100 while ($in =~ m/[<>&"]/) {
101 $out.= $`. '&'. $saniarray{$&}. ';';
108 sub update_realtime {
109 my ($file, $bug, $new) = @_;
111 # update realtime index.db
113 open(IDXDB, "<$file") or die "Couldn't open $file";
114 open(IDXNEW, ">$file.new");
117 while($line = <IDXDB>) {
118 my @line = split /\s/, $line;
119 last if ($line[1] == $ref);
123 if ($new eq "NOCHANGE") {
125 } elsif ($new eq "REMOVE") {
131 print IDXNEW while(<IDXDB>);
136 rename("$file.new", $file);
141 sub bughook_archive {
143 &filelock("debbugs.trace.lock");
144 &appendfile("debbugs.trace","archive $ref\n");
145 my $line = update_realtime(
146 "$gSpoolDir/index.db.realtime",
149 update_realtime("$gSpoolDir/index.archive.realtime",
155 my ( $type, $ref ) = ( shift, shift );
156 &filelock("debbugs.trace.lock");
158 &appendfile("debbugs.trace","$type $ref\n",@_);
160 my @stuff=split /\n/, "$_[0]\n\n\n\n\n\n\n";
163 my $whendone = "open";
164 my $severity = $gDefaultSeverity;
165 ($firstpkg = $stuff[4]) =~ s/[,\s].*$//;
166 $whendone = "forwarded" if length $stuff[7];
167 $whendone = "done" if length $stuff[6];
168 $severity = $stuff[9] if length $stuff[9];
170 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
171 $firstpkg, $ref, $stuff[1], $whendone, $stuff[0],
172 $severity, $stuff[5];
174 update_realtime("$gSpoolDir/index.db.realtime", $ref, $k);
181 if (!open(AP,">>$file")) {
182 print DEBUG "failed open log<\n";
183 print DEBUG "failed open log err $!<\n";
184 &quit("opening $file (appendfile): $!");
186 print(AP @_) || &quit("writing $file (appendfile): $!");
187 close(AP) || &quit("closing $file (appendfile): $!");
192 my $type = $entity->effective_type;
193 if ($type eq 'text/plain' or
194 ($type =~ m#text/# and $type ne 'text/html') or
195 $type eq 'application/pgp') {
196 return $entity->bodyhandle;
197 } elsif ($type eq 'multipart/alternative') {
198 # RFC 2046 says we should use the last part we recognize.
199 for my $part (reverse $entity->parts) {
200 my $ret = getmailbody($part);
204 # For other multipart types, we just pretend they're
205 # multipart/mixed and run through in order.
206 for my $part ($entity->parts) {
207 my $ret = getmailbody($part);
216 map { s/^([\01-\07\030])/\030$1/gm } @log;
221 @severities= @gSeverityList;
222 @showseverities= @severities;
223 grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
224 @strongseverities= @gStrongSeverities;
225 %displayshowseverities= %gSeverityDisplay;