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 use Mouse;
  15 use strictures 2;
  16 use namespace::clean;
  17 use v5.10; # for state
  18
  19 use vars qw($VERSION $DEBUG @EXPORT @EXPORT_OK %EXPORT_TAGS);
  20 use Exporter qw(import);
  21
  22 BEGIN {
  23     $VERSION = 1.00;
  24     $DEBUG = 0 unless defined $DEBUG;
  25
  26     @EXPORT = ();
  27     %EXPORT_TAGS = (write => [qw(write_log_records),
  28                              ],
  29                     read  => [qw(read_log_records record_text record_regex),
  30                              ],
  31                     misc  => [qw(escape_log),
  32                              ],
  33                    );
  34     @EXPORT_OK = ();
  35     Exporter::export_ok_tags(qw(write read misc));
  36     $EXPORT_TAGS{all} = [@EXPORT_OK];
  37 }
  38
  39 use Carp;
  40
  41 use Debbugs::Common qw(getbuglocation getbugcomponent make_list);
  42 use Params::Validate qw(:types validate_with);
  43 use Encode qw(encode encode_utf8 is_utf8);
  44 use IO::InnerFile;
  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 BUILD {
 169     my ($self,$args) = @_;
 170     if (not ($self->_has_bug_num or
 171              $self->_has_logfh or
 172              $self->_has_log_name)) {
 173         croak "Exactly one of bug_num, logfh, or log_name ".
 174             "must be passed and must be defined";
 175     }
 176 }
 177
 178 has 'bug_num' =>
 179     (is => 'ro',
 180      isa => 'Int',
 181      predicate => '_has_bug_num',
 182     );
 183
 184 has 'logfh' =>
 185     (is => 'ro',
 186      lazy => 1,
 187      builder => '_build_logfh',
 188      predicate => '_has_logfh',
 189     );
 190
 191 sub _build_logfh {
 192     my $self = shift;
 193     my $bug_log =
 194         $self->log_name;
 195     my $log_fh;
 196     if ($bug_log =~ m/\.gz$/) {
 197         my $oldpath = $ENV{'PATH'};
 198         $ENV{'PATH'} = '/bin:/usr/bin';
 199         open($log_fh,'-|','gzip','-dc',$bug_log) or
 200             die "Unable to open $bug_log for reading: $!";
 201         $ENV{'PATH'} = $oldpath;
 202     } else {
 203         open($log_fh,'<',$bug_log) or
 204             die "Unable to open $bug_log for reading: $!";
 205     }
 206     return $log_fh;
 207 }
 208
 209 has 'log_name' =>
 210     (is => 'ro',
 211      isa => 'Str',
 212      lazy => 1,
 213      builder => '_build_log_name',
 214      predicate => '_has_log_name',
 215     );
 216
 217 sub _build_log_name {
 218     my $self = shift;
 219     my $location = getbuglocation($self->bug_num,'log');
 220     return getbugcomponent($self->bug_num,'log',$location);
 221 }
 222
 223 has 'inner_file' =>
 224     (is => 'ro',
 225      isa => 'Bool',
 226      default => 0,
 227     );
 228
 229 has 'state' =>
 230     (is => 'ro',
 231      isa => 'Str',
 232      default => 'kill-init',
 233      writer => '_state',
 234     );
 235
 236 sub state_transition {
 237     my $self = shift;
 238     my $new_state = shift;
 239     my $old_state = $self->state;
 240     local $_ = "$old_state $new_state";
 241     unless (/^(go|go-nox|html) kill-end$/ or
 242             /^(kill-init|kill-end) (incoming-recv|autocheck|recips|html)$/ or
 243             /^autocheck autowait$/ or
 244             /^autowait go-nox$/ or
 245             /^recips kill-body$/ or
 246             /^(kill-body|incoming-recv) go$/) {
 247         confess "transition from $old_state to $new_state at $self->linenum disallowed";
 248     }
 249     $self->_state($new_state);
 250 }
 251
 252 sub increment_linenum {
 253     my $self = shift;
 254     $self->_linenum($self->_linenum+1);
 255 }
 256 has '_linenum' =>
 257     (is => 'rw',
 258      isa => 'Int',
 259      default => 0,
 260     );
 261
 262 =item read_record
 263
 264 Reads and returns a single record from a log reader object. At end of file,
 265 returns undef. Throws exceptions using die(), so you may want to wrap this
 266 in an eval().
 267
 268 =cut
 269
 270 sub read_record
 271 {
 272     my $this = shift;
 273     my $logfh = $this->logfh;
 274
 275     # This comes from bugreport.cgi, but is much simpler since it doesn't
 276     # worry about the details of output.
 277
 278     my $record = {};
 279
 280     while (defined (my $line = <$logfh>)) {
 281         $record->{start} = $logfh->tell() if not defined $record->{start};
 282         chomp $line;
 283         $this->increment_linenum;
 284         if (length($line) == 1 and exists $states{ord($line)}) {
 285             # state transitions
 286             $this->state_transition($states{ord($line)});
 287             if ($this->state =~ /^(autocheck|recips|html|incoming-recv)$/) {
 288                 $record->{type} = $this->state;
 289                 $record->{start} = $logfh->tell;
 290                 $record->{stop} = $logfh->tell;
 291                 $record->{inner_file} = $this->inner_file;
 292             } elsif ($this->state eq 'kill-end') {
 293                 if ($this->inner_file) {
 294                     $record->{fh} =
 295                         IO::InnerFile->new($logfh,$record->{start},
 296                                            $record->{stop} - $record->{start})
 297                         }
 298                 return $record;
 299             }
 300
 301             next;
 302         }
 303         $record->{stop} = $logfh->tell;
 304         $_ = $line;
 305         if ($this->state eq 'incoming-recv') {
 306             my $pl = $_;
 307             unless (/^Received: \(at \S+\) by \S+;/) {
 308                 die "bad line '$pl' in state incoming-recv";
 309             }
 310             $this->state_transition('go');
 311             $record->{text} .= "$_\n" unless $this->inner_file;
 312         } elsif ($this->state eq 'html') {
 313             $record->{text} .= "$_\n"  unless $this->inner_file;
 314         } elsif ($this->state eq 'go') {
 315             s/^\030//;
 316             $record->{text} .= "$_\n"  unless $this->inner_file;
 317         } elsif ($this->state eq 'go-nox') {
 318             $record->{text} .= "$_\n"  unless $this->inner_file;
 319         } elsif ($this->state eq 'recips') {
 320             if (/^-t$/) {
 321                 undef $record->{recips};
 322             } else {
 323                 # preserve trailing null fields, e.g. #2298
 324                 $record->{recips} = [split /\04/, $_, -1];
 325             }
 326             $this->state_transition('kill-body');
 327             $record->{start} = $logfh->tell+2;
 328             $record->{stop} = $logfh->tell+2;
 329             $record->{inner_file} = $this->inner_file;
 330         } elsif ($this->state eq 'autocheck') {
 331             $record->{text} .= "$_\n" unless $this->inner_file;
 332             next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/;
 333             $this->state_transition('autowait');
 334         } elsif ($this->state eq 'autowait') {
 335             $record->{text} .= "$_\n" unless $this->inner_file;
 336             next if !/^$/;
 337             $this->state_transition('go-nox');
 338         } else {
 339             die "state $this->state at line $this->linenum ('$_')";
 340         }
 341     }
 342     die "state $this->state at end" unless $this->state eq 'kill-end';
 343
 344     if (keys %$record) {
 345         return $record;
 346     } else {
 347         return undef;
 348     }
 349 }
 350
 351 =item rewind
 352
 353 Rewinds the Debbugs::Log to the beginning
 354
 355 =cut
 356
 357 sub rewind {
 358     my $self = shift;
 359     if ($self->_has_log_name) {
 360         $self->_clear_log_fh;
 361     } else {
 362         $self->log_fh->seek(0);
 363     }
 364     $self->_state('kill-init');
 365     $self->_linenum(0);
 366 }
 367
 368 =item read_all_records
 369
 370 Reads all of the Debbugs::Records
 371
 372 =cut
 373
 374 sub read_all_records {
 375     my $self = shift;
 376     if ($self->_linenum != 0) {
 377         $self->rewind;
 378     }
 379     my @records;
 380     while (defined(my $record = $self->read_record())) {
 381         push @records, $record;
 382     }
 383     return @records;
 384 }
 385
 386
 387 =item read_log_records
 388
 389 Takes a .log filehandle as input, and returns an array of all records in
 390 that file. Throws exceptions using die(), so you may want to wrap this in an
 391 eval().
 392
 393 Uses exactly the same options as Debbugs::Log::new
 394
 395 =cut
 396
 397 sub read_log_records
 398 {
 399     my %param;
 400     if (@_ == 1) {
 401          ($param{logfh}) = @_;
 402     }
 403     else {
 404          %param = validate_with(params => \@_,
 405                                 spec   => {bug_num => {type => SCALAR,
 406                                                        optional => 1,
 407                                                       },
 408                                            logfh   => {type => HANDLE,
 409                                                        optional => 1,
 410                                                       },
 411                                            log_name => {type => SCALAR,
 412                                                         optional => 1,
 413                                                        },
 414                            inner_file => {type => BOOLEAN,
 415                                           default => 0,
 416                                          },
 417                                           }
 418                                );
 419     }
 420     if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) {
 421          croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined";
 422     }
 423
 424     my @records;
 425     my $reader = Debbugs::Log->new(%param);
 426     while (defined(my $record = $reader->read_record())) {
 427         push @records, $record;
 428     }
 429     return @records;
 430 }
 431
 432 =item write_log_records
 433
 434 Takes a filehandle and a list of records as input, and prints the .log
 435 format representation of those records to that filehandle.
 436
 437 =back
 438
 439 =cut
 440
 441 sub write_log_records
 442 {
 443     my %param = validate_with(params => \@_,
 444                               spec   => {bug_num => {type => SCALAR,
 445                                                      optional => 1,
 446                                                     },
 447                                          logfh   => {type => HANDLE,
 448                                                      optional => 1,
 449                                                     },
 450                                          log_name => {type => SCALAR,
 451                                                       optional => 1,
 452                                                      },
 453                                          records => {type => HASHREF|ARRAYREF,
 454                                                     },
 455                                         },
 456                              );
 457     if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) {
 458          croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined";
 459     }
 460     my $logfh;
 461     if (exists $param{logfh}) {
 462          $logfh = $param{logfh}
 463     }
 464     elsif (exists $param{log_name}) {
 465          $logfh = IO::File->new(">>$param{log_name}") or
 466               die "Unable to open bug log $param{log_name} for writing: $!";
 467     }
 468     elsif (exists $param{bug_num}) {
 469          my $location = getbuglocation($param{bug_num},'log');
 470          my $bug_log = getbugcomponent($param{bug_num},'log',$location);
 471          $logfh = IO::File->new($bug_log, 'r') or
 472               die "Unable to open bug log $bug_log for reading: $!";
 473     }
 474     my @records = make_list($param{records});
 475
 476     for my $record (@records) {
 477         my $type = $record->{type};
 478         croak "record type '$type' with no text field" unless defined $record->{text};
 479         # I am not sure if we really want to croak here; but this is
 480         # almost certainly a bug if is_utf8 is on.
 481         my $text = $record->{text};
 482         if (is_utf8($text)) {
 483             carp('Record text was in the wrong encoding (perl internal instead of utf8 octets)');
 484             $text = encode_utf8($text)
 485         }
 486         ($text) = escape_log($text);
 487         if ($type eq 'autocheck') {
 488             print {$logfh} "\01\n$text\03\n" or
 489                 die "Unable to write to logfile: $!";
 490         } elsif ($type eq 'recips') {
 491             print {$logfh} "\02\n";
 492             my $recips = $record->{recips};
 493             if (defined $recips) {
 494                 croak "recips not undef or array"
 495                     unless ref($recips) eq 'ARRAY';
 496                 my $wrong_encoding = 0;
 497                 my @recips =
 498                     map { if (is_utf8($_)) {
 499                         $wrong_encoding=1;
 500                         encode_utf8($_);
 501                     } else {
 502                         $_;
 503                     }} @$recips;
 504                 carp('Recipients was in the wrong encoding (perl internal instead of utf8 octets') if $wrong_encoding;
 505                 print {$logfh} join("\04", @$recips) . "\n" or
 506                     die "Unable to write to logfile: $!";
 507             } else {
 508                 print {$logfh} "-t\n" or
 509                     die "Unable to write to logfile: $!";
 510             }
 511             #$text =~ s/^([\01-\07\030])/\030$1/gm;
 512             print {$logfh} "\05\n$text\03\n" or
 513                 die "Unable to write to logfile: $!";
 514         } elsif ($type eq 'html') {
 515             print {$logfh} "\06\n$text\03\n" or
 516                 die "Unable to write to logfile: $!";
 517         } elsif ($type eq 'incoming-recv') {
 518             #$text =~ s/^([\01-\07\030])/\030$1/gm;
 519             print {$logfh} "\07\n$text\03\n" or
 520                 die "Unable to write to logfile: $!";
 521         } else {
 522             croak "unknown record type type '$type'";
 523         }
 524     }
 525
 526     1;
 527 }
 528
 529 =head2 escape_log
 530
 531      print {$log} escape_log(@log)
 532
 533 Applies the log escape regex to the passed logfile.
 534
 535 =cut
 536
 537 sub escape_log {
 538         my @log = @_;
 539         return map {s/^([\01-\07\030])/\030$1/gm; $_ } @log;
 540 }
 541
 542
 543 sub record_text {
 544     my ($record) = @_;
 545     if ($record->{inner_file}) {
 546         local $/;
 547         my $text;
 548         my $t = $record->{fh};
 549         $text = <$t>;
 550         $record->{fh}->seek(0,0);
 551         return $text;
 552     } else {
 553         return $record->{text};
 554     }
 555 }
 556
 557 sub record_regex {
 558     my ($record,$regex) = @_;
 559     if ($record->{inner_file}) {
 560         my @result;
 561         my $fh = $record->{fh};
 562         while (<$fh>) {
 563             if (@result = $_ =~ m/$regex/) {
 564                 $record->{fh}->seek(0,0);
 565                 return @result;
 566             }
 567         }
 568         $record->{fh}->seek(0,0);
 569         return ();
 570     } else {
 571         my @result = $record->{text} =~ m/$regex/;
 572         return @result;
 573     }
 574 }
 575
 576
 577 =head1 CAVEATS
 578
 579 This module does none of the formatting that bugreport.cgi et al do. It's
 580 simply a means for extracting and rewriting raw records.
 581
 582 =cut
 583
 584 1;
 585
 586 # Local Variables:
 587 # indent-tabs-mode: nil
 588 # cperl-indent-level: 4
 589 # End: