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