Add IO::InnerFile support to Debbugs::Log and use it

[debbugs.git] / Debbugs / Log.pm

diff --git a/Debbugs/Log.pm b/Debbugs/Log.pm
index 96748b7ee401813e6a096bf825a33122caca9daf..dce86d5c05a36d708ed22efe3c95cf4b062c7783 100644 (file)
--- a/Debbugs/Log.pm
+++ b/Debbugs/Log.pm
@@ -25,7 +25,7 @@ BEGIN {
     @EXPORT = ();
     %EXPORT_TAGS = (write => [qw(write_log_records),
                             ],
-                   read  => [qw(read_log_records),
+                   read  => [qw(read_log_records record_text record_regex),
                             ],
                    misc  => [qw(escape_log),
                             ],
@@ -39,7 +39,8 @@ use Carp;
 
 use Debbugs::Common qw(getbuglocation getbugcomponent make_list);
 use Params::Validate qw(:types validate_with);
-use Encode qw(encode is_utf8);
+use Encode qw(encode encode_utf8 is_utf8);
+use IO::InnerFile;
 
 =head1 NAME
 
@@ -51,6 +52,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.
 
+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
@@ -164,6 +170,7 @@ sub new
     my %param;
     if (@_ == 1) {
         ($param{logfh}) = @_;
+        $param{inner_file} = 0;
     }
     else {
         %param = validate_with(params => \@_,
@@ -175,7 +182,10 @@ sub new
                                                      },
                                           log_name => {type => SCALAR,
                                                        optional => 1,
-                                                      },
+                                   },
+                           inner_file => {type => BOOLEAN,
+                                          default => 0,
+                                         },
                                          }
                               );
     }
@@ -201,9 +211,9 @@ sub new
              die "Unable to open bug log $bug_log for reading: $!";
     }
 
-    binmode($self->{logfh},':utf8');
     $self->{state} = 'kill-init';
     $self->{linenum} = 0;
+    $self->{inner_file} = $param{inner_file};
     return $self;
 }
 
@@ -241,16 +251,21 @@ sub read_record
            }
 
            $this->{state} = $newstate;
-
            if ($this->{state} =~ /^(autocheck|recips|html|incoming-recv)$/) {
-               $record->{type} = $this->{state};
+            $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 = $_;
@@ -258,14 +273,14 @@ sub read_record
                die "bad line '$pl' in state incoming-recv";
            }
            $this->{state} = 'go';
-           $record->{text} .= "$_\n";
+           $record->{text} .= "$_\n" unless $this->{inner_file};
        } elsif ($this->{state} eq 'html') {
-           $record->{text} .= "$_\n";
+           $record->{text} .= "$_\n"  unless $this->{inner_file};
        } elsif ($this->{state} eq 'go') {
            s/^\030//;
-           $record->{text} .= "$_\n";
+           $record->{text} .= "$_\n"  unless $this->{inner_file};
        } elsif ($this->{state} eq 'go-nox') {
-           $record->{text} .= "$_\n";
+           $record->{text} .= "$_\n"  unless $this->{inner_file};
        } elsif ($this->{state} eq 'recips') {
            if (/^-t$/) {
                undef $record->{recips};
@@ -275,11 +290,11 @@ sub read_record
            }
            $this->{state} = 'kill-body';
        } elsif ($this->{state} eq 'autocheck') {
-           $record->{text} .= "$_\n";
+           $record->{text} .= "$_\n" unless $this->{inner_file};
            next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/;
            $this->{state} = 'autowait';
        } elsif ($this->{state} eq 'autowait') {
-           $record->{text} .= "$_\n";
+           $record->{text} .= "$_\n" unless $this->{inner_file};
            next if !/^$/;
            $this->{state} = 'go-nox';
        } else {
@@ -322,6 +337,9 @@ sub read_log_records
                                           log_name => {type => SCALAR,
                                                        optional => 1,
                                                       },
+                           inner_file => {type => BOOLEAN,
+                                          default => 0,
+                                         },
                                          }
                               );
     }
@@ -384,7 +402,14 @@ sub write_log_records
     for my $record (@records) {
        my $type = $record->{type};
        croak "record type '$type' with no text field" unless defined $record->{text};
-       my ($text) = escape_log($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: $!";
@@ -394,6 +419,15 @@ sub write_log_records
            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 {
@@ -428,7 +462,42 @@ Applies the log escape regex to the passed logfile.
 
 sub escape_log {
        my @log = @_;
-       return map { eval {$_ = is_utf8($_)?encode("utf8",$_,Encode::FB_CROAK):$_;}; s/^([\01-\07\030])/\030$1/gm; $_ } @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;
+        return $record->{text};
+    }
 }