path: root/xmpt

#!/usr/bin/env perl

use Data::Dumper;
use Getopt::Long;
use IO::File;
use IPC::Open2;
use POSIX;
use utf8;

use strict;
use warnings;
use v5.10;

our $VERSION = '0';

my $verbose;
my $envpath      = 'localhost.env';
my $timeout      = 5;
my $testplanpath = 'testplan';
my $templatepath = 'xml';
my @libs;
my $help;

GetOptions('verbose|v'     => \$verbose,
           'env|e=s'       => \$envpath,
	   'timeout|t=i'   => \$timeout,
	   'testplan|p=s'  => \$testplanpath,
	   'templates|d=s' => \$templatepath,
           'lib|l=s'       => \@libs,
	   'help|h'        => \$help) || usage(1);
usage(0) if $help;

$| = 1;

local %evalpkg::env = read_env($envpath);
my @plans = load_plans($testplanpath, $templatepath);

# Ignore SIGPIPE at the top level, since it only matters when reading
# or writing to the subprocess.
local $SIG{PIPE} = sub {};

my ($inh, $outh) = (\*STDIN, \*STDOUT);
my $pid;
if (@ARGV) {
  $inh = $outh = undef;
  $pid = open2($inh, $outh, join(' ', @ARGV));
}
binmode($inh, ':utf8');
binmode($outh, ':utf8');

eval_in($inh, $outh, @plans);
waitpid($pid, 0) if $pid;

# TODO: swap over to Pod::Usage.
sub usage {
  print STDERR "Usage: $0 [-hv] [-e envpath] [-t seconds] [-p testplan] [-d templatedir] [-l libpath] [command]\n";
  exit shift;
}

sub read_env {
  my ($filen) = @_;

  my $fh = new IO::File("<$filen") ||
    die "Couldn't open $filen for reading: $!\n";
  binmode($fh, ':utf8');
  map {
    chomp;
    s/\#.*$//;
    map { s/^\s*([^\s]+)\s*$/$1/; $_ } split(/=/, $_, 2);
  } <$fh>;
}

our $testplan;
our $line;
sub load_plans {
  local $testplan = shift;
  my $dir = shift;

  my $planfh = new IO::File($testplan) ||
    die "Couldn't open $testplan for reading: $!.\n";
  local $line = 0;
  map {
    $line++;
    chomp;

    my %rc = (name => $_);
    $rc{send} = parse_template("$dir/$_.xml");
    if (-f "$dir/$_.expected.xml") {
      $rc{expect} = parse_template("$dir/$_.expected.xml");
    }
    \%rc;
  } <$planfh>
}

sub parse_template {
  my ($fn) = @_;

  my $fh = new IO::File($fn) ||
    die "Couldn't open $fn for reading at line $line in $testplan: $!.\n";
  binmode($fh, ':utf8');

  my @parts = split /([{}]|\n)/, do { local $/; <$fh> };
  my $intext = 1;
  my $curthunk;
  my $line = 1;
  my $thunkstart;
  my @rc;
  while (@parts) {
    my $tok = shift @parts;

    $line++ if $tok =~ /\n/;

    if ($intext) {
      if ($tok =~ /{/) {
        if ($line =~ /^#/) {
          do { my $tok = shift @parts } until $tok = '}';
          next;
        }
	$thunkstart = $line;
	$intext = 0;
      } else {
	push @rc, text($tok);
      }
    } else {
      if ($tok =~ /}/) {
	$intext = 1;
	push @rc, thunk($curthunk, $fn, $thunkstart);
	$curthunk = '';
      } else {
	$curthunk .= $tok;
      }
    }
  }

  die "Error in $fn: template ended inside thunk started at line $thunkstart.\n" .
    "\tDid you forget a '}'?\n" unless $intext;
  \@rc;
}

sub nothing { ["text", sub { "" }] }

sub text {
  my $t = shift;
  ['text', sub { $t }];
}

sub thunk {
  my ($b, $fn, $line) = @_;
  ['thunk',
   sub {
     package evalpkg;
     use utf8;
     local $evalpkg::arg = shift;
     my $rc = eval $b;
     $@ &&
       die "Error in $fn:$line: $@\ttestplan: $testplanpath\n\tenvpath: $envpath\n";
     $rc;
   }]
}

