use strict;
use vars qw($VERSION $DEBUG @EXPORT @EXPORT_OK %EXPORT_TAGS);
-use base qw(Exporter);
+use Exporter qw(import);
BEGIN {
$VERSION = 1.00;
@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),
],
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
+use Carp;
-use Debbugs::Common qw(getbuglocation getbugcomponent);
+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
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
my %param;
if (@_ == 1) {
($param{logfh}) = @_;
+ $param{inner_file} = 0;
}
else {
- %param = validate_with(params => @_,
+ %param = validate_with(params => \@_,
spec => {bug_num => {type => SCALAR,
optional => 1,
},
- logfh => {type => SCALAR,
+ 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 3) {
+ 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";
}
die "Unable to open bug log $param{log_name} for reading: $!";
}
elsif (exists $param{bug_num}) {
- my $location = getbuglocation($bug,'log');
- my $bug_log = getbugcomponent($bug,'log',$location);
+ my $location = getbuglocation($param{bug_num},'log');
+ my $bug_log = getbugcomponent($param{bug_num},'log',$location);
$self->{logfh} = IO::File->new($bug_log, 'r') or
die "Unable to open bug log $bug_log for reading: $!";
}
$self->{state} = 'kill-init';
$self->{linenum} = 0;
+ $self->{inner_file} = $param{inner_file};
return $self;
}
}
$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 = $_;
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};
$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 {
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 (*)
+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 $reader = Debbugs::Log->new($logfh);
+ my $reader = Debbugs::Log->new(%param);
while (defined(my $record = $reader->read_record())) {
push @records, $record;
}
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 (*@)
+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};
- my ($text) = escape_log($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') {
- 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') {
- print $logfh "\02\n";
+ print {$logfh} "\02\n";
my $recips = $record->{recips};
if (defined $recips) {
- die "recips not undef or array"
+ croak "recips not undef or 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 {
- 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";
+ 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";
+ 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";
+ print {$logfh} "\07\n$text\03\n" or
+ die "Unable to write to logfile: $!";
} else {
- die "unknown type '$type'";
+ croak "unknown record type type '$type'";
}
}
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;
}
-=back
+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