From 9ee028d2b566587890c6803c05887e5b9aae0772 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Pavel=20Jan=C3=ADk?= Date: Wed, 26 Jun 2002 15:50:47 +0000 Subject: [PATCH] New file. --- lib-src/ChangeLog | 4 ++ lib-src/b2m.pl | 148 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 152 insertions(+) create mode 100644 lib-src/b2m.pl diff --git a/lib-src/ChangeLog b/lib-src/ChangeLog index ea592deca2b..af89fd1bb2c 100644 --- a/lib-src/ChangeLog +++ b/lib-src/ChangeLog @@ -1,3 +1,7 @@ +2002-06-26 Pavel Jan,Bm(Bk + + * b2m.pl: New file. + 2002-06-21 Francesco Potorti` * etags.c: (F_getit, Fortran_functions, Ada_getit, Asm_labels) diff --git a/lib-src/b2m.pl b/lib-src/b2m.pl new file mode 100644 index 00000000000..6ec923d3d22 --- /dev/null +++ b/lib-src/b2m.pl @@ -0,0 +1,148 @@ +#!/usr/bin/perl + +# b2m.pl - Script to convert a Babyl file to an mbox file + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. + +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +# USA. + +# Maintained by Jonathan Kamens . + +# Requires CPAN modules: MailTools (for Mail::Address), TimeDate (for +# Date::Parse). + +use warnings; +use strict; +use File::Basename; +use Getopt::Long; +use Mail::Address; +use Date::Parse; + +my($whoami) = basename $0; +my($version) = '$Revision: 1.4 $'; +my($usage) = "Usage: $whoami [--help] [--version] [--[no]full-headers] [Babyl-file] +\tBy default, full headers are printed.\n"; + +my($opt_help, $opt_version); +my($opt_full_headers) = 1; + +die $usage if (! GetOptions( + 'help' => \$opt_help, + 'version' => \$opt_version, + 'full-headers!' => \$opt_full_headers, + )); + +if ($opt_help) { + print $usage; + exit; +} +elsif ($opt_version) { + print "$whoami version: $version\n"; + exit; +} + +die $usage if (@ARGV > 1); + +$/ = "\n\037"; + +if (<> !~ /^BABYL OPTIONS:/) { + die "$whoami: $ARGV is not a Babyl file\n$usage"; +} + +while (<>) { + my($msg_num) = $. - 1; + my($labels, $full_header, $header); + my($from_line, $from_addr); + my($time); + + # This will strip the initial form feed, any whitespace that may + # be following it, and then a newline + s/^\s+//; + # This will strip the ^_ off of the end of the message + s/\037$//; + + if (! s/(.*)\n//) { + malformatted: + warn "$whoami: message $msg_num in $ARGV is malformatted\n"; + next; + } + $labels = $1; + + s/(?:((?:.+\n)+)\n+)?\*\*\* EOOH \*\*\*\n+// || goto malformatted; + $full_header = $1; + + if (s/((?:.+\n)+)\n+//) { + $header = $1; + } + else { + # Message has no body + $header = $_; + $_ = ''; + } + + if (! $full_header) { + $full_header = $header; + } + + # End message with a single newline + s/\s+$/\n/; + + # Quote "^From " + s/(^|\n)From /$1>From /g; + + # Strip the integer indicating whether the header is pruned + $labels =~ s/^\d+[,\s]*//; + # Strip extra commas and whitespace from the end + $labels =~ s/[,\s]+$//; + # Now collapse extra commas and whitespace in the remaining label string + $labels =~ s/[,\s]+/, /g; + + foreach my $rmail_header qw(summary-line x-coding-system) { + $full_header =~ s/(^|\n)$rmail_header:.*\n/$1/i; + } + + if ($full_header =~ s/(^|\n)mail-from:\s*(From .*)\n/$1/i) { + ($from_line = $2) =~ s/\s*$/\n/; + } + else { + foreach my $addr_header qw(return-path from really-from sender) { + if ($full_header =~ /(?:^|\n)$addr_header:\s*((?:\S.*\n)+)/i) { + my($addr) = Mail::Address->parse($1); + $from_addr = $addr->address($addr); + last; + } + } + + if (! $from_addr) { + $from_addr = "Babyl_to_mail_by_$whoami\@localhost"; + } + + if ($full_header =~ /(?:^|\n)date:\s*(\S.*\S)/i) { + $time = str2time($1); + } + + if (! $time) { + # No Date header or we failed to parse it + $time = time; + } + + $from_line = "From " . $from_addr . " " . localtime($time) . "\n"; + } + + print($from_line, ($opt_full_headers ? $full_header : $header), + ($labels ? "X-Babyl-Labels: $labels\n" : ""), "\n", + $_) || die "$whoami: error writing to stdout: $!\n"; +} + +close(STDOUT) || die "$whoami: Error closing stdout: $!\n"; -- 2.39.5