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