Mousify Debbugs::Log and integrate with Debbugs::Bug

[debbugs.git] / Debbugs / Log.pm

diff --git a/Debbugs/Log.pm b/Debbugs/Log.pm
index c9a9e3002693531df28599014ef263f72f3626f6..710a844164624c37a4e712c5f7830adc86784f71 100644 (file)
--- a/Debbugs/Log.pm
+++ b/Debbugs/Log.pm
@@ -1,17 +1,48 @@
+# 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;
 
 package Debbugs::Log;
 

-use strict;
+use Mouse;
+use strictures 2;
+use namespace::clean;
+use v5.10; # for state

 
 

-use Exporter ();
-use vars qw($VERSION @ISA @EXPORT);
+use vars qw($VERSION $DEBUG @EXPORT @EXPORT_OK %EXPORT_TAGS);
+use Exporter qw(import);

 
 BEGIN {
     $VERSION = 1.00;
 
 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 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 NAME
 
 Debbugs::Log - an interface to debbugs .log files


@@ -22,6 +53,11 @@ 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.
 
 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
 =head2 The .log File Format
 
 .log files consist of a sequence of records, of one of the following four


@@ -109,20 +145,120 @@ C<[html]> as above; C<recips> is a reference to an array of recipients
 
 Creates a new log reader based on a .log filehandle.
 
 
 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
 
 =cut
 

-sub new
-{
-    my $this = shift;
-    my $class = ref($this) || $this;
-    my $self = {};
-    bless $self, $class;
-    $self->{logfh} = shift;
-    $self->{state} = 'kill-init';
-    $self->{linenum} = 0;
-    return $self;
+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,
 =item read_record
 
 Reads and returns a single record from a log reader object. At end of file,


@@ -134,7 +270,7 @@ in an eval().
 sub read_record
 {
     my $this = shift;
 sub read_record
 {
     my $this = shift;

-    my $logfh = $this->{logfh};
+    my $logfh = $this->logfh;

 
     # This comes from bugreport.cgi, but is much simpler since it doesn't
     # worry about the details of output.
 
     # This comes from bugreport.cgi, but is much simpler since it doesn't
     # worry about the details of output.


@@ -142,67 +278,68 @@ sub read_record
     my $record = {};
 
     while (defined (my $line = <$logfh>)) {
     my $record = {};
 
     while (defined (my $line = <$logfh>)) {

+        $record->{start} = $logfh->tell() if not defined $record->{start};

        chomp $line;
        chomp $line;

-       ++$this->{linenum};
+       $this->increment_linenum;

        if (length($line) == 1 and exists $states{ord($line)}) {
            # state transitions
        if (length($line) == 1 and exists $states{ord($line)}) {
            # state transitions

-           my $newstate = $states{ord($line)};
-
-           # disallowed transitions
-           $_ = "$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 $this->{state} to $newstate at $this->{linenum} disallowed";
-           }
-
-           $this->{state} = $newstate;
-
-           if ($this->{state} =~ /^(autocheck|recips|html|incoming-recv)$/) {
-               $record->{type} = $this->{state};
-           } elsif ($this->{state} eq 'kill-end') {
+           $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;
        }
                return $record;
            }
 
            next;
        }

-
+        $record->{stop} = $logfh->tell;

        $_ = $line;
        $_ = $line;

-       if ($this->{state} 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";
            }
            my $pl = $_;
            unless (/^Received: \(at \S+\) by \S+;/) {
                die "bad line '$pl' in state incoming-recv";
            }

-           $this->{state} = 'go';
-           $record->{text} .= "$_\n";
-       } elsif ($this->{state} eq 'html') {
-           $record->{text} .= "$_\n";
-       } elsif ($this->{state} eq 'go') {
+           $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//;
            s/^\030//;

-           $record->{text} .= "$_\n";
-       } elsif ($this->{state} eq 'go-nox') {
-           $record->{text} .= "$_\n";
-       } elsif ($this->{state} eq 'recips') {
+           $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];
            }
            if (/^-t$/) {
                undef $record->{recips};
            } else {
                # preserve trailing null fields, e.g. #2298
                $record->{recips} = [split /\04/, $_, -1];
            }

-           $this->{state} = 'kill-body';
-       } elsif ($this->{state} eq 'autocheck') {
-           $record->{text} .= "$_\n";
+           $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+)/;
            next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/;

-           $this->{state} = 'autowait';
-       } elsif ($this->{state} eq 'autowait') {
-           $record->{text} .= "$_\n";
+           $this->state_transition('autowait');
+       } elsif ($this->state eq 'autowait') {
+           $record->{text} .= "$_\n" unless $this->inner_file;

            next if !/^$/;
            next if !/^$/;

-           $this->{state} = 'go-nox';
+           $this->state_transition('go-nox');

        } else {
        } else {

-           die "state $this->{state} at line $this->{linenum} ('$_')";
+           die "state $this->state at line $this->linenum ('$_')";

        }
     }
        }
     }

-    die "state $this->{state} at end" unless $this->{state} eq 'kill-end';
+    die "state $this->state at end" unless $this->state eq 'kill-end';

 
     if (keys %$record) {
        return $record;
 
     if (keys %$record) {
        return $record;


@@ -211,20 +348,81 @@ sub read_record
     }
 }
 
     }
 }
 

+=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().
 
 =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
 
 =cut
 

-sub read_log_records (*)
+sub read_log_records

 {
 {

-    my $logfh = 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,
+                                                      },
+                           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 @records;

-    my $reader = Debbugs::Log->new($logfh);
+    my $reader = Debbugs::Log->new(%param);

     while (defined(my $record = $reader->read_record())) {
        push @records, $record;
     }
     while (defined(my $record = $reader->read_record())) {
        push @records, $record;
     }


@@ -236,45 +434,145 @@ 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.
 
 Takes a filehandle and a list of records as input, and prints the .log
 format representation of those records to that filehandle.
 

+=back
+

 =cut
 
 =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}") 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};
 
     for my $record (@records) {
        my $type = $record->{type};

-       my $text = $record->{text};
-       die "type '$type' with no text field" unless defined $text;
+       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') {
        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') {
        } elsif ($type eq 'recips') {

-           print $logfh "\02\n";
+           print {$logfh} "\02\n";

            my $recips = $record->{recips};
            if (defined $recips) {
            my $recips = $record->{recips};
            if (defined $recips) {

-               die "recips not undef or array"
+               croak "recips not undef or array"

                    unless ref($recips) eq 'ARRAY';
                    unless ref($recips) eq 'ARRAY';

-               print $logfh join("\04", @$recips) . "\n";
+                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 {
            } 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') {
        } 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') {
        } 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 {
        } else {

-           die "unknown type '$type'";
+           croak "unknown record type type '$type'";

        }
     }
 
     1;
 }
 
        }
     }
 
     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;
+}
+
+
+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
 
 
 =head1 CAVEATS
 


@@ -284,3 +582,8 @@ simply a means for extracting and rewriting raw records.
 =cut
 
 1;
 =cut
 
 1;

+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End: