]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/Log.pm
get_bug_status can now accept a schema to pull from DB
[debbugs.git] / Debbugs / Log.pm
1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
5 #
6 # [Other people have contributed to this file; their copyrights should
7 # go here too.]
8 # Copyright 2004 by Collin Watson <cjwatson@debian.org>
9 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>
10
11
12 package Debbugs::Log;
13
14
15 use warnings;
16 use strict;
17
18 use vars qw($VERSION $DEBUG @EXPORT @EXPORT_OK %EXPORT_TAGS);
19 use Exporter qw(import);
20
21 BEGIN {
22     $VERSION = 1.00;
23     $DEBUG = 0 unless defined $DEBUG;
24
25     @EXPORT = ();
26     %EXPORT_TAGS = (write => [qw(write_log_records),
27                              ],
28                     read  => [qw(read_log_records record_text record_regex),
29                              ],
30                     misc  => [qw(escape_log),
31                              ],
32                    );
33     @EXPORT_OK = ();
34     Exporter::export_ok_tags(qw(write read misc));
35     $EXPORT_TAGS{all} = [@EXPORT_OK];
36 }
37
38 use Carp;
39
40 use Debbugs::Common qw(getbuglocation getbugcomponent make_list);
41 use Params::Validate qw(:types validate_with);
42 use Encode qw(encode encode_utf8 is_utf8);
43 use IO::InnerFile;
44 use feature 'state';
45
46 =head1 NAME
47
48 Debbugs::Log - an interface to debbugs .log files
49
50 =head1 DESCRIPTION
51
52 The Debbugs::Log module provides a convenient way for scripts to read and
53 write the .log files used by debbugs to store the complete textual records
54 of all bug transactions.
55
56 Debbugs::Log does not decode utf8 into perl's internal encoding or
57 encode into utf8 from perl's internal encoding. For html records and
58 all recips, this should probably be done. For other records, this should
59 not be needed.
60
61 =head2 The .log File Format
62
63 .log files consist of a sequence of records, of one of the following four
64 types. ^A, ^B, etc. represent those control characters.
65
66 =over 4
67
68 =item incoming-recv
69
70   ^G
71   [mail]
72   ^C
73
74 C<[mail]> must start with /^Received: \(at \S+\) by \S+;/, and is copied to
75 the output.
76
77 =item autocheck
78
79 Auto-forwarded messages are recorded like this:
80
81   ^A
82   [mail]
83   ^C
84
85 C<[mail]> must contain /^X-Debian-Bugs(-\w+)?: This is an autoforward from
86 \S+/. The first line matching that is removed; all lines in the message body
87 that begin with 'X' will be copied to the output, minus the 'X'.
88
89 Nothing in debbugs actually generates this record type any more, but it may
90 still be in old .logs at some sites.
91
92 =item recips
93
94   ^B
95   [recip]^D[recip]^D[...] OR -t
96   ^E
97   [mail]
98   ^C
99
100 Each [recip] is output after "Message sent"; C<-t> represents the same
101 sendmail option, indicating that the recipients are taken from the headers
102 of the message itself.
103
104 =item html
105
106   ^F
107   [html]
108   ^C
109
110 [html] is copied unescaped to the output. The record immediately following
111 this one is considered "boring" and only shown in certain output modes.
112
113 (This is a design flaw in the log format, since it makes it difficult to
114 change the HTML presentation later, or to present the data in an entirely
115 different format.)
116
117 =back
118
119 No other types of records are permitted, and the file must end with a ^C
120 line.
121
122 =cut
123
124 my %states = (
125     1 => 'autocheck',
126     2 => 'recips',
127     3 => 'kill-end',
128     5 => 'go',
129     6 => 'html',
130     7 => 'incoming-recv',
131 );
132
133 =head2 Perl Record Representation
134
135 Each record is a hash. The C<type> field is C<incoming-recv>, C<autocheck>,
136 C<recips>, or C<html> as above; C<text> contains text from C<[mail]> or
137 C<[html]> as above; C<recips> is a reference to an array of recipients
138 (strings), or undef for C<-t>.
139
140 =head1 FUNCTIONS
141
142 =over 4
143
144 =item new
145
146 Creates a new log reader based on a .log filehandle.
147
148       my $log = Debbugs::Log->new($logfh);
149       my $log = Debbugs::Log->new(bug_num => $nnn);
150       my $log = Debbugs::Log->new(logfh => $logfh);
151
152 Parameters
153
154 =over
155
156 =item bug_num -- bug number
157
158 =item logfh -- log filehandle
159
160 =item log_name -- name of log
161
162 =back
163
164 One of the above options must be passed.
165
166 =cut
167
168 sub new
169 {
170     my $this = shift;
171     my %param;
172     if (@_ == 1) {
173          ($param{logfh}) = @_;
174          $param{inner_file} = 0;
175     }
176     else {
177         state $spec =
178             {bug_num => {type => SCALAR,
179                          optional => 1,
180                         },
181              logfh   => {type => HANDLE,
182                          optional => 1,
183                         },
184              log_name => {type => SCALAR,
185                           optional => 1,
186                          },
187              inner_file => {type => BOOLEAN,
188                             default => 0,
189                            },
190             };
191         %param = validate_with(params => \@_,
192                                spec   => $spec,
193                               );
194     }
195     if (grep({exists $param{$_} and defined $param{$_}}
196              qw(bug_num logfh log_name)) ne 1) {
197         croak "Exactly one of bug_num, logfh, or log_name ".
198             "must be passed and must be defined";
199     }
200
201     my $class = ref($this) || $this;
202     my $self = {};
203     bless $self, $class;
204
205     if (exists $param{logfh}) {
206         $self->{logfh} = $param{logfh}
207     } else {
208         my $bug_log;
209         if (exists $param{bug_num}) {
210             my $location = getbuglocation($param{bug_num},'log');
211             $bug_log = getbugcomponent($param{bug_num},'log',$location);
212         } else {
213             $bug_log = $param{log_name};
214         }
215         if ($bug_log =~ m/\.gz$/) {
216             my $oldpath = $ENV{'PATH'};
217             $ENV{'PATH'} = '/bin:/usr/bin';
218             open($self->{logfh},'-|','gzip','-dc',$bug_log) or
219                 die "Unable to open $bug_log for reading: $!";
220             $ENV{'PATH'} = $oldpath;
221         } else {
222             open($self->{logfh},'<',$bug_log) or
223                 die "Unable to open $bug_log for reading: $!";
224         }
225     }
226
227     $self->{state} = 'kill-init';
228     $self->{linenum} = 0;
229     $self->{inner_file} = $param{inner_file};
230     return $self;
231 }
232
233 =item read_record
234
235 Reads and returns a single record from a log reader object. At end of file,
236 returns undef. Throws exceptions using die(), so you may want to wrap this
237 in an eval().
238
239 =cut
240
241 sub read_record
242 {
243     my $this = shift;
244     my $logfh = $this->{logfh};
245
246     # This comes from bugreport.cgi, but is much simpler since it doesn't
247     # worry about the details of output.
248
249     my $record = {};
250
251     while (defined (my $line = <$logfh>)) {
252         $record->{start} = $logfh->tell() if not defined $record->{start};
253         chomp $line;
254         ++$this->{linenum};
255         if (length($line) == 1 and exists $states{ord($line)}) {
256             # state transitions
257             my $newstate = $states{ord($line)};
258
259             # disallowed transitions
260             $_ = "$this->{state} $newstate";
261             unless (/^(go|go-nox|html) kill-end$/ or
262                     /^(kill-init|kill-end) (incoming-recv|autocheck|recips|html)$/ or
263                     /^kill-body go$/) {
264                 die "transition from $this->{state} to $newstate at $this->{linenum} disallowed";
265             }
266
267             $this->{state} = $newstate;
268             if ($this->{state} =~ /^(autocheck|recips|html|incoming-recv)$/) {
269             $record->{type} = $this->{state};
270             $record->{start} = $logfh->tell;
271             $record->{stop} = $logfh->tell;
272             $record->{inner_file} = $this->{inner_file};
273             } elsif ($this->{state} eq 'kill-end') {
274             if ($this->{inner_file}) {
275                 $record->{fh} = IO::InnerFile->new($logfh,$record->{start},$record->{stop} - $record->{start})
276             }
277                 return $record;
278             }
279
280             next;
281         }
282     $record->{stop} = $logfh->tell;
283         $_ = $line;
284         if ($this->{state} eq 'incoming-recv') {
285             my $pl = $_;
286             unless (/^Received: \(at \S+\) by \S+;/) {
287                 die "bad line '$pl' in state incoming-recv";
288             }
289             $this->{state} = 'go';
290             $record->{text} .= "$_\n" unless $this->{inner_file};
291         } elsif ($this->{state} eq 'html') {
292             $record->{text} .= "$_\n"  unless $this->{inner_file};
293         } elsif ($this->{state} eq 'go') {
294             s/^\030//;
295             $record->{text} .= "$_\n"  unless $this->{inner_file};
296         } elsif ($this->{state} eq 'go-nox') {
297             $record->{text} .= "$_\n"  unless $this->{inner_file};
298         } elsif ($this->{state} eq 'recips') {
299             if (/^-t$/) {
300                 undef $record->{recips};
301             } else {
302                 # preserve trailing null fields, e.g. #2298
303                 $record->{recips} = [split /\04/, $_, -1];
304             }
305             $this->{state} = 'kill-body';
306         $record->{start} = $logfh->tell+2;
307         $record->{stop} = $logfh->tell+2;
308         $record->{inner_file} = $this->{inner_file};
309         } elsif ($this->{state} eq 'autocheck') {
310             $record->{text} .= "$_\n" unless $this->{inner_file};
311             next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/;
312             $this->{state} = 'autowait';
313         } elsif ($this->{state} eq 'autowait') {
314             $record->{text} .= "$_\n" unless $this->{inner_file};
315             next if !/^$/;
316             $this->{state} = 'go-nox';
317         } else {
318             die "state $this->{state} at line $this->{linenum} ('$_')";
319         }
320     }
321     die "state $this->{state} at end" unless $this->{state} eq 'kill-end';
322
323     if (keys %$record) {
324         return $record;
325     } else {
326         return undef;
327     }
328 }
329
330 =item read_log_records
331
332 Takes a .log filehandle as input, and returns an array of all records in
333 that file. Throws exceptions using die(), so you may want to wrap this in an
334 eval().
335
336 Uses exactly the same options as Debbugs::Log::new
337
338 =cut
339
340 sub read_log_records
341 {
342     my %param;
343     if (@_ == 1) {
344          ($param{logfh}) = @_;
345     }
346     else {
347          %param = validate_with(params => \@_,
348                                 spec   => {bug_num => {type => SCALAR,
349                                                        optional => 1,
350                                                       },
351                                            logfh   => {type => HANDLE,
352                                                        optional => 1,
353                                                       },
354                                            log_name => {type => SCALAR,
355                                                         optional => 1,
356                                                        },
357                            inner_file => {type => BOOLEAN,
358                                           default => 0,
359                                          },
360                                           }
361                                );
362     }
363     if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) {
364          croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined";
365     }
366
367     my @records;
368     my $reader = Debbugs::Log->new(%param);
369     while (defined(my $record = $reader->read_record())) {
370         push @records, $record;
371     }
372     return @records;
373 }
374
375 =item write_log_records
376
377 Takes a filehandle and a list of records as input, and prints the .log
378 format representation of those records to that filehandle.
379
380 =back
381
382 =cut
383
384 sub write_log_records
385 {
386     my %param = validate_with(params => \@_,
387                               spec   => {bug_num => {type => SCALAR,
388                                                      optional => 1,
389                                                     },
390                                          logfh   => {type => HANDLE,
391                                                      optional => 1,
392                                                     },
393                                          log_name => {type => SCALAR,
394                                                       optional => 1,
395                                                      },
396                                          records => {type => HASHREF|ARRAYREF,
397                                                     },
398                                         },
399                              );
400     if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) {
401          croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined";
402     }
403     my $logfh;
404     if (exists $param{logfh}) {
405          $logfh = $param{logfh}
406     }
407     elsif (exists $param{log_name}) {
408          $logfh = IO::File->new(">>$param{log_name}") or
409               die "Unable to open bug log $param{log_name} for writing: $!";
410     }
411     elsif (exists $param{bug_num}) {
412          my $location = getbuglocation($param{bug_num},'log');
413          my $bug_log = getbugcomponent($param{bug_num},'log',$location);
414          $logfh = IO::File->new($bug_log, 'r') or
415               die "Unable to open bug log $bug_log for reading: $!";
416     }
417     my @records = make_list($param{records});
418
419     for my $record (@records) {
420         my $type = $record->{type};
421         croak "record type '$type' with no text field" unless defined $record->{text};
422         # I am not sure if we really want to croak here; but this is
423         # almost certainly a bug if is_utf8 is on.
424         my $text = $record->{text};
425         if (is_utf8($text)) {
426             carp('Record text was in the wrong encoding (perl internal instead of utf8 octets)');
427             $text = encode_utf8($text)
428         }
429         ($text) = escape_log($text);
430         if ($type eq 'autocheck') {
431             print {$logfh} "\01\n$text\03\n" or
432                 die "Unable to write to logfile: $!";
433         } elsif ($type eq 'recips') {
434             print {$logfh} "\02\n";
435             my $recips = $record->{recips};
436             if (defined $recips) {
437                 croak "recips not undef or array"
438                     unless ref($recips) eq 'ARRAY';
439                 my $wrong_encoding = 0;
440                 my @recips =
441                     map { if (is_utf8($_)) {
442                         $wrong_encoding=1;
443                         encode_utf8($_);
444                     } else {
445                         $_;
446                     }} @$recips;
447                 carp('Recipients was in the wrong encoding (perl internal instead of utf8 octets') if $wrong_encoding;
448                 print {$logfh} join("\04", @$recips) . "\n" or
449                     die "Unable to write to logfile: $!";
450             } else {
451                 print {$logfh} "-t\n" or
452                     die "Unable to write to logfile: $!";
453             }
454             #$text =~ s/^([\01-\07\030])/\030$1/gm;
455             print {$logfh} "\05\n$text\03\n" or
456                 die "Unable to write to logfile: $!";
457         } elsif ($type eq 'html') {
458             print {$logfh} "\06\n$text\03\n" or
459                 die "Unable to write to logfile: $!";
460         } elsif ($type eq 'incoming-recv') {
461             #$text =~ s/^([\01-\07\030])/\030$1/gm;
462             print {$logfh} "\07\n$text\03\n" or
463                 die "Unable to write to logfile: $!";
464         } else {
465             croak "unknown record type type '$type'";
466         }
467     }
468
469     1;
470 }
471
472 =head2 escape_log
473
474      print {$log} escape_log(@log)
475
476 Applies the log escape regex to the passed logfile.
477
478 =cut
479
480 sub escape_log {
481         my @log = @_;
482         return map {s/^([\01-\07\030])/\030$1/gm; $_ } @log;
483 }
484
485
486 sub record_text {
487     my ($record) = @_;
488     if ($record->{inner_file}) {
489         local $/;
490         my $text;
491         my $t = $record->{fh};
492         $text = <$t>;
493         $record->{fh}->seek(0,0);
494         return $text;
495     } else {
496         return $record->{text};
497     }
498 }
499
500 sub record_regex {
501     my ($record,$regex) = @_;
502     if ($record->{inner_file}) {
503         my @result;
504         my $fh = $record->{fh};
505         while (<$fh>) {
506             if (@result = $_ =~ m/$regex/) {
507                 $record->{fh}->seek(0,0);
508                 return @result;
509             }
510         }
511         $record->{fh}->seek(0,0);
512         return ();
513     } else {
514         my @result = $record->{text} =~ m/$regex/;
515         return @result;
516     }
517 }
518
519
520 =head1 CAVEATS
521
522 This module does none of the formatting that bugreport.cgi et al do. It's
523 simply a means for extracting and rewriting raw records.
524
525 =cut
526
527 1;
528
529 # Local Variables:
530 # indent-tabs-mode: nil
531 # cperl-indent-level: 4
532 # End: