aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xtesting/auto-testing.pl95
-rw-r--r--testing/lib/Test/Irssi.pm32
-rw-r--r--testing/lib/Test/Irssi/Callbacks.pm113
-rw-r--r--testing/lib/Test/Irssi/Driver.pm89
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) = @_;
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 16:32:26 +0000