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 base qw(Exporter);
  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),
  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
  39 use Debbugs::Common qw(getbuglocation getbugcomponent);
  40 use Params::Validate qw(:types validate_with);
  41
  42 =head1 NAME
  43
  44 Debbugs::Log - an interface to debbugs .log files
  45
  46 =head1 DESCRIPTION
  47
  48 The Debbugs::Log module provides a convenient way for scripts to read and
  49 write the .log files used by debbugs to store the complete textual records
  50 of all bug transactions.
  51
  52 =head2 The .log File Format
  53
  54 .log files consist of a sequence of records, of one of the following four
  55 types. ^A, ^B, etc. represent those control characters.
  56
  57 =over 4
  58
  59 =item incoming-recv
  60
  61   ^G
  62   [mail]
  63   ^C
  64
  65 C<[mail]> must start with /^Received: \(at \S+\) by \S+;/, and is copied to
  66 the output.
  67
  68 =item autocheck
  69
  70 Auto-forwarded messages are recorded like this:
  71
  72   ^A
  73   [mail]
  74   ^C
  75
  76 C<[mail]> must contain /^X-Debian-Bugs(-\w+)?: This is an autoforward from
  77 \S+/. The first line matching that is removed; all lines in the message body
  78 that begin with 'X' will be copied to the output, minus the 'X'.
  79
  80 Nothing in debbugs actually generates this record type any more, but it may
  81 still be in old .logs at some sites.
  82
  83 =item recips
  84
  85   ^B
  86   [recip]^D[recip]^D[...] OR -t
  87   ^E
  88   [mail]
  89   ^C
  90
  91 Each [recip] is output after "Message sent"; C<-t> represents the same
  92 sendmail option, indicating that the recipients are taken from the headers
  93 of the message itself.
  94
  95 =item html
  96
  97   ^F
  98   [html]
  99   ^C
 100
 101 [html] is copied unescaped to the output. The record immediately following
 102 this one is considered "boring" and only shown in certain output modes.
 103
 104 (This is a design flaw in the log format, since it makes it difficult to
 105 change the HTML presentation later, or to present the data in an entirely
 106 different format.)
 107
 108 =back
 109
 110 No other types of records are permitted, and the file must end with a ^C
 111 line.
 112
 113 =cut
 114
 115 my %states = (
 116     1 => 'autocheck',
 117     2 => 'recips',
 118     3 => 'kill-end',
 119     5 => 'go',
 120     6 => 'html',
 121     7 => 'incoming-recv',
 122 );
 123
 124 =head2 Perl Record Representation
 125
 126 Each record is a hash. The C<type> field is C<incoming-recv>, C<autocheck>,
 127 C<recips>, or C<html> as above; C<text> contains text from C<[mail]> or
 128 C<[html]> as above; C<recips> is a reference to an array of recipients
 129 (strings), or undef for C<-t>.
 130
 131 =head1 FUNCTIONS
 132
 133 =over 4
 134
 135 =item new
 136
 137 Creates a new log reader based on a .log filehandle.
 138
 139       my $log = Debbugs::Log->new($logfh);
 140       my $log = Debbugs::Log->new(bug_num => $nnn);
 141       my $log = Debbugs::Log->new(logfh => $logfh);
 142
 143 Parameters
 144
 145 =over
 146
 147 =item bug_num -- bug number
 148
 149 =item logfh -- log filehandle
 150
 151 =item log_name -- name of log
 152
 153 =back
 154
 155 One of the above options must be passed.
 156
 157 =cut
 158
 159 sub new
 160 {
 161     my $this = shift;
 162     my %param;
 163     if (@_ == 1) {
 164          ($param{logfh}) = @_;
 165     }
 166     else {
 167          %param = validate_with(params => @_,
 168                                 spec   => {bug_num => {type => SCALAR,
 169                                                        optional => 1,
 170                                                       },
 171                                            logfh   => {type => SCALAR,
 172                                                        optional => 1,
 173                                                       },
 174                                            log_name => {type => SCALAR,
 175                                                         optional => 1,
 176                                                        },
 177                                           }
 178                                );
 179     }
 180     if (grep {exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name) ne 3) {
 181          croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined";
 182     }
 183
 184     my $class = ref($this) || $this;
 185     my $self = {};
 186     bless $self, $class;
 187
 188     if (exists $param{logfh}) {
 189          $self->{logfh} = $param{logfh}
 190     }
 191     elsif (exists $param{log_name}) {
 192          $self->{logfh} = IO::File->new($param{log_name},'r') or
 193               die "Unable to open bug log $param{log_name} for reading: $!";
 194     }
 195     elsif (exists $param{bug_num}) {
 196          my $location = getbuglocation($bug,'log');
 197          my $bug_log = getbugcomponent($bug,'log',$location);
 198          $self->{logfh} = IO::File->new($bug_log, 'r') or
 199               die "Unable to open bug log $bug_log for reading: $!";
 200     }
 201
 202     $self->{state} = 'kill-init';
 203     $self->{linenum} = 0;
 204     return $self;
 205 }
 206
 207 =item read_record
 208
 209 Reads and returns a single record from a log reader object. At end of file,
 210 returns undef. Throws exceptions using die(), so you may want to wrap this
 211 in an eval().
 212
 213 =cut
 214
 215 sub read_record
 216 {
 217     my $this = shift;
 218     my $logfh = $this->{logfh};
 219
 220     # This comes from bugreport.cgi, but is much simpler since it doesn't
 221     # worry about the details of output.
 222
 223     my $record = {};
 224
 225     while (defined (my $line = <$logfh>)) {
 226         chomp $line;
 227         ++$this->{linenum};
 228         if (length($line) == 1 and exists $states{ord($line)}) {
 229             # state transitions
 230             my $newstate = $states{ord($line)};
 231
 232             # disallowed transitions
 233             $_ = "$this->{state} $newstate";
 234             unless (/^(go|go-nox|html) kill-end$/ or
 235                     /^(kill-init|kill-end) (incoming-recv|autocheck|recips|html)$/ or
 236                     /^kill-body go$/) {
 237                 die "transition from $this->{state} to $newstate at $this->{linenum} disallowed";
 238             }
 239
 240             $this->{state} = $newstate;
 241
 242             if ($this->{state} =~ /^(autocheck|recips|html|incoming-recv)$/) {
 243                 $record->{type} = $this->{state};
 244             } elsif ($this->{state} eq 'kill-end') {
 245                 return $record;
 246             }
 247
 248             next;
 249         }
 250
 251         $_ = $line;
 252         if ($this->{state} eq 'incoming-recv') {
 253             my $pl = $_;
 254             unless (/^Received: \(at \S+\) by \S+;/) {
 255                 die "bad line '$pl' in state incoming-recv";
 256             }
 257             $this->{state} = 'go';
 258             $record->{text} .= "$_\n";
 259         } elsif ($this->{state} eq 'html') {
 260             $record->{text} .= "$_\n";
 261         } elsif ($this->{state} eq 'go') {
 262             s/^\030//;
 263             $record->{text} .= "$_\n";
 264         } elsif ($this->{state} eq 'go-nox') {
 265             $record->{text} .= "$_\n";
 266         } elsif ($this->{state} eq 'recips') {
 267             if (/^-t$/) {
 268                 undef $record->{recips};
 269             } else {
 270                 # preserve trailing null fields, e.g. #2298
 271                 $record->{recips} = [split /\04/, $_, -1];
 272             }
 273             $this->{state} = 'kill-body';
 274         } elsif ($this->{state} eq 'autocheck') {
 275             $record->{text} .= "$_\n";
 276             next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/;
 277             $this->{state} = 'autowait';
 278         } elsif ($this->{state} eq 'autowait') {
 279             $record->{text} .= "$_\n";
 280             next if !/^$/;
 281             $this->{state} = 'go-nox';
 282         } else {
 283             die "state $this->{state} at line $this->{linenum} ('$_')";
 284         }
 285     }
 286     die "state $this->{state} at end" unless $this->{state} eq 'kill-end';
 287
 288     if (keys %$record) {
 289         return $record;
 290     } else {
 291         return undef;
 292     }
 293 }
 294
 295 =item read_log_records
 296
 297 Takes a .log filehandle as input, and returns an array of all records in
 298 that file. Throws exceptions using die(), so you may want to wrap this in an
 299 eval().
 300
 301 =cut
 302
 303 sub read_log_records (*)
 304 {
 305     my $logfh = shift;
 306
 307     my @records;
 308     my $reader = Debbugs::Log->new($logfh);
 309     while (defined(my $record = $reader->read_record())) {
 310         push @records, $record;
 311     }
 312     return @records;
 313 }
 314
 315 =item write_log_records
 316
 317 Takes a filehandle and a list of records as input, and prints the .log
 318 format representation of those records to that filehandle.
 319
 320 =cut
 321
 322 sub write_log_records (*@)
 323 {
 324     my $logfh = shift;
 325     my @records = @_;
 326
 327     for my $record (@records) {
 328         my $type = $record->{type};
 329         my ($text) = escape_log($record->{text});
 330         die "type '$type' with no text field" unless defined $text;
 331         if ($type eq 'autocheck') {
 332             print $logfh "\01\n$text\03\n";
 333         } elsif ($type eq 'recips') {
 334             print $logfh "\02\n";
 335             my $recips = $record->{recips};
 336             if (defined $recips) {
 337                 die "recips not undef or array"
 338                     unless ref($recips) eq 'ARRAY';
 339                 print $logfh join("\04", @$recips) . "\n";
 340             } else {
 341                 print $logfh "-t\n";
 342             }
 343             #$text =~ s/^([\01-\07\030])/\030$1/gm;
 344             print $logfh "\05\n$text\03\n";
 345         } elsif ($type eq 'html') {
 346             print $logfh "\06\n$text\03\n";
 347         } elsif ($type eq 'incoming-recv') {
 348             #$text =~ s/^([\01-\07\030])/\030$1/gm;
 349             print $logfh "\07\n$text\03\n";
 350         } else {
 351             die "unknown type '$type'";
 352         }
 353     }
 354
 355     1;
 356 }
 357
 358 =head2 escape_log
 359
 360      print {$log} escape_log(@log)
 361
 362 Applies the log escape regex to the passed logfile.
 363
 364 =cut
 365
 366 sub escape_log {
 367         my @log = @_;
 368         return map { s/^([\01-\07\030])/\030$1/gm; $_ } @log;
 369 }
 370
 371
 372 =back
 373
 374 =head1 CAVEATS
 375
 376 This module does none of the formatting that bugreport.cgi et al do. It's
 377 simply a means for extracting and rewriting raw records.
 378
 379 =cut
 380
 381 1;