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 [mail] must start with /^Received: \(at \S+\) by \S+;/, and is copied to the
  39 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 No other types of records are permitted, and the file must end with a ^C
  78 line.
  79
  80 =back
  81
  82 =head2 Perl Record Representation
  83
  84 Each record is a hash. The C<type> field is C<incoming-recv>, C<autocheck>,
  85 C<recips>, or C<html> as above; C<mail> and C<html> contain text as above;
  86 C<recips> is a reference to an array of recipients (strings), or undef for
  87 C<-t>.
  88
  89 =head1 FUNCTIONS
  90
  91 =over 4
  92
  93 =item read_log_records
  94
  95 Takes a .log filehandle as input, and returns an array of all records in
  96 that file. Throws exceptions using die(), so you may want to wrap this in an
  97 eval().
  98
  99 =cut
 100
 101 sub read_log_records (*)
 102 {
 103     my $logfh = shift;
 104
 105     # This comes from bugreport.cgi, but is much simpler since it doesn't
 106     # worry about the details of output.
 107
 108     my %states = (
 109         1 => 'autocheck',
 110         2 => 'recips',
 111         3 => 'kill-end',
 112         5 => 'go',
 113         6 => 'html',
 114         7 => 'incoming-recv',
 115     );
 116
 117     my @records;
 118
 119     my $normstate = 'kill-init';
 120     my $linenum = 0;
 121     my $record = {};
 122
 123     while (defined (my $line = <$logfh>)) {
 124         chomp $line;
 125         ++$linenum;
 126         if (length($line) == 1 and exists $states{ord($line)}) {
 127             # state transitions
 128             my $newstate = $states{ord($line)};
 129
 130             # disallowed transitions
 131             $_ = "$normstate $newstate";
 132             unless (/^(go|go-nox|html) kill-end$/ or
 133                     /^(kill-init|kill-end) (incoming-recv|autocheck|recips|html)$/ or
 134                     /^kill-body go$/) {
 135                 die "transition from $normstate to $newstate at $linenum disallowed";
 136             }
 137
 138             if ($newstate =~ /^(autocheck|recips|html|incoming-recv)$/) {
 139                 $record->{type} = $newstate;
 140             } elsif ($newstate eq 'kill-end') {
 141                 push @records, $record;
 142                 $record = {};
 143             }
 144
 145             $normstate = $newstate;
 146             next;
 147         }
 148
 149         $_ = $line;
 150         if ($normstate eq 'incoming-recv') {
 151             my $pl = $_;
 152             unless (/^Received: \(at \S+\) by \S+;/) {
 153                 die "bad line '$pl' in state incoming-recv";
 154             }
 155             $normstate = 'go';
 156             $record->{text} .= "$_\n";
 157         } elsif ($normstate eq 'html') {
 158             $record->{text} .= "$_\n";
 159         } elsif ($normstate eq 'go') {
 160             s/^\030//;
 161             $record->{text} .= "$_\n";
 162         } elsif ($normstate eq 'go-nox') {
 163             $record->{text} .= "$_\n";
 164         } elsif ($normstate eq 'recips') {
 165             if (/^-t$/) {
 166                 undef $record->{recips};
 167             } else {
 168                 # preserve trailing null fields, e.g. #2298
 169                 $record->{recips} = [split /\04/, $_, -1];
 170             }
 171             $normstate = 'kill-body';
 172         } elsif ($normstate eq 'autocheck') {
 173             $record->{text} .= "$_\n";
 174             next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/;
 175             $normstate = 'autowait';
 176         } elsif ($normstate eq 'autowait') {
 177             $record->{text} .= "$_\n";
 178             next if !/^$/;
 179             $normstate = 'go-nox';
 180         } else {
 181             die "state $normstate at line $linenum ('$_')";
 182         }
 183     }
 184     die "state $normstate at end" unless $normstate eq 'kill-end';
 185
 186     return @records;
 187 }
 188
 189 =item write_log_records
 190
 191 Takes a filehandle and a list of records as input, and prints the .log
 192 format representation of those records to that filehandle.
 193
 194 =cut
 195
 196 sub write_log_records (*@)
 197 {
 198     my $logfh = shift;
 199     my @records = @_;
 200
 201     for my $record (@records) {
 202         my $type = $record->{type};
 203         my $text = $record->{text};
 204         die "type '$type' with no text field" unless defined $text;
 205         if ($type eq 'autocheck') {
 206             print $logfh "\01\n$text\03\n";
 207         } elsif ($type eq 'recips') {
 208             print $logfh "\02\n";
 209             my $recips = $record->{recips};
 210             if (defined $recips) {
 211                 die "recips not undef or array"
 212                     unless ref($recips) eq 'ARRAY';
 213                 print $logfh join("\04", @$recips) . "\n";
 214             } else {
 215                 print $logfh "-t\n";
 216             }
 217             $text =~ s/^([\01-\07\030])/\030$1/gm;
 218             print $logfh "\05\n$text\03\n";
 219         } elsif ($type eq 'html') {
 220             print $logfh "\06\n$text\03\n";
 221         } elsif ($type eq 'incoming-recv') {
 222             $text =~ s/^([\01-\07\030])/\030$1/gm;
 223             print $logfh "\07\n$text\03\n";
 224         } else {
 225             die "unknown type '$type'";
 226         }
 227     }
 228
 229     1;
 230 }
 231
 232 =head1 CAVEATS
 233
 234 This module does none of the formatting that bugreport.cgi et al do. It's
 235 simply a means for extracting and rewriting raw records.
 236
 237 =cut
 238
 239 1;