X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FLog.pm;h=e64d2369a371b131466dd7f8d7fdf3e4aae4e73b;hb=764cf056fc8d74fd4704bb90ba352d5d8ea5d55d;hp=fbc445883d5516d843fc1262b5e2da40a1cf0c4b;hpb=ef0444b333fa2266dbcf1d6dba5d09affe7bb10a;p=debbugs.git diff --git a/Debbugs/Log.pm b/Debbugs/Log.pm index fbc4458..e64d236 100644 --- a/Debbugs/Log.pm +++ b/Debbugs/Log.pm @@ -1,17 +1,45 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later +# version at your option. +# See the file README and COPYING for more information. +# +# [Other people have contributed to this file; their copyrights should +# go here too.] +# Copyright 2004 by Collin Watson +# Copyright 2007 by Don Armstrong + + package Debbugs::Log; + +use warnings; use strict; -use Exporter (); -use vars qw($VERSION @ISA @EXPORT); +use vars qw($VERSION $DEBUG @EXPORT @EXPORT_OK %EXPORT_TAGS); +use base qw(Exporter); BEGIN { $VERSION = 1.00; - - @ISA = qw(Exporter); - @EXPORT = qw(read_log_records write_log_records); + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (write => [qw(write_log_records), + ], + read => [qw(read_log_records), + ], + misc => [qw(escape_log), + ], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(qw(write read misc)); + $EXPORT_TAGS{all} = [@EXPORT_OK]; } +use Carp; + +use Debbugs::Common qw(getbuglocation getbugcomponent make_list); +use Params::Validate qw(:types validate_with); + =head1 NAME Debbugs::Log - an interface to debbugs .log files @@ -74,15 +102,26 @@ of the message itself. [html] is copied unescaped to the output. The record immediately following this one is considered "boring" and only shown in certain output modes. -No other types of records are permitted, and the file must end with a ^C -line. - (This is a design flaw in the log format, since it makes it difficult to change the HTML presentation later, or to present the data in an entirely different format.) =back +No other types of records are permitted, and the file must end with a ^C +line. + +=cut + +my %states = ( + 1 => 'autocheck', + 2 => 'recips', + 3 => 'kill-end', + 5 => 'go', + 6 => 'html', + 7 => 'incoming-recv', +); + =head2 Perl Record Representation Each record is a hash. The C field is C, C, @@ -94,99 +133,205 @@ C<[html]> as above; C is a reference to an array of recipients =over 4 -=item read_log_records +=item new -Takes a .log filehandle as input, and returns an array of all records in -that file. Throws exceptions using die(), so you may want to wrap this in an -eval(). +Creates a new log reader based on a .log filehandle. + + my $log = Debbugs::Log->new($logfh); + my $log = Debbugs::Log->new(bug_num => $nnn); + my $log = Debbugs::Log->new(logfh => $logfh); + +Parameters + +=over + +=item bug_num -- bug number + +=item logfh -- log filehandle + +=item log_name -- name of log + +=back + +One of the above options must be passed. =cut -sub read_log_records (*) +sub new { - my $logfh = shift; + my $this = shift; + my %param; + if (@_ == 1) { + ($param{logfh}) = @_; + } + else { + %param = validate_with(params => \@_, + spec => {bug_num => {type => SCALAR, + optional => 1, + }, + logfh => {type => HANDLE, + optional => 1, + }, + log_name => {type => SCALAR, + optional => 1, + }, + } + ); + } + if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) { + croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined"; + } - # This comes from bugreport.cgi, but is much simpler since it doesn't - # worry about the details of output. + my $class = ref($this) || $this; + my $self = {}; + bless $self, $class; + + if (exists $param{logfh}) { + $self->{logfh} = $param{logfh} + } + elsif (exists $param{log_name}) { + $self->{logfh} = IO::File->new($param{log_name},'r') or + die "Unable to open bug log $param{log_name} for reading: $!"; + } + elsif (exists $param{bug_num}) { + my $location = getbuglocation($param{bug_num},'log'); + my $bug_log = getbugcomponent($param{bug_num},'log',$location); + $self->{logfh} = IO::File->new($bug_log, 'r') or + die "Unable to open bug log $bug_log for reading: $!"; + } - my %states = ( - 1 => 'autocheck', - 2 => 'recips', - 3 => 'kill-end', - 5 => 'go', - 6 => 'html', - 7 => 'incoming-recv', - ); + $self->{state} = 'kill-init'; + $self->{linenum} = 0; + return $self; +} - my @records; +=item read_record + +Reads and returns a single record from a log reader object. At end of file, +returns undef. Throws exceptions using die(), so you may want to wrap this +in an eval(). + +=cut + +sub read_record +{ + my $this = shift; + my $logfh = $this->{logfh}; + + # This comes from bugreport.cgi, but is much simpler since it doesn't + # worry about the details of output. - my $normstate = 'kill-init'; - my $linenum = 0; my $record = {}; while (defined (my $line = <$logfh>)) { chomp $line; - ++$linenum; + ++$this->{linenum}; if (length($line) == 1 and exists $states{ord($line)}) { # state transitions my $newstate = $states{ord($line)}; # disallowed transitions - $_ = "$normstate $newstate"; + $_ = "$this->{state} $newstate"; unless (/^(go|go-nox|html) kill-end$/ or /^(kill-init|kill-end) (incoming-recv|autocheck|recips|html)$/ or /^kill-body go$/) { - die "transition from $normstate to $newstate at $linenum disallowed"; + die "transition from $this->{state} to $newstate at $this->{linenum} disallowed"; } - if ($newstate =~ /^(autocheck|recips|html|incoming-recv)$/) { - $record->{type} = $newstate; - } elsif ($newstate eq 'kill-end') { - push @records, $record; - $record = {}; + $this->{state} = $newstate; + + if ($this->{state} =~ /^(autocheck|recips|html|incoming-recv)$/) { + $record->{type} = $this->{state}; + } elsif ($this->{state} eq 'kill-end') { + return $record; } - $normstate = $newstate; next; } $_ = $line; - if ($normstate eq 'incoming-recv') { + if ($this->{state} eq 'incoming-recv') { my $pl = $_; unless (/^Received: \(at \S+\) by \S+;/) { die "bad line '$pl' in state incoming-recv"; } - $normstate = 'go'; + $this->{state} = 'go'; $record->{text} .= "$_\n"; - } elsif ($normstate eq 'html') { + } elsif ($this->{state} eq 'html') { $record->{text} .= "$_\n"; - } elsif ($normstate eq 'go') { + } elsif ($this->{state} eq 'go') { s/^\030//; $record->{text} .= "$_\n"; - } elsif ($normstate eq 'go-nox') { + } elsif ($this->{state} eq 'go-nox') { $record->{text} .= "$_\n"; - } elsif ($normstate eq 'recips') { + } elsif ($this->{state} eq 'recips') { if (/^-t$/) { undef $record->{recips}; } else { # preserve trailing null fields, e.g. #2298 $record->{recips} = [split /\04/, $_, -1]; } - $normstate = 'kill-body'; - } elsif ($normstate eq 'autocheck') { + $this->{state} = 'kill-body'; + } elsif ($this->{state} eq 'autocheck') { $record->{text} .= "$_\n"; next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/; - $normstate = 'autowait'; - } elsif ($normstate eq 'autowait') { + $this->{state} = 'autowait'; + } elsif ($this->{state} eq 'autowait') { $record->{text} .= "$_\n"; next if !/^$/; - $normstate = 'go-nox'; + $this->{state} = 'go-nox'; } else { - die "state $normstate at line $linenum ('$_')"; + die "state $this->{state} at line $this->{linenum} ('$_')"; } } - die "state $normstate at end" unless $normstate eq 'kill-end'; + die "state $this->{state} at end" unless $this->{state} eq 'kill-end'; + + if (keys %$record) { + return $record; + } else { + return undef; + } +} + +=item read_log_records + +Takes a .log filehandle as input, and returns an array of all records in +that file. Throws exceptions using die(), so you may want to wrap this in an +eval(). + +Uses exactly the same options as Debbugs::Log::new + +=cut + +sub read_log_records +{ + my %param; + if (@_ == 1) { + ($param{logfh}) = @_; + } + else { + %param = validate_with(params => \@_, + spec => {bug_num => {type => SCALAR, + optional => 1, + }, + logfh => {type => HANDLE, + optional => 1, + }, + log_name => {type => SCALAR, + optional => 1, + }, + } + ); + } + if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) { + croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined"; + } + my @records; + my $reader = Debbugs::Log->new(%param); + while (defined(my $record = $reader->read_record())) { + push @records, $record; + } return @records; } @@ -195,45 +340,95 @@ sub read_log_records (*) Takes a filehandle and a list of records as input, and prints the .log format representation of those records to that filehandle. +=back + =cut -sub write_log_records (*@) +sub write_log_records { - my $logfh = shift; - my @records = @_; + my %param = validate_with(params => \@_, + spec => {bug_num => {type => SCALAR, + optional => 1, + }, + logfh => {type => HANDLE, + optional => 1, + }, + log_name => {type => SCALAR, + optional => 1, + }, + records => {type => HASHREF|ARRAYREF, + }, + }, + ); + if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) { + croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined"; + } + my $logfh; + if (exists $param{logfh}) { + $logfh = $param{logfh} + } + elsif (exists $param{log_name}) { + $logfh = IO::File->new($param{log_name},'w') or + die "Unable to open bug log $param{log_name} for writing: $!"; + } + elsif (exists $param{bug_num}) { + my $location = getbuglocation($param{bug_num},'log'); + my $bug_log = getbugcomponent($param{bug_num},'log',$location); + $logfh = IO::File->new($bug_log, 'r') or + die "Unable to open bug log $bug_log for reading: $!"; + } + my @records = make_list($param{records}); for my $record (@records) { my $type = $record->{type}; - my $text = $record->{text}; - die "type '$type' with no text field" unless defined $text; + my ($text) = escape_log($record->{text}); + croak "record type '$type' with no text field" unless defined $text; if ($type eq 'autocheck') { - print $logfh "\01\n$text\03\n"; + print {$logfh} "\01\n$text\03\n" or + die "Unable to write to logfile: $!"; } elsif ($type eq 'recips') { - print $logfh "\02\n"; + print {$logfh} "\02\n"; my $recips = $record->{recips}; if (defined $recips) { - die "recips not undef or array" + croak "recips not undef or array" unless ref($recips) eq 'ARRAY'; - print $logfh join("\04", @$recips) . "\n"; + print {$logfh} join("\04", @$recips) . "\n" or + die "Unable to write to logfile: $!"; } else { - print $logfh "-t\n"; + print {$logfh} "-t\n" or + die "Unable to write to logfile: $!"; } - $text =~ s/^([\01-\07\030])/\030$1/gm; - print $logfh "\05\n$text\03\n"; + #$text =~ s/^([\01-\07\030])/\030$1/gm; + print {$logfh} "\05\n$text\03\n" or + die "Unable to write to logfile: $!"; } elsif ($type eq 'html') { - print $logfh "\06\n$text\03\n"; + print {$logfh} "\06\n$text\03\n" or + die "Unable to write to logfile: $!"; } elsif ($type eq 'incoming-recv') { - $text =~ s/^([\01-\07\030])/\030$1/gm; - print $logfh "\07\n$text\03\n"; + #$text =~ s/^([\01-\07\030])/\030$1/gm; + print {$logfh} "\07\n$text\03\n" or + die "Unable to write to logfile: $!"; } else { - die "unknown type '$type'"; + croak "unknown record type type '$type'"; } } 1; } -=back +=head2 escape_log + + print {$log} escape_log(@log) + +Applies the log escape regex to the passed logfile. + +=cut + +sub escape_log { + my @log = @_; + return map { s/^([\01-\07\030])/\030$1/gm; $_ } @log; +} + =head1 CAVEATS