Perl-based test harness for the commandline client sample

2026-03-22 06:45:37 +08:00 · 2013-08-31 01:04:34 +01:00
parent 0ae6ae5fea
commit 7a7fd69ee1
3 changed files with 349 additions and 0 deletions
--- a/tests/blackcore/scripts/perllib/BlackCore/Expect/Dict.pm
+++ b/tests/blackcore/scripts/perllib/BlackCore/Expect/Dict.pm
@@ -0,0 +1,144 @@
+#
+# Copyright (C) 2013 VATSIM Community / authors
+# This Source Code Form is subject to the terms of the Mozilla Public License,
+# version 2.0. If a copy of the MPL was not distributed with this file, you can
+# obtain one at http://mozilla.org/MPL/2.0
+#
+# This program is also separately licensed under the same terms as Perl itself.
+#
+##############################################################################
+#
+# This package offers an extra interface on top of Expect.pm, based on a
+# dictionary of patterns which can be dynamically enabled and disabled.
+#
+
+##
+## $dict = Dict->new($expect)
+##   Constructor, returns a new Dict object.
+##   $expect : The Expect object to be used.
+##
+## $key = $dict->add($pattern, $disabled_cb, $enabled_cb)
+##   Adds a pattern to the dictionary, which will be initially disabled.
+##   Returns a key object which can be used to refer to the pattern later.
+##   $pattern : A simple string or regex object.
+##   $disabled_cb : A callback to be called when the disabled pattern matches.
+##   $enabled_cb  : A callback to be called when the enabled pattern matches.
+##
+## $key = $dict->add_enabled($pattern, $disabled_cb, $enabled_cb)
+##   As add(), but the pattern will be initially enabled.
+##
+## $dict->enable($key)
+##   Enable a pattern.
+##   $key : As returned by add() or add_enabled().
+##
+## $dict->disable($key)
+##   Disable a pattern.
+##   $key : As returned by add() or add_enabled().
+##
+## $state = $dict->save_state()
+##   Returns a representation of the current state of the dictionary, which
+##   can be restored later.
+##
+## $dict->restore_state($state)
+##   Revert the dictionary to the state represented by $state.
+##
+## $dict->expect($timeout)
+##   Calls $expect->expect() with the patterns of the dictionary.
+##   $timeout : Time to wait in seconds.
+
+package BlackCore::Expect::Dict;
+use strict;
+use warnings;
+
+sub new
+{
+  my ($pkg, $expect) = @_;
+  die unless $expect->isa('Expect');
+  
+  return bless {
+    expect => $expect,
+    patterns => {},
+    enabled_patterns => {}
+  } => $pkg;
+}
+
+sub add
+{
+  my ($self, $pattern, $disabled_cb, $enabled_cb) = @_;
+  
+  my $key = keys %{ $self->{patterns} };
+  $self->{patterns}{$key} = [ $pattern, $disabled_cb, $enabled_cb ];
+  return $key;
+}
+
+sub add_enabled
+{
+  my ($self, @args) = @_;
+  
+  my $key = $self->add(@args);
+  $self->enable($key);
+  return $key;
+}
+
+sub enable
+{
+  my ($self, $key) = @_;
+  
+  $self->{enabled_patterns}{$key} = 1;
+}
+
+sub disable
+{
+  my ($self, $key) = @_;
+  
+  delete $self->{enabled_patterns}{$key}
+    if exists $self->{enabled_patterns}{$key};
+}
+
+sub save_state
+{
+  my ($self) = @_;
+  
+  return \%{ $self->{enabled_patterns} };
+}
+
+sub restore_state
+{
+  my ($self, $state) = @_;
+  
+  %{ $self->{enabled_patterns} } = %$state;
+}
+
+sub expect
+{
+  my ($self, $timeout) = @_;
+  
+  my @args;
+  my $last_key = scalar(keys %{ $self->{patterns} }) - 1;
+  foreach my $key (0..$last_key)
+  {
+    my $pattern = $self->{patterns}{$key}[0];
+    push @args, [ $pattern, sub { return $self->_matched($key) } ];
+  }
+  
+  my @result = $self->{expect}->expect($timeout, @args);
+
+  if (wantarray) {
+    return @result;
+  } else {
+    return $result[0];
+  }
+}
+
+sub _matched
+{
+  my ($self, $key) = @_;
+  
+  if (exists $self->{enabled_patterns}{$key}) {
+    return $self->{patterns}{$key}[2]();
+  } else {
+    return $self->{patterns}{$key}[1]();
+  }
+}
+
+1;
--- a/tests/blackcore/scripts/perllib/BlackCore/Expect/Test.pm
+++ b/tests/blackcore/scripts/perllib/BlackCore/Expect/Test.pm
@@ -0,0 +1,171 @@
+#
+# Copyright (C) 2013 VATSIM Community / authors
+# This Source Code Form is subject to the terms of the Mozilla Public License,
+# version 2.0. If a copy of the MPL was not distributed with this file, you can
+# obtain one at http://mozilla.org/MPL/2.0
+#
+# This program is also separately licensed under the same terms as Perl itself.
+#
+##############################################################################
+#
+# This package offers a procedural interface for specifying and running simple
+# unit tests of interactive commandline programs, implemented using Expect.pm.
+#
+
+##
+## All commandline arguments of the script are passed to Expect::spawn().
+## Therefore the first argument must be the name of the program to be tested.
+##
+## Expect.pm depends on IO::Pty, which only supports true Unix operating
+## systems. On Windows, this means Cygwin only. MinGW, ActiveState or
+## Strawberry Perl will not work.
+##
+## put($lines...)
+##   Prints $lines to stdin of the program under test.
+##
+## set_timeout($seconds)
+##   Set the number of seconds to wait for expected responses before returning
+##   an error.
+##
+## add_test($text, $patterns...)
+##   Add a test.
+##   $text : The text to print to stdin of the program under test.
+##   $patterns : One or more patterns which are expected to sequentially match
+##     the responses received from stdout of the program under test.
+##
+## add_ok($pattern)
+##   Add a pattern which will always be ignored if it matches while waiting
+##   for a response during a test.
+##
+## add_fail($pattern)
+##   Add a pattern which will always cause a test to fail if it matches while
+##   waiting for a response.
+##
+## run_tests()
+##   Run all defined tests in sequence, and print the results.
+##
+## Patterns can be simple strings, or regex objects.
+##
+
+package BlackCore::Expect::Test;
+use strict;
+use warnings;
+use BlackCore::Expect::Dict;
+use Expect;
+use IO::String;
+use base 'Exporter';
+our @EXPORT = qw(add_test add_ok add_fail run_tests put set_timeout);
+
+@ARGV > 0 or _usage();
+$ARGV[0] =~ m'^-' and _usage();
+
+our $timeout = 10;
+our $expect = Expect->new;
+our $log = IO::String->new;
+$expect->raw_pty(1);
+$expect->log_stdout(0);
+$expect->log_file($log);
+$expect->spawn(@ARGV) or die "$!";
+our $dict = BlackCore::Expect::Dict->new($expect);
+
+sub put
+{
+  print $log "$_\n" for @_;
+  $expect->print("$_\n") for @_;
+}
+
+sub set_timeout
+{
+  $timeout = shift;
+}
+
+sub add_test
+{
+  my ($print_test, @pattern_seq) = @_;
+  
+  my @pattern_keys;
+  foreach my $pattern (@pattern_seq) {
+    push @pattern_keys, $dict->add($pattern, \&_test_fail, \&_test_ok);
+  }
+  
+  chomp $print_test;
+  $print_test =~ m'(\S+)\N*$';
+  my $name = $1 || '';
+  push our @tests, [ $name, $print_test, @pattern_keys ];
+}
+
+sub add_ok
+{
+  my ($pattern) = @_;
+  
+  $dict->add_enabled($pattern, (sub { exp_continue_timeout }) x 2);
+}
+
+sub add_fail
+{
+  my ($pattern) = @_;
+  
+  $dict->add($pattern, \&_test_fail, \&_test_fail);
+}
+
+sub run_tests
+{
+  our $passes = 0;
+  our $fails = 0;
+  my $total = 0;
+  
+  foreach my $test (our @tests)
+  {
+    my ($name, $print_test, @pattern_keys) = @$test;
+    
+    my $dots = '.' x (40 - length $name);
+    
+    print $log "$print_test\n";
+    $expect->print("$print_test\n");
+    foreach my $key (@pattern_keys) {
+      $total++;
+      print "Testing $name$dots";
+      $dict->enable($key);
+      my $pos = $dict->expect($timeout);
+      $dict->disable($key);
+      _check_result();
+      defined $pos or print $expect->error . "\n";
+    }
+  }
+  
+  print "Log:\n" . ${ $expect->log_file->string_ref };
+  
+  my $errors = $total - $passes - $fails;
+  print "\n$total TESTS, $passes PASSED, $fails FAILED, $errors ERRORS\n";
+}
+
+sub _test_fail
+{
+  our $test_status = 'fail';
+  (our $fails)++;
+}
+
+sub _test_ok
+{
+  our $test_status = 'ok';
+  (our $passes)++;
+}
+
+sub _check_result
+{
+  if (our $test_status) {
+    print "$test_status\n";
+    $test_status eq 'ok' or print "Received: " . $expect->match . "\n";
+    undef $test_status;
+  } else {
+    print "error\n";
+  }
+}
+
+sub _usage
+{
+  print "Usage:\n  $0 <program>\nRun tests on <program>.\n";
+  exit;
+}
+
+1;
--- a/tests/blackcore/scripts/test_sample_cli_client.pl
+++ b/tests/blackcore/scripts/test_sample_cli_client.pl
@@ -0,0 +1,34 @@
+#!/usr/bin/perl
+#
+# Copyright (C) 2013 VATSIM Community / authors
+# This Source Code Form is subject to the terms of the Mozilla Public License,
+# version 2.0. If a copy of the MPL was not distributed with this file, you can
+# obtain one at http://mozilla.org/MPL/2.0
+#
+
+use strict;
+use warnings;
+use lib::abs 'perllib';
+use BlackCore::Expect::Test;
+
+my $callsign = 'TEST01';
+set_timeout(10);
+
+add_test(<<"", 'CONN_STATUS_CONNECTING', 'CONN_STATUS_CONNECTED');
+setserver vatsim-germany.org 6809
+setuser guest guest
+setrealname Pilot Client Tester
+setcallsign $callsign
+initconnect
+
+add_test('ping server', qr'PONG server');
+
+add_test('termconnect', 'CONN_STATUS_DISCONNECTED');
+
+add_ok(qr"PRIV_MSG server -> $callsign");
+
+add_fail('Cannot exec');
+
+run_tests();
+
+put('exit');