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