New file.

2 files changed, 152 insertions, 0 deletions

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  <Pavel@Janik.cz>
+
+        * b2m.pl: New file.
+
 2002-06-21  Francesco Potorti`  <pot@gnu.org>
 
         * 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 <jik@kamens.brookline.ma.us>.
+
+# 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";