#!/usr/bin/perl -w
# ham.pl - Htam's Away Messages handler for pork
# Author: Jed Yang (htam) <jed@htam.org> [aim:htam23]
# Date: 2005.07.28
# Usage: After loading with /perl_load, access this script by using /ham in pork.
# Versions:
# 0.2 - preliminary release, primary functions
# 0.3 - added regex support with highlighting and editing
# TODO:
# - add EVENT_UNLOAD
# - one letter shorthand for commands

use strict;

my $DAT = ".pork/ham.dat";
my $VER = "0.3";

# These are for highling regex results uncomment one set
# Reverse
my $MARKSTART = "%%2";
my $MARKEND = "%%-2";

# Yellow
#my $MARKSTART = "%%Y";
#my $MARKEND = "%%x";

# None
#my $MARKSTART = "";
#my $MARKEND = "";

my $handler_refnum;
my %msgs = ();
my $acct;

sub echo
{
   return PORK::echo("$_[0]");
}

sub strip_word
{
   local $_ = shift;
   my($f, $l) = ("", "");
   if (/\s/) {
      ($f, $l) = /(@?\w+)\s+(.*)/;
   } else {
      $f = $_;
   }
   return ($f, $l);
}

sub getMessages
{
   chdir;
   if (! -e $DAT)
   {
      open (DAT, "> $DAT") || die ("error creating $DAT: $!");
      print DAT "ham I am using ham $VER in pork";
      close DAT;
   }
   open (DAT, $DAT) || die ("error opening $DAT for reading: $!");
   while (<DAT>)
   {
      chomp;
      my ($k, $m) = /(@?\w+)\s+(.*)/;
      $msgs{$k}=$m;
   }
   close DAT;
}

sub saveMessages
{
   chdir;
   open (DAT, "> $DAT") || die ("error opening $DAT for writing: $!");
   my $k;
   foreach $k (sort(keys(%msgs)))
   {
      print DAT "$k $msgs{$k}\n";
   }
   close DAT;
}

sub ham_add
{
   if (@_ == 0 || $_[0] eq '')
   {
      echo("Usage: ham add <keyword> <msg>");
      echo("Add <msg> as the message of <keyword> to the repetoire. Overwrite if already present.");
      return -1;
   }
   my($k, $m);
   if (@_ == 1) { ($k, $m) = strip_word shift; }
   else { ($k, $m) = @_ }
   
   if ($m)
   {
      if ($msgs{$k})
      {
         echo("Overriding `$msgs{$k}'");
      }
      $msgs{$k}=$m;
      echo("Away message keyword `$k' set to `$m'");
   }
   else
   {
      if ($msgs{$k})
      {
         echo("Away message keyword `$k' is `$msgs{$k}'");
      }
      else
      {
         echo("Away message keyword `$k' is undefined");
      }
   }
   return 0;
}

sub ham_del
{
   if (@_ == 0 || $_[0] eq '')
   {
      echo("Usage: ham del <keyword>");
      echo("Delete <keyword> from the repetoire.");
      return -1;
   }
   my($k) = shift;
   if ($msgs{$k})
   {
      echo("Away message keyword `$k' with message `$msgs{$k}' deleted");
      delete $msgs{$k};
      return 0;
   }
   else
   {
      echo("No match.");
      return -1;
   }
}

sub ham_use
{
   if (@_ == 0 || $_[0] eq '')
   {
      echo("Usage: ham use <keyword> [<msg>]");
      echo("If <msg> present, this will add <msg> for <keyword> first.  Then in any case, use the message of <keyword> as away message.");
      return -1;
   }
   my($k, $m);
   if (@_ == 1) { ($k, $m) = strip_word shift; }
   else { ($k, $m) = @_ }

   if ($m)
   {
      ham_add($k, $m);
   }
   if (PORK::set_away($msgs{$k}, $acct) == 0)
   {
      echo("Away message set to `$msgs{$k}'");
      return 0;
   }
   else
   {
      echo("Unable to set away message.");
      return -1;
   }
}

sub ham_edit
{
   if (@_ == 0 || $_[0] eq '')
   { 
      echo("Usage: ham edit <keyword> <regex>");
      echo("Edit the message of <keyword> by applying <regex> to it.");
      echo("This <regex> is of the form `/foo/bar/' where `foo' will be replaced by `bar' globally.  One could use any (nonspace) character as delimiter in place of `/'.  Choose carefully, as no escaping of the delimiter character will be allowed.  Also, do not try to use s///i (don't worry if you have no idea what this is, just don't use it.)");
      echo("For example, to append the string `~/bin/pork' to the end of an away message, one may use `#\$#~/bin/pork#' to achieve the job (note `\$' matches the end of string).  For more information on regular expressions, read `perldoc perlrequick' or `man 7 regex' if you do not have `perldocs' installed.");
      return -1;
   }
   my($k, $r);
   if (@_ == 1) { ($k, $r) = strip_word shift; }
   else { ($k, $r) = @_ }
   
   if (!$msgs{$k})
   {
      echo ("Away message keyword `$k' is undefined.");
      return -1;
   }
   my $now = "";
   if ($r) {
      if ($r =~ /^(.)(.*)\1(.*)\1$/) {
         my $s = $3;
         if ($msgs{$k} =~ s/$2/$s/g) {
            $now = " now";
         } else {
            echo("No match.");
            return -1;
         }
      } else {
         echo("The regular expression entered is malformed.");
         return -1;
      }
   }
   echo("Away message keyword `$k' is$now `$msgs{$k}'.");
   return 0;
}

