diff options
Diffstat (limited to 'testing')
| -rw-r--r-- | testing/.gitignore | 5 | ||||
| -rw-r--r-- | testing/Changes | 0 | ||||
| -rw-r--r-- | testing/MANIFEST | 13 | ||||
| -rw-r--r-- | testing/MANIFEST.SKIP | 9 | ||||
| -rw-r--r-- | testing/Makefile.PL | 30 | ||||
| -rw-r--r-- | testing/README | 0 | ||||
| -rw-r--r-- | testing/lib/Test/Irssi.pm | 314 | ||||
| -rw-r--r-- | testing/lib/Test/Irssi/Callbacks.pm | 123 | ||||
| -rw-r--r-- | testing/lib/Test/Irssi/Driver.pm | 258 | ||||
| -rw-r--r-- | testing/lib/Test/Irssi/Misc.pm | 35 | ||||
| -rw-r--r-- | testing/lib/Test/Irssi/Test.pm | 308 | ||||
| -rw-r--r-- | testing/lib/Test/Irssi/VirtualIrssi.pm | 32 | ||||
| -rwxr-xr-x | testing/t/001-use.t | 27 | ||||
| -rwxr-xr-x | testing/t/002-init.t | 33 | ||||
| -rw-r--r-- | testing/test-shim.pl | 114 | ||||
| -rwxr-xr-x | testing/test.pl | 17 | ||||
| -rwxr-xr-x | testing/tests/001-basic.t | 50 | ||||
| -rwxr-xr-x | testing/tests/002-cursor-test.t | 29 |
18 files changed, 1397 insertions, 0 deletions
diff --git a/testing/.gitignore b/testing/.gitignore new file mode 100644 index 0000000..119fe08 --- /dev/null +++ b/testing/.gitignore @@ -0,0 +1,5 @@ +Makefile +Makefile.old +blib/ +irssi.log +pm_to_blib diff --git a/testing/Changes b/testing/Changes new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/testing/Changes diff --git a/testing/MANIFEST b/testing/MANIFEST new file mode 100644 index 0000000..1810c3e --- /dev/null +++ b/testing/MANIFEST @@ -0,0 +1,13 @@ +Makefile.PL +MANIFEST +MANIFEST.SKIP +README +Changes + +t/001-use.t +t/002-init.t + +lib/Test/Irssi.pm +lib/Test/Irssi/Callbacks.pm +lib/Test/Irssi/Driver.pm +lib/Test/Irssi/Test.pm
\ No newline at end of file diff --git a/testing/MANIFEST.SKIP b/testing/MANIFEST.SKIP new file mode 100644 index 0000000..1bfcbf3 --- /dev/null +++ b/testing/MANIFEST.SKIP @@ -0,0 +1,9 @@ +.*\.git.* +pm_to_blib +.*\.old +.*\.bak +.*\.swp +blib/.* +^Makefile$ +\d+_local_ + diff --git a/testing/Makefile.PL b/testing/Makefile.PL new file mode 100644 index 0000000..3312c95 --- /dev/null +++ b/testing/Makefile.PL @@ -0,0 +1,30 @@ +use strict; +use warnings; +use Cwd; +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. + +WriteMakefile( + NAME => 'Test::Irssi', + AUTHOR => 'shabble <shabble+cpan@metavore.org>', + VERSION_FROM => 'lib/Test/Irssi.pm', # finds $VERSION + ABSTRACT_FROM => 'lib/Test/Irssi.pm', + PL_FILES => {}, + # LIBS => ["-L/opt/local/lib -lcprops"], + # INC => "-I/opt/local/include/cprops", + PREREQ_PM => { + 'Test::More' => 0, + 'Carp' => 0, + 'MooseX::Declare' => 0, + 'IO::File' => 0, + 'Term::VT102' => 0, + 'Term::Terminfo' => 0, + 'strictures' => 0, + 'Data::Dump' => 0, + }, + dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, + # clean => { + # FILES => 'CProps-Trie-* Trie.inl _Inline' + # }, + ); diff --git a/testing/README b/testing/README new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/testing/README diff --git a/testing/lib/Test/Irssi.pm b/testing/lib/Test/Irssi.pm new file mode 100644 index 0000000..0db7ee0 --- /dev/null +++ b/testing/lib/Test/Irssi.pm @@ -0,0 +1,314 @@ +use strictures 1; +use MooseX::Declare; + +our $VERSION = 0.02; + +class Test::Irssi { + + # requires the latest pre-release POE from + # https://github.com/rcaputo/poe until a new release is...released. + use lib $ENV{HOME} . "/projects/poe/lib"; + use POE; + + use Term::VT102; + use Term::Terminfo; + use feature qw/say switch/; + use Data::Dump; + use IO::File; + + use Test::Irssi::Driver; + use Test::Irssi::Callbacks; + use Test::Irssi::Test; + + has 'generate_tap' + => ( + is => 'rw', + isa => 'Bool', + required => 1, + default => 1, + ); + + has 'irssi_binary' + => ( + is => 'ro', + isa => 'Str', + required => 1, + ); + + has 'irssi_homedir' + => ( + is => 'ro', + isa => 'Str', + required => 1, + ); + + has 'terminal_width' + => ( + is => 'ro', + isa => 'Int', + required => 1, + default => 80, + ); + + has 'terminal_height' + => ( + is => 'ro', + isa => 'Int', + required => 1, + default => 24, + ); + + has 'vt' + => ( + is => 'ro', + isa => 'Term::VT102', + required => 1, + lazy => 1, + builder => '_build_vt_obj', + ); + + has 'logfile' + => ( + is => 'ro', + isa => 'Str', + required => 1, + default => 'irssi-test.log', + ); + + has '_logfile_fh' + => ( + is => 'ro', + isa => 'IO::File', + required => 1, + lazy => 1, + builder => '_build_logfile_fh', + ); + + has 'driver' + => ( + is => 'ro', + isa => 'Test::Irssi::Driver', + required => 1, + lazy => 1, + builder => '_build_driver_obj', + handles => { + run_headless => 'headless', + } + ); + + has '_callbacks' + => ( + is => 'ro', + isa => 'Test::Irssi::Callbacks', + required => 1, + lazy => 1, + builder => '_build_callback_obj', + ); + + has 'pending_tests' + => ( + is => 'ro', + isa => "ArrayRef", + required => 1, + default => sub { [] }, + traits => [qw/Array/], + handles => { + add_pending_test => 'push', + next_pending_test => 'shift', + tests_remaining => 'count', + } + ); + + has 'completed_tests' + => ( + is => 'ro', + isa => "ArrayRef", + required => 1, + default => sub { [] }, + traits => [qw/Array/], + handles => { + add_completed_test => 'push', + tests_completed => 'count', + }, + ); + + has 'active_test' + => ( + is => 'rw', + isa => 'Test::Irssi::Test', + ); + + sub new_test { + my ($self, $name, @params) = @_; + my $new = Test::Irssi::Test->new(name => $name, + parent => $self, + @params); + $self->add_pending_test($new); + return $new; + } + + method _build_callback_obj { + Test::Irssi::Callbacks->new(parent => $self); + } + + method _build_driver_obj { + Test::Irssi::Driver->new(parent => $self); + } + + method _build_vt_obj { + my $rows = $self->terminal_height; + my $cols = $self->terminal_width; + + Term::VT102->new($cols, $rows); + } + + method _build_logfile_fh { + + my $logfile = $self->logfile; + + my $fh = IO::File->new($logfile, 'w'); + die "Couldn't open $logfile for writing: $!" unless defined $fh; + $fh->autoflush(1); + + return $fh; + } + + method _vt_setup { + # options + my $vt = $self->vt; + + $vt->option_set(LINEWRAP => 1); + $vt->option_set(LFTOCRLF => 1); + + $self->_callbacks->register_callbacks; + + } + method screenshot { + my $data = ''; + my $vt = $self->vt; + foreach my $row (1 .. $vt->rows) { + $data .= $vt->row_plaintext($row) . "\n"; + } + return $data; + } + + method complete_test { + # put the completed one onto the completed pile + my $old_test = $self->active_test; + $self->add_completed_test($old_test); + + # TAP: print status. + if ($self->generate_tap) { + my $pass = $old_test->passed; + my $tap = sprintf("%s %d - %s", $pass?'ok':'not ok', + $self->tests_completed, + $old_test->description); + say STDOUT $tap; + if (not $pass) { + $old_test->details; + $self->log("-------------------"); + $self->log($self->screenshot); + $self->log("-------------------"); + + } + } + } + + method run_test { + # and make the next pending one active. + my $test = $self->next_pending_test; + $self->active_test($test); + + # signal to the driver to start executing it. + $poe_kernel->post(IrssiTestDriver => execute_test => $test); + } + + method run { + + $self->driver->setup; + $self->_vt_setup; + $self->log("Driver setup complete"); + ### Start a session to encapsulate the previous features. + + # TAP: print number of tests. + if ($self->generate_tap) { + print STDOUT "1.." . $self->tests_remaining . "\n"; + } + + $poe_kernel->run(); + } + + sub apply_delay { + my ($self, $delay, $next_index) = @_; + $poe_kernel->post(IrssiTestDriver + => create_delay + => $delay, $next_index); + } + + # TODO: pick one. + sub inject_text { + my ($self, $text) = @_; + $poe_kernel->post(IrssiTestDriver => got_terminal_stdin + => $text); + } + + sub simulate_keystroke { + my ($self, $text) = @_; + $poe_kernel->post(IrssiTestDriver => got_terminal_stdin + => $text); + + } + + method get_topic_line { + return $self->vt->row_plaintext(1); + } + + method get_prompt_line { + return $self->vt->row_plaintext($self->terminal_height); + } + + method get_window_statusbar_line { + return $self->vt->row_plaintext($self->terminal_height() - 1); + } + + method get_window_contents { + my $buf = ''; + for (2..$self->terminal_height() - 2) { + $buf .= $self->vt->row_plaintext($_); + } + return $buf; + } + + method get_cursor_position { + return ($self->vt->x(), $self->vt->y()); + } + + method load_script { + my ($script_name) = @_; + + } + + method summarise_test_results { + foreach my $test (@{$self->completed_tests}) { + my $name = $test->name; + printf("Test %s\t\t-\t%s\n", $name, $test->passed?"pass":"fail"); + $test->details(); + } + } + + sub log { + my ($self, $msg) = @_; + $self->_logfile_fh->say($msg); + } + +} + + __END__ + +=head1 NAME + +Test::Irssi - A cunning testing system for Irssi scripts + +=head1 SYNOPSIS + +blah blah blah diff --git a/testing/lib/Test/Irssi/Callbacks.pm b/testing/lib/Test/Irssi/Callbacks.pm new file mode 100644 index 0000000..8321ace --- /dev/null +++ b/testing/lib/Test/Irssi/Callbacks.pm @@ -0,0 +1,123 @@ +use strictures 1; + +package Test::Irssi::Callbacks; + +use Moose; +use Data::Dump qw/dump/; +use Data::Dumper; + +has 'parent' + => ( + is => 'ro', + isa => 'Test::Irssi', + required => 1, + ); + +sub register_callbacks { + my ($self) = @_; + + my $vt = $self->parent->vt; + $self->log("Callbacks registered"); + + $vt->callback_set(OUTPUT => sub { $self->vt_output(@_) }, undef); + $vt->callback_set(ROWCHANGE => sub { $self->vt_rowchange(@_) }, undef); + $vt->callback_set(CLEAR => sub { $self->vt_clear(@_) }, undef); + $vt->callback_set(SCROLL_DOWN => sub { $self->vt_scr_up(@_) }, undef); + $vt->callback_set(SCROLL_UP => sub { $self->vt_scr_dn(@_) }, undef); + $vt->callback_set(GOTO => sub { $self->vt_goto(@_) }, undef); + +} + +sub vt_output { + my ($self, $vt, $cb_name, $cb_data) = @_; + $self->log( "OUTPUT: " . dump([@_[1..$#_]])); +} + +sub vt_rowchange { + my $self = shift; + my ($vt, $cb_name, $arg1, $arg2) = @_; + + $arg1 //= '?'; + $arg2 //= '?'; + + $self->log( "-" x 100); + $self->log( "Row $arg1 changed: "); + + my $bottom_line = $vt->rows(); + + $self->log( "-" x 100); + $self->log( "Window Line"); + $self->log( "-" x 100); + $self->log( $vt->row_plaintext($bottom_line - 1)); + $self->log( "-" x 100); + $self->log( "Prompt line"); + $self->log( "-" x 100); + $self->log( $vt->row_plaintext($bottom_line)); + +} + +sub vt_clear { + my $self = shift; + my ($vt, $cb_name, $arg1, $arg2) = @_; + $arg1 //= '?'; + $arg2 //= '?'; + + $self->log( "VT Cleared"); +} + +sub vt_scr_dn { + my $self = shift; + my ($vt, $cb_name, $arg1, $arg2) = @_; + $arg1 //= '?'; + $arg2 //= '?'; + + $self->log( "Scroll Down"); +} + +sub vt_scr_up { + my $self = shift; + my ($vt, $cb_name, $arg1, $arg2) = @_; + $arg1 //= '?'; + $arg2 //= '?'; + + $self->log( "Scroll Up"); +} + + +sub vt_goto { + my $self = shift; + my ($vt, $cb_name, $arg1, $arg2) = @_; + $arg1 //= '?'; + $arg2 //= '?'; + + $self->log( "Goto: $arg1, $arg2"); +} + +sub vt_dump { + my ($self) = @_; + my $vt = $self->parent->vt; + my $rows = $self->parent->terminal_height; + my $str = ''; + for my $y (1..$rows) { + $str .= $vt->row_sgrtext($y) . "\n"; + } + + return $str; +} + +sub log { + my ($self, $msg) = @_; + #$self->parent->_logfile_fh->say($msg); +} + +__PACKAGE__->meta->make_immutable; + +no Moose; + + + +# # delegate to Callbacks. +# sub vt_dump { +# my ($self) = @_; +# my $cb = $self->parent->_callbacks->vt_dump(); +# } diff --git a/testing/lib/Test/Irssi/Driver.pm b/testing/lib/Test/Irssi/Driver.pm new file mode 100644 index 0000000..6b4e5e5 --- /dev/null +++ b/testing/lib/Test/Irssi/Driver.pm @@ -0,0 +1,258 @@ +use strictures 1; + +package Test::Irssi::Driver; + +use Moose; +use lib $ENV{HOME} . "/projects/poe/lib"; + +use POE qw( Wheel::ReadWrite Wheel::Run Filter::Stream ); +use POSIX; +use feature qw/say/; +use Data::Dump qw/dump/; + +has 'parent' + => ( + is => 'ro', + isa => 'Test::Irssi', + required => 1, + ); + +has 'headless' + => ( + is => 'rw', + isa => 'Bool', + default => 0, + ); + +sub START { + my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP]; + + $kernel->alias_set("IrssiTestDriver"); + + $self->log("Start handler called"); + + $self->save_term_settings($heap); + + # Set a signal handler. + $kernel->sig(CHLD => "got_sigchld"); + + $self->make_raw_terminal; + + my @stdio_options = + ( + InputHandle => \*STDIN, + OutputHandle => \*STDOUT, + InputEvent => "got_terminal_stdin", + Filter => POE::Filter::Stream->new(), + ); + + $self->log("stdio options: " . dump(@stdio_options)); + + # Start the terminal reader/writer. + $heap->{stdio} = POE::Wheel::ReadWrite->new(@stdio_options); + + $self->log("Created stdio wheel"); + + my $rows = $self->parent->terminal_height; + my $cols = $self->parent->terminal_width; + + my @program_options = + ( + Program => $self->parent->irssi_binary, + ProgramArgs => ['--noconnect', '--home=' . $self->parent->irssi_homedir ], + Conduit => "pty", + Winsize => [$rows, $cols, 0, 0], + StdoutEvent => "got_child_stdout", + StdioFilter => POE::Filter::Stream->new(), + ); + + $self->log("wheel options: " . dump(@program_options)); + + # Start the asynchronous child process. + $heap->{program} = POE::Wheel::Run->new(@program_options); + + $self->log("Created child run wheel"); + $poe_kernel->yield('testing_ready'); +} + +sub STOP { + my ($self, $heap) = @_[OBJECT,HEAP]; + $self->log("STOP called"); + $self->restore_term_settings($heap); + $self->parent->_logfile_fh->close(); + + if (not $self->parent->generate_tap) { + $self->parent->summarise_test_results(); + } +} + +### Handle terminal STDIN. Send it to the background program's STDIN. +### If the user presses ^C, then echo a little string + +sub terminal_stdin { + my ($self, $heap, $input) = @_[OBJECT, HEAP, ARG0]; + + if ($input =~ m/\003/g) { # C-c + $input = "/echo I like cakes\n"; + } elsif ($input =~ m/\x17/g) { # C-w + $input = "/quit\n"; + } + + $heap->{program}->put($input); +} + +### Handle STDOUT from the child program. +sub child_stdout { + my ($self, $heap, $input) = @_[OBJECT, HEAP, ARG0]; + # process via vt + $self->parent->vt->process($input); + + if (not $self->headless) { + # send to terminal + $heap->{stdio}->put($input); + } +} + +### Handle SIGCHLD. Shut down if the exiting child process was the +### one we've been managing. + +sub shutdown { + my ($self, $heap, $kernel) = @_[OBJECT, HEAP, KERNEL]; + $self->log("Shutdown called"); + $heap->{program}->kill(15); + $kernel->alias_remove("IrssiTestDriver"); +} + +sub CHILD { + my ($self, $heap, $child_pid) = @_[OBJECT, HEAP, ARG1]; + if ($child_pid == $heap->{program}->PID) { + delete $heap->{program}; + delete $heap->{stdio}; + } + return 0; +} + +sub setup { + my $self = shift; + + my @states = + ( + object_states => + [ $self => + { + _start => 'START', + _stop => 'STOP', + got_sigchld => 'CHILD', + + got_terminal_stdin => 'terminal_stdin', + got_child_stdout => 'child_stdout', + + got_delay => 'timer_expired', + create_delay => 'timer_created', + + + testing_ready => 'testing_ready', + test_complete => 'test_complete', + execute_test => 'execute_test', + + shutdown => 'shutdown', + } + ] + ); + $self->log("creating root session"); + + POE::Session->create(@states); + $self->log("session created"); + +} + +sub testing_ready { + my ($self) = $_[OBJECT]; + # begin by fetching a test from the pending queue. + $self->log("Starting to run tests"); + $self->log("-" x 80); + $self->parent->run_test; +} + +sub execute_test { + my ($self, $heap, $kernel, $test) = @_[OBJECT,HEAP, KERNEL, ARG0]; + # do some stuff here to evaluate it. + + $test->evaluate_test; + +} + +sub test_complete { + my ($self, $kernel) = @_[OBJECT, KERNEL]; + + $self->parent->complete_test; + + if ($self->parent->tests_remaining) { + $self->parent->run_test; + } + + # otherwise, we're done, and can shutdown. + #kernel->yield('shutdown'); + +} + +sub timer_created { + my ($self, $heap, $kernel, $duration) = @_[OBJECT, HEAP, KERNEL, ARG0]; + $kernel->delay(got_delay => $duration); + $self->log("Timer created for $duration"); +} + +sub timer_expired { + my ($self, $data) = @_[OBJECT,ARG0]; + $self->log("Timeout invoking test again."); + $self->parent->active_test->resume_from_timer; +} + +sub save_term_settings { + my ($self, $heap) = @_; + # Save the original terminal settings so they can be restored later. + $heap->{stdin_tio} = POSIX::Termios->new(); + $heap->{stdin_tio}->getattr(0); + $heap->{stdout_tio} = POSIX::Termios->new(); + $heap->{stdout_tio}->getattr(1); + $heap->{stderr_tio} = POSIX::Termios->new(); + $heap->{stderr_tio}->getattr(2); +} + +sub restore_term_settings { + my ($self, $heap) = @_; + + $heap->{stdin_tio}->setattr (0, TCSANOW); + $heap->{stdout_tio}->setattr(1, TCSANOW); + $heap->{stderr_tio}->setattr(2, TCSANOW); +} + +sub make_raw_terminal { + my ($self) = @_; + # Put the terminal into raw input mode. Otherwise discrete + # keystrokes will not be read immediately. + my $tio = POSIX::Termios->new(); + $tio->getattr(0); + my $lflag = $tio->getlflag; + $lflag &= ~(ECHO | ECHOE | ECHOK | ECHONL | ICANON | IEXTEN | ISIG); + $tio->setlflag($lflag); + my $iflag = $tio->getiflag; + $iflag &= ~(BRKINT | INPCK | ISTRIP | IXON); + $tio->setiflag($iflag); + my $cflag = $tio->getcflag; + $cflag &= ~(CSIZE | PARENB); + $tio->setcflag($cflag); + $tio->setattr(0, TCSANOW); +} + +sub log { + my ($self, $msg) = @_; + my $fh = $self->parent->_logfile_fh; + $fh->say($msg); +} + + +__PACKAGE__->meta->make_immutable; + +no Moose; + diff --git a/testing/lib/Test/Irssi/Misc.pm b/testing/lib/Test/Irssi/Misc.pm new file mode 100644 index 0000000..a6339e0 --- /dev/null +++ b/testing/lib/Test/Irssi/Misc.pm @@ -0,0 +1,35 @@ +package Test::Irssi::Misc; +use strictures 1; + + + +sub keycombo_to_code { + my ($key_combo) = @_; + my $output = ''; + my $ctrl = 0; + my $meta = 0; + if ($key_combo =~ m/[cC](?:trl)?-(.+)/) { + $ctrl = 1; + _parse_rest($1); + } + if ($key_combo =~ m/[Mm](?:eta)?-(.+)/) { + $meta = 1; + _parse_rest($1); + } +} + +sub _parse_key { + my ($rest) = @_; + my $special = { + left => '', + right => '', + up => '', + down => '', + tab => '', + space => '', + spc => '', + }; +} + + +1; diff --git a/testing/lib/Test/Irssi/Test.pm b/testing/lib/Test/Irssi/Test.pm new file mode 100644 index 0000000..cd0a6f9 --- /dev/null +++ b/testing/lib/Test/Irssi/Test.pm @@ -0,0 +1,308 @@ +use strictures 1; +use MooseX::Declare; + +class Test::Irssi::Test { + + use POE; + use Test::Irssi; + use Test::Irssi::Driver; + use feature qw/say/; + use Data::Dump qw/dump/; + + has 'parent' + => ( + is => 'ro', + isa => 'Test::Irssi', + required => 1, + ); + + has 'name' + => ( + is => 'ro', + isa => 'Str', + required => 1, + ); + + has 'description' + => ( + is => 'rw', + isa => 'Str', + default => '', + ); + + has 'states' + => ( + is => 'ro', + isa => 'ArrayRef', + traits => [qw/Array/], + default => sub { [] }, + lazy => 1, + handles => { + add_state => 'push', + state_count => 'count', + get_state => 'get', + }, + ); + + has 'results' + => ( + is => 'ro', + isa => 'ArrayRef', + default => sub { [] }, + ); + + has 'complete' + => ( + is => 'rw', + isa => 'Bool', + default => 0, + ); + + + has '_next_state' + => ( + is => 'rw', + isa => 'Int', + default => 0, + traits => [qw/Counter/], + handles => { + _increment_state_counter => 'inc', + _clear_state => 'reset', + }, + ); + + # TODO: should only be valid when complete is set. + sub passed { + my $self = shift; + my $pass = 0; + foreach my $result (@{$self->results}) { + $pass = $result; + } + return $pass and $self->complete; + } + + sub failed { + my $self = shift; + return not $self->passed; + } + + + sub details { + my ($self) = shift; + my $state_count = $self->state_count; + for (0..$state_count-1) { + my $state = $self->states->[$_]; + my $result = $self->results->[$_]; + say( "#\t" . $state->{type} . " - " . $state->{desc} . " " + . " = " .( $result?"ok":"not ok")); + } + } + ############# API FUNCTIONS ########################################## + + + method add_input_sequence(Str $input) { + $self->add_state({type => 'command', + of => 'input', + input => $input, + desc => 'input'}); + + $self->log("Adding $input as input"); + } + + method add_delay (Num $delay) { + $self->add_state({type => 'command', + of => 'delay', + desc => 'delay', + delay => $delay }); + $self->log("Adding $delay as delay"); + + } + + method add_keycode(Str $code) { + my $input = $self->translate_keycode($code); + $self->add_state({type => 'command', + desc => 'input', + input => $input }); + $self->log("Adding $input ($code) as input"); + + } + sub add_diag { + my ($self, $diag) = @_; + $self->add_state({type => 'command', + of => 'diag', + desc => $diag }); + } + + sub add_pattern_match { + my ($self, $pattern, $constraints, $desc) = @_; + $self->add_state({type => 'test', + of => 'pattern', + pattern => $pattern, + constraints => $constraints, + desc => $desc}); + + $self->log("Adding $pattern as output match "); + } + + sub test_cursor_position { + my ($self, $x, $y, $desc) = @_; + $self->add_state({type => 'test', + of => 'cursor', + x => $x, + y => $y, + desc => $desc }); + $self->log("Adding cursor [$x, $y] test "); + + } + + sub add_evaluation_function { + my ($self, $coderef, $desc) = @_; + $self->add_state({type => 'test', + of => 'function', + code => $coderef, + desc => $desc}); + } + + + ############# END OF API FUNCTIONS #################################### + + + + method translate_keycode(Str $code) { + my $seq = ''; + if ($code =~ m/M-([a-z])/i) { + $seq = "\x1b" . $1; + } elsif ($code =~ m/C-([a-z])/i) { + $seq = chr ( ord(lc $1) - 64 ); + } + return $seq; + } + + method this_state { + return $self->_next_state - 1; + } + + sub check_output { + my ($self, $data) = @_; + + my ($pattern, $constraints) = ($data->{pattern}, $data->{constraints}); + + my $ok = 0; + my $line = ''; + if ($constraints eq 'prompt') { + $line = $self->parent->get_prompt_line; + } elsif ($constraints eq 'window_sbar') { + $line = $self->parent->get_window_statusbar_line; + } elsif ($constraints eq 'window') { + # NOTE: not actually a line. + $line = $self->parent->get_window_contents; + } elsif ($constraints eq 'topic') { + $line = $self->parent->get_topic_line; + } + + $self->log("Testing pattern against: '$line'"); + + if ($line =~ m/$pattern/) { + $self->log("Pattern $pattern passed"); + $self->results->[$self->this_state] = 1; + } else { + $self->log("Pattern $pattern failed"); + $self->results->[$self->this_state] = 0;; + } + } + + sub get_next_state { + my ($self) = @_; + my $item = $self->get_state($self->_next_state); + $self->_increment_state_counter; + + return $item; + } + + sub evaluate_test { + my ($self) = @_; + + while (my $state = $self->get_next_state) { + + $self->log("Evaluating Test: " . dump($state)); + + my $type = $state->{type}; + + if ($type eq 'command') { + my $subtype = $state->{of}; + + if ($subtype eq 'diag') { + if ($self->parent->generate_tap) { + say STDOUT '#' . $state->{desc}; + } + } + if ($subtype eq 'input') { + $self->parent->inject_text($state->{input}); + $self->log("input: ". $state->{input}); + } + if ($subtype eq 'delay') { + $self->log("inserting delay"); + $self->parent->apply_delay($state->{delay}); + $self->results->[$self->this_state] = 1; + return; + } + + # all commands are considered to succeed. + $self->results->[$self->this_state] = 1; + + } elsif ($type eq 'test') { + + my $test_type = $state->{of}; + + if ($test_type eq 'pattern') { + my $pattern = $state->{pattern}; + $self->check_output($state); + } + if ($test_type eq 'cursor') { + my ($curs_x, $curs_y) = $self->parent->get_cursor_position; + + my $ret = 0; + if ($state->{x} == $curs_x and $state->{y} == $curs_y) { + $ret = 1; + } + + $self->results->[$self->this_state] = $ret; + + } + + if ($test_type eq 'function') { + # code evaluation + my @args = ($self, $self->parent, $self->parent->vt); + my $ret = $state->{code}->(@args); + $ret //= 0; # ensure that undef failures are + # marked as such. + $self->results->[$self->this_state] = $ret; + } + } else { + # wtf? + } + } + + $poe_kernel->post(IrssiTestDriver => 'test_complete'); + + $self->complete(1); + + $self->log("Test Execution Finished"); + } + + sub resume_from_timer { + my ($self) = @_; + $self->log("Resuming after timeout"); + $self->evaluate_test; + } + sub log { + my ($self, $msg) = @_; + $self->parent->_logfile_fh->say($msg); + } + + sub _all { $_ || return 0 for @_; 1 } +} + + + + __END__ diff --git a/testing/lib/Test/Irssi/VirtualIrssi.pm b/testing/lib/Test/Irssi/VirtualIrssi.pm new file mode 100644 index 0000000..dc3bfc7 --- /dev/null +++ b/testing/lib/Test/Irssi/VirtualIrssi.pm @@ -0,0 +1,32 @@ +use strictures 1; +use MooseX::Declare; + +class Test::Irssi::VirtualIrssi { + +# class that pretends to be irssi which you can pull out various data from. + + +has cursor + => ( + is => 'ro', + writer => '_set_cursor', + isa => 'ArrayRef[Int]', + default => sub { [0, 0] }, + ); + +has topic_row + => ( + ); + +has window_row + => ( + ); + +has prompt_row + => ( + ); + +has window + => ( + ); +} diff --git a/testing/t/001-use.t b/testing/t/001-use.t new file mode 100755 index 0000000..6ebbb5a --- /dev/null +++ b/testing/t/001-use.t @@ -0,0 +1,27 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use Test::More; +use Data::Dumper; + +BEGIN { + use_ok 'Test::Irssi'; +} + + +my $test = new_ok 'Test::Irssi', + [irssi_binary => 'null', irssi_homedir => 'null']; + +my @methods = qw/logfile terminal_height terminal_width irssi_homedir irssi_binary/; +can_ok($test, @methods); + +undef $test; + +done_testing; + +__END__ + + + diff --git a/testing/t/002-init.t b/testing/t/002-init.t new file mode 100755 index 0000000..b688f9f --- /dev/null +++ b/testing/t/002-init.t @@ -0,0 +1,33 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use Test::More; +use Data::Dumper; + +BEGIN { + use_ok 'Test::Irssi'; +} + + +my $test = new_ok 'Test::Irssi', + [irssi_binary => "/opt/stow/repo/irssi-debug/bin/irssi", + irssi_homedir => $ENV{HOME} . "/projects/tmp/test/irssi-debug"]; + +if (-f $test->logfile) { + ok(unlink $test->logfile, 'deleted old logfile'); +} + +my $drv = $test->driver; +isa_ok($drv, 'Test::Irssi::Driver', 'driver created ok'); + +diag "Starting POE session"; +$test->run(); + +done_testing; + +__END__ + + + diff --git a/testing/test-shim.pl b/testing/test-shim.pl new file mode 100644 index 0000000..628f7af --- /dev/null +++ b/testing/test-shim.pl @@ -0,0 +1,114 @@ +use strict; +use warnings; + +use Irssi; +use Irssi::Irc; +use Irssi::TextUI; + +use Data::Dumper; +use POSIX; +use Time::HiRes qw/sleep/; +use JSON::Any; + + +our $VERSION = '0.1'; +our %IRSSI = ( + authors => 'shabble', + contact => 'shabble+irssi@metavore.org', + name => 'test-shim', + description => '', + license => 'Public Domain', + ); + + +my $forked = 0; + +sub pipe_and_fork { + my ($read_handle, $write_handle); + pipe($read_handle, $write_handle); + + my $oldfh = select($write_handle); + $| = 1; + select $oldfh; + + return if $forked; + + my $pid = fork(); + + if (not defined $pid) { + _error("Can't fork: Aborting"); + close($read_handle); + close($write_handle); + return; + } + + $forked = 1; + + if ($pid > 0) { # this is the parent (Irssi) + close ($write_handle); + Irssi::pidwait_add($pid); + my $job = $pid; + my $tag; + my @args = ($read_handle, \$tag, $job); + $tag = Irssi::input_add(fileno($read_handle), + Irssi::INPUT_READ, + \&child_input, + \@args); + + } else { # child + child_process($write_handle); + close $write_handle; + + POSIX::_exit(1); + } +} +sub _cleanup_child { + my ($read_handle, $input_tag_ref) = @_; + close $read_handle; + Irssi::input_remove($$input_tag_ref); + _msg("child finished"); + $forked = 0; +} +sub child_input { + my $args = shift; + my ($read_handle, $input_tag_ref, $job) = @$args; + + my $input = <$read_handle>; + my $data = JSON::Any::jsonToObj($input); + if (ref $data ne 'HASH') { + _error("Invalid data received: $input"); + _cleanup_child($read_handle, $input_tag_ref); + } + + if (exists $data->{connection}) { + if ($data->{connection} eq 'close') { + _cleanup_child($read_handle, $input_tag_ref); + } + } else { + parent_process_response($data); + } +} + +sub parent_process_response { + my ($data) = @_; +} + + +sub child_process { + my ($handle) = @_; + +} + +sub _error { + my ($msg) = @_; + my $win = Irssi::active_win(); + $win->print($msg, Irssi::MSGLEVEL_CLIENTERROR); +} + +sub _msg { + my ($msg) = @_; + my $win = Irssi::active_win(); + $win->print($msg, Irssi::MSGLEVEL_CLIENTCRAP); +} + +Irssi::command_bind("start_pipes", \&pipe_and_fork); diff --git a/testing/test.pl b/testing/test.pl new file mode 100755 index 0000000..bf01530 --- /dev/null +++ b/testing/test.pl @@ -0,0 +1,17 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use feature qw/say/; +#use lib 'blib/lib'; + +use TAP::Harness; +my $harness = TAP::Harness->new({ verbosity => 1, + lib => 'blib/lib', + color => 1, + }); + +my @tests = glob($ARGV[0]); +say "Tests: " . join (", ", @tests); +$harness->runtests(@tests); diff --git a/testing/tests/001-basic.t b/testing/tests/001-basic.t new file mode 100755 index 0000000..60578d8 --- /dev/null +++ b/testing/tests/001-basic.t @@ -0,0 +1,50 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use feature qw/say/; +use Test::Irssi; + +my $tester = Test::Irssi->new + (irssi_binary => "/opt/stow/repo/irssi-debug/bin/irssi", + irssi_homedir => $ENV{HOME} . "/projects/tmp/test/irssi-debug"); + +if (exists $ENV{IRSSI_TEST_HEADLESS} and $ENV{IRSSI_TEST_NOHEADLESS} == 1) { + $tester->run_headless(0); + $tester->generate_tap(0); +} else { + $tester->run_headless(1); + $tester->generate_tap(1); +} + +my $test = $tester->new_test('test1'); +$test->description("simple echo tests"); + +$test->add_input_sequence("/echo Hello cats\n"); +$test->add_delay(1); +$test->add_input_sequence("/echo Hello Again\n"); +$test->add_input_sequence("this is a long test"); +$test->add_delay(0.5); +$test->add_pattern_match(qr/long/, 'prompt', 'prompt contains long'); +$test->add_delay(1); + +$test->add_pattern_match(qr/this is a .*? test/, 'prompt', 'prompt matches'); + +my $test2 = $tester->new_test('test2'); +$test2->description("cursor movement and deletion"); + +$test2->add_delay(1); +$test2->add_input_sequence("\x01"); +$test2->add_delay(0.1); +$test2->add_input_sequence("\x0b"); +$test2->add_delay(0.1); +$test2->add_input_sequence("/clear\n"); +$test2->add_delay(0.1); +$test2->add_input_sequence("/echo moo\n"); + +my $quit = $tester->new_test('quit'); +$quit->description('quitting'); +$quit->add_input_sequence("/quit\n"); + +$tester->run; diff --git a/testing/tests/002-cursor-test.t b/testing/tests/002-cursor-test.t new file mode 100755 index 0000000..eb35170 --- /dev/null +++ b/testing/tests/002-cursor-test.t @@ -0,0 +1,29 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use feature qw/say/; +use Test::Irssi; + +my $tester = Test::Irssi->new + (irssi_binary => "/opt/stow/repo/irssi-debug/bin/irssi", + irssi_homedir => $ENV{HOME} . "/projects/tmp/test/irssi-debug"); + +if (exists $ENV{IRSSI_TEST_HEADLESS} and $ENV{IRSSI_TEST_NOHEADLESS} == 1) { + $tester->run_headless(0); + $tester->generate_tap(0); +} else { + $tester->run_headless(1); + $tester->generate_tap(1); +} + +my $test = $tester->new_test('test1'); +$test->description("simple echo tests"); +$test->add_diag("Testing 123"); + +my $quit = $tester->new_test('quit'); +$quit->description('quitting'); +$quit->add_input_sequence("/quit\n"); + +$tester->run; |