#!/usr/bin/perl

# Chat script machine processor.

# Copyright 1999 Ray Blaak <blaak@infomatch.com>

# chatm 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, or (at your option) any later version.

# chatm is distributed under 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.

# If you need a copy of the GNU General Public License, write to the Free
# Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
# 02111-1307, USA.


sub Usage
{ die <<'USAGE';
usage: chatm [--help|-h] [-v|-vl|-vf file] [-t timeout] (-f sm_file | sm)
 Processes standard input according to the specified state machine.
  --help      Gives this text.
  -v          Verbose. State transition descriptions are written to STDERR.
  -vl         Verbose, but written to syslog instead.
  -vf file    Verbose, but written to specified file.
  -t timeout  Maximum seconds to wait for a matching pattern (default 30).
  -f sm_file  Read state machine description from the specified file.
  sm          State machine description of the form:

  [rule1, rule2, ..., ruleN]

  where a rule is of the form:
 
  [state_pattern, wait_pattern, send_text, new_state].

  The description can be broken across lines, strings containing whitespace
  needed to be quoted, comments are denoted by a '#'. Essentially it is the
  perl syntax for nested array references.

  A state pattern is a regular expression to match the current state.  The
  initial state is called START, and switching to the state END halts the
  machine successfully. Switching to the state FAIL halts the machine in a
  failure mode, and the last received/sent patterns are reported.

  A wait pattern is a regular expression to match some input text. Upon a
  match, and if the current state matches, the send_text (and a carraige
  return) is written to output, and the current state becomes the new_state.

  If a wait pattern is "", no waiting is done. If the send text is "", nothing
  is sent. To send a single carraige return, use "\r". To send a single
  newline, use "\n". Any send text that ends with a "\r" or "\n" does not have
  a "\r" appended. To send text *without* a carraige return, end it with "\c"
  (e.g. "carraige return is suppressed\c"). To send an arbitrary character,
  use "\xNN", where N is a hex digit.

  If no state/wait pair matches within a specified time (default 30 seconds),
  and current state transitions to "current_state/TIMEOUT" with an input of
  "".  If still no rule matches, the TIMEOUT state is entered and the machine
  halts in a failure mode.
USAGE
}

use strict;
use FileHandle;
use Getopt::Long;
use Safe;

my $true = 1;
my $false = 0;

my $help = $false;
my $verbose = $false;
my $verbose_log = $false;
my $verbose_file = undef;
my $timeout_period = 30;
my $chat_script = "";
my $chat_machine = undef;
my $chat_state = "START";
my $chat_file = "";

# Get our arguments;
GetOptions ('help|h', \$help, 'f=s', \$chat_file, 
            't=i', \$timeout_period,
            'v', \$verbose, 'vl', \$verbose_log, 'vf=s', \$verbose_file);
if ($help)
{ Usage;
  exit 0;
}
elsif ($chat_file)
{ # Get the state machine from the file.
  open CHAT_FILE, "< $chat_file" or die "file not found: $chat_file\n";
  while (<CHAT_FILE>)
  { $chat_script = $chat_script . $_;
  }
  close CHAT_FILE;
}
elsif (scalar (@ARGV) > 0)
{ # Get the state machine from the command line.
  $chat_script = join (' ', @ARGV);
}
else
{ Usage;
  exit 1;
}

# I/O: Allow direct character input (no line buffering), autoflush for output,
# send debug output to STDERR.
my $line_buffer = " " x 256;
STDIN->setvbuf ($line_buffer, _IONBF, length($line_buffer));
STDOUT->autoflush($true);
# Configure modem device.
system "stty -echo raw 2>/dev/null";
my $line_input = "";
my ($line_length, $line_index) = (0, -1);

# Set up verbose output, if necessary.
my $verbose_output;
$verbose_output = ">& STDERR" if $verbose;
$verbose_output = "| logger -t 'chatm[$$]'" if $verbose_log;
$verbose_output = "> $verbose_file" if $verbose_file;
$verbose = $verbose or $verbose_log or $verbose_file;
if ($verbose)
{ open DEBUG_LOG, $verbose_output
    or die "cannot open verbose output: $verbose_output\n";
  DEBUG_LOG->autoflush($true);
}

# Read descriptor for the select probe.
my $read_descriptor;
vec($read_descriptor, STDIN->fileno, 1) = 1;


# Build the state machine. Since the chat script is evaluated as a
# perl expression, we allow no operations in the machine except those
# for literal data.
my $machine_room = new Safe 'chatscript';
$machine_room->mask (Safe::fullmask);
$machine_room->untrap ("const", "pushmark", "anonlist", "refgen", "leaveeval",
                       "stringify");
