File Coverage

blib/lib/TheBat/Read_TBB.pm

Criterion	Covered	Total	%
statement	121	145	83.4
branch	27	42	64.2
condition	4	6	66.6
subroutine	7	8	87.5
pod	2	3	66.6
total	161	204	78.9

package TheBat::Read_TBB;

use 5.00001;
use strict;
use warnings;
use bytes;
use Digest::MD5;

require Exporter;

=head1 NAME

TheBat::Read_TBB - Read individual email messages out of TheBat! .tbb messages files

=head1 SYNOPSIS

  use TheBat::Read_TBB;
  while(&Read_TBB("messages.tbb",\%ref) {
    print "$ref{'sender'}\n";
  }

=head1 DESCRIPTION

Reads the TheBat! binary messages flags (status codes like "deleted" or "replied" or "flagged" etc)
as well as the email headers and body, and returns md5 checksums of some parts as well as flags
and headers etc.

Call repeatedly in a loop; returns 0 when there's no more to read.

=head2 EXPORT

Read_TBB

=head2 EXAMPLE

  use TheBat::Read_TBB;
  my %ref;
  while(&Read_TBB("t/messages.tbb",\%ref)) {
    foreach my $k (keys %ref) {
      print "$k:\t" . $ref{$k} . "\n";
    }
  }

=head1 SEE ALSO

http://www.felix-schwarz.name/files/thebat/tbb.txt


=head1 AUTHOR

Chris Drake, [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2013 by Chris Drake

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.1 or,
at your option, any later version of Perl 5 you may have available.


=cut



our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use TheBat::Read_TBB ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	Read_TBB
);

our $VERSION = '0.01';



# Call repeatedly; returns 1 email at a time
sub Read_TBB {
  my($tbb,$ref)=@_;	# Supply input .TBB filename, and a ref to keep status info

  my($readbuf)=536870911;			# How big shall our message-sysread chunks be?
  my $flagcodes='DoaPAxFft.c................m....';
  my($buf,$bytes_read)=(undef,0); my %persist=qw(tbb 1 more 1 total 1 msgs 1 deld 1 msgno 1 seek 1); foreach my $k(keys %{$ref}){$ref->{$k}=undef unless($persist{$k})}
  if(!$ref->{'tbb'}) {	# Not opened yet
    if(open(TBB,'<',$tbb)) {
      $ref->{'tbb'}=$tbb;
      binmode(TBB);
      $bytes_read=sysread(TBB,$buf,6);			# Get magic number and file header size
      $ref->{'seek'}=$bytes_read;
      ($ref->{'file_magic'},$ref->{'head_size'})=unpack("VS",$buf);
      $ref->{'head_size'}-=6; # remove the size of the header(magic+size) itself from the header

      if($ref->{'file_magic'} != 427361824) { # if(unpack('H*',substr($buf,0,6)) ne '20067919080c');
        &write_log("Possible input file corruption: magic number mismatch: " . $ref->{'file_magic'} . " != 427361824 " . unpack('H*',$buf));
	close(TBB);
        return 0;
      }

      $bytes_read=sysread(TBB,$buf,$ref->{'head_size'});	# Get the TBB file header
      $ref->{'seek'}+=$bytes_read;
      &write_log("Possible input file corruption: $bytes_read != ". $ref->{'head_size'} ." - too short") if($bytes_read != $ref->{'head_size'});

      $ref->{'more'}=1;
      $ref->{'total'}=0;
      $ref->{'msgs'}=0;
      $ref->{'deld'}=0;
      $ref->{'msgno'}=0;

    } else {
      &write_log("Skipping: " . $ref->{'tbb'} . " - $!");
      return 0;
    }
  } else {
    goto NOMORE unless($ref->{'more'});
  }

  $bytes_read=sysread(TBB,$buf,6);	# Get the message header's magic and size
  $ref->{'seek'}+=$bytes_read;
  if($bytes_read<6) {
NOMORE:
    close(TBB);
    # &write_log("End of " . $ref->{'tbb'} . " - Total messages:".$ref->{'total'} ." (." . $ref->{'msgs'}." messages, ".$ref->{'deld'}." deleted): run=".$ref->{'grandtot'});# if($switch{'debug'});
    undef $ref;	# works
    return 0;
  }


  my($msg_magic,$msghead_size)=unpack("VS",$buf);	# V is a little-endian 32bit int, S is an unsigned little-ending 16 bit short)
  $msghead_size-=6; # remove the size of the header(magic+size) itself from the header
  if($msg_magic != 426772769) {
    die "Possible input file corruption: message magic number mismatch: $msg_magic != 426772769 / 21 09 70 19 != " . unpack('H*',$buf);
  }

  $msghead_size=0 if($msghead_size<0);
  # &write_log($ref->{'tbb'} . " message header size is $msghead_size"); # debug
  &write_log("Possible input file corruption: message header size unusual") if($msghead_size != 42);

  $ref->{'tell'}=$ref->{'seek'}; # remember where this message started
  $bytes_read=sysread(TBB,$buf,$msghead_size);	# Get the tbb message header
  $ref->{'seek'}+=$bytes_read;
  if($bytes_read != $msghead_size) {
    &write_log("Possible input file corruption: message header too short");
    goto NOMORE;
  }

  $ref->{'total'}++; $ref->{'grandtot'}++;
  $ref->{'msgno'}++;

   #(	0  ,3441210366,1038086103,1830,0  ,146    ,0  ,0   ,1   ,78594    ,0         ,0)
  my(	$z1,$unknown  ,$time     ,$id ,$z2,$status,$z4,$col,$pri,$msg_size,$msg_sizeB,$z5)=unpack(
        'v  V          V          v    v   b32     V   V    V    V         V          V',$buf);
  my $flags='';for(my $i=0; $i{"flag_$f"}++;}	# DoaPAxFft.c................m....
  $ref->{'flags'}=$flags;


  my($read)=0;
  my($head)=1;
  my($towrite)=1;
  my($full)='';
  $ref->{'sender'}='<>';

  if(substr($status,0,1)) {
    $ref->{'deld'}++;
  } else {
    $ref->{'msgs'}++;
  }

  $ref->{'md5'} = Digest::MD5->new;
  $ref->{'md5h'} = Digest::MD5->new;
  $ref->{'md5b'} = Digest::MD5->new;
  my %hdr; my($more)=1;
  $ref->{'size'} = 0;

  while(($more)&&($read<$msg_size)&&($msg_size>0)) { # Loop over sensible sized reads of the message
    if(($msg_size-$read)<$readbuf) {
      $bytes_read=sysread(TBB,$buf,($msg_size-$read));		# Get the rest of the message
      $ref->{'seek'}+=$bytes_read;
      $ref->{'size'}+=$bytes_read;
      if($bytes_read != ($msg_size-$read)) {
        $more=0; $ref->{'more'}=0;
        &write_log("Possible input file corruption: file ends before message $ref->{'total'} does");
      }
      $read=$msg_size;	# Got the lot now
    } else {
      $bytes_read=sysread(TBB,$buf,$readbuf);			# Get 32k of the message
      $ref->{'seek'}+=$bytes_read;
      $ref->{'size'}+=$bytes_read;
      if($bytes_read != $readbuf) {
        $more=0; $ref->{'more'}=0;
        &write_log("Possible input file corruption: file ends before message $ref->{'total'} does");
      }
      $read+=$readbuf;
    }


    if($head) {		# We're in the header
      $head=0;
      ($ref->{'header'},$buf)=split(/(?:\r\r|\n\n|\r\n\r\n|\n\r\n\r)/,$buf,2);
      $ref->{'header'}=~s/\r\n/\n/gsm;
      chop($ref->{'header'}) while(substr($ref->{'header'},-1) eq "\r");
      &ParseHead(\$ref->{'header'},\%hdr);

      ($ref->{'sender'})=($ref->{'header'}=~/[\s<]([^\s<>]+\@[a-z0-9\.\-]+)/i);

      if(substr($ref->{'header'},0,5) ne 'From ') {
        $ref->{'header'}=~s/^From /X-From:/gsm;		# Don't allow another "^From " in the headers
        $ref->{'header'}="From $ref->{'sender'}\n" . $ref->{'header'};
      }

      $ref->{'md5h'}->add($ref->{'header'});
      $ref->{'md5b'}->add("From:" . $hdr{'from'} .
	"\tTo:" . $hdr{'to'} .
	"\tDate:" . $hdr{'date'} .
	"\tId:"  . $hdr{'message-id'} .
	"\tSubject:"  . $hdr{'subject'} );

      foreach my $k (keys %hdr){$ref->{"h_$k"}=$hdr{$k};}
    }

    $ref->{'md5'}->add($buf);

    #$full.=$buf if($switch{'uniq'});

  } # loop over 1 email

  foreach my $h (qw(md5 md5h md5b)) {
    $ref->{"b$h"}=$ref->{$h}->digest;
    $ref->{$h.'hex'}=unpack("H*",$ref->{"b$h"});	# $ref->{'bmd5'} / $ref->{'md5hex'} / etc
  }

  return 1;
} # bat_read



#######################################################################

=head2 ParseHead

Extract fields from header

=cut
#######################################################################


sub ParseHead {
  my($phdrc,$phdr)=@_;
  my @hdr=split(/(?:\r\n|\n\r|\r|\n)/,$$phdrc);
  push @hdr,'';	# So the loop below also does the last element properly (the $i++ bit)
  my $i=0; while($i<($#hdr)) {
#print "h$i =$hdr[$i]\n";
    if($hdr[1+$i]=~/^\s(.*)/) {
      $hdr[$i].=" $1"; splice(@hdr,$i+1,1);
    } else {
      my($f,$b)=split(':',$hdr[$i],2); if(!defined $phdr->{lc($f)}){$phdr->{lc($f)}=$b}else{$phdr->{lc($f)}.=" ".$b}
      $i++;
    }
#print "h$i'=$hdr[$i]\n";
  }
  pop @hdr;	# @hdr now has headers, all one-lined.

} # ParseHead






#######################################################################

=head2 write_log

Outputs debugging and informational letters to /var/log file.

=cut
#######################################################################
sub write_log {
  my($message)=@_;
  my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
  my($date)=sprintf("%02d/%02d %02d:%02d.%02d",$mon+1,$mday,$hour,$min,$sec);
  print STDERR "$date $$ Read_TBB $message\n";
}




__END__