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