#!/usr/bin/perl -w
#
# Simple script to extract an email address from an MH message,
# prompt for an alias for it, and add it to the ~/Mail/aliases
# file.
# Yes, I could have used a shell script, but I don't really
# know enough to do that. Perl isn't much of a problem to use
# for this not-very-common task...
# 'simple' is no longer as accurate as it once was :->  -- PMM 09/1998
#
# For usage information, try 'getaddr --help'.
#
# If you find this script useful (or find bugs in it :->) please let me know:
# email <pmaydell@chiark.greenend.org.uk>.

# Stand by for legal bumph... 
# Executive summary: this is the XFree86 copyright minus the restriction
# about not using the project name in advertising. You can do what
# you like with the code, but don't remove my name and don't come whining
# to me if it eats your aliases file.

############################################################################
# Copyright (C) 1998 Peter Maydell <pmaydell@chiark.greenend.org.uk>.
# All Rights Reserved.
#
# Permission is hereby granted, free of charge, to any person obtaining a 
# copy of this software and associated documentation files (the "Software"), 
# to deal in the Software without restriction, including without limitation 
# the rights to use, copy, modify, merge, publish, distribute, sublicense, 
# and/or sell copies of the Software, and to permit persons to whom the 
# Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included 
# in a copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
# IN NO EVENT SHALL PETER MAYDELL BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 
# DEALINGS IN THE SOFTWARE.
############################################################################

# TODO:
# maybe we could have a 'getaddr emailaddress alias' form?
#   (how this would fit into argument parsing:
#    if 1 arg, as now. if 2 args, check arg1 for msg. if not valid,
#    must be emailaddress. Allowing 'getaddr emailaddress' is probably
#    not a terribly good idea...)
# see comment below about taking human name from from and email from reply-to
# Maybe support creating a new aliases file if none exists?

#This causes lots of errors I can't be bothered to fix
#(mostly through use of global variables, I think.)
use strict;

sub parseargs();
sub getprofileentry($);
sub usage();
sub help();
sub version();
sub getprogname();
sub getaliasfile();
sub getaddress($$);
sub deletealias($$);
sub main();

# version string; used in help() and version().
my $VERSION = '1.5 (March 2007)';

# who, me, a C fan?
exit main();

