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         chomp $line;
 253         ++$this->{linenum};
 254         if (length($line) == 1 and exists $states{ord($line)}) {
 255             # state transitions
 256             my $newstate = $states{ord($line)};
 257
 258             # disallowed transitions
 259             $_ = "$this->{state} $newstate";
 260             unless (/^(go|go-nox|html) kill-end$/ or
 261                     /^(kill-init|kill-end) (incoming-recv|autocheck|recips|html)$/ or
 262                     /^kill-body go$/) {
 263                 die "transition from $this->{state} to $newstate at $this->{linenum} disallowed";
 264             }
 265
 266             $this->{state} = $newstate;
 267             if ($this->{state} =~ /^(autocheck|recips|html|incoming-recv)$/) {
 268             $record->{type} = $this->{state};
 269             $record->{start} = $logfh->tell;
 270             $record->{stop} = $logfh->tell;
 271             $record->{inner_file} = $this->{inner_file};
 272             } elsif ($this->{state} eq 'kill-end') {
 273             if ($this->{inner_file}) {
 274                 $record->{fh} = IO::InnerFile->new($logfh,$record->{start},$record->{stop} - $record->{start})
 275             }
 276                 return $record;
 277             }
 278
 279             next;
 280         }
 281     $record->{stop} = $logfh->tell;
 282         $_ = $line;
 283         if ($this->{state} eq 'incoming-recv') {
 284             my $pl = $_;
 285             unless (/^Received: \(at \S+\) by \S+;/) {
 286                 die "bad line '$pl' in state incoming-recv";
 287             }
 288             $this->{state} = 'go';
 289             $record->{text} .= "$_\n" unless $this->{inner_file};
 290         } elsif ($this->{state} eq 'html') {
 291             $record->{text} .= "$_\n"  unless $this->{inner_file};
 292         } elsif ($this->{state} eq 'go') {
 293             s/^\030//;
 294             $record->{text} .= "$_\n"  unless $this->{inner_file};
 295         } elsif ($this->{state} eq 'go-nox') {
 296             $record->{text} .= "$_\n"  unless $this->{inner_file};
 297         } elsif ($this->{state} eq 'recips') {
 298             if (/^-t$/) {
 299                 undef $record->{recips};
 300             } else {
 301                 # preserve trailing null fields, e.g. #2298
 302                 $record->{recips} = [split /\04/, $_, -1];
 303             }
 304             $this->{state} = 'kill-body';
 305         $record->{start} = $logfh->tell+2;
 306         $record->{stop} = $logfh->tell+2;
 307         $record->{inner_file} = $this->{inner_file};
 308         } elsif ($this->{state} eq 'autocheck') {
 309             $record->{text} .= "$_\n" unless $this->{inner_file};
 310             next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/;
 311             $this->{state} = 'autowait';
 312         } elsif ($this->{state} eq 'autowait') {
 313             $record->{text} .= "$_\n" unless $this->{inner_file};
 314             next if !/^$/;
 315             $this->{state} = 'go-nox';
 316         } else {
 317             die "state $this->{state} at line $this->{linenum} ('$_')";
 318         }
 319     }
 320     die "state $this->{state} at end" unless $this->{state} eq 'kill-end';
 321
 322     if (keys %$record) {
 323         return $record;
 324     } else {
 325         return undef;
 326     }
 327 }
 328
 329 =item read_log_records
 330
 331 Takes a .log filehandle as input, and returns an array of all records in
 332 that file. Throws exceptions using die(), so you may want to wrap this in an
 333 eval().
 334
 335 Uses exactly the same options as Debbugs::Log::new
 336
 337 =cut
 338
 339 sub read_log_records
 340 {
 341     my %param;
 342     if (@_ == 1) {
 343          ($param{logfh}) = @_;
 344     }
 345     else {
 346          %param = validate_with(params => \@_,
 347                                 spec   => {bug_num => {type => SCALAR,
 348                                                        optional => 1,
 349                                                       },
 350                                            logfh   => {type => HANDLE,
 351                                                        optional => 1,
 352                                                       },
 353                                            log_name => {type => SCALAR,
 354                                                         optional => 1,
 355                                                        },
 356                            inner_file => {type => BOOLEAN,
 357                                           default => 0,
 358                                          },
 359                                           }
 360                                );
 361     }
 362     if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) {
 363          croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined";
 364     }
 365
 366     my @records;
 367     my $reader = Debbugs::Log->new(%param);
 368     while (defined(my $record = $reader->read_record())) {
 369         push @records, $record;
 370     }
 371     return @records;
 372 }
 373
 374 =item write_log_records
 375
 376 Takes a filehandle and a list of records as input, and prints the .log
 377 format representation of those records to that filehandle.
 378
 379 =back
 380
 381 =cut
 382
 383 sub write_log_records
 384 {
 385     my %param = validate_with(params => \@_,
 386                               spec   => {bug_num => {type => SCALAR,
 387                                                      optional => 1,
 388                                                     },
 389                                          logfh   => {type => HANDLE,
 390                                                      optional => 1,
 391                                                     },
 392                                          log_name => {type => SCALAR,
 393                                                       optional => 1,
 394                                                      },
 395                                          records => {type => HASHREF|ARRAYREF,
 396                                                     },
 397                                         },
 398                              );
 399     if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) {
 400          croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined";
 401     }
 402     my $logfh;
 403     if (exists $param{logfh}) {
 404          $logfh = $param{logfh}
 405     }
 406     elsif (exists $param{log_name}) {
 407          $logfh = IO::File->new(">>$param{log_name}") or
 408               die "Unable to open bug log $param{log_name} for writing: $!";
 409     }
 410     elsif (exists $param{bug_num}) {
 411          my $location = getbuglocation($param{bug_num},'log');
 412          my $bug_log = getbugcomponent($param{bug_num},'log',$location);
 413          $logfh = IO::File->new($bug_log, 'r') or
 414               die "Unable to open bug log $bug_log for reading: $!";
 415     }
 416     my @records = make_list($param{records});
 417
 418     for my $record (@records) {
 419         my $type = $record->{type};
 420         croak "record type '$type' with no text field" unless defined $record->{text};
 421         # I am not sure if we really want to croak here; but this is
 422         # almost certainly a bug if is_utf8 is on.
 423         my $text = $record->{text};
 424         if (is_utf8($text)) {
 425             carp('Record text was in the wrong encoding (perl internal instead of utf8 octets)');
 426             $text = encode_utf8($text)
 427         }
 428         ($text) = escape_log($text);
 429         if ($type eq 'autocheck') {
 430             print {$logfh} "\01\n$text\03\n" or
 431                 die "Unable to write to logfile: $!";
 432         } elsif ($type eq 'recips') {
 433             print {$logfh} "\02\n";
 434             my $recips = $record->{recips};
 435             if (defined $recips) {
 436                 croak "recips not undef or array"
 437                     unless ref($recips) eq 'ARRAY';
 438                 my $wrong_encoding = 0;
 439                 my @recips =
 440                     map { if (is_utf8($_)) {
 441                         $wrong_encoding=1;
 442                         encode_utf8($_);
 443                     } else {
 444                         $_;
 445                     }} @$recips;
 446                 carp('Recipients was in the wrong encoding (perl internal instead of utf8 octets') if $wrong_encoding;
 447                 print {$logfh} join("\04", @$recips) . "\n" or
 448                     die "Unable to write to logfile: $!";
 449             } else {
 450                 print {$logfh} "-t\n" or
 451                     die "Unable to write to logfile: $!";
 452             }
 453             #$text =~ s/^([\01-\07\030])/\030$1/gm;
 454             print {$logfh} "\05\n$text\03\n" or
 455                 die "Unable to write to logfile: $!";
 456         } elsif ($type eq 'html') {
 457             print {$logfh} "\06\n$text\03\n" or
 458                 die "Unable to write to logfile: $!";
 459         } elsif ($type eq 'incoming-recv') {
 460             #$text =~ s/^([\01-\07\030])/\030$1/gm;
 461             print {$logfh} "\07\n$text\03\n" or
 462                 die "Unable to write to logfile: $!";
 463         } else {
 464             croak "unknown record type type '$type'";
 465         }
 466     }
 467
 468     1;
 469 }
 470
 471 =head2 escape_log
 472
 473      print {$log} escape_log(@log)
 474
 475 Applies the log escape regex to the passed logfile.
 476
 477 =cut
 478
 479 sub escape_log {
 480         my @log = @_;
 481         return map {s/^([\01-\07\030])/\030$1/gm; $_ } @log;
 482 }
 483
 484
 485 sub record_text {
 486     my ($record) = @_;
 487     if ($record->{inner_file}) {
 488         local $/;
 489         my $text;
 490         my $t = $record->{fh};
 491         $text = <$t>;
 492         $record->{fh}->seek(0,0);
 493         return $text;
 494     } else {
 495         return $record->{text};
 496     }
 497 }
 498
 499 sub record_regex {
 500     my ($record,$regex) = @_;
 501     if ($record->{inner_file}) {
 502         my @result;
 503         my $fh = $record->{fh};
 504         while (<$fh>) {
 505             if (@result = $_ =~ m/$regex/) {
 506                 $record->{fh}->seek(0,0);
 507                 return @result;
 508             }
 509         }
 510         $record->{fh}->seek(0,0);
 511         return ();
 512     } else {
 513         my @result = $record->{text} =~ m/$regex/;
 514         return @result;
 515     }
 516 }
 517
 518
 519 =head1 CAVEATS
 520
 521 This module does none of the formatting that bugreport.cgi et al do. It's
 522 simply a means for extracting and rewriting raw records.
 523
 524 =cut
 525
 526 1;
 527
 528 # Local Variables:
 529 # indent-tabs-mode: nil
 530 # cperl-indent-level: 4
 531 # End: