diff options
| -rwxr-xr-x | testing/auto-testing.pl | 95 | ||||
| -rw-r--r-- | testing/lib/Test/Irssi.pm | 32 | ||||
| -rw-r--r-- | testing/lib/Test/Irssi/Callbacks.pm | 113 | ||||
| -rw-r--r-- | testing/lib/Test/Irssi/Driver.pm | 89 |
4 files changed, 199 insertions, 130 deletions
diff --git a/testing/auto-testing.pl b/testing/auto-testing.pl deleted file mode 100755 index 69a855e..0000000 --- a/testing/auto-testing.pl +++ /dev/null @@ -1,95 +0,0 @@ - - -#package Test::Irssi; - -use warnings; -use strict; - -# for fixed version of P:W:R -use lib $ENV{HOME} . "/projects/poe/lib"; - -sub PROGRAM () { "/opt/stow/repo/irssi-debug/bin/irssi" } -sub IRSSI_HOME () { $ENV{HOME} . "/projects/tmp/test/irssi-debug" } - -sub ROWS () { 24 } -sub COLS () { 80 } - -use Term::VT102; -use Term::TermInfo; -use feature qw/say switch/; -use Data::Dumper; -use IO::File; - -my $logfile = "irssi.log"; -my $logfh = IO::File->new($logfile, 'w'); - die "Couldn't open $logfile for writing: $!" unless defined $logfh; - -$logfh->autoflush(1); - - -my $ti = Term::Terminfo->new(); -my $vt = Term::VT102->new(rows => ROWS, cols => COLS); - -vt_configure_callbacks($vt); - -sub vt_output { - my ($vt, $cb_name, $cb_data, $priv_data) = @_; - say $logfh "OUTPUT: " . Dumper([@_[1..$#_]]); -} - - -sub vt_rowchange { - my ($vt, $cb_name, $arg1, $arg2, $priv_data) = @_; - #say $logfh "ROWCHANGE: " . Dumper(\@_); - #say $logfh "Row $arg1 changed: "; - #say $logfh $vt->row_plaintext($arg1); - my $bottom_line = $vt->rows(); - say $logfh "-" x 100; - say $logfh "Window Line"; - say $logfh $vt->row_plaintext($bottom_line - 1); - say $logfh "-" x 100; - say $logfh "Prompt line"; - say $logfh $vt->row_plaintext($bottom_line); - say $logfh "-" x 100; - - - # print $ti->getstr("clear"); - # print vt_dump(); -} - -sub vt_clear { - my ($vt, $cb_name, $arg1, $arg2, $priv_data) = @_; - say $logfh "VT Cleared"; -} -sub vt_scr_dn { - my ($vt, $cb_name, $arg1, $arg2, $priv_data) = @_; - say $logfh "Scroll Down"; -} -sub vt_scr_up { - my ($vt, $cb_name, $arg1, $arg2, $priv_data) = @_; - say $logfh "Scroll Up"; -} -sub vt_goto { - my ($vt, $cb_name, $arg1, $arg2, $priv_data) = @_; - say $logfh "Goto: $arg1, $arg2"; -} - -sub vt_dump { - my $str = ''; - for my $y (1..ROWS) { - $str .= $vt->row_sgrtext($y) . "\n"; - } - return $str; -} - - - - - - -sub vt_configure_callbacks { - my ($vt) = @_; -} - -### Start POE's main loop, which runs the session until it's done. -exit 0; diff --git a/testing/lib/Test/Irssi.pm b/testing/lib/Test/Irssi.pm index f4acb71..be87dcf 100644 --- a/testing/lib/Test/Irssi.pm +++ b/testing/lib/Test/Irssi.pm @@ -11,9 +11,11 @@ class Test::Irssi { use Data::Dump; use IO::File; use Test::Irssi::Driver; + use Test::Irssi::Callbacks; # 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; @@ -82,6 +84,24 @@ class Test::Irssi { builder => '_build_driver', ); + has '_callbacks' + => ( + is => 'ro', + isa => 'Test::Irssi::Callbacks', + required => 1, + lazy => 1, + builder => '_build_callback_obj', + ); + + method _build_callback_obj { + my $cbo = Test::Irssi::Callbacks->new(parent => $self); + + $self->log("Going to register vt callbacks"); + $cbo->register_vt_callbacks; + + return $cbo; + } + method _build_driver { my $drv = Test::Irssi::Driver->new(parent => $self); return $drv; @@ -97,13 +117,6 @@ class Test::Irssi { $vt->option_set(LINEWRAP => 1); $vt->option_set(LFTOCRLF => 1); - # callbacks - $vt->callback_set(OUTPUT => \&vt_output, undef); - $vt->callback_set(ROWCHANGE => \&vt_rowchange, undef); - $vt->callback_set(CLEAR => \&vt_clear, undef); - $vt->callback_set(SCROLL_DOWN => \&vt_scr_dn, undef); - $vt->callback_set(SCROLL_UP => \&vt_scr_up, undef); - $vt->callback_set(GOTO => \&vt_goto, undef); return $vt; } @@ -126,14 +139,13 @@ class Test::Irssi { method run { - + $self->_driver->setup(); + $self->log("Driver setup complete"); ### Start a session to encapsulate the previous features. $poe_kernel->run(); } } - - __END__ =head1 NAME diff --git a/testing/lib/Test/Irssi/Callbacks.pm b/testing/lib/Test/Irssi/Callbacks.pm index e69de29..eb33039 100644 --- a/testing/lib/Test/Irssi/Callbacks.pm +++ b/testing/lib/Test/Irssi/Callbacks.pm @@ -0,0 +1,113 @@ +use strictures 1; + +package Test::Irssi::Callbacks; + +use Moose; +use Data::Dump qw/dump/; + +has 'parent' + => ( + is => 'ro', + isa => 'Test::Irssi', + required => 1, + ); + +sub register_vt_callbacks { + my ($self) = @_; + + $self->log("Callbacks registered"); + my $vt = $self->parent->vt; + # callbacks + $self->log("VT is " . ref($vt)); + + $vt->callback_set(OUTPUT => sub { \&vt_output }, $self); + $vt->callback_set(ROWCHANGE => sub { \&vt_rowchange }, $self); + $vt->callback_set(CLEAR => sub { \&vt_clear }, $self); + $vt->callback_set(SCROLL_DOWN => sub { \&vt_scr_dn }, $self); + $vt->callback_set(SCROLL_UP => sub { \&vt_scr_up }, $self); + $vt->callback_set(GOTO => sub { \&vt_goto }, $self); +} + +sub vt_output { + my ($vt, $cb_name, $cb_data, $self) = @_; + $self->log( "OUTPUT: " . dump([@_[1..$#_]])); +} + +sub vt_rowchange { + my ($vt, $cb_name, $arg1, $arg2, $self) = @_; + + $self->log("Type of param is: " . ref($_)) for (@_); + + $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 ($vt, $cb_name, $arg1, $arg2, $self) = @_; + $arg1 //= '?'; + $arg2 //= '?'; + + $self->log( "VT Cleared"); +} + +sub vt_scr_dn { + my ($vt, $cb_name, $arg1, $arg2, $self) = @_; + $arg1 //= '?'; + $arg2 //= '?'; + + $self->log( "Scroll Down"); +} + +sub vt_scr_up { + my ($vt, $cb_name, $arg1, $arg2, $self) = @_; + $arg1 //= '?'; + $arg2 //= '?'; + + $self->log( "Scroll Up"); +} + + +sub vt_goto { + my ($vt, $cb_name, $arg1, $arg2, $self) = @_; + $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; + diff --git a/testing/lib/Test/Irssi/Driver.pm b/testing/lib/Test/Irssi/Driver.pm index 8aa547a..0ff90e9 100644 --- a/testing/lib/Test/Irssi/Driver.pm +++ b/testing/lib/Test/Irssi/Driver.pm @@ -3,14 +3,18 @@ use strictures 1; package Test::Irssi::Driver; use Moose; -use MooseX::POE; +use lib $ENV{HOME} . "/projects/poe/lib"; + +#use MooseX::POE; 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', + is => 'ro', + isa => 'Test::Irssi', required => 1, ); @@ -18,6 +22,8 @@ has 'parent' sub START { my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP]; + $self->log("Start handler called"); + $self->save_term_settings($heap); # Set a signal handler. @@ -32,10 +38,13 @@ sub START { 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; @@ -49,35 +58,47 @@ sub START { 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"); +} sub STOP { my ($self, $heap) = @_[OBJECT,HEAP]; - $heap->{stdin_tio}->setattr (0, TCSANOW); - $heap->{stdout_tio}->setattr(1, TCSANOW); - $heap->{stderr_tio}->setattr(2, TCSANOW); - $self->_logfile_fh->close(); + $self->log("STOP called"); + $self->restore_term_settings($heap); + $self->parent->_logfile_fh->close(); } ### Handle terminal STDIN. Send it to the background program's STDIN. ### If the user presses ^C, then echo a little string -sub handle_terminal_stdin { +sub terminal_stdin { my ($self, $heap, $input) = @_[OBJECT, HEAP, ARG0]; + if ($input =~ m/\003/g) { $input = "/echo I like cakes\n"; - } elsif ($input =~ m/\004/g) { - $self->log( vt_dump()); + } elsif ($input =~ m/\005/g) { + $self->log( $self->vt_dump()); + } elsif ($input =~ m/\x17/g) { + $input = "/quit\n"; } + $heap->{program}->put($input); } -## + +# delegate to Callbacks. +sub vt_dump { + my ($self) = @_; + my $cb = $self->parent->_callbacks->vt_dump(); +} + ### Handle STDOUT from the child program. -sub handle_child_stdout { +sub child_stdout { my ($self, $heap, $input) = @_[OBJECT, HEAP, ARG0]; # process via vt $self->parent->vt->process($input); @@ -85,10 +106,11 @@ sub handle_child_stdout { $heap->{stdio}->put($input); } + ### Handle SIGCHLD. Shut down if the exiting child process was the ### one we've been managing. -sub CHILD { +sub CHILD { my ($self, $heap, $child_pid) = @_[OBJECT, HEAP, ARG1]; if ($child_pid == $heap->{program}->PID) { delete $heap->{program}; @@ -97,17 +119,27 @@ sub CHILD { return 0; } -sub bacon { - POE::Session->create - ( - inline_states => { - _start => \&handle_start, - _stop => \&handle_stop, - got_terminal_stdin => \&handle_terminal_stdin, - got_child_stdout => \&handle_child_stdout, - got_sigchld => \&handle_sigchld, - }, - ); +sub setup { + my $self = shift; + + my @states = + ( + object_states => + [ $self => + { + _start => 'START', + _stop => 'STOP', + got_terminal_stdin => 'terminal_stdin', + got_child_stdout => 'child_stdout', + got_sigchld => 'CHILD', + } + ] + ); + $self->log("creating root session"); + + POE::Session->create(@states); + $self->log("session created"); + } sub save_term_settings { @@ -121,6 +153,13 @@ sub save_term_settings { $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) = @_; |