[comp.lang.perl] from.pl

schwartz@groucho.cs.psu.edu (Scott Schwartz) (12/01/90)

This is a slightly hacked version of a script Johan Vormans
posted a while ago.  It has been taught to understand emacs
BABYL format files.  Enjoy.

#!/usr/bin/perl
#
# Show messages from a Unix mailbox. With -n: shown message numbers also.
#
# Usage "from [-n] MAILBOX..."
#
# This program requires perl version 3.0, patchlevel 4 or higher
#
# Copyright 1989,1990 Johan Vromans <jv@mh.nl>, no rights reserved.
# Usage and redistribution is free and encouraged.
#
# Hacked 1990 by Scott Schwartz <schwartz@cs.psu.edu> to recognise
# emacs RMAIL files.
#

# Default output format
format =
@<<<<<<<<<<< "@<<<<<<<<<<<<" ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<..
$date,        $from,         $subj
.

# Output format when sequence numbers are requested
format format_n =
@>: @<<<<<<<<<<< "@<<<<<<<<<<<<" ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<..
$seq, $date,      $from,         $subj
.

# Parse and stash away -n switch, if provided
if ($#ARGV >= 0 && $ARGV[0] eq '-n') {
  shift (@ARGV);
  $~ = "format_n";
}

# Use system mailbox if none was specified on the command line
if ( $#ARGV < 0 ) {
  if ( ! ($user = getlogin)) {
    @a = getpwuid($<);
    $user = $a[0];
  }
  if ( -r "/usr/mail/$user" ) {		# System V
    @ARGV = ("/usr/mail/$user");
  }
  elsif ( -r "/usr/spool/mail" ) {	# BSD
    @ARGV = ("/usr/spool/mail/$user");
  }
  else {
    printf STDERR "No mail for $user.\n";
    exit 1;
  }
}
  
$seq = 0;
# Read through input file(s)
while (<>) {
  # Look for a "From_" header (See RFC822 and associated documents).
  if (/^From\s+(\S+)\s+.*(\w{3}\s+\d+\s+\d+:\d+)/) {
    do scan_mail ($_, $1, $2, $3);
  }
  # Else look for a "Summary-line:_" header (See GNU BABYL documents).
  elsif (/^Summary-line:\s+(\S+)\s+(\S+)\s+#(.*)$/) {
    do scan_mail ($_, $2, $1, $3);
  }
}

exit 0;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

sub scan_mail {
  local (@args);
  @args = @_;

  $_ = $args[0];
  $from = $args[1];  
  $date = $args[2];
  $subj = $args[3];

  if ( $date eq "" || $from eq "" ) {
    print STDERR "Possible garbage: $_\n";
    return 0;
  }

  $seq++;

  # Get user name from uucp path
  chop;
  $from = $1 if $from =~ /.*!(.+)/;

  # Now, scan for Subject or empty line
  while ( <> ) {
    chop ($_);

    if ( /^$/ ) {
      # force fall-though
      $subj = "<none>" unless $subj;
    }
    else {
      $subj = $1 if /^Subject\s*:\s*(.*)/i;
      if ( /^From\s*:\s*/ ) {
        $_ = $';
        if ( /\((.+)\)/i ) { $from = $1; } 
        elsif ( /^\s*(.+)\s*<.+>/i ) { $from = $1; } 
        elsif ( /^<.+>\s*(.+)/i ) { $from = $1; } 
      }
    }

    # do we have enough info?
    if ( $from && $subj ) {
      write;
      last;
    }
  }
}