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