aboutsummaryrefslogtreecommitdiffstats
path: root/xmpt
diff options
context:
space:
mode:
Diffstat (limited to 'xmpt')
-rwxr-xr-xxmpt279
1 files changed, 279 insertions, 0 deletions
diff --git a/xmpt b/xmpt
new file mode 100755
index 0000000..bae4eee
--- /dev/null
+++ b/xmpt
@@ -0,0 +1,279 @@
+#!/usr/bin/env perl
+
+use Data::Dumper;
+use Getopt::Long;
+use IO::File;
+use IPC::Open2;
+use v5.10;
+
+use strict;
+use warnings;
+
+my $configpath = 'localhost.conf';
+my $testplanpath = 'testplan';
+my $templatepath = 'xml';
+my $timeout = 5;
+my $verbose;
+my $help;
+
+GetOptions('config|c=s' => \$configpath,
+ 'testplan|p=s' => \$testplanpath,
+ 'templates|d=s' => \$templatepath,
+ 'timeout|t=i' => \$timeout,
+ 'verbose|v' => \$verbose,
+ 'help|h' => \$help) || usage(1);
+usage(0) if $help;
+
+my %conf = read_conf($configpath);
+my @plans = load_plans($testplanpath, $templatepath);
+
+my $curstep;
+local $SIG{CHLD} = sub {
+ my $suffix = "before test plan started.";
+ $suffix = "in $curstep step." if $curstep;
+ die "Command '@ARGV' terminated $suffix\n"
+};
+
+my ($inh, $outh) = (\*STDIN, \*STDOUT);
+my $pid;
+if (@ARGV) {
+ $inh = $outh = undef;
+ $pid = open2($inh, $outh, join(' ', @ARGV));
+}
+binmode($inh, ':utf8');
+binmode($outh, ':utf8');
+autoflush $outh 1;
+eval_in($inh, $outh, \%conf, @plans);
+waitpid($pid, 0) if $pid;
+
+# TODO: swap over to Pod::Usage.
+sub usage {
+ print STDERR "Usage: $0 [-v] [-c config] [-p testplan] [-d templatedir] [-t seconds] [command]\n";
+ exit shift;
+}
+
+sub read_conf {
+ my ($filen) = @_;
+
+ my $fh = new IO::File("<$filen") ||
+ die "Couldn't open $filen for reading: $!\n";
+ 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 =~ /{/) {
+ $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;
+ local $evalpkg::arg = shift;
+ my $rc = eval $b;
+ $@ &&
+ die "Error in $fn:$line: $@\ttestplan: $testplanpath\n\tconfig: $configpath\n";
+ $rc;
+ }]
+}
+
+sub eval_in {
+ local ($evalpkg::in, $evalpkg::out) = (shift, shift);
+ local %evalpkg::env = %{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 {
+ foreach my $plan (@plans) {
+ $curstep = $plan->{name};
+ print STDERR "=> Executing $curstep step.\n" if $verbose;
+ 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]->() } @_));
+ if ($verbose) {
+ my $l = $s;
+ chomp $l;
+ print STDERR "SEND: $l\n" unless $l =~ /^\s*$/;
+ }
+ 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\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;
+ if ($verbose) {
+ my $l = $r;
+ chomp $l;
+ print STDERR "RECV: $l\n"
+ }
+ $readbuf .= $r;
+ }
+ alarm 0;
+
+ for (my $i = 0; $i < @thunks; $i++) {
+ $thunks[$i]->($matches[$i]);
+ }
+}
+
+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;
+
+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}));
+}