view lib-src/b2m.pl @ 50357:e5a09c97e444

Include blockinput.h. (Vx_resource_name, Vx_resource_class, Qx_frame_parameter) (Qx_resource_name, Qface_set_after_frame_default): Define vars here. (Qauto_raise, Qauto_lower, ...): Define all frame parameter related vars here. (struct frame_parm_table, frame_parms): New table for describing frame parameters and their associated Q-variable. The order of the parameters corresponds to the sequence of the frame_parm_handlers table in redisplay_interface. (x_fullscreen_move, x_set_frame_parameters) (x_report_frame_params, x_set_fullscreen, x_set_line_spacing) (x_set_screen_gamma, x_set_font, x_set_fringe_width) (x_set_border_width, x_set_internal_border_width, x_set_visibility) (x_set_autoraise, x_set_autolower, x_set_unsplittable) (x_set_vertical_scroll_bars, x_set_scroll_bar_width, x_icon_type): Generic functions for processing of frame parameters. (validate_x_resource_name, xrdb_get_resource, Fx_get_resource) (display_x_get_resource, x_get_resource_string): Functions for generic access to X resources. (x_get_arg, x_frame_get_arg, x_frame_get_and_record_arg) (x_default_parameter, Fx_parse_geometry): Functions for generic access to frame parameters. (x_figure_window_size): Generic calculation of frame size. Fixed to add space needed for tool bar. Also setup size_hint_flags. (syms_of_frame): Intern and staticpro frame parameter variables. Defvar_lisp Vx_resource_class and Vx_resource_name here. Defsubr Sx_get_resource and Sx_parse_geometry.

#!/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 <[e-mail]>.

# 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, $pruned, $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;

    # Strip the integer indicating whether the header is pruned
    $labels =~ s/^(\d+)[,\s]*//;
    $pruned = $1;

    s/(?:((?:.+\n)+)\n*)?\*\*\* EOOH \*\*\*\n+// || goto malformatted;
    $full_header = $1;

    if (s/((?:.+\n)+)\n+//) {
	$header = $1;
    }
    else {
	# Message has no body
	$header = $_;
	$_ = '';
    }

    # "$pruned eq '0'" is different from "! $pruned".  We want to make
    # sure that we found a valid label line which explicitly indicated
    # that the header was not pruned.
    if ((! $full_header) || ($pruned eq '0')) {
	$full_header = $header;
    }

    # End message with two newlines (some mbox parsers require a blank
    # line before the next "From " line).
    s/\s+$/\n\n/;

    # Quote "^From "
    s/(^|\n)From /$1>From /g;

    # 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*(.*\n(?:\B.*\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";