sub ham_list_help
{
   echo("Usage: ham list [<regex>]");
   echo("List all keywords (with their messages) that match <regex>.  If no arguments are present, list all.");
}

sub ham_list
{
   my $r = shift;
   my $f = 0;
   my $k;
   foreach $k (sort(keys(%msgs)))
   {
      if (!$r)
      {
         echo("`$k' => `$msgs{$k}'");
         $f++;
      }
      elsif ($k =~ /$r/)
      {
         echo("`$`$MARKSTART$&$MARKEND$'' => `$msgs{$k}'");
         $f++;
      }
   }
   if (!$f)
   {
      my $match = ($r?" matches":"");
      echo("Nothing$match.");
   }
}

sub ham_search
{
   if (@_ == 0 || $_[0] eq '')
   {
      echo("Usage: ham search <regex>");
      echo("Search for away messages using regex matching on the text.");
      return -1;
   }
   my $r = shift;
   
   my $f = 0;
   my $k;
   foreach $k (sort(keys(%msgs)))
   {
      if ($msgs{$k} =~ /$r/)
      {
         echo("`$k' => `$`$MARKSTART$&$MARKEND$''");
         $f++;
      }
   }
   if (!$f)
   {
      echo("Nothing matches.");
   }
}

sub ham_random_help
{
   echo("Usage: ham random [<keywords>]");
   echo("Randomly use a keyword as away message.  This may be combined with a TIMER (external) to keep changing away messages.  If a keyword starts with the symbol `\@', it will be treated as a list, and its contents will be treated as keywords.  List evaluation occurs only once. So no nesting of lists are allowed.  If no argument is present, the entire repetoire will be used, lists will still be parsed, causing entries in them to have increased frequency.");
}

sub ham_random
{
   local $_, @_;
   srand; # yes, yes, I know, but whatever

   # put individual words in all arguments in @l
   my @l = ();
   foreach (@_)
   {
      push(@l, split);
   }

   # have some (intelligent) default behaviour
   if (@l == 0)
   {  
      @l = keys(%msgs);
   }

   # validation
   # N.B. do not try to reduce code by pushing a list to the end for validation
   # we need to assume that users are dumb (or malicious)
   # and may include recursive lists, so do not parse them
   # sorry to those intelligent users who want lists inside lists (correctly)
   @_ = ();
   foreach (@l)
   {
      if ($_ =~ /^@(.*)/)
      { # this is a list
         if ($_ = $msgs{$_})
         { # and it has content
            foreach (split)
            { # look at each content
               if ($msgs{$_})
               { # verify
                  push(@_,$_); # and add
               }
            }
         }
      }
      else
      {
         if ($msgs{$_})
         {
            push(@_,$_);
            # repetition is allowed to procure increased frequency
         }
      }
   }
   
   # this happens because the USER specified keys that cannot be matched
   # we already tried to be intelligent, no need to be overly intelligent
   if (@_ == 0)
   {
      echo("No match.");
      return -1;
   }

   return ham_use $_[int rand(@_)];
}  

sub ham_unaway
{
   if (@_ == 0 || $_[0] eq '')
   {
      echo("Usage: ham unaway [<number>]");
      echo("Remove away status.  Optionally include your favourite number, and it will be used to match you up with another ham user such that the sum of your two numbers is a prime and their product is a perfect number (http://mathworld.wolfram.com/PerfectNumber.html).  Just kidding, any arguments will be silently ignored.");
      return -1;
   }
   if (PORK::set_away("", $acct) == 0)
   {
      echo("You are no longer away.");
      return 0;
   }
   else
   {
      echo("Unable to remove away status.");
      return -1;
   }
}

sub ham_credits
{
   echo("ham - Htam's Away Messages handler for pork");
   echo("Author: Jed Yang (htam)");
   echo("Version: $VER");
}

sub ham
{
   my ($c, $a) = strip_word shift;
   $acct = shift;

   getMessages();

   if ($c eq 'add') {
      ham_add $a;
   } elsif ($c eq 'del') {
      ham_del $a;
   } elsif ($c eq 'use') {
      ham_use $a;
   } elsif ($c eq 'edit') {
      ham_edit $a;
   } elsif ($c eq 'list') {
      ham_list $a;
   } elsif ($c eq 'search') {
      ham_search $a;
   } elsif ($c eq 'random') {
      ham_random $a;
   } elsif ($c eq 'unaway') {
      ham_unaway 1; # no input results in `help'
   } elsif ($c eq 'help') {
      ham_credits; echo("");
      ham_add; echo("");
      ham_del; echo("");
      ham_use; echo("");
      ham_edit; echo("");
      ham_list_help; echo("");
      ham_search; echo("");
      ham_random_help; echo("");
      ham_unaway;
   } elsif ($c eq 'credits' || $c eq 'author' || $c eq 'version') {
      ham_credits;
   } else {
      echo("Usage: Methink thou art confused, try the following, one at a time.");
      echo("   away < help | add | del | use | edit | list | search | random | unaway | version >");
   }

   saveMessages();
   return (1); # do NOT continue
}

sub ham_handler
{
   my $k = shift;
   my $acct = shift;
   
   getMessages();
   
   if ($msgs{$k})
   {
      ham_use $k;
      return 1; # do NOT continue
   }
   return 0; # continue
}

sub ham_unload
{
   PORK::event_del_refnum($handler_refnum);
   PORK::unalias("ham");
   return 1;
}

$handler_refnum = PORK::event_add("SEND_AWAY", "ham_handler");
PORK::event_add("EVENT_UNLOAD", "ham_unload");
PORK::alias("ham", "perl ham");