Re: extract-mbox

> > > Wayne Chapeskie wrote:
> The mhonarc list archives at www.xray.mpe.mpg.de contain, in each
> message, a link to retrieve the complete original message from the
> original mailbox format archive.  A cgi script called "extract-mbox"
> is called to do this.  I was quite interested in this when I first saw
> it, and hoped that it was part of the standard MHonArc distribution.
> Unfortunately it isn't.  Before I try to reinvent the wheel, can anyone
> point me to a source for extract-mbox?
It's one of my quick and dirty scripts. extract-mbox appended.

> (I tried searchine the various Perl archives for it, with no luck;
> searching the list archives for refererences to it was a bit tricky
> since "extract-mbox" is found in every message...)
Yupp, known problem.

Achim

> Thanks,
> Wayne Chapeskie
#!/usr/local/bin/perl -Tw
#!/usr/local/bin/perl -Tw
use strict;
$| = 1;

$ENV{PATH} = '/usr/bin:/usr/local/bin';

my $debug = 0;
my $root = '/mail/archive/lists';
my $gzcat = '/usr/local/bin/gzcat';

sub wrerr {
         my $t = localtime();
         print "Error: @_\n";
         die "$0 [$t]: @_";
}

print "Content-type: text/plain\r\n\r\n";

my $path  = $ENV{PATH_INFO}
         or wrerr "Name of mbox not specified";

$root = '/mail/archive/asdc/www' if $path =~ m,/asdc-[a-z],;

my $msgid = shift
         or wrerr "Message Id not specified";

wrerr "I do not accept the path to mbox: '$path'" if not $path =~ 
m#^/[-\w\d]+/+[-\w\d]+$#;
wrerr "I do not accept the given msg-id: '$msgid'" if not $msgid =~ 
m#^[-\w\d\(_at_)\(_dot_)]+$#;

print "\n##########$path|$msgid##########\n" if $debug;

# map old archive names to current names (backward comp.)
my %trans = (
        'Alpha-OSF-Managers'    => 'alpha-osf-managers',
        'Hyper-G'               => 'hyperwave',
        'LaTeX2HTML'            => 'latex2html',
        'Perl5-Porters'         => 'perl5-porters',
        'perl-porters'          => 'perl5-porters',
        'MakeMaker'             => 'makemaker',
        'PerlDB-Interest'       => 'dbi',
        'TIX-Info'              => 'tix',
        'TKined'                => 'tkined',
        'VMSperl'               => 'vmsperl',
        'teTeX'                 => 'tetex',
        );

$path =~ m|^/([^/]+)(.*)|; my $oldpath = $1; 
$path = "/".$trans{$oldpath}.$2 if exists $trans{$oldpath};

my $mbox = "$root$path.mbox";
print "\n##########$path|$msgid -> $mbox ##########\n" if $debug;


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

my @cache = ();
my $found = 0;

if ( -r "$mbox.gz" ) {
        $mbox .= ".gz";
        open(MBOX, "-|") or exec $gzcat, $mbox or wrerr "Open mbox '$path.mbox 
$!";
} else {
        open MBOX, $mbox or wrerr "Open mbox '$path.mbox': $!";
}

my $id;

MAIL:
while (!eof(MBOX)) {
        while (<MBOX>) {
                push @cache, $_;
                last if /^message-id:/i;
        }

        chomp $_;
        ($id = $_) =~ s/^.*<([^>]+)>.*$/$1/;
        print "## <$id>\n" if $debug;

        if ($id eq $msgid) {
                $found = 1;
                print @cache;
                while (<MBOX>) {
                        last MAIL if /^From /;
                        print;
                } 
                last MAIL;
        }

        @cache = ();
        while (<MBOX>) {
                if (/^From /) {
                        @cache = ($_);
                        last;
                }
        }
}

#wrerr "Message ID = <$msgid> not found. Mbox $mbox inconsistent!?\n" if not 
$found;
wrerr "Message ID = <$msgid> not found. Mbox $path.mbox inconsistent!?\n" if 
not $found;

# Uh! gives error on 'or exec ...' construct.  RTFM????
#close MBOX or wrerr "Error close mbox: '$path.mbox'";

1;