Debbugs/Log.pm

   1 package Debbugs::Log;
   2
   3 use strict;
   4
   5 use Exporter ();
   6 use vars qw($VERSION @ISA @EXPORT);
   7
   8 BEGIN {
   9     $VERSION = 1.00;
  10
  11     @ISA = qw(Exporter);
  12     @EXPORT = qw(read_log_records write_log_records);
  13 }
  14
  15 =head1 NAME
  16
  17 Debbugs::Log - an interface to debbugs .log files
  18
  19 =head1 DESCRIPTION
  20
  21 The Debbugs::Log module provides a convenient way for scripts to read and
  22 write the .log files used by debbugs to store the complete textual records
  23 of all bug transactions.
  24
  25 =head2 The .log File Format
  26
  27 .log files consist of a sequence of records, of one of the following four
  28 types. ^A, ^B, etc. represent those control characters.
  29
  30 =over 4
  31
  32 =item incoming-recv
  33
  34   ^G
  35   [mail]
  36   ^C
  37
  38 C<[mail]> must start with /^Received: \(at \S+\) by \S+;/, and is copied to
  39 the output.
  40
  41 =item autocheck
  42
  43 Auto-forwarded messages are recorded like this:
  44
  45   ^A
  46   [mail]
  47   ^C
  48
  49 C<[mail]> must contain /^X-Debian-Bugs(-\w+)?: This is an autoforward from
  50 \S+/. The first line matching that is removed; all lines in the message body
  51 that begin with 'X' will be copied to the output, minus the 'X'.
  52
  53 Nothing in debbugs actually generates this record type any more, but it may
  54 still be in old .logs at some sites.
  55
  56 =item recips
  57
  58   ^B
  59   [recip]^D[recip]^D[...] OR -t
  60   ^E
  61   [mail]
  62   ^C
  63
  64 Each [recip] is output after "Message sent"; C<-t> represents the same
  65 sendmail option, indicating that the recipients are taken from the headers
  66 of the message itself.
  67
  68 =item html
  69
  70   ^F
  71   [html]
  72   ^C
  73
  74 [html] is copied unescaped to the output. The record immediately following
  75 this one is considered "boring" and only shown in certain output modes.
  76
  77 (This is a design flaw in the log format, since it makes it difficult to
  78 change the HTML presentation later, or to present the data in an entirely
  79 different format.)
  80
  81 =back
  82
  83 No other types of records are permitted, and the file must end with a ^C
  84 line.
  85
  86 =cut
  87
  88 my %states = (
  89     1 => 'autocheck',
  90     2 => 'recips',
  91     3 => 'kill-end',
  92     5 => 'go',
  93     6 => 'html',
  94     7 => 'incoming-recv',
  95 );
  96
  97 =head2 Perl Record Representation
  98
  99 Each record is a hash. The C<type> field is C<incoming-recv>, C<autocheck>,
 100 C<recips>, or C<html> as above; C<text> contains text from C<[mail]> or
 101 C<[html]> as above; C<recips> is a reference to an array of recipients
 102 (strings), or undef for C<-t>.
 103
 104 =head1 FUNCTIONS
 105
 106 =over 4
 107
 108 =item new
 109
 110 Creates a new log reader based on a .log filehandle.
 111
 112 =cut
 113
 114 sub new
 115 {
 116     my $this = shift;
 117     my $class = ref($this) || $this;
 118     my $self = {};
 119     bless $self, $class;
 120     $self->{logfh} = shift;
 121     $self->{state} = 'kill-init';
 122     $self->{linenum} = 0;
 123     return $self;
 124 }
 125
 126 =item read_record
 127
 128 Reads and returns a single record from a log reader object. At end of file,
 129 returns undef. Throws exceptions using die(), so you may want to wrap this
 130 in an eval().
 131
 132 =cut
 133
 134 sub read_record
 135 {
 136     my $this = shift;
 137     my $logfh = $this->{logfh};
 138
 139     # This comes from bugreport.cgi, but is much simpler since it doesn't
 140     # worry about the details of output.
 141
 142     my $record = {};
 143
 144     while (defined (my $line = <$logfh>)) {
 145         chomp $line;
 146         ++$this->{linenum};
 147         if (length($line) == 1 and exists $states{ord($line)}) {
 148             # state transitions
 149             my $newstate = $states{ord($line)};
 150
 151             # disallowed transitions
 152             $_ = "$this->{state} $newstate";
 153             unless (/^(go|go-nox|html) kill-end$/ or
 154                     /^(kill-init|kill-end) (incoming-recv|autocheck|recips|html)$/ or
 155                     /^kill-body go$/) {
 156                 die "transition from $this->{state} to $newstate at $this->{linenum} disallowed";
 157             }
 158
 159             $this->{state} = $newstate;
 160
 161             if ($this->{state} =~ /^(autocheck|recips|html|incoming-recv)$/) {
 162                 $record->{type} = $this->{state};
 163             } elsif ($this->{state} eq 'kill-end') {
 164                 return $record;
 165             }
 166
 167             next;
 168         }
 169
 170         $_ = $line;
 171         if ($this->{state} eq 'incoming-recv') {
 172             my $pl = $_;
 173             unless (/^Received: \(at \S+\) by \S+;/) {
 174                 die "bad line '$pl' in state incoming-recv";
 175             }
 176             $this->{state} = 'go';
 177             $record->{text} .= "$_\n";
 178         } elsif ($this->{state} eq 'html') {
 179             $record->{text} .= "$_\n";
 180         } elsif ($this->{state} eq 'go') {
 181             s/^\030//;
 182             $record->{text} .= "$_\n";
 183         } elsif ($this->{state} eq 'go-nox') {
 184             $record->{text} .= "$_\n";
 185         } elsif ($this->{state} eq 'recips') {
 186             if (/^-t$/) {
 187                 undef $record->{recips};
 188             } else {
 189                 # preserve trailing null fields, e.g. #2298
 190                 $record->{recips} = [split /\04/, $_, -1];
 191             }
 192             $this->{state} = 'kill-body';
 193         } elsif ($this->{state} eq 'autocheck') {
 194             $record->{text} .= "$_\n";
 195             next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/;
 196             $this->{state} = 'autowait';
 197         } elsif ($this->{state} eq 'autowait') {
 198             $record->{text} .= "$_\n";
 199             next if !/^$/;
 200             $this->{state} = 'go-nox';
 201         } else {
 202             die "state $this->{state} at line $this->{linenum} ('$_')";
 203         }
 204     }
 205     die "state $this->{state} at end" unless $this->{state} eq 'kill-end';
 206
 207     if (keys %$record) {
 208         return $record;
 209     } else {
 210         return undef;
 211     }
 212 }
 213
 214 =item read_log_records
 215
 216 Takes a .log filehandle as input, and returns an array of all records in
 217 that file. Throws exceptions using die(), so you may want to wrap this in an
 218 eval().
 219
 220 =cut
 221
 222 sub read_log_records (*)
 223 {
 224     my $logfh = shift;
 225
 226     my @records;
 227     my $reader = Debbugs::Log->new($logfh);
 228     while (defined(my $record = $reader->read_record())) {
 229         push @records, $record;
 230     }
 231     return @records;
 232 }
 233
 234 =item write_log_records
 235
 236 Takes a filehandle and a list of records as input, and prints the .log
 237 format representation of those records to that filehandle.
 238
 239 =cut
 240
 241 sub write_log_records (*@)
 242 {
 243     my $logfh = shift;
 244     my @records = @_;
 245
 246     for my $record (@records) {
 247         my $type = $record->{type};
 248         my $text = $record->{text};
 249         die "type '$type' with no text field" unless defined $text;
 250         if ($type eq 'autocheck') {
 251             print $logfh "\01\n$text\03\n";
 252         } elsif ($type eq 'recips') {
 253             print $logfh "\02\n";
 254             my $recips = $record->{recips};
 255             if (defined $recips) {
 256                 die "recips not undef or array"
 257                     unless ref($recips) eq 'ARRAY';
 258                 print $logfh join("\04", @$recips) . "\n";
 259             } else {
 260                 print $logfh "-t\n";
 261             }
 262             $text =~ s/^([\01-\07\030])/\030$1/gm;
 263             print $logfh "\05\n$text\03\n";
 264         } elsif ($type eq 'html') {
 265             print $logfh "\06\n$text\03\n";
 266         } elsif ($type eq 'incoming-recv') {
 267             $text =~ s/^([\01-\07\030])/\030$1/gm;
 268             print $logfh "\07\n$text\03\n";
 269         } else {
 270             die "unknown type '$type'";
 271         }
 272     }
 273
 274     1;
 275 }
 276
 277 =back
 278
 279 =head1 CAVEATS
 280
 281 This module does none of the formatting that bugreport.cgi et al do. It's
 282 simply a means for extracting and rewriting raw records.
 283
 284 =cut
 285
 286 1;