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