--- /dev/null
+# 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 <cjwatson@debian.org>
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>
+
+
+package Debbugs::Log;
+
+use Mouse;
+use strictures 2;
+use namespace::clean;
+use v5.10; # for state
+
+use vars qw($VERSION $DEBUG @EXPORT @EXPORT_OK %EXPORT_TAGS);
+use Exporter qw(import);
+
+BEGIN {
+ $VERSION = 1.00;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ %EXPORT_TAGS = (write => [qw(write_log_records),
+ ],
+ read => [qw(read_log_records record_text record_regex),
+ ],
+ 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);
+use Encode qw(encode encode_utf8 is_utf8);
+use IO::InnerFile;
+
+=head1 NAME
+
+Debbugs::Log - an interface to debbugs .log files
+
+=head1 DESCRIPTION
+
+The Debbugs::Log module provides a convenient way for scripts to read and
+write the .log files used by debbugs to store the complete textual records
+of all bug transactions.
+
+Debbugs::Log does not decode utf8 into perl's internal encoding or
+encode into utf8 from perl's internal encoding. For html records and
+all recips, this should probably be done. For other records, this should
+not be needed.
+
+=head2 The .log File Format
+
+.log files consist of a sequence of records, of one of the following four
+types. ^A, ^B, etc. represent those control characters.
+
+=over 4
+
+=item incoming-recv
+
+ ^G
+ [mail]
+ ^C
+
+C<[mail]> must start with /^Received: \(at \S+\) by \S+;/, and is copied to
+the output.
+
+=item autocheck
+
+Auto-forwarded messages are recorded like this:
+
+ ^A
+ [mail]
+ ^C
+
+C<[mail]> must contain /^X-Debian-Bugs(-\w+)?: This is an autoforward from
+\S+/. The first line matching that is removed; all lines in the message body
+that begin with 'X' will be copied to the output, minus the 'X'.
+
+Nothing in debbugs actually generates this record type any more, but it may
+still be in old .logs at some sites.
+
+=item recips
+
+ ^B
+ [recip]^D[recip]^D[...] OR -t
+ ^E
+ [mail]
+ ^C
+
+Each [recip] is output after "Message sent"; C<-t> represents the same
+sendmail option, indicating that the recipients are taken from the headers
+of the message itself.
+
+=item html
+
+ ^F
+ [html]
+ ^C
+
+[html] is copied unescaped to the output. The record immediately following
+this one is considered "boring" and only shown in certain output modes.
+
+(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<type> field is C<incoming-recv>, C<autocheck>,
+C<recips>, or C<html> as above; C<text> contains text from C<[mail]> or
+C<[html]> as above; C<recips> is a reference to an array of recipients
+(strings), or undef for C<-t>.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item new
+
+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 BUILD {
+ my ($self,$args) = @_;
+ if (not ($self->_has_bug_num or
+ $self->_has_logfh or
+ $self->_has_log_name)) {
+ croak "Exactly one of bug_num, logfh, or log_name ".
+ "must be passed and must be defined";
+ }
+}
+
+has 'bug_num' =>
+ (is => 'ro',
+ isa => 'Int',
+ predicate => '_has_bug_num',
+ );
+
+has 'logfh' =>
+ (is => 'ro',
+ lazy => 1,
+ builder => '_build_logfh',
+ predicate => '_has_logfh',
+ );
+
+sub _build_logfh {
+ my $self = shift;
+ my $bug_log =
+ $self->log_name;
+ my $log_fh;
+ if ($bug_log =~ m/\.gz$/) {
+ my $oldpath = $ENV{'PATH'};
+ $ENV{'PATH'} = '/bin:/usr/bin';
+ open($log_fh,'-|','gzip','-dc',$bug_log) or
+ die "Unable to open $bug_log for reading: $!";
+ $ENV{'PATH'} = $oldpath;
+ } else {
+ open($log_fh,'<',$bug_log) or
+ die "Unable to open $bug_log for reading: $!";
+ }
+ return $log_fh;
+}
+
+has 'log_name' =>
+ (is => 'ro',
+ isa => 'Str',
+ lazy => 1,
+ builder => '_build_log_name',
+ predicate => '_has_log_name',
+ );
+
+sub _build_log_name {
+ my $self = shift;
+ my $location = getbuglocation($self->bug_num,'log');
+ return getbugcomponent($self->bug_num,'log',$location);
+}
+
+has 'inner_file' =>
+ (is => 'ro',
+ isa => 'Bool',
+ default => 0,
+ );
+
+has 'state' =>
+ (is => 'ro',
+ isa => 'Str',
+ default => 'kill-init',
+ writer => '_state',
+ );
+
+sub state_transition {
+ my $self = shift;
+ my $new_state = shift;
+ my $old_state = $self->state;
+ local $_ = "$old_state $new_state";
+ unless (/^(go|go-nox|html) kill-end$/ or
+ /^(kill-init|kill-end) (incoming-recv|autocheck|recips|html)$/ or
+ /^autocheck autowait$/ or
+ /^autowait go-nox$/ or
+ /^recips kill-body$/ or
+ /^(kill-body|incoming-recv) go$/) {
+ confess "transition from $old_state to $new_state at $self->linenum disallowed";
+ }
+ $self->_state($new_state);
+}
+
+sub increment_linenum {
+ my $self = shift;
+ $self->_linenum($self->_linenum+1);
+}
+has '_linenum' =>
+ (is => 'rw',
+ isa => 'Int',
+ default => 0,
+ );
+
+=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 $record = {};
+
+ while (defined (my $line = <$logfh>)) {
+ $record->{start} = $logfh->tell() if not defined $record->{start};
+ chomp $line;
+ $this->increment_linenum;
+ if (length($line) == 1 and exists $states{ord($line)}) {
+ # state transitions
+ $this->state_transition($states{ord($line)});
+ if ($this->state =~ /^(autocheck|recips|html|incoming-recv)$/) {
+ $record->{type} = $this->state;
+ $record->{start} = $logfh->tell;
+ $record->{stop} = $logfh->tell;
+ $record->{inner_file} = $this->inner_file;
+ } elsif ($this->state eq 'kill-end') {
+ if ($this->inner_file) {
+ $record->{fh} =
+ IO::InnerFile->new($logfh,$record->{start},
+ $record->{stop} - $record->{start})
+ }
+ return $record;
+ }
+
+ next;
+ }
+ $record->{stop} = $logfh->tell;
+ $_ = $line;
+ if ($this->state eq 'incoming-recv') {
+ my $pl = $_;
+ unless (/^Received: \(at \S+\) by \S+;/) {
+ die "bad line '$pl' in state incoming-recv";
+ }
+ $this->state_transition('go');
+ $record->{text} .= "$_\n" unless $this->inner_file;
+ } elsif ($this->state eq 'html') {
+ $record->{text} .= "$_\n" unless $this->inner_file;
+ } elsif ($this->state eq 'go') {
+ s/^\030//;
+ $record->{text} .= "$_\n" unless $this->inner_file;
+ } elsif ($this->state eq 'go-nox') {
+ $record->{text} .= "$_\n" unless $this->inner_file;
+ } elsif ($this->state eq 'recips') {
+ if (/^-t$/) {
+ undef $record->{recips};
+ } else {
+ # preserve trailing null fields, e.g. #2298
+ $record->{recips} = [split /\04/, $_, -1];
+ }
+ $this->state_transition('kill-body');
+ $record->{start} = $logfh->tell+2;
+ $record->{stop} = $logfh->tell+2;
+ $record->{inner_file} = $this->inner_file;
+ } elsif ($this->state eq 'autocheck') {
+ $record->{text} .= "$_\n" unless $this->inner_file;
+ next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/;
+ $this->state_transition('autowait');
+ } elsif ($this->state eq 'autowait') {
+ $record->{text} .= "$_\n" unless $this->inner_file;
+ next if !/^$/;
+ $this->state_transition('go-nox');
+ } else {
+ die "state $this->state at line $this->linenum ('$_')";
+ }
+ }
+ die "state $this->state at end" unless $this->state eq 'kill-end';
+
+ if (keys %$record) {
+ return $record;
+ } else {
+ return undef;
+ }
+}
+
+=item rewind
+
+Rewinds the Debbugs::Log to the beginning
+
+=cut
+
+sub rewind {
+ my $self = shift;
+ if ($self->_has_log_name) {
+ $self->_clear_log_fh;
+ } else {
+ $self->log_fh->seek(0);
+ }
+ $self->_state('kill-init');
+ $self->_linenum(0);
+}
+
+=item read_all_records
+
+Reads all of the Debbugs::Records
+
+=cut
+
+sub read_all_records {
+ my $self = shift;
+ if ($self->_linenum != 0) {
+ $self->rewind;
+ }
+ my @records;
+ while (defined(my $record = $self->read_record())) {
+ push @records, $record;
+ }
+ return @records;
+}
+
+
+=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,
+ },
+ inner_file => {type => BOOLEAN,
+ default => 0,
+ },
+ }
+ );
+ }
+ 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;
+}
+
+=item write_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
+{
+ 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}") 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};
+ croak "record type '$type' with no text field" unless defined $record->{text};
+ # I am not sure if we really want to croak here; but this is
+ # almost certainly a bug if is_utf8 is on.
+ my $text = $record->{text};
+ if (is_utf8($text)) {
+ carp('Record text was in the wrong encoding (perl internal instead of utf8 octets)');
+ $text = encode_utf8($text)
+ }
+ ($text) = escape_log($text);
+ if ($type eq 'autocheck') {
+ print {$logfh} "\01\n$text\03\n" or
+ die "Unable to write to logfile: $!";
+ } elsif ($type eq 'recips') {
+ print {$logfh} "\02\n";
+ my $recips = $record->{recips};
+ if (defined $recips) {
+ croak "recips not undef or array"
+ unless ref($recips) eq 'ARRAY';
+ my $wrong_encoding = 0;
+ my @recips =
+ map { if (is_utf8($_)) {
+ $wrong_encoding=1;
+ encode_utf8($_);
+ } else {
+ $_;
+ }} @$recips;
+ carp('Recipients was in the wrong encoding (perl internal instead of utf8 octets') if $wrong_encoding;
+ print {$logfh} join("\04", @$recips) . "\n" or
+ die "Unable to write to logfile: $!";
+ } else {
+ 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" or
+ die "Unable to write to logfile: $!";
+ } elsif ($type eq 'html') {
+ 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" or
+ die "Unable to write to logfile: $!";
+ } else {
+ croak "unknown record type type '$type'";
+ }
+ }
+
+ 1;
+}
+
+=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;
+}
+
+
+sub record_text {
+ my ($record) = @_;
+ if ($record->{inner_file}) {
+ local $/;
+ my $text;
+ my $t = $record->{fh};
+ $text = <$t>;
+ $record->{fh}->seek(0,0);
+ return $text;
+ } else {
+ return $record->{text};
+ }
+}
+
+sub record_regex {
+ my ($record,$regex) = @_;
+ if ($record->{inner_file}) {
+ my @result;
+ my $fh = $record->{fh};
+ while (<$fh>) {
+ if (@result = $_ =~ m/$regex/) {
+ $record->{fh}->seek(0,0);
+ return @result;
+ }
+ }
+ $record->{fh}->seek(0,0);
+ return ();
+ } else {
+ my @result = $record->{text} =~ m/$regex/;
+ return @result;
+ }
+}
+
+
+=head1 CAVEATS
+
+This module does none of the formatting that bugreport.cgi et al do. It's
+simply a means for extracting and rewriting raw records.
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
projects / debbugs.git / blobdiff