Fix clone removing all other blocks instead of add

[debbugs.git] / Debbugs / Log.pm

diff --git a/Debbugs/Log.pm b/Debbugs/Log.pm
index 89b14d5d04d90642761dbe9ae3c8e7561ff50179..5a7306de38ecfd5ecee354e06961aad60610badd 100644 (file)
--- a/Debbugs/Log.pm
+++ b/Debbugs/Log.pm
@@ -16,7 +16,7 @@ use warnings;
 use strict;
 
 use vars qw($VERSION $DEBUG @EXPORT @EXPORT_OK %EXPORT_TAGS);
 use strict;
 
 use vars qw($VERSION $DEBUG @EXPORT @EXPORT_OK %EXPORT_TAGS);

-use base qw(Exporter);
+use Exporter qw(import);

 
 BEGIN {
     $VERSION = 1.00;
 
 BEGIN {
     $VERSION = 1.00;


@@ -25,7 +25,7 @@ BEGIN {
     @EXPORT = ();
     %EXPORT_TAGS = (write => [qw(write_log_records),
                             ],
     @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),
                             ],
                             ],
                    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 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
 
 
 =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.
 
 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


@@ -164,6 +170,7 @@ sub new
     my %param;
     if (@_ == 1) {
         ($param{logfh}) = @_;
     my %param;
     if (@_ == 1) {
         ($param{logfh}) = @_;

+        $param{inner_file} = 0;

     }
     else {
         %param = validate_with(params => \@_,
     }
     else {
         %param = validate_with(params => \@_,


@@ -175,7 +182,10 @@ sub new
                                                      },
                                           log_name => {type => SCALAR,
                                                        optional => 1,
                                                      },
                                           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: $!";
     }
 
              die "Unable to open bug log $bug_log for reading: $!";
     }
 

-    binmode($self->{logfh},':utf8');

     $self->{state} = 'kill-init';
     $self->{linenum} = 0;
     $self->{state} = 'kill-init';
     $self->{linenum} = 0;

+    $self->{inner_file} = $param{inner_file};

     return $self;
 }
 
     return $self;
 }
 


@@ -241,16 +251,21 @@ sub read_record
            }
 
            $this->{state} = $newstate;
            }
 
            $this->{state} = $newstate;

-

            if ($this->{state} =~ /^(autocheck|recips|html|incoming-recv)$/) {
            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') {
            } 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;
        if ($this->{state} eq 'incoming-recv') {
            my $pl = $_;
        $_ = $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';
                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') {
        } elsif ($this->{state} eq 'html') {

-           $record->{text} .= "$_\n";
+           $record->{text} .= "$_\n"  unless $this->{inner_file};

        } elsif ($this->{state} eq 'go') {
            s/^\030//;
        } elsif ($this->{state} eq 'go') {
            s/^\030//;

-           $record->{text} .= "$_\n";
+           $record->{text} .= "$_\n"  unless $this->{inner_file};

        } elsif ($this->{state} eq 'go-nox') {
        } 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};
        } elsif ($this->{state} eq 'recips') {
            if (/^-t$/) {
                undef $record->{recips};


@@ -274,12 +289,15 @@ sub read_record
                $record->{recips} = [split /\04/, $_, -1];
            }
            $this->{state} = 'kill-body';
                $record->{recips} = [split /\04/, $_, -1];
            }
            $this->{state} = 'kill-body';

+        $record->{start} = $logfh->tell+2;
+        $record->{stop} = $logfh->tell+2;
+        $record->{inner_file} = $this->{inner_file};

        } elsif ($this->{state} eq 'autocheck') {
        } 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') {
            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 {
            next if !/^$/;
            $this->{state} = 'go-nox';
        } else {


@@ -322,6 +340,9 @@ sub read_log_records
                                           log_name => {type => SCALAR,
                                                        optional => 1,
                                                       },
                                           log_name => {type => SCALAR,
                                                        optional => 1,
                                                       },

+                           inner_file => {type => BOOLEAN,
+                                          default => 0,
+                                         },

                                          }
                               );
     }
                                          }
                               );
     }


@@ -386,8 +407,12 @@ sub write_log_records
        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.
        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.

-       # croak "probably wrong encoding" if is_utf8($record->{text});
-       my ($text) = escape_log($record->{text});
+        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: $!";
        if ($type eq 'autocheck') {
            print {$logfh} "\01\n$text\03\n" or
                die "Unable to write to logfile: $!";


@@ -397,6 +422,15 @@ sub write_log_records
            if (defined $recips) {
                croak "recips not undef or array"
                    unless ref($recips) eq 'ARRAY';
            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} join("\04", @$recips) . "\n" or
                    die "Unable to write to logfile: $!";
            } else {


@@ -435,6 +469,41 @@ sub escape_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};
+    }
+}
+
+

 =head1 CAVEATS
 
 This module does none of the formatting that bugreport.cgi et al do. It's
 =head1 CAVEATS
 
 This module does none of the formatting that bugreport.cgi et al do. It's