sub main()
{
   my($forceoverwrites, $folder, $msg, $alias, $aliasfile, $address, $oldalias);

   # parse commandline args
   ($forceoverwrites, $folder, $msg, $alias) = parseargs();

   # locate the user's alias file
   $aliasfile = getaliasfile();
   # extract email address from given folder/message
   $address = getaddress($folder, $msg);

   # Loop round until we're happy with the alias
   do 
   {
      if (!defined $alias)
      {
         print "What alias do you want to use for $address?\n";
         chop($alias = <STDIN>);
      }

      # Don't permit funny characters. This regexp disallows:
      # * empty strings 
      # * whitespace
      # * '<', ';', ':', '*' : these all have special meaning
      #   in the alias file (see mh-alias(5))
      # * ''' : this is so that when we say `ali '$alias'` the
      #   shell doesn't get confused.
      # * '-' : this is because ali treats arguments with a leading '-'
      #   as options.
      if ($alias !~ /^[^\s<;:*'-]+$/)
      {
         print "Sorry, '$alias' isn't a valid alias: please try again.\n";
         undef $alias;
         # What I really want to say here is 'next', but that doesn't
         # work in a do {..} while() loop for arcane reasons.
         # (see the Camel Book (2nd ed.) p96)
      }
      else
      {
         # check for existing alias. Note that 'ali foo' returns foo if 
         # there is no alias, not ''...  
         chop($oldalias = `ali '$alias'`); die "oops, ali $alias failed: $!\n" if $? != 0;
         if ($forceoverwrites == 0 && $oldalias ne $alias)
         {
            my $yn;
            print "Warning: $alias is already aliased to $oldalias.\n";
            do { 
	       print "Overwrite? (y/n): "; 
               $yn = <STDIN>; 
            } while ($yn !~ /^[YyNn]/);
            $alias = undef if $yn =~ /^[Nn]/;
         }
      }
   } while (!defined $alias);

   # if we got out of that with $oldalias ne $alias then we must
   # have confirmed deletion or specified --force on the commandline
   deletealias($aliasfile, $alias) if ($oldalias ne $alias);

   open(ALIASFILE, ">>$aliasfile") or die "oops, couldn't append to $aliasfile: $!\n";
   print ALIASFILE "$alias: $address\n";

   return 0;   # success!
}


sub parseargs()
{
   # parse command line arguments
   # returns a tuple (forceoverwrites, folder, message, alias)
   # representing the results. Any or all of folder, message or alias may be
   # '' or some other default value if the command line args don't specify them.
   # If --help or --version were specified, or arguments are invalid,
   # we print an appropriate message and exit rather than returning.

   # The 'intelligent' argument parsing basically means that we
   # expect args in the order 'folder msg alias'. If an argument
   # looks like what we're expecting next we use it up, otherwise
   # we leave it for the next possible match.

   # defaults: no overwrite, no folder given, current message, no alias given
   my($forceoverwrites, $folder, $msg, $alias) = (0, '', 'cur', undef);

   # First we check for switches that must be the first argument.
   if (defined $ARGV[0])
   {
      # accept several flavours of help request
      if ($ARGV[0] eq '--help' || $ARGV[0] eq '-help' || $ARGV[0] eq '-h')
      {
         help();      # never returns
      }
      elsif ($ARGV[0] eq '--version')
      {
         version();   # never returns
      }
      elsif ($ARGV[0] eq '--force')
      {
         $forceoverwrites = 1;
         shift @ARGV;
      }
   }

   # now we check the next argument to see if it looks like a folder name
   if (defined $ARGV[0])
   {
      # if argument looks like '+foldername' then it's a folder
      if ($ARGV[0] =~ /^\+(.*)/)
      {
         $folder = $1;
         # do syntax checks for metacharacters:
         # ' is bad because it confuses the shell
         # spaces are bad on general principle
         if ($folder !~ /^[^'\s]+$/)
         {
            die "$folder is not a valid folder name.\n";
         }
         # Unfortunately there doesn't seem to be any way to suppress
         # the output of folder, hence the redirection to /dev/null...
         if (system("folder '+$folder' -fast -nocreate >/dev/null") != 0)
         {
            # folder doesn't exist, uhoh
            die "Folder $folder does not exist.\n";
         }
         shift @ARGV;
      }
   }

   # does next arg look like a message specifier?
   if (defined $ARGV[0])
   {
       # next argument might be a message number or cur/first/last/next/prev
       if ($ARGV[0] eq 'cur' || $ARGV[0] eq 'first' || $ARGV[0] eq 'last'
           || $ARGV[0] eq 'next' || $ARGV[0] eq 'prev' || $ARGV[0] =~ /^\d+$/)
       {
           $msg = $ARGV[0];
           shift @ARGV;
       }
   }

   # if there's a next arg it must be an alias name
   if (defined $ARGV[0])
   { 
       $alias = $ARGV[0];
       shift @ARGV;
   }

   # any more arguments is too many; print a usage message
   if (defined $ARGV[0])
   { 
       usage();
   }

   return ($forceoverwrites, $folder, $msg, $alias);
}

sub help()
{ 
  # Print detailed help text and exit
  my $progname = getprogname();
  print <<EOT;
$progname : adds an entry to your file of MH mail aliases (which should 
be specified in your .mh_profile with the Aliasfile keyword).

Usage:
$progname --help | -help | -h  
   prints this message.
$progname --version
   prints a version string and copyright message.
$progname [--force] [+folder] [msg] [alias]
   extracts the Reply-To address (or if that doesn't exist, the From
   address) from the specified message, and adds an entry with the 
   specified alias. 

   If no alias is given, we prompt the user for one. 
   msg may be a message number, or one of 'cur', 'first', 'last', 'next', 
   'prev'. If no message is given, we use cur. 
   +folder specifies a particular folder to use, in standard MH fashion.
   If the alias matches an existing entry we ask for confirmation before 
   overwriting, unless the --force option is given.

   Processing of command line arguments is intelligent: 
   If four arguments are given, they must be '--force +folder msg alias'.
   If less are given, then they are examined to see if they look like
   a flag or a folder or message specifier. So you can omit some
   of the arguments and $progname will generally do the Right Thing.
   [If you can think of a more precise way of saying exactly how this
   works which isn't confusing, please let me know :->]
   
   Examples:
        $progname fredbloggs      ; alias 'fredbloggs'; use message 'cur'
        $progname last            ; message 'last'; will prompt for alias
        $progname --force last    ; ditto, but force alias overwriting
        $progname +friends mike   ; make alias 'mike' for sender of current
                                    message in the 'friends' folder
        $progname +friends first  ; make alias for first message in 'friends',
                                    prompting for alias

   If you really wanted to make an alias like 'last' then you'll have to
   say something like '$progname cur last'.

   MH supports more complex alias formats than this program produces;
   see mh-aliases(5) for more details.

Bugs:
   This help message is rather long; perhaps we should turn it into
   a man page?

EOT
  # Tack the version string and copyright onto the end of the help text
  version();
  exit(0);
}

sub usage()
{
  # Print abbreviated usage string and exit
  my $progname = getprogname();
  print "Usage:    $progname [--force] [msg] [alias] | -help | --help | -h | --version\n";
  exit(0);
}

sub version()
{
   my $progname = getprogname();
   print <<EOT;
$progname version $VERSION;
   copyright (C) Peter Maydell <pmaydell\@chiark.greenend.org.uk>
EOT
   exit(0);
}

sub getprogname()
{
   my($progname) = $0;
   $progname =~ s/.*\///;
   return $progname;
}

sub getaddress($$)
{
   my($folder, $msg) = @_;
   # Get the right address from the given (folder,message)

   my($address, $foldstr);

   # Set $foldstr to something suitable to put into a command line
   if ($folder eq '')
   {
      $foldstr = '';
   }
   else
   { 
      $foldstr = "'+$folder'";
   }

   # Use scan to get the address out of the message
   # We use Reply-To if it exists, otherwise From.
   # Maybe we could check a reply-to address for a human-readable 
   # part and if it doesn't have one nick the one from From?
   # This would handle cases like
   #From: Adrian Bridgett <adrian.bridgett@zetnet.co.uk>
   #Reply-To: adrian.bridgett@zetnet.co.uk
   # more elegantly. Downside: parsing RFC-822 addresses is very hairy.
   $address = `scan $foldstr $msg -format '%{reply-to}'`; die "oops, scan failed: $!\n" if $? != 0;
   if ($address eq "\n")
   {
      $address = `scan $foldstr $msg -format '%{from}'`; die "oops, scan failed: $!\n" if $? != 0;
   }
   chop($address);

   # paranoia
   die "oops, message has empty From: field?!?\n" if ($address eq '');

   return $address;
}

sub getaliasfile()
{
   # return the filename the user keeps aliases in, by
   # reading config details from the user's .mh_profile...
   my($mhpath,$aliasfile);

   chop($mhpath = `mhpath +`);
   die "aargh, 'mhpath +' failed: $!\n" if $? != 0; 
   if ($mhpath eq '')
   {
      die "No Path entry in .mh_profile -- it is mandatory! Aborting.\n";
   }

   $aliasfile=getprofileentry('aliasfile');
   if ($aliasfile eq '')
   { 
      # If we want to support adding an Aliasfile entry (ie starting a
      # new aliases file) then we should do that here...
      die <<EOT;
No Aliasfile entry in .mh_profile -- I don't know where to put
your mail aliases... Aborting.
EOT
   }
   # If the path is absolute to start with then just use that:
   if ($aliasfile =~ /^\//)
   {
      return $aliasfile;
   }

   $aliasfile = $mhpath. '/' . $aliasfile;

   # If path is not absolute, prepend '~/' to make it relative to
   # user's home directory.
   $aliasfile = '~/' . $aliasfile if $aliasfile !~ /^\//;

   return $aliasfile;
}

sub deletealias($$)
{ 
   my($aliasfile, $alias) = @_;
   # delete alias from given alias file.
   # We do this by reading the file for /^$alias:/ and deleting
   # those lines. We also need to support continuation lines (\\n)
   # but can probably get away with ignoring /^<other-file/ directives...
   # It might be nice to split this out into a separate program
   # (call it rmalias or something?)

   my($continuing) = 0;   # flag, are we on later lines of a continuation?
   my($deleting) = 0;     # flag, are we on the alias to delete?
   my $oldalias;

   open(OLDALIASFILE, "$aliasfile") or die "oops, couldn't read $aliasfile: $!\n";
   open(ALIASFILE, ">$aliasfile.tmp") or die "oops, couldn't write to temporary file $aliasfile.tmp: $!\n";

   while (<OLDALIASFILE>)
   {
      # if continuing, treat this line the same as the last one,
      # regardless of whether or not it starts 'alias'...
      if (!$continuing)
      {
         $deleting = 1 if /^$alias/;   # check for alias to delete
      }
      # Next line will be a continuation of this one if this line 
      # ends in '\' and doesn't begin with ';' (which would make it a comment)
      $continuing = /^[^\;].*\\\n$/;
      print ALIASFILE unless $deleting;
      $deleting = 0 unless $continuing;
   }
   close ALIASFILE;
   close OLDALIASFILE;
   rename("$aliasfile.tmp", "$aliasfile") || die "oops, couldn't rename temporary file to $aliasfile: $!\n";

   # check that we succeeded :->
   chop($oldalias = `ali '$alias'`); 
   die "oops, ali $alias failed: $!\n" if $? != 0;
   die <<EOT if $oldalias ne $alias;
Oops, I tried to delete the old alias $alias from $aliasfile, but
it still seems to be aliased to $oldalias. Perhaps it's defined in
a system-wide aliases file or in a file included into your aliases
file with the '<included-file' syntax? 
I'm afraid you'll have to delete the old alias yourself...
EOT
}


# read the .mh_profile and extract a field value
# This correctly handles default values. It returns '' if
# there is no such component (or if there is and the value is '').
# The only reason for wrapping this up in a function
# is for the error-handling.
sub getprofileentry($)
{
    my($fieldname) = @_;
    my($value);
    chop($value = `mhparam '$fieldname'`);
    die "mhparam failed: $?" if $? != 0;
    return $value;
}