# Disable perl variable references in the chat script
$chat_script =~ s/([^\\])([@\$][^\"\'])/\1\\\2/mg;
$chat_machine = $machine_room->reval ($chat_script);
die "invalid chat machine: $@\n" if $@;

sub Chat;

my $success = 0;
my $failure = 1;
if (Chat)
{ exit $success;
}
else
{ exit $failure;
}

sub Quoted
# Ensures non-printable characters are printable.
{ my $s = shift;
  my ($quoted, $c, $q);
  my $c;
  my %specials = ("\\" => "\\\\", "\n" => "\\n", "\r" => "\\r", "\f" => "\\f",
                  "\t" => "\\t", "\e" => "\\e", "\"" => "\\\"");
  my $punc = " !\@#\$\%^&*()_-+={}[]/:;'<>,.?|";
  foreach $c (split //, $s)
  { if ($q = $specials{$c}) {}
    elsif ($c =~ /[a-zA-Z0-9]/) {$q = $c;}
    elsif (0 <= index ($punc, $c)) {$q = $c;}
    else {$q = sprintf ("\\x%02X", ord ($c));}
    $quoted .= $q;
  }
  return "\"" . $quoted . "\"";
}

sub Debug
{ my $line = shift;
  print DEBUG_LOG "[$chat_state] $line\n" if $verbose;
}

sub GetChar
{ my $c = undef;
  if (0 <= $line_index and $line_index < $line_length)
  { # Get buffered character.
    $c = substr $line_input, $line_index, 1;
    $line_index += 1;
  }
  else
  { # No buffered chars. Input some more.
    my ($rout, $timeout) = ($read_descriptor, 1);
    my ($wout, $eout);
    my $count;
    if (0 < select ($rout, $wout, $eout, $timeout))
    { $line_input = "";
      $line_length = sysread STDIN, $line_input, 255;
      $line_index = 0;
      $c = GetChar() if $line_length > 0;
    }
  }
  return $c;
}

sub GetLine
{ my $c;
  $_ = undef;
  $c = GetChar;
  while (defined $c)
  { $_ .= $c;
    last if $c eq "\n";
    $c = GetChar;
  }
  Debug ("Got: " . Quoted($_)) if defined $_;
  return $_;
}

sub Send
{ my $sent = shift;
  if ($sent)
  { my $last = substr ($sent, -1, 1);
    $sent .= "\r" if not ($last eq "\r" or $last eq "\n");
    print $sent;
    Debug ("Sent: " . Quoted($sent));
  }
}

sub Matches
{ my ($input, $rule) = @_;
  my ($state_pattern, $wait_pattern, $send_text, $next_state) = @{$rule};
  my $matches = ($chat_state =~ /$state_pattern/ 
                 and (($wait_pattern) 
                      ? $input =~ /$wait_pattern/
                      : $input eq $wait_pattern));
  if ($matches)
  { Debug ("Matched: [/$state_pattern/, /$wait_pattern/" 
           . ", " . Quoted($send_text) . ", $next_state]");
    Send ($send_text);
    $chat_state = $next_state;
    Debug ("State entered");
  }
  return $matches;
}

sub IsStopState
{ my $state = shift;
  return $state =~ /^(END|FAIL|TIMEOUT)$/;
}

sub SettleTransitions
{ # Process non-waiting transitions.
  my $rule;
  my $settled = $false;
  while (not ($settled or IsStopState($chat_state)))
  { $settled = $true;      
    foreach $rule (@{$chat_machine})
    { if (Matches ("", $rule))
      { $settled = $false;
        last;
      }
    }
  }
}

sub TransitionOnMatch
{ my ($input) = @_;
  my $transitioned = $false;
  my $rule;

  foreach $rule (@{$chat_machine})
  { if (Matches ($input, $rule))
    { SettleTransitions;
      $transitioned = $true;
      last;
    }
  }
  return $transitioned;
}

sub Chat
{ # Scan until an end state is reached.
  my $received;
  my $success = $false;
  my $timeout = time + $timeout_period;
  my $transitioned;
  my $current_state;

  $chat_state = "START";
  SettleTransitions;
  while (not IsStopState($chat_state))
  { $current_state = $chat_state;
    $received = GetLine;
    if (defined $received)
    { # Look for a matching pattern in the current state.
      if (TransitionOnMatch ($received))
      { # We had a match. Reset the timeout.
        $timeout = time + $timeout_period;
      }
    }

    if (time >= $timeout)
    { # We have timed out.
      $chat_state = "$chat_state/TIMEOUT";
      if (TransitionOnMatch (""))
      { # The timeout was handled. Reset it.
        $timeout = time + $timeout_period;      
      }
      else
      { # Not handled. We have a true timeout.
        $chat_state = "TIMEOUT";
      }
    }
  }

  if ($chat_state eq "END")
  { $success = $true;
  }
  else
  { my %map = ("TIMEOUT" => "Timeout", "FAIL" => "Failure");
    my $error = (($map{$chat_state}) ? $map{$chat_state} : "Unknown error");
    print STDERR "$error during $current_state. Last input: "
      . Quoted($received) . "\n";
  }
  return $success;
}
