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