sub eval_in {
  local ($evalpkg::in, $evalpkg::out) = (shift, shift);
  my @plans = @_;

  foreach my $k (keys %evalpkg::env) {
    # TODO: put $k in the symbol table directly, rather than calling
    # string eval.
    eval "package evalpkg; sub $k() { env('$k') };";
  }

  eval {
    require $_ for @libs;
    foreach my $plan (@plans) {
      verbose("=> Executing $plan->{name} step.");
      do_send($plan->{name}, @{$plan->{send}});
      do_recv($plan->{name}, @{$plan->{expect}}) if $plan->{expect};
    }
  };
  $@ && die $@;
}

sub do_send {
  my $name = shift;
  my $s = join('', (map { $_->[1]->() } @_));
  verbose("SEND: $s");

  # TODO: make write SIGPIPE configurable, but for now just ignore it.
  local $SIG{PIPE} = sub {
    print STDERR "Warning: SIGPIPE received from '@ARGV' while writing in $name step.\n"
  };
  print $evalpkg::out $s;
}

sub do_recv {
  my $name = shift;
  my (@reparts, @thunks);
  foreach my $plan (@_) {
    # Text is matched explicitly, thunks are treated as wildcards,
    # with the match sent as an argument.
    if ($plan->[0] eq 'text') {
      my $t = $plan->[1]->();
      push @reparts, $t;
    } else {
      push @reparts, "(.*)";
      push @thunks, $plan->[1];
    }
  }
  my $re = join '', @reparts;
  # TODO: add CLI options for whitespace/quote substitution.
  $re =~ s/\s+/\\s\*/g;
  $re =~ s/'|"/\['"\]/g;

  # Need a persistent buffer for reading, because we may get more data
  # than needed when matching for expected output, so stash it here
  # for subsequent reads after the current matcher is done.
  state $readbuf = '';
  local $SIG{ALRM} = sub {
    my $b = $readbuf;
    chomp $b;
    die "Timed out waiting for match in $name step. Current read buffer:\n$b\nMatcher:\n$re\n";
  };
  local $SIG{PIPE} = sub {
    die "SIGPIPE received from '@ARGV' while matching in $name step.\n";
  };
  alarm $timeout;
  my @matches;
  while (1) {
    @matches = ($readbuf =~ /$re/);
    if (@matches >= @thunks) {
      $readbuf = $';
      last;
    }
    my $r;
    my $n = sysread $evalpkg::in, $r, 2048;
    die "Error reading data while waiting for match in $name step: $!.\n" if $n == -1;
    die "End of file while waiting for match in $name step.\n" unless $n;
    verbose("RECV: $r");
    $readbuf .= $r;
  }
  alarm 0;

  for (my $i = 0; $i < @thunks; $i++) {
    $thunks[$i]->($matches[$i]);
  }
}

sub verbose {
  if ($verbose) {
    my $msg = shift;
    chomp $msg;
    print STDERR strftime('%Y-%m-%d %H:%M:%S', localtime) . " [$$] $msg\n";
  }
}

sub assert_arg {
  my ($name, $want) = @_;
  if ($evalpkg::arg) {
    my $got = $evalpkg::arg;
    die "Bad $name (got '$got', want: '$want').\n" if $got ne $want;
  }
  $want;
}

# Stick actual execution in its own package so you don't accidentally
# clobber stuff in main while running templates.
package evalpkg; # TODO: Make package name dynamic.

use MIME::Base64;

our ($in, $out);
our %env;
our $arg;

sub env {
  my $k = shift;
  main::assert_arg($k, $env{$k});
}

sub bare_jid() {
  main::assert_arg('bare_jid', (split /\//, $env{full_jid}, 2)[0]);
}

sub localpart() {
  main::assert_arg('localpart', (split /\@/, $env{full_jid}, 2)[0]);
}

sub domainpart() {
  main::assert_arg('domainpart', (split /\//, (split /\@/, $env{full_jid}, 2)[1])[0]);
}

sub resourcepart() {
  main::assert_arg('resourcepart', (split /\//, $env{full_jid}, 2)[1]);
}

sub plain_auth() {
  MIME::Base64::encode(join("\0", "", bare_jid(), $env{password}));
}

sub stream() {
  main::assert_arg('stream', 'stream:stream');
}