X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FLog.pm;h=5a7306de38ecfd5ecee354e06961aad60610badd;hb=1f81df46999fc3699ce73aeba95af5095a5a413a;hp=e64d2369a371b131466dd7f8d7fdf3e4aae4e73b;hpb=764cf056fc8d74fd4704bb90ba352d5d8ea5d55d;p=debbugs.git diff --git a/Debbugs/Log.pm b/Debbugs/Log.pm index e64d236..5a7306d 100644 --- 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 base qw(Exporter); +use Exporter qw(import); BEGIN { $VERSION = 1.00; @@ -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,6 +39,8 @@ 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 @@ -50,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 @@ -163,6 +170,7 @@ sub new my %param; if (@_ == 1) { ($param{logfh}) = @_; + $param{inner_file} = 0; } else { %param = validate_with(params => \@_, @@ -174,7 +182,10 @@ sub new }, log_name => {type => SCALAR, optional => 1, - }, + }, + inner_file => {type => BOOLEAN, + default => 0, + }, } ); } @@ -202,6 +213,7 @@ sub new $self->{state} = 'kill-init'; $self->{linenum} = 0; + $self->{inner_file} = $param{inner_file}; return $self; } @@ -239,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 = $_; @@ -256,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}; @@ -272,12 +289,15 @@ sub read_record $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') { - $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 { @@ -320,6 +340,9 @@ sub read_log_records log_name => {type => SCALAR, optional => 1, }, + inner_file => {type => BOOLEAN, + default => 0, + }, } ); } @@ -368,7 +391,7 @@ sub write_log_records $logfh = $param{logfh} } elsif (exists $param{log_name}) { - $logfh = IO::File->new($param{log_name},'w') or + $logfh = IO::File->new(">>$param{log_name}") or die "Unable to open bug log $param{log_name} for writing: $!"; } elsif (exists $param{bug_num}) { @@ -381,8 +404,15 @@ sub write_log_records for my $record (@records) { my $type = $record->{type}; - my ($text) = escape_log($record->{text}); - croak "record 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') { print {$logfh} "\01\n$text\03\n" or die "Unable to write to logfile: $!"; @@ -392,6 +422,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 { @@ -426,7 +465,42 @@ Applies the log escape regex to the passed logfile. sub escape_log { my @log = @_; - return map { 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}; + } }