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