From 42e4d2b23759185fa0d32decab19c95614e91e03 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sun, 9 Jan 2011 21:46:51 +0000 Subject: some dirty hacks to make the package appear as an internal module, LeoNerd++ --- feature-tests/format-test.pl | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/format-test.pl b/feature-tests/format-test.pl index d8be412..2c99d50 100644 --- a/feature-tests/format-test.pl +++ b/feature-tests/format-test.pl @@ -14,13 +14,21 @@ our %IRSSI = ( license => 'Public Domain', ); -init(); +sub actually_printformat { + my ($win, $level, $module, $format, @args) = @_; + { + # deeeeeeep black magic. + local *CORE::GLOBAL::caller = sub { $module }; + $win->printformat($level, $format, @args); + } -sub init { - Irssi::command_bind('ft', \&format_test); } +init(); + +sub init { + my $win = Irssi::active_win(); + actually_printformat($win, Irssi::MSGLEVEL_CLIENTCRAP, 'fe-common/irc', + "kill_server", "foo", "bar", "horse", "cake"); -sub format_test { - my ($args, $win, $server) = @_; } -- cgit v1.2.3 From d285e7854dfc62c213bec4c101eaf080fa81ac46 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Wed, 12 Jan 2011 00:10:16 +0000 Subject: pipes: added an example feature test on how to use pipes for non-blocking IO. Hope to expand it to include network IO at some point. --- feature-tests/format-test.pl | 13 ++++-- feature-tests/local_input_capture.pl | 50 +++++++++++++++++++++ feature-tests/pipes.pl | 87 ++++++++++++++++++++++++++++++++++++ 3 files changed, 146 insertions(+), 4 deletions(-) create mode 100644 feature-tests/local_input_capture.pl create mode 100644 feature-tests/pipes.pl (limited to 'feature-tests') diff --git a/feature-tests/format-test.pl b/feature-tests/format-test.pl index 2c99d50..7a38d9f 100644 --- a/feature-tests/format-test.pl +++ b/feature-tests/format-test.pl @@ -3,7 +3,7 @@ use warnings; use Irssi; - +use Data::Dumper; our $VERSION = '0.1'; our %IRSSI = ( @@ -16,19 +16,24 @@ our %IRSSI = ( sub actually_printformat { my ($win, $level, $module, $format, @args) = @_; + my $ret = ''; { # deeeeeeep black magic. local *CORE::GLOBAL::caller = sub { $module }; $win->printformat($level, $format, @args); - } + $ret = Irssi::current_theme()->get_format($module, $format); + } + return $ret; } init(); sub init { my $win = Irssi::active_win(); - actually_printformat($win, Irssi::MSGLEVEL_CLIENTCRAP, 'fe-common/irc', - "kill_server", "foo", "bar", "horse", "cake"); + my $moo = actually_printformat($win, Irssi::MSGLEVEL_CLIENTCRAP, 'fe-common/irc', + "kill_server", "foo", "bar", "horse", "cake"); + + print Dumper($moo); } diff --git a/feature-tests/local_input_capture.pl b/feature-tests/local_input_capture.pl new file mode 100644 index 0000000..847ff07 --- /dev/null +++ b/feature-tests/local_input_capture.pl @@ -0,0 +1,50 @@ +use strict; +use warnings; + + +use Irssi; +use Irssi::Irc; +use Irssi::TextUI; + +use Data::Dumper; + + +our $VERSION = '0.1'; +our %IRSSI = ( + authors => 'shabble', + contact => 'shabble+irssi@metavore.org', + name => '', + description => '', + license => 'Public Domain', + ); + +my $buffer = ''; +init(); + +sub init { + + Irssi::signal_add_first 'print text', 'sig_print_text'; + Irssi::command 'echo Hello there'; + Irssi::signal_remove 'print text', 'sig_print_text'; + Irssi::command_bind 'showbuf', 'cmd_showbuf'; +} + +sub cmd_showbuf { + my ($args, $server, $win_item) = @_; + my $win; + if (defined $win_item) { + $win = $win_item->window(); + } else { + $win = Irssi::active_win(); + } + + $win->print("buffer is: $buffer"); + $buffer = ''; +} + +sub sig_print_text { + my ($text_dest, $str, $stripped_str) = @_; + + $buffer .= $stripped_str; + Irssi::signal_stop; +} diff --git a/feature-tests/pipes.pl b/feature-tests/pipes.pl new file mode 100644 index 0000000..50bff53 --- /dev/null +++ b/feature-tests/pipes.pl @@ -0,0 +1,87 @@ +use strict; +use warnings; + +use Irssi; +use POSIX; +use Time::HiRes qw/sleep/; + +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 + # make up some data - block if we like. + for (1..10) { + sleep rand 1; + print $write_handle "Some data: $_\n"; + } + print $write_handle "__DONE__\n"; + close $write_handle; + + POSIX::_exit(1); + } +} + +sub child_input { + my $args = shift; + my ($read_handle, $input_tag_ref, $job) = @$args; + + my $data = <$read_handle>; + + if ($data =~ m/__DONE__/) { + close($read_handle); + Irssi::input_remove($$input_tag_ref); + _msg("child finished"); + + $forked = 0; + + } else { + _msg("Received from child: $data"); + } + +} + +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); -- cgit v1.2.3 From 823e0002921c8e80f6373f271482fc3acc13bdc2 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 15 Jan 2011 04:06:20 +0000 Subject: bindings: added an example of parsing bindings a'la adv_windowlist. needs some attributions and cleanup though --- feature-tests/bindings.pl | 77 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100644 feature-tests/bindings.pl (limited to 'feature-tests') diff --git a/feature-tests/bindings.pl b/feature-tests/bindings.pl new file mode 100644 index 0000000..006eaf1 --- /dev/null +++ b/feature-tests/bindings.pl @@ -0,0 +1,77 @@ +use strict; +use warnings; + + +use Irssi; +use Irssi::Irc; +use Irssi::TextUI; + +use Data::Dumper; + + +our $VERSION = '0.1'; +our %IRSSI = ( + authors => 'shabble', + contact => 'shabble+irssi@metavore.org', + name => '', + description => '', + licence => q(GNU GPLv2 or later), + + ); + +# code taken from adv_windowlist + +my $keymap; + +init(); + +sub init { + update_keymap(); + Irssi::command_bind('showbinds', 'cmd_showbinds'); +} + +sub cmd_showbinds { + my ($args, @rest) = @_; + + my $win = Irssi::active_win(); + $win->print("Change window bindings:", Irssi::MSGLEVEL_CLIENTCRAP); + for my $w (sort keys %$keymap) { + my $x = $keymap->{$w}; + $win->print("$w ==> $x", Irssi::MSGLEVEL_CLIENTCRAP); + } + $win->print("Done showing window bindings:", Irssi::MSGLEVEL_CLIENTCRAP); + +} +sub get_keymap { + my ($text_dest, $str, $str_stripped) = @_; + + if ($text_dest->{level} == Irssi::MSGLEVEL_CLIENTCRAP and $text_dest->{target} eq '') { + if (not defined($text_dest->{'server'})) { + if ($str_stripped =~ m/((?:meta-)+)(.)\s+change_window (\d+)/) { + my ($level, $key, $window) = ($1, $2, $3); + #my $numlevel = ($level =~ y/-//) - 1; + my $kk = $level . $key; + $keymap->{$kk} = $window; + } + Irssi::signal_stop(); + } + } +} + +sub update_keymap { + $keymap = {}; + Irssi::signal_remove('command bind' => 'watch_keymap'); + Irssi::signal_add_first('print text' => 'get_keymap'); + Irssi::command('bind'); # stolen from grep + Irssi::signal_remove('print text' => 'get_keymap'); + Irssi::signal_add('command bind' => 'watch_keymap'); + #Irssi::timeout_add_once(100, 'eventChanged', undef); +} + +# watch keymap changes +sub watch_keymap { + Irssi::timeout_add_once(1000, 'update_keymap', undef); +} + + + -- cgit v1.2.3 From 9f7242b130829edb2f47fdd8327b5130ac7c276b Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Tue, 18 Jan 2011 00:16:07 +0000 Subject: signal_logger: an test to determine how signals are fired, and if they are nested. --- feature-tests/signal_logger.pl | 170 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 170 insertions(+) create mode 100644 feature-tests/signal_logger.pl (limited to 'feature-tests') diff --git a/feature-tests/signal_logger.pl b/feature-tests/signal_logger.pl new file mode 100644 index 0000000..3b3b9ad --- /dev/null +++ b/feature-tests/signal_logger.pl @@ -0,0 +1,170 @@ +use strict; +use warnings; + + +use Irssi; +use Irssi::Irc; +use Irssi::TextUI; +use Time::HiRes qw/time/; + +use Data::Dumper; + + +our $VERSION = '0.1'; +our %IRSSI = ( + authors => 'shabble', + contact => 'shabble+irssi@metavore.org', + name => '', + description => '', + license => 'Public Domain', + ); + +my $enabled = 0; +my $depth = 0; +my $handlers = { }; +my @log = (); +my @signals = +( +'send text', +'send command', +#'print text', +#'gui print text', +'beep', +#'complete word', +#'gui key pressed', +'window changed', + "server add fill", + "server connect copy", + "server connect failed", + "server connected", + "server connecting", + "server disconnected", + "server event", + "server incoming", + "server lag disconnect", + "server lag", + "server looking", + "server nick changed", + "server quit", + "server reconnect not found", + "server reconnect remove", + "server reconnect save status", + "server sendmsg", + "server setup fill chatnet", + "server setup fill connect", + "server setup fill reconn", + "server setup read", + "server setup saved", + "default event", +#'gui print text finished', + +); + +init(); + +sub init { + + @log = (); + $handlers = {}; + + Irssi::command_bind('siglog_on', \&cmd_register_all_signals); + Irssi::command_bind('siglog_off', \&cmd_unregister_all_signals); + Irssi::command_bind('siglog_dump', \&cmd_log_dump); + Irssi::command_bind('siglog_stats', \&cmd_log_stats); +} + +sub cmd_register_all_signals { + + + Irssi::active_win->print("Starting to log all signals"); + $enabled = 1; + + foreach my $sig_name (@signals) { + + my $first_func = build_init_func($sig_name); + my $last_func = build_end_func($sig_name); + + $handlers->{$sig_name} = [ $first_func, $last_func ]; + + Irssi::signal_add_first($sig_name, $first_func); + Irssi::signal_add_last($sig_name, $last_func); + } +} + +sub cmd_unregister_all_signals { + + foreach my $sig_name (@signals) { + + my ($first_func, $last_func) = @{ $handlers->{$sig_name} }; + + Irssi::signal_remove($sig_name, $first_func); + Irssi::signal_remove($sig_name, $last_func); + } + $enabled = 0; + Irssi::active_win->print("Signal logging disabled"); + +} + +sub cmd_log_dump { + + my $win = Irssi::active_win(); + if ($enabled) { + cmd_unregister_all_signals(); + $win->print("Disabled logging"); + } + foreach my $lref (@log) { + my ($line, $indent) = @$lref; + my $xx = " " x $indent; + $win->print($xx . $line); + } +} + +sub cmd_log_stats { + + my $win = Irssi::active_win(); + if ($enabled) { + cmd_unregister_all_signals(); + $win->print("Disabled logging"); + } +} + +sub build_init_func { + my ($sig_name) = @_; + + return sub { + my @args = @_; + my $args_str = ''; + my $n = 0; + + foreach my $arg (@args) { + $args_str .= "[$n] "; + + if (not defined $arg) { + $args_str .= "undef, "; + next; + } + + if (ref $arg) { + $args_str .= ref($arg) . ", " + } else { + $arg =~ s/^(.{20})/$1/; + $args_str .= "$arg, "; + } + $n++; + } + my $msg = sprintf("%f: %s - First %s", time(), $sig_name, $args_str); + push @log, [$msg, $depth]; + $depth++; + } +} + +sub build_end_func { + my ($sig_name) = @_; + + return sub { + my $msg = sprintf("%f: %s - End", time(), $sig_name); + push @log, [$msg, $depth]; + $depth--; + } +} + -- cgit v1.2.3 From d8aa70c8814e73213f108bbe3cf7e3db3a905959 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Tue, 18 Jan 2011 00:17:09 +0000 Subject: mroe changes to easy_exec to try to get tab-completion of function names. Works, but still a bit dumb. --- feature-tests/easy_exec.pl | 59 +++++++++++++++++++++++++--------------------- 1 file changed, 32 insertions(+), 27 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/easy_exec.pl b/feature-tests/easy_exec.pl index 669a00b..d342516 100644 --- a/feature-tests/easy_exec.pl +++ b/feature-tests/easy_exec.pl @@ -2,7 +2,7 @@ use strict; use warnings; # export everything. -use Irssi; #(@Irssi::EXPORT_OK); +use Irssi; use Irssi::Irc; use Irssi::TextUI; @@ -18,33 +18,38 @@ our %IRSSI = ( license => 'Public Domain', ); -#Irssi::signal_add_first 'command script exec', \&better_exec; -Irssi::command_bind('script exec', \&better_exec); - -sub better_exec { - my ($args, $serv, $witem) = @_; - # todo: handle permanent arg? - my $perm = 0; - print "Args: $args"; - if ($args =~ s/^\s*-permanent\s*(.*)$/$1/) { - $perm = 1; - } - print "Args now: $args"; - -# eval $args; - my $str = "//script exec " . - ($perm ? '-permanent' : '') - . 'use Irssi (@Irssi::EXPORT_OK); ' . $args; - print "Running: $str"; - -# Irssi::command($str); - Irssi::signal_continue($str, @_[1..$#_]); -} +# TODO: make this more tab-complete friendly +init(); + +sub init { + Irssi::command('/alias se script exec use Data::Dumper\;' + .' use Irssi (@Irssi::EXPORT_OK)\; $0-'); + Irssi::command('/alias sep script exec -permanent ' + . 'use Data::Dumper\; use Irssi (@Irssi::EXPORT_OK)\; $0-'); -sub Dump { - print Dumper(\@_); + Irssi::signal_add_last ('complete word', 'sig_complete_word'); } -sub test() { - print "This is a test"; +sub sig_complete_word { + my ($strings, $window, $word, $linestart, $want_space) = @_; + # only provide these completions if the input line is otherwise empty. + my $cmdchars = Irssi::settings_get_str('cmdchars'); + my $quoted = quotemeta($cmdchars); + #print "Linestart: $linestart"; + return unless ($linestart =~ /^${quoted}(?:se|sep)/); + + my $clean_word = $word; + $clean_word =~ s/^"//g; + $clean_word =~ s/"$//g; + $clean_word =~ s/->$//g; + + + + my @expansions = @Irssi::EXPORT_OK; + push @$strings, grep { $_ =~ m/^\Q$clean_word\E/ } @expansions; + print "Sebug: " . join(", ", @$strings); + $$want_space = 0; + + + Irssi::signal_stop() if (@$strings); } -- cgit v1.2.3 From 64c4b2fd935c348070e95761724e209b9c88f078 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Tue, 18 Jan 2011 00:17:56 +0000 Subject: joinforward/joinforward: a first pass at a script which observes redirection messages and automatically overrides /join to point you to the right forwarded channel. --- feature-tests/bindings.pl | 75 +++++++++++++++++++++++++++++++++++------------ 1 file changed, 56 insertions(+), 19 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/bindings.pl b/feature-tests/bindings.pl index 006eaf1..ece220d 100644 --- a/feature-tests/bindings.pl +++ b/feature-tests/bindings.pl @@ -23,11 +23,39 @@ our %IRSSI = ( my $keymap; +sub STATE_HEADER () { 0 } +sub STATE_BODY () { 1 } +sub STATE_END () { 2 } +my $parse_state = STATE_HEADER; + +my $binding_formats = {}; + init(); sub init { - update_keymap(); + + $keymap = {}; + Irssi::command_bind('showbinds', 'cmd_showbinds'); + Irssi::signal_add('command bind' => 'watch_keymap'); + + $binding_formats = get_binding_formats(); + + capture_bind_data(); +} + +sub get_binding_formats { + my $theme = Irssi::current_theme(); + my @keys = qw/bind_header bind_list bind_command_list + bind_footer bind_unknown_id/; + + my $ret = {}; + foreach my $key (@keys) { + my $tmp = $theme->get_format('fe-common/core', $key); + #$tmp =~ s/%/%%/g; # escape colour codes? + $ret->{$key} = $tmp; + } + return $ret; } sub cmd_showbinds { @@ -42,35 +70,44 @@ sub cmd_showbinds { $win->print("Done showing window bindings:", Irssi::MSGLEVEL_CLIENTCRAP); } -sub get_keymap { + +sub sig_print_text { my ($text_dest, $str, $str_stripped) = @_; - if ($text_dest->{level} == Irssi::MSGLEVEL_CLIENTCRAP and $text_dest->{target} eq '') { - if (not defined($text_dest->{'server'})) { - if ($str_stripped =~ m/((?:meta-)+)(.)\s+change_window (\d+)/) { - my ($level, $key, $window) = ($1, $2, $3); - #my $numlevel = ($level =~ y/-//) - 1; - my $kk = $level . $key; - $keymap->{$kk} = $window; - } - Irssi::signal_stop(); - } + return unless $text_dest->{level} == Irssi::MSGLEVEL_CLIENTCRAP; + return unless $text_dest->{target} eq ''; + return unless not defined $text_dest->{server}; + + # if ($parse_state = STATE_HEADER) { + # if ($str =~ m/\Q$binding_formats->{bind_header}\E/) { + # $parse_state = STATE_BODY; + # } + # } elsif ($parse_state = STATE_BODY) { + print "Data is: $str_stripped"; + if ($str_stripped =~ m/^.*?(\S{,20})\s+(\S+)\s+(\S+)/) { + $keymap->{$1} = "$2, $3"; + print "Parsed $1 as $2, $3"; } + Irssi::signal_stop(); + # } elsif ($str =~ m/$binding_formats->{bind_footer}\E/) { + # $parse_state = STATE_END; + # } + # } } -sub update_keymap { - $keymap = {}; + +sub capture_bind_data { Irssi::signal_remove('command bind' => 'watch_keymap'); - Irssi::signal_add_first('print text' => 'get_keymap'); + Irssi::signal_add_first('print text' => 'sig_print_text'); Irssi::command('bind'); # stolen from grep - Irssi::signal_remove('print text' => 'get_keymap'); - Irssi::signal_add('command bind' => 'watch_keymap'); - #Irssi::timeout_add_once(100, 'eventChanged', undef); + Irssi::signal_remove('print text' => 'sig_print_text'); + } + # watch keymap changes sub watch_keymap { - Irssi::timeout_add_once(1000, 'update_keymap', undef); + Irssi::timeout_add_once(1000, 'capture_bind_data', undef); } -- cgit v1.2.3 From ae36028f610acd6fdafff534f197e05ed6a3a16a Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 19 Feb 2011 14:31:46 +0000 Subject: initial commit, probably about to get blasted. --- feature-tests/auto-testing.pl | 74 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 74 insertions(+) create mode 100755 feature-tests/auto-testing.pl (limited to 'feature-tests') diff --git a/feature-tests/auto-testing.pl b/feature-tests/auto-testing.pl new file mode 100755 index 0000000..db45226 --- /dev/null +++ b/feature-tests/auto-testing.pl @@ -0,0 +1,74 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use feature qw/say/; + +package Manager; +use Moose; +with qw(MooseX::Workers); + +use POE qw(Filter::Reference Filter::Stream); + +use Term::VT102; + +has 'vt' + => ( + is => 'ro', + isa => 'Term::VT102', + required => 1, + lazy => 1, + builder => '_build_vt' + ); + +sub _build_vt { + my $vt = Term::VT102->new(cols => 80, rows => 24); + $vt->callback_set('OUTPUT', \&vt_output, undef); + + return $vt; +} + +sub vt_output { + my ($vt, $cb_name, $data, $priv) = @_; + say "Data is: $data" +} +sub run { + my $self = shift; + my $job = MooseX::Workers::Job->new + ( + name => "Irssi", + command => "/opt/stow/repo/irssi-debug/bin/irssi", + args => [ "--home=/tmp" ], + ); + + $self->spawn($job); + + POE::Kernel->run(); +} + +# Implement our Interface +# These two are both optional; if defined (as here), they +# should return a subclass of POE::Filter. +sub stdout_filter { new POE::Filter::Stream } +sub stderr_filter { new POE::Filter::Line } + +sub worker_stdout { + my ( $self, $data ) = @_; + + $self->vt->process($data); +} + +sub worker_manager_start { warn 'started worker manager' } +sub worker_manager_stop { warn 'stopped worker manager' } + +sub max_workers_reached { warn 'maximum worker count reached' } +sub worker_error { shift; warn join ' ', @_; } +sub worker_done { shift; warn join ' ', @_; } +sub worker_started { shift; warn join ' ', @_; } +sub sig_child { shift; warn join ' ', @_; } +sub sig_TERM { shift; warn 'Handled TERM' } + +no Moose; + +Manager->new->run(); + -- cgit v1.2.3 From ca08f1290f9798c3c65c1c6c924bd49546edd863 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 19 Feb 2011 15:06:28 +0000 Subject: semi-working wrapper for irssi allowing command/keystroke injection. Still need to work on the output format though. --- feature-tests/auto-testing.pl | 184 ++++++++++++++++++++++++++++++------------ 1 file changed, 132 insertions(+), 52 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/auto-testing.pl b/feature-tests/auto-testing.pl index db45226..5ed9d70 100755 --- a/feature-tests/auto-testing.pl +++ b/feature-tests/auto-testing.pl @@ -1,74 +1,154 @@ #!/usr/bin/env perl -use strict; use warnings; -use feature qw/say/; - -package Manager; -use Moose; -with qw(MooseX::Workers); +use strict; -use POE qw(Filter::Reference Filter::Stream); +sub PROGRAM () { "/opt/stow/repo/irssi-debug/bin/irssi" } +use POSIX; +use POE qw( Wheel::ReadWrite Wheel::Run Filter::Stream ); use Term::VT102; +use Term::TermInfo; + +my $ti = Term::Terminfo->new(); + +my $vt = Term::VT102->new(rows => 24, cols => 80); +$vt->callback_set('OUTPUT', \&vt_output, undef); +$vt->callback_set('ROWCHANGE', \&vt_rowchange, undef); + +sub vt_rowchange { + my ($vt, $cb_name, $arg1, $arg2, $priv_data) = @_; + #print STDERR "Row $arg1 changing: $arg2\n"; + print $ti->getstr("clear"); + print vt_dump(); + +} + +sub vt_output { + my ($vt, $cb_name, $cb_data, $priv_data) = @_; + #print "X:" . $cb_data; +} -has 'vt' - => ( - is => 'ro', - isa => 'Term::VT102', - required => 1, - lazy => 1, - builder => '_build_vt' - ); +sub vt_dump { + my $str = ''; + for my $y (1..24) { + $str .= $vt->row_sgrtext($y) . "\n"; + } + return $str; +} + +### Handle the _start event. This sets things in motion. +sub handle_start { + my ($kernel, $heap) = @_[KERNEL, HEAP]; + + save_term_settings($heap); + + # Set a signal handler. + $kernel->sig(CHLD => "got_sigchld"); + + make_raw(); -sub _build_vt { - my $vt = Term::VT102->new(cols => 80, rows => 24); - $vt->callback_set('OUTPUT', \&vt_output, undef); + # Start the terminal reader/writer. + $heap->{stdio} = POE::Wheel::ReadWrite->new( + InputHandle => \*STDIN, + OutputHandle => \*STDOUT, + InputEvent => "got_terminal_stdin", + Filter => POE::Filter::Stream->new(), + ); - return $vt; + # Start the asynchronous child process. + $heap->{program} = POE::Wheel::Run->new( + Program => PROGRAM, + Conduit => "pty", + StdoutEvent => "got_child_stdout", + StdioFilter => POE::Filter::Stream->new(), + ); } -sub vt_output { - my ($vt, $cb_name, $data, $priv) = @_; - say "Data is: $data" +### Handle the _stop event. This restores the original terminal +### settings when we're done. That's very important. +sub handle_stop { + my $heap = $_[HEAP]; + $heap->{stdin_tio}->setattr(0, TCSANOW); + $heap->{stdout_tio}->setattr(1, TCSANOW); + $heap->{stderr_tio}->setattr(2, TCSANOW); } -sub run { - my $self = shift; - my $job = MooseX::Workers::Job->new - ( - name => "Irssi", - command => "/opt/stow/repo/irssi-debug/bin/irssi", - args => [ "--home=/tmp" ], - ); - - $self->spawn($job); - - POE::Kernel->run(); + +### Handle terminal STDIN. Send it to the background program's STDIN. +### If the user presses ^C, then also go berserk a little. + +sub handle_terminal_stdin { + my ($heap, $input) = @_[HEAP, ARG0]; + while ($input =~ m/\003/g) { + $input = "/echo I like cakes\n"; + } + $heap->{program}->put($input); } -# Implement our Interface -# These two are both optional; if defined (as here), they -# should return a subclass of POE::Filter. -sub stdout_filter { new POE::Filter::Stream } -sub stderr_filter { new POE::Filter::Line } +### Handle STDOUT from the child program. +sub handle_child_stdout { + my ($heap, $input) = @_[HEAP, ARG0]; + # process via vt + $vt->process($input); + # send to terminal +# $heap->{stdio}->put($input); +} -sub worker_stdout { - my ( $self, $data ) = @_; +### Handle SIGCHLD. Shut down if the exiting child process was the +### one we've been managing. - $self->vt->process($data); +sub handle_sigchld { + my ($heap, $child_pid) = @_[HEAP, ARG1]; + if ($child_pid == $heap->{program}->PID) { + delete $heap->{program}; + delete $heap->{stdio}; + } + return 0; } -sub worker_manager_start { warn 'started worker manager' } -sub worker_manager_stop { warn 'stopped worker manager' } -sub max_workers_reached { warn 'maximum worker count reached' } -sub worker_error { shift; warn join ' ', @_; } -sub worker_done { shift; warn join ' ', @_; } -sub worker_started { shift; warn join ' ', @_; } -sub sig_child { shift; warn join ' ', @_; } -sub sig_TERM { shift; warn 'Handled TERM' } +### Start a session to encapsulate the previous features. +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 make_raw { + + # 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); -no Moose; +} -Manager->new->run(); +sub save_term_settings { + my ($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); +} +### Start POE's main loop, which runs the session until it's done. +$poe_kernel->run(); +exit 0; -- cgit v1.2.3 From 19e07580166ecea83f6712b469a616073b96201a Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 19 Feb 2011 16:28:25 +0000 Subject: updated auto-testing to ebe able to handle inputs, and partially process the output. --- feature-tests/auto-testing.pl | 64 +++++++++++++++++++++++++++++++++++-------- 1 file changed, 52 insertions(+), 12 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/auto-testing.pl b/feature-tests/auto-testing.pl index 5ed9d70..43bc489 100755 --- a/feature-tests/auto-testing.pl +++ b/feature-tests/auto-testing.pl @@ -9,24 +9,62 @@ use POSIX; use POE qw( Wheel::ReadWrite Wheel::Run Filter::Stream ); use Term::VT102; use Term::TermInfo; +use feature qw/say switch/; +use Data::Dumper; + +use Term::Size; + +my ($columns, $rows) = Term::Size::chars *STDOUT{IO}; + +my $logfile = "irssi.log"; +open my $logfh, ">", $logfile or die "Couldn't open $logfile for writing: $!"; + my $ti = Term::Terminfo->new(); -my $vt = Term::VT102->new(rows => 24, cols => 80); -$vt->callback_set('OUTPUT', \&vt_output, undef); -$vt->callback_set('ROWCHANGE', \&vt_rowchange, undef); +my $vt = Term::VT102->new(rows => $rows, cols => $columns); + +$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); + +$vt->option_set(LINEWRAP => 1); +$vt->option_set(LFTOCRLF => 1); + +sub vt_output { + my ($vt, $cb_name, $cb_data, $priv_data) = @_; + say $logfh "OUTPUT: " . Dumper(\@_); +} + sub vt_rowchange { my ($vt, $cb_name, $arg1, $arg2, $priv_data) = @_; - #print STDERR "Row $arg1 changing: $arg2\n"; - print $ti->getstr("clear"); - print vt_dump(); + #say $logfh "ROWCHANGE: " . Dumper(\@_); + say $logfh "Row $arg1 changed: "; + say $logfh $vt->row_plaintext($arg1); +# print $ti->getstr("clear"); + # print vt_dump(); } -sub vt_output { - my ($vt, $cb_name, $cb_data, $priv_data) = @_; - #print "X:" . $cb_data; +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 { @@ -75,12 +113,14 @@ sub handle_stop { } ### Handle terminal STDIN. Send it to the background program's STDIN. -### If the user presses ^C, then also go berserk a little. +### If the user presses ^C, then echo a little string sub handle_terminal_stdin { my ($heap, $input) = @_[HEAP, ARG0]; - while ($input =~ m/\003/g) { + if ($input =~ m/\003/g) { $input = "/echo I like cakes\n"; + } elsif ($input =~ m/\004/g) { + say $logfh vt_dump(); } $heap->{program}->put($input); } @@ -91,7 +131,7 @@ sub handle_child_stdout { # process via vt $vt->process($input); # send to terminal -# $heap->{stdio}->put($input); + $heap->{stdio}->put($input); } ### Handle SIGCHLD. Shut down if the exiting child process was the -- cgit v1.2.3 From 97707dda9149b17a0fc6ee7f73cb619d891dbf94 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 19 Feb 2011 17:07:37 +0000 Subject: added program args to Wheel::Run --- feature-tests/auto-testing.pl | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/auto-testing.pl b/feature-tests/auto-testing.pl index 43bc489..c7d9178 100755 --- a/feature-tests/auto-testing.pl +++ b/feature-tests/auto-testing.pl @@ -36,15 +36,25 @@ $vt->option_set(LFTOCRLF => 1); sub vt_output { my ($vt, $cb_name, $cb_data, $priv_data) = @_; - say $logfh "OUTPUT: " . Dumper(\@_); + 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); + #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(); @@ -97,6 +107,7 @@ sub handle_start { # Start the asynchronous child process. $heap->{program} = POE::Wheel::Run->new( Program => PROGRAM, + ProgramArgs => qw/--noconnect/, Conduit => "pty", StdoutEvent => "got_child_stdout", StdioFilter => POE::Filter::Stream->new(), -- cgit v1.2.3 From 652e5cbb57bde8a1adc3c44f9c2819b3823090f7 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 19 Feb 2011 17:09:16 +0000 Subject: fix for program args: make it a reference --- feature-tests/auto-testing.pl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'feature-tests') diff --git a/feature-tests/auto-testing.pl b/feature-tests/auto-testing.pl index c7d9178..61e460c 100755 --- a/feature-tests/auto-testing.pl +++ b/feature-tests/auto-testing.pl @@ -107,7 +107,7 @@ sub handle_start { # Start the asynchronous child process. $heap->{program} = POE::Wheel::Run->new( Program => PROGRAM, - ProgramArgs => qw/--noconnect/, + ProgramArgs => [qw/--noconnect/], Conduit => "pty", StdoutEvent => "got_child_stdout", StdioFilter => POE::Filter::Stream->new(), -- cgit v1.2.3 From 925f13cc20a5b80b742c72f44155df73579f73fa Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sun, 20 Feb 2011 20:06:21 +0000 Subject: mostly functional as script, final comit before transitioning into Test::Irssi module. --- feature-tests/auto-testing.pl | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/auto-testing.pl b/feature-tests/auto-testing.pl index 61e460c..b009323 100755 --- a/feature-tests/auto-testing.pl +++ b/feature-tests/auto-testing.pl @@ -1,8 +1,12 @@ -#!/usr/bin/env perl + +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" } use POSIX; @@ -11,18 +15,18 @@ use Term::VT102; use Term::TermInfo; use feature qw/say switch/; use Data::Dumper; - -use Term::Size; - -my ($columns, $rows) = Term::Size::chars *STDOUT{IO}; +use IO::File; my $logfile = "irssi.log"; -open my $logfh, ">", $logfile or die "Couldn't open $logfile for writing: $!"; +#open my $logfh, ">", $logfile or die "Couldn't open $logfile for writing: $!"; +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 => $columns); +my $vt = Term::VT102->new(rows => 24, cols => 80); $vt->callback_set(OUTPUT => \&vt_output, undef); $vt->callback_set(ROWCHANGE => \&vt_rowchange, undef); @@ -109,6 +113,7 @@ sub handle_start { Program => PROGRAM, ProgramArgs => [qw/--noconnect/], Conduit => "pty", + Winsize => [24, 80, 0, 0], StdoutEvent => "got_child_stdout", StdioFilter => POE::Filter::Stream->new(), ); @@ -118,9 +123,11 @@ sub handle_start { ### settings when we're done. That's very important. sub handle_stop { my $heap = $_[HEAP]; - $heap->{stdin_tio}->setattr(0, TCSANOW); + $heap->{stdin_tio}->setattr (0, TCSANOW); $heap->{stdout_tio}->setattr(1, TCSANOW); $heap->{stderr_tio}->setattr(2, TCSANOW); + + $logfh->close(); } ### Handle terminal STDIN. Send it to the background program's STDIN. @@ -135,7 +142,7 @@ sub handle_terminal_stdin { } $heap->{program}->put($input); } - +## ### Handle STDOUT from the child program. sub handle_child_stdout { my ($heap, $input) = @_[HEAP, ARG0]; -- cgit v1.2.3 From c1d27ce25a2724371b16640e4bb9d04aa70cc1eb Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Mon, 21 Feb 2011 00:54:03 +0000 Subject: minor whitespace muddling --- feature-tests/auto-testing.pl | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/auto-testing.pl b/feature-tests/auto-testing.pl index b009323..31a9e5e 100755 --- a/feature-tests/auto-testing.pl +++ b/feature-tests/auto-testing.pl @@ -8,9 +8,11 @@ use strict; use lib $ENV{HOME} . "/projects/poe/lib"; sub PROGRAM () { "/opt/stow/repo/irssi-debug/bin/irssi" } + use POSIX; use POE qw( Wheel::ReadWrite Wheel::Run Filter::Stream ); + use Term::VT102; use Term::TermInfo; use feature qw/say switch/; @@ -28,12 +30,12 @@ my $ti = Term::Terminfo->new(); my $vt = Term::VT102->new(rows => 24, cols => 80); -$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); +$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); $vt->option_set(LINEWRAP => 1); $vt->option_set(LFTOCRLF => 1); -- cgit v1.2.3 From 1e6f98e7d399163ac51b0bd10f9f6e1714163016 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Mon, 21 Feb 2011 00:54:59 +0000 Subject: moved testing into its own dir --- feature-tests/auto-testing.pl | 214 ------------------------------------------ 1 file changed, 214 deletions(-) delete mode 100755 feature-tests/auto-testing.pl (limited to 'feature-tests') diff --git a/feature-tests/auto-testing.pl b/feature-tests/auto-testing.pl deleted file mode 100755 index 31a9e5e..0000000 --- a/feature-tests/auto-testing.pl +++ /dev/null @@ -1,214 +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" } - -use POSIX; - -use POE qw( Wheel::ReadWrite Wheel::Run Filter::Stream ); - -use Term::VT102; -use Term::TermInfo; -use feature qw/say switch/; -use Data::Dumper; -use IO::File; - -my $logfile = "irssi.log"; -#open my $logfh, ">", $logfile or die "Couldn't open $logfile for writing: $!"; -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 => 24, cols => 80); - -$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); - -$vt->option_set(LINEWRAP => 1); -$vt->option_set(LFTOCRLF => 1); - -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..24) { - $str .= $vt->row_sgrtext($y) . "\n"; - } - return $str; -} - -### Handle the _start event. This sets things in motion. -sub handle_start { - my ($kernel, $heap) = @_[KERNEL, HEAP]; - - save_term_settings($heap); - - # Set a signal handler. - $kernel->sig(CHLD => "got_sigchld"); - - make_raw(); - - # Start the terminal reader/writer. - $heap->{stdio} = POE::Wheel::ReadWrite->new( - InputHandle => \*STDIN, - OutputHandle => \*STDOUT, - InputEvent => "got_terminal_stdin", - Filter => POE::Filter::Stream->new(), - ); - - # Start the asynchronous child process. - $heap->{program} = POE::Wheel::Run->new( - Program => PROGRAM, - ProgramArgs => [qw/--noconnect/], - Conduit => "pty", - Winsize => [24, 80, 0, 0], - StdoutEvent => "got_child_stdout", - StdioFilter => POE::Filter::Stream->new(), - ); -} - -### Handle the _stop event. This restores the original terminal -### settings when we're done. That's very important. -sub handle_stop { - my $heap = $_[HEAP]; - $heap->{stdin_tio}->setattr (0, TCSANOW); - $heap->{stdout_tio}->setattr(1, TCSANOW); - $heap->{stderr_tio}->setattr(2, TCSANOW); - - $logfh->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 { - my ($heap, $input) = @_[HEAP, ARG0]; - if ($input =~ m/\003/g) { - $input = "/echo I like cakes\n"; - } elsif ($input =~ m/\004/g) { - say $logfh vt_dump(); - } - $heap->{program}->put($input); -} -## -### Handle STDOUT from the child program. -sub handle_child_stdout { - my ($heap, $input) = @_[HEAP, ARG0]; - # process via vt - $vt->process($input); - # send to terminal - $heap->{stdio}->put($input); -} - -### Handle SIGCHLD. Shut down if the exiting child process was the -### one we've been managing. - -sub handle_sigchld { - my ($heap, $child_pid) = @_[HEAP, ARG1]; - if ($child_pid == $heap->{program}->PID) { - delete $heap->{program}; - delete $heap->{stdio}; - } - return 0; -} - - -### Start a session to encapsulate the previous features. -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 make_raw { - - # 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 save_term_settings { - my ($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); -} - -### Start POE's main loop, which runs the session until it's done. -$poe_kernel->run(); -exit 0; -- cgit v1.2.3 From fcbef4a58c1b896be4e7d5cac9f17c6fdcd2eaed Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Fri, 1 Apr 2011 00:07:59 +0100 Subject: feature-tests: created signal_redir as a stripped down version of cmpusers.pl. Hopefully a useful starting point for people wanting remote command info. --- feature-tests/signal_redir.pl | 98 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 98 insertions(+) create mode 100644 feature-tests/signal_redir.pl (limited to 'feature-tests') diff --git a/feature-tests/signal_redir.pl b/feature-tests/signal_redir.pl new file mode 100644 index 0000000..15f9f08 --- /dev/null +++ b/feature-tests/signal_redir.pl @@ -0,0 +1,98 @@ +# mangled from cmpusers.pl (unpublished, afaik) by Bazerka . + +use strict; +use warnings; + +use Irssi; +use Data::Dumper; + +my $debug = 1; +my $running = 0; # flag to prevent overlapping requests. + +sub redir_init { + # set up event to handler mappings + Irssi::signal_add + ({ + 'redir test_redir_whois_user' => \&event_whois_user, + 'redir test_redir_whois_channels' => \&event_whois_channels, + 'redir test_redir_whois_end' => \&event_whois_end, + 'redir test_redir_whois_nosuchnick' => \&event_whois_nosuchnick, + 'redir test_redir_whois_timeout' => \&event_whois_timeout, + }); +} + +sub request_whois { + my ($server, $nick) = @_; + + $server->redirect_event + ( + 'whois', 1, $nick, 0, # command, remote, arg, timeout + 'redir test_redir_whois_timeout', # error handler + { + 'event 311' => 'redir test_redir_whois_user', # event mappings + 'event 318' => 'redir test_redir_whois_end', + 'event 319' => 'redir test_redir_whois_channels', + 'event 401' => 'redir test_redir_whois_nosuchnick', + '' => 'event empty', + } + ); + Irssi::print("Sending Command: WHOIS $nick", MSGLEVEL_CLIENTCRAP) + if $debug; + # send the actual command directly to the server, rather than + # with $server->command() + $server->send_raw("WHOIS $nick"); +} + +sub event_whois_user { + my ($server, $data) = @_; + my ($nick, $user, $host) = ( split / +/, $data, 6 )[ 1, 2, 3 ]; + Irssi::print("test_redir whois_user: $nick!$user\@$host", MSGLEVEL_CLIENTCRAP); +} + +sub event_whois_channels { + my ($server, $data) = @_; + my ($nick, $channels) = ( split / +/, $data, 3 )[ 1, 2 ]; + Irssi::print("test_redir whois_channels: $nick, $channels", MSGLEVEL_CLIENTCRAP); +} + +sub event_whois_end { + my ($server, $data) = @_; + my ($nick) = ( split / +/, $data, 3 )[1]; + Irssi::print("test_redir whois_end: $nick", MSGLEVEL_CLIENTCRAP); + + return if $running == 0; # catch 318 -> 401 (nosuchnick followed by endofwhois) + $running = 0; +} + +sub event_whois_nosuchnick { + my ($server, $data) = @_; + my $nick = ( split / +/, $data, 4)[1]; + Irssi::active_win->print("test_redir error: no such nick $nick - aborting.", + MSGLEVEL_CLIENTCRAP); + $running = 0; +} + +sub event_whois_timeout { + my ($server, $data) = @_; + Irssi::print("test_redir whois_timeout", MSGLEVEL_CLIENTCRAP); + $running = 0; +} + +sub cmd_test_redir { + my ($args, $server, $witem) = @_; + $args = lc $args; + my @nicks = split /\s+/, $args; + + if ($running) { + Irssi::active_win->print + ("test_redir error: a request is currently being processed " + . "- please try again shortly.", MSGLEVEL_CLIENTCRAP); + return; + } + $running = 1; + request_whois($server, $nicks[0]); +} + +redir_init(); +Irssi::command_bind("test_redir", \&cmd_test_redir); + -- cgit v1.2.3 From 67c392b2e5b849a0432f52d376c940c4cf2ae962 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Fri, 1 Apr 2011 06:36:56 +0100 Subject: signal_redir: general cleanup, and added attribution block %IRSSI --- feature-tests/signal_redir.pl | 38 ++++++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 10 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/signal_redir.pl b/feature-tests/signal_redir.pl index 15f9f08..89da34c 100644 --- a/feature-tests/signal_redir.pl +++ b/feature-tests/signal_redir.pl @@ -1,23 +1,36 @@ # mangled from cmpusers.pl (unpublished, afaik) by Bazerka . +# He is not to blame for any problems, contact me instead. use strict; use warnings; use Irssi; -use Data::Dumper; -my $debug = 1; -my $running = 0; # flag to prevent overlapping requests. +our $VERSION = "0.1"; +our %IRSSI = + ( + authors => "shabble, Bazerka", + contact => 'shabble+irssi@metavore.org, shabble@#irssi/Freenode,' + . 'bazerka@quakenet.org', + name => "signal_redir", + description => "Demonstration showing how to redirect a remote WHOIS" + . "command so the results can be captured by a script.", + license => "BSD", + url => "https://github.com/shabble/irssi-scripts/", + changed => "Fri Apr 1 00:05:39 2011" + ); +my $running = 0; # flag to prevent overlapping requests. +my $debug = 1; sub redir_init { # set up event to handler mappings Irssi::signal_add ({ - 'redir test_redir_whois_user' => \&event_whois_user, - 'redir test_redir_whois_channels' => \&event_whois_channels, - 'redir test_redir_whois_end' => \&event_whois_end, - 'redir test_redir_whois_nosuchnick' => \&event_whois_nosuchnick, - 'redir test_redir_whois_timeout' => \&event_whois_timeout, + 'redir test_redir_whois_user' => 'event_whois_user', + 'redir test_redir_whois_channels' => 'event_whois_channels', + 'redir test_redir_whois_end' => 'event_whois_end', + 'redir test_redir_whois_nosuchnick' => 'event_whois_nosuchnick', + 'redir test_redir_whois_timeout' => 'event_whois_timeout', }); } @@ -36,8 +49,7 @@ sub request_whois { '' => 'event empty', } ); - Irssi::print("Sending Command: WHOIS $nick", MSGLEVEL_CLIENTCRAP) - if $debug; + Irssi::print("Sending Command: WHOIS $nick", MSGLEVEL_CLIENTCRAP) if $debug; # send the actual command directly to the server, rather than # with $server->command() $server->send_raw("WHOIS $nick"); @@ -52,7 +64,13 @@ sub event_whois_user { sub event_whois_channels { my ($server, $data) = @_; my ($nick, $channels) = ( split / +/, $data, 3 )[ 1, 2 ]; + my $prefix = 'cowu.be'; # server name + my $args = "shabble"; # match criteria + my $event = 'event 319'; # triggering event + my $sig = $server->redirect_get_signal($prefix, $event, $args); Irssi::print("test_redir whois_channels: $nick, $channels", MSGLEVEL_CLIENTCRAP); + Irssi::print("test_redir get_signal: $sig", MSGLEVEL_CLIENTCRAP); + } sub event_whois_end { -- cgit v1.2.3 From aa429131a379cdbfb9b8e75cb27b5707a219fcd0 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Fri, 8 Apr 2011 20:53:03 +0100 Subject: add sig_unbind as a demonstration of the signal_remove coderef bug, and a patch to fix it. --- feature-tests/sig_unbind.pl | 58 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) create mode 100644 feature-tests/sig_unbind.pl (limited to 'feature-tests') diff --git a/feature-tests/sig_unbind.pl b/feature-tests/sig_unbind.pl new file mode 100644 index 0000000..3123182 --- /dev/null +++ b/feature-tests/sig_unbind.pl @@ -0,0 +1,58 @@ +use strict; +use warnings; + + +use Irssi (@Irssi::EXPORT_OK); +use Irssi::Irc; +use Irssi::TextUI; + +use Data::Dumper; + + +our $VERSION = '0.1'; +our %IRSSI = ( + authors => 'shabble', + contact => 'shabble+irssi@metavore.org', + name => '', + description => '', + license => 'Public Domain', + ); + +command_bind("dosig_r", + sub { + my $ref = \&cmd_oink; + _print("binding oink to $ref"); + signal_add("command oink", $ref); + }); + +command_bind("undosig_r", + sub { + my $ref = \&cmd_oink; + + _print("unbinding oink from $ref"); + + signal_remove("command oink", $ref); + }); + +command_bind("dosig_s", + sub { + signal_add("command oink", 'cmd_oink'); + }); + +command_bind("undosig_s", + sub { + signal_remove("command oink", 'cmd_oink'); + }); + +sub cmd_oink { + Irssi::active_win()->print("Oink:"); +} + +sub _print { + Irssi::active_win()->print($_[0]); +} + +command("dosig_r"); +command("oink"); +command("undosig_r"); +command("oink"); -- cgit v1.2.3 From f2d7b83e5d84c75510372ca9ba575181d35d20aa Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 9 Apr 2011 17:26:38 +0100 Subject: redir-input: test of some internal callback stuff. Which doesn't work. Ho Hum. --- feature-tests/redir-input.pl | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/redir-input.pl b/feature-tests/redir-input.pl index 94ca523..ed77d3c 100644 --- a/feature-tests/redir-input.pl +++ b/feature-tests/redir-input.pl @@ -20,11 +20,14 @@ our %IRSSI = ( Irssi::command_bind("ri", \&cmd_ri); - +Irssi::signal_register({ 'gui entry redirect' => [ qw/string string intptr intptr/]}); sub cmd_ri { my ($args, $server, $witem) = @_; my $win = Irssi::active_win(); - + my ($x, $y) = (0, 0); + Irssi::signal_emit('gui entry redirect', 'sub_blah', "bacon", $x, $y); #my $ref = Irssi::windows_refnum_last - $win->format_create_dest(Irssi::MSGLEVEL_ClIENTCRAP()); +# $win->format_create_dest(Irssi::MSGLEVEL_ClIENTCRAP()); } + +sub sub_blah { print "Moo" } -- cgit v1.2.3 From c6752d86b8a161d5ee3c4b008eb78a008b755e40 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Wed, 13 Apr 2011 09:30:08 +0100 Subject: added exec.pl, a pseudo-replacement for teh native /exec since it's broken and I can't figure out why. --- feature-tests/exec.pl | 248 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 248 insertions(+) create mode 100644 feature-tests/exec.pl (limited to 'feature-tests') diff --git a/feature-tests/exec.pl b/feature-tests/exec.pl new file mode 100644 index 0000000..e268291 --- /dev/null +++ b/feature-tests/exec.pl @@ -0,0 +1,248 @@ +# exec.pl +# a (currently stupid) alternative to the built-in /exec, because it's broken +# on OSX. This thing stll needs a whole bunch of actual features, but for now, +# you can actually run commands. + +# Obviously, that's pretty dangerous. Use at your own risk. + +# EXEC [-] [-nosh] [-out | -msg | -notice ] [-name ] +# EXEC -out | -window | -msg | -notice | -close | - % +# EXEC -in % +# +# -: Don't print "process terminated ..." message +# +# -nosh: Don't start command through /bin/sh +# +# -out: Send output to active channel/query +# +# -msg: Send output to specified nick/channel +# +# -notice: Send output to specified nick/channel as notices +# +# -name: Name the process so it could be accessed easier +# +# -window: Move the output of specified process to active window +# +# -close: Forcibly close (or "forget") a process that doesn't die. +# This only removes all information from irssi concerning the +# process, it doesn't send SIGKILL or any other signal +# to the process. +# +# -: Send a signal to process. can be either numeric +# or one of the few most common ones (hup, term, kill, ...) +# +# -in: Send text to standard input of the specified process +# +# -interactive: Creates a query-like window item. Text written to it is +# sent to executed process, like /EXEC -in. +# +# Execute specified command in background. Output of process is printed to +# active window by default, but can be also sent as messages or notices to +# specified nick or channel. +# +# Processes can be accessed either by their ID or name if you named it. Process +# identifier must always begin with '%' character, like %0 or %name. +# +# Once the process is started, its output can still be redirected elsewhere with +# the -window, -msg, etc. options. You can send text to standard input of the +# process with -in option. +# +# -close option shouldn't probably be used if there's a better way to kill the +# process. It is meant to remove the processes that don't die even with +# SIGKILL. This option just closes the pipes used to communicate with the +# process and frees all memory it used. +# +# EXEC without any arguments displays the list of started processes. +# + + + +use 5.010; # 5.10 or above, necessary to get the return value from a command. + +use strict; +use warnings; +use English '-no_match_vars'; + +use Irssi; +use POSIX; +use Time::HiRes qw/sleep/; +use IO::Handle; +use IO::Pipe; +use IPC::Open3; + + +use Data::Dumper; + +our $VERSION = '0.1'; +our %IRSSI = ( + authors => 'shabble', + contact => 'shabble+irssi@metavore.org', + name => 'exec.pl', + description => '', + license => 'Public Domain', + ); + + +my $forked = 0; + +my $command; +my $command_options; + + +sub parse_options { + my ($args) = @_; + my @options = Irssi::command_parse_options($command, $args); + if (@options) { + my $opt_hash = $options[0]; + my $rest = $options[1]; + + print Dumper($opt_hash); + return ($opt_hash, $rest); + } else { + _error("Error parsing $command options"); + return (); + } +} + + + +sub do_fork_and_exec { + my ($options, $cmd) = @_; + + my $stdout_pipe = IO::Pipe->new; + my $stderr_pipe = IO::Pipe->new; + +# return if $forked; + + #my $pid = fork(); + + if (not defined $pid) { + _error("Fork failed: $! Aborting"); + $_->close for $stdout_pipe->handles; + undef $stdout_pipe; + return; + } + +# $forked = 1; + + if ($pid > 0) { # this is the parent (Irssi) + my $tag; + + Irssi::pidwait_add($pid); + + my $stdout_reader = $stdout_pipe->reader; + $stdout_reader->autoflush; + + my @args = ($stdout_reader, \$tag, $pid, $cmd, $options); + $tag = Irssi::input_add($stdout_reader->fileno, + Irssi::INPUT_READ, + \&child_output, + \@args); + + } else { # child + # make up some data - block if we like. + drop_privs(); + my $stdout_fh = $stdout_pipe->writer; + $stdout_fh->autoflush; + + my @data = qx/$cmd/; + my $retval = ${^CHILD_ERROR_NATIVE}; + + $stdout_fh->print($_) for @data; + + my $done_str = "__DONE__$retval\n"; + if ($data[$#data] =~ m/\n$/) { + } else { + $done_str = "\n" . $done_str; + } + $stdout_fh->print($done_str); + + $stdout_fh->close; + + POSIX::_exit(1); + } +} +sub drop_privs { + my @temp = ($EUID, $EGID); + my $orig_uid = $UID; + my $orig_gid = $GID; + $EUID = $UID; + $EGID = $GID; + # Drop privileges + $UID = $orig_uid; + $GID = $orig_gid; + # Make sure privs are really gone + ($EUID, $EGID) = @temp; + die "Can't drop privileges" + unless $UID == $EUID && $GID eq $EGID; +} + +sub child_output { + my $args = shift; + my ($stdout_reader, $tag_ref, $pid, $cmd, $options) = @$args; + + my $return_value = 0; + + while (defined(my $data = <$stdout_reader>)) { + + chomp $data; + + # TODO: do we want to remove empty lines? + #return unless length $data; + + if ($data =~ m/^__DONE__(\d+)$/) { + $return_value = $1; + last; + } else { + _msg("$data"); + } + } + + if (not exists $options->{'-'}) { + _msg("process %d (%s) terminated with return code %d", + $pid, $cmd, $return_value); + } + + $stdout_reader->close; + Irssi::input_remove($$tag_ref); +} + +sub _error { + my ($msg) = @_; + my $win = Irssi::active_win(); + $win->print($msg, Irssi::MSGLEVEL_CLIENTERROR); +} + +sub _msg { + my ($msg, @params) = @_; + my $win = Irssi::active_win(); + my $str = sprintf($msg, @params); + $win->print($str, Irssi::MSGLEVEL_CLIENTCRAP); +} + +sub cmd_exec { + + my ($args, $server, $witem) = @_; + # TODO: parse some options here. + Irssi::signal_stop; + + my @options = parse_options($args); + if (@options) { + do_fork_and_exec(@options) + } + +} + +sub exec_init { + $command = "exec"; + $command_options = join ' ', + ( + '!-', 'interactive', 'nosh', '+name', '+msg', + '+notice', 'window', 'close', '+level', 'quiet' + ); + + Irssi::command_bind($command, \&cmd_exec); + Irssi::command_set_options($command, $command_options); +} + +exec_init(); -- cgit v1.2.3 From 0b960e5d3cea20058ccd1e1bbd92d49dfffc325d Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Wed, 13 Apr 2011 12:05:59 +0100 Subject: exec.pl: now mostly working with IPC::Open3. Needs cleanup --- feature-tests/exec.pl | 182 +++++++++++++++++++++++++++++++++----------------- 1 file changed, 120 insertions(+), 62 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/exec.pl b/feature-tests/exec.pl index e268291..ca8c6a2 100644 --- a/feature-tests/exec.pl +++ b/feature-tests/exec.pl @@ -69,7 +69,7 @@ use Time::HiRes qw/sleep/; use IO::Handle; use IO::Pipe; use IPC::Open3; - +use Symbol qw/gensym geniosym/; use Data::Dumper; @@ -83,11 +83,14 @@ our %IRSSI = ( ); -my $forked = 0; +my $pid = 0; my $command; my $command_options; +my ($sin, $serr, $sout) = (new IO::Handle, new IO::Handle, new IO::Handle); +my ($stdout_tag, $stderr_tag); + sub parse_options { my ($args) = @_; @@ -96,7 +99,9 @@ sub parse_options { my $opt_hash = $options[0]; my $rest = $options[1]; - print Dumper($opt_hash); + $rest =~ s/^\s*(.*?)\s*$/$1/; # trim surrounding space. + + print Dumper([$opt_hash, $rest]); return ($opt_hash, $rest); } else { _error("Error parsing $command options"); @@ -104,64 +109,66 @@ sub parse_options { } } - +sub schedule_cleanup { + my $fd = shift; + Irssi::timeout_add_once(100, sub { $_[0]->close }, $fd); +} sub do_fork_and_exec { my ($options, $cmd) = @_; - my $stdout_pipe = IO::Pipe->new; - my $stderr_pipe = IO::Pipe->new; + #Irssi::timeout_add_once(100, sub { die }, {}); -# return if $forked; + return unless $cmd; - #my $pid = fork(); + #_msg("type of siin is %s, out is %s, err is %s", ref $sin, ref $sout, ref $serr); - if (not defined $pid) { - _error("Fork failed: $! Aborting"); - $_->close for $stdout_pipe->handles; - undef $stdout_pipe; - return; - } + $sin->autoflush; + $sout->autoflush; + $serr->autoflush; -# $forked = 1; + drop_privs(); - if ($pid > 0) { # this is the parent (Irssi) - my $tag; + $pid = open3($sin, $sout, $serr, $cmd); - Irssi::pidwait_add($pid); + # _msg("Pid %s, in: %s, out: %s, err: %s, cmd: %s", + # $pid, $sin, $sout, $serr, $cmd); + + # _msg("filenos, Pid %s, in: %s, out: %s, err: %s", + # $pid, $sin->fileno, $sout->fileno, $serr->fileno); + + if (not defined $pid) { + _error("open3 failed: $! Aborting"); + + $_->close for ($sin, $serr, $sout); + undef($_) for ($sin, $serr, $sout); - my $stdout_reader = $stdout_pipe->reader; - $stdout_reader->autoflush; + return; + } - my @args = ($stdout_reader, \$tag, $pid, $cmd, $options); - $tag = Irssi::input_add($stdout_reader->fileno, - Irssi::INPUT_READ, - \&child_output, - \@args); + # parent + if ($pid) { - } else { # child - # make up some data - block if we like. - drop_privs(); - my $stdout_fh = $stdout_pipe->writer; - $stdout_fh->autoflush; - my @data = qx/$cmd/; - my $retval = ${^CHILD_ERROR_NATIVE}; + eval { + my @out_args = ($sout, $cmd, $options); + $stdout_tag = Irssi::input_add( $sout->fileno, Irssi::INPUT_READ, + \&child_output, \@out_args); + die unless $stdout_tag; - $stdout_fh->print($_) for @data; + my @err_args = ($serr, $cmd, $options); + $stderr_tag = Irssi::input_add($serr->fileno, Irssi::INPUT_READ, + \&child_error, \@err_args); + die unless $stderr_tag; - my $done_str = "__DONE__$retval\n"; - if ($data[$#data] =~ m/\n$/) { - } else { - $done_str = "\n" . $done_str; - } - $stdout_fh->print($done_str); + }; - $stdout_fh->close; + Irssi::pidwait_add($pid); - POSIX::_exit(1); + die "input_add failed to initialise: $@" if $@; } } + sub drop_privs { my @temp = ($EUID, $EGID); my $orig_uid = $UID; @@ -177,40 +184,79 @@ sub drop_privs { unless $UID == $EUID && $GID eq $EGID; } -sub child_output { +sub child_error { my $args = shift; - my ($stdout_reader, $tag_ref, $pid, $cmd, $options) = @$args; + my ($stderr_reader, $cmd, $options) = @$args; - my $return_value = 0; + read_err_data_loop: + my $data = ''; + my $bytes_read = sysread($stderr_reader, $data, 256); + if (not defined $bytes_read) { + _error("stderr: sysread failed:: $!"); + + } elsif ($bytes_read == 0) { + _msg("stderr: sysread got EOF"); + + } elsif ($bytes_read < 256) { + # that's all, folks. + _msg("stderr: read %d bytes: %s", $bytes_read, $data); + } else { + # we maybe need to read some more + _msg("stderr: read %d bytes: %s, maybe more", $bytes_read, $data); + goto read_err_data_loop; + } + +} - while (defined(my $data = <$stdout_reader>)) { +sub sig_pidwait { + my ($pidwait, $status) = @_; + if ($pidwait == $pid) { + _msg("PID %d has terminated. Status %d (or maybe %d .... %d)", + $pidwait, $status, $?, ${^CHILD_ERROR_NATIVE} ); + $pid = 0; - chomp $data; + _msg('removing input stdout tag'); + Irssi::input_remove($stdout_tag); - # TODO: do we want to remove empty lines? - #return unless length $data; + _msg('removing input stderr tag'); + Irssi::input_remove($stderr_tag); - if ($data =~ m/^__DONE__(\d+)$/) { - $return_value = $1; - last; - } else { - _msg("$data"); - } } +} + +sub child_output { + my $args = shift; + my ($stdout_reader, $tag_ref, $pid, $cmd, $options) = @$args; + + my $return_value = 0; - if (not exists $options->{'-'}) { - _msg("process %d (%s) terminated with return code %d", - $pid, $cmd, $return_value); + read_out_data_loop: + my $data = ''; + my $bytes_read = sysread($stdout_reader, $data, 256); + if (not defined $bytes_read) { + _error("stdout: sysread failed:: $!"); + + } elsif ($bytes_read == 0) { + _msg("stdout: sysread got EOF"); + + } elsif ($bytes_read < 256) { + # that's all, folks. + _msg("stdout: read %d bytes: %s", $bytes_read, $data); + } else { + # we maybe need to read some more + _msg("stdout: read %d bytes: %s, maybe more", $bytes_read, $data); + goto read_out_data_loop; } - $stdout_reader->close; - Irssi::input_remove($$tag_ref); + #schedule_cleanup($stdout_reader); + #$stdout_reader->close; } sub _error { - my ($msg) = @_; + my ($msg, @params) = @_; my $win = Irssi::active_win(); - $win->print($msg, Irssi::MSGLEVEL_CLIENTERROR); + my $str = sprintf($msg, @params); + $win->print($str, Irssi::MSGLEVEL_CLIENTERROR); } sub _msg { @@ -233,6 +279,15 @@ sub cmd_exec { } +sub cmd_input { + my ($args) = @_; + if ($pid) { + print $sin "$args\n"; + } else { + _error("no execs are running to accept input"); + } +} + sub exec_init { $command = "exec"; $command_options = join ' ', @@ -243,6 +298,9 @@ sub exec_init { Irssi::command_bind($command, \&cmd_exec); Irssi::command_set_options($command, $command_options); + Irssi::command_bind('input', \&cmd_input); + + Irssi::signal_add('pidwait', \&sig_pidwait); } -exec_init(); + exec_init(); -- cgit v1.2.3 From 5af03a3997260b48cc3b3689e5f9e62d777831ab Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Wed, 13 Apr 2011 22:17:41 +0100 Subject: exec.pl: using open3, but horribly broken. Still not sure why. --- feature-tests/exec.pl | 302 ++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 219 insertions(+), 83 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/exec.pl b/feature-tests/exec.pl index ca8c6a2..f6d6377 100644 --- a/feature-tests/exec.pl +++ b/feature-tests/exec.pl @@ -69,7 +69,7 @@ use Time::HiRes qw/sleep/; use IO::Handle; use IO::Pipe; use IPC::Open3; -use Symbol qw/gensym geniosym/; +use Symbol 'geniosym'; use Data::Dumper; @@ -82,15 +82,105 @@ our %IRSSI = ( license => 'Public Domain', ); +my @processes = (); +sub get_processes { return @processes } -my $pid = 0; - +# the /exec command, nothing to do with the actual command being run. my $command; my $command_options; -my ($sin, $serr, $sout) = (new IO::Handle, new IO::Handle, new IO::Handle); -my ($stdout_tag, $stderr_tag); +sub get_new_id { + my $i = 1; + foreach my $proc (@processes) { + if ($proc->{id} != $i) { + next; + } + $i++; + } + return $i; +} + +sub add_process { + #my ($pid) = @_; + my $id = get_new_id(); + + my $new = { + id => $id, + pid => 0, + in_tag => 0, + out_tag => 0, + err_tag => 0, + s_in => geniosym(), #IO::Handle->new, + s_err => geniosym(), #IO::Handle->new, + s_out => geniosym(), #IO::Handle->new, + cmd => '', + opts => {}, + }; + + # $new->{s_in}->autoflush(1); + # $new->{s_out}->autoflush(1); + # $new->{s_err}->autoflush(1); + + push @processes, $new; + + _msg("New process item created: $id"); + return $new; +} + +sub find_process_by_id { + my ($id) = @_; + my @matches = grep { $_->{id} == $id } @processes; + _error("wtf, multiple id matches for $id. BUG") if @matches > 1; + return $matches[0]; + +} +sub find_process_by_pid { + my ($pid) = @_; + my @matches = grep { $_->{pid} == $pid } @processes; + _error("wtf, multiple pid matches for $pid. BUG") if @matches > 1; + + return $matches[0]; +} + +sub remove_process { + my ($id, $verbose) = @_; + my $del_index = 0; + foreach my $proc (@processes) { + if ($id == $proc->{id}) { + last; + } + $del_index++; + } + print "remove: del index: $del_index"; + if ($del_index <= $#processes) { + my $dead = splice(@processes, $del_index, 1, ()); + #_msg("removing " . Dumper($dead)); + + Irssi::input_remove($dead->{err_tag}); + Irssi::input_remove($dead->{out_tag}); + + close $dead->{s_out}; + close $dead->{s_in}; + close $dead->{s_err}; + + } else { + $verbose = 1; + if ($verbose) { + print "remove: No such process with ID $id"; + } + } +} + +sub show_current_processes { + if (@processes == 0) { + print "No processes running"; + return; + } + foreach my $p (@processes) { + printf("ID: %d, PID: %d, Command: %s", $p->{id}, $p->{pid}, $p->{cmd}); + } +} sub parse_options { my ($args) = @_; @@ -101,8 +191,13 @@ sub parse_options { $rest =~ s/^\s*(.*?)\s*$/$1/; # trim surrounding space. - print Dumper([$opt_hash, $rest]); - return ($opt_hash, $rest); + #print Dumper([$opt_hash, $rest]); + if (length $rest) { + return ($opt_hash, $rest); + } else { + show_current_processes(); + return (); + } } else { _error("Error parsing $command options"); return (); @@ -115,21 +210,19 @@ sub schedule_cleanup { } sub do_fork_and_exec { - my ($options, $cmd) = @_; + my ($rec) = @_; #Irssi::timeout_add_once(100, sub { die }, {}); - return unless $cmd; - - #_msg("type of siin is %s, out is %s, err is %s", ref $sin, ref $sout, ref $serr); - - $sin->autoflush; - $sout->autoflush; - $serr->autoflush; - + return unless exists $rec->{cmd}; drop_privs(); - $pid = open3($sin, $sout, $serr, $cmd); + _msg("Executing command " . join(", ", @{ $rec->{cmd} })); + my $c = join(" ", @{ $rec->{cmd} }); + my $pid = open3($rec->{s_sin}, $rec->{s_out}, $rec->{s_err}, $c); + + _msg("PID is $pid"); + $rec->{pid} = $pid; # _msg("Pid %s, in: %s, out: %s, err: %s, cmd: %s", # $pid, $sin, $sout, $serr, $cmd); @@ -138,10 +231,11 @@ sub do_fork_and_exec { # $pid, $sin->fileno, $sout->fileno, $serr->fileno); if (not defined $pid) { + _error("open3 failed: $! Aborting"); - $_->close for ($sin, $serr, $sout); - undef($_) for ($sin, $serr, $sout); + close($_) for ($rec->{s_in}, $rec->{s_err}, $rec->{s_out}); + undef($_) for ($rec->{s_in}, $rec->{s_err}, $rec->{s_out}); return; } @@ -149,22 +243,24 @@ sub do_fork_and_exec { # parent if ($pid) { +# eval { + print "fileno is " . fileno($rec->{s_out}); + $rec->{out_tag} = Irssi::input_add( fileno($rec->{s_out}), + Irssi::INPUT_READ, + \&child_output, + $rec); + #die unless $rec->{out_tag}; - eval { - my @out_args = ($sout, $cmd, $options); - $stdout_tag = Irssi::input_add( $sout->fileno, Irssi::INPUT_READ, - \&child_output, \@out_args); - die unless $stdout_tag; + $rec->{err_tag} = Irssi::input_add(fileno($rec->{s_err}), + Irssi::INPUT_READ, + \&child_error, + $rec); + #die unless $rec->{err_tag}; - my @err_args = ($serr, $cmd, $options); - $stderr_tag = Irssi::input_add($serr->fileno, Irssi::INPUT_READ, - \&child_error, \@err_args); - die unless $stderr_tag; + # }; - }; Irssi::pidwait_add($pid); - die "input_add failed to initialise: $@" if $@; } } @@ -185,69 +281,75 @@ sub drop_privs { } sub child_error { - my $args = shift; - my ($stderr_reader, $cmd, $options) = @$args; - - read_err_data_loop: - my $data = ''; - my $bytes_read = sysread($stderr_reader, $data, 256); - if (not defined $bytes_read) { - _error("stderr: sysread failed:: $!"); - - } elsif ($bytes_read == 0) { - _msg("stderr: sysread got EOF"); - - } elsif ($bytes_read < 256) { - # that's all, folks. - _msg("stderr: read %d bytes: %s", $bytes_read, $data); - } else { - # we maybe need to read some more - _msg("stderr: read %d bytes: %s, maybe more", $bytes_read, $data); - goto read_err_data_loop; + my $rec = shift; + + my $err_fh = $rec->{s_err}; + + my $done = 0; + + while (not $done) { + my $data = ''; + _msg("Stderr: starting sysread"); + my $bytes_read = sysread($err_fh, $data, 256); + if (not defined $bytes_read) { + _error("stderr: sysread failed:: $!"); + $done = 1; + } elsif ($bytes_read == 0) { + _msg("stderr: sysread got EOF"); + $done = 1; + } elsif ($bytes_read < 256) { + # that's all, folks. + _msg("%%_stderr:%%_ read %d bytes: %s", $bytes_read, $data); + } else { + # we maybe need to read some more + _msg("%%_stderr:%%_ read %d bytes: %s, maybe more", $bytes_read, $data); + } } + _msg('removing input stderr tag'); + Irssi::input_remove($rec->{err_tag}); + } sub sig_pidwait { my ($pidwait, $status) = @_; - if ($pidwait == $pid) { + my @matches = grep { $_->{pid} == $pidwait } @processes; + foreach my $m (@matches) { _msg("PID %d has terminated. Status %d (or maybe %d .... %d)", $pidwait, $status, $?, ${^CHILD_ERROR_NATIVE} ); - $pid = 0; - - _msg('removing input stdout tag'); - Irssi::input_remove($stdout_tag); - - _msg('removing input stderr tag'); - Irssi::input_remove($stderr_tag); + remove_process($m->{id}); } } sub child_output { - my $args = shift; - my ($stdout_reader, $tag_ref, $pid, $cmd, $options) = @$args; - - my $return_value = 0; - - read_out_data_loop: - my $data = ''; - my $bytes_read = sysread($stdout_reader, $data, 256); - if (not defined $bytes_read) { - _error("stdout: sysread failed:: $!"); - - } elsif ($bytes_read == 0) { - _msg("stdout: sysread got EOF"); - - } elsif ($bytes_read < 256) { - # that's all, folks. - _msg("stdout: read %d bytes: %s", $bytes_read, $data); - } else { - # we maybe need to read some more - _msg("stdout: read %d bytes: %s, maybe more", $bytes_read, $data); - goto read_out_data_loop; + my $rec = shift; + my $out_fh = $rec->{s_out}; + + my $done = 0; + + while (not $done) { + my $data = ''; + _msg("Stdout: starting sysread"); + my $bytes_read = sysread($out_fh, $data, 256); + if (not defined $bytes_read) { + _error("stdout: sysread failed:: $!"); + $done = 1; + } elsif ($bytes_read == 0) { + _msg("stdout: sysread got EOF"); + $done = 1; + } elsif ($bytes_read < 256) { + # that's all, folks. + _msg("%%_stdout:%%_ read %d bytes: %s", $bytes_read, $data); + } else { + # we maybe need to read some more + _msg("%%_stdout:%%_ read %d bytes: %s, maybe more", $bytes_read, $data); + } } + _msg('removing input stdout tag'); + Irssi::input_remove($rec->{out_tag}); + #schedule_cleanup($stdout_reader); #$stdout_reader->close; } @@ -269,20 +371,41 @@ sub _msg { sub cmd_exec { my ($args, $server, $witem) = @_; - # TODO: parse some options here. Irssi::signal_stop; - my @options = parse_options($args); + if (@options) { - do_fork_and_exec(@options) + my $rec = add_process(); + my ($options, $cmd) = @options; + + $cmd = [split ' ', $cmd]; + + if (not exists $options->{nosh}) { + unshift @$cmd, ("/bin/sh -c"); + } + + $rec->{opts} = $options; + $rec->{cmd} = $cmd; + + do_fork_and_exec($rec) } } sub cmd_input { my ($args) = @_; - if ($pid) { - print $sin "$args\n"; + my $rec = $processes[0]; # HACK, make them specify. + if ($rec->{pid}) { + print "INput writing to $rec->{pid}"; + my $fh = $rec->{s_in}; + + my $ret = syswrite($fh, "$args\n"); + if (not defined $ret) { + print "Error writing to process $rec->{pid}: $!"; + } else { + print "Wrote $ret bytes to $rec->{pid}"; + } + } else { _error("no execs are running to accept input"); } @@ -304,3 +427,16 @@ sub exec_init { } exec_init(); + +package Irssi::UI; + +{ + no warnings 'redefine'; + + sub processes() { + return Irssi::Script::exec::get_processes(); + } + +} + +1; -- cgit v1.2.3 From e65031e3f1809ff404aa1a2715bceb2ed387d36c Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Thu, 14 Apr 2011 06:29:03 +0100 Subject: template: update with MIT licence and bit more doc stubbing. --- feature-tests/template.pl | 33 ++++++++++++++++++++++++++++++--- 1 file changed, 30 insertions(+), 3 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/template.pl b/feature-tests/template.pl index f3ae68a..3cb7b61 100644 --- a/feature-tests/template.pl +++ b/feature-tests/template.pl @@ -1,19 +1,46 @@ +# DOCUMENTATION: +# +# +# +# +# LICENCE: +# +# Copyright (c) 2011 Tom Feist +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to deal +# in the Software without restriction, including without limitation the rights +# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +# copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +# THE SOFTWARE. +# + use strict; use warnings; - use Irssi; use Irssi::Irc; use Irssi::TextUI; use Data::Dumper; - our $VERSION = '0.1'; our %IRSSI = ( authors => 'shabble', contact => 'shabble+irssi@metavore.org', name => '', description => '', - license => 'Public Domain', + license => 'MIT', + updated => '$DATE' ); -- cgit v1.2.3 From b659b7ec8d3875f714af977cdf92844a9e303e21 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Mon, 18 Apr 2011 08:36:21 +0100 Subject: readme: fixed generator to not stomp if multiple files in one dir. Doesn't auto-display though. Maybe need to generate an index? (But where to store it?) --- feature-tests/template.pl | 77 ++++++++++++++++++++++++++++++----------------- 1 file changed, 50 insertions(+), 27 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/template.pl b/feature-tests/template.pl index 3cb7b61..a49d742 100644 --- a/feature-tests/template.pl +++ b/feature-tests/template.pl @@ -1,30 +1,53 @@ -# DOCUMENTATION: -# -# -# -# -# LICENCE: -# -# Copyright (c) 2011 Tom Feist -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to deal -# in the Software without restriction, including without limitation the rights -# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -# copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -# THE SOFTWARE. -# +=pod + +=head1 NAME + +template.pl + +=head1 DESCRIPTION + +A minimalist template useful for basing actual scripts on. + +=head1 INSTALLATION + +Copy into your F<~/.irssi/scripts/> directory and load with +C>. + +=head1 USAGE + +None, since it doesn't actually do anything. + +=head1 AUTHORS + +Copyright E 2011 Tom Feist Cshabble+irssi@metavore.orgE> + +=head1 LICENCE + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +=head1 BUGS + +=head1 TODO + +Use this template to make an actual script. + +=cut use strict; use warnings; -- cgit v1.2.3 From 365525590fd2615fb7e348c08102049e1eb5aece Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Mon, 18 Apr 2011 08:36:41 +0100 Subject: some minimalist pod. --- feature-tests/augment_inputline.pl | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'feature-tests') diff --git a/feature-tests/augment_inputline.pl b/feature-tests/augment_inputline.pl index 577f756..97a129e 100644 --- a/feature-tests/augment_inputline.pl +++ b/feature-tests/augment_inputline.pl @@ -1,3 +1,12 @@ +=pod + +=head1 NAME + +test + +=cut + + use strict; use Irssi; use Irssi::TextUI; # for sbar_items_redraw -- cgit v1.2.3 From a0507750ffa0974c063fa4fefa766a4de1c7dd9c Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Fri, 22 Apr 2011 03:21:02 +0100 Subject: feature-tests/key_sig: test to see if there's any useful info in the 'keyboard created' signals. Answer is no, because it gets initialised befor the perl core, so we're too late to handle the signal. Might be a useful testcase for when I start meddling with multiple keyboards though. --- feature-tests/key_sig.pl | 51 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) create mode 100644 feature-tests/key_sig.pl (limited to 'feature-tests') diff --git a/feature-tests/key_sig.pl b/feature-tests/key_sig.pl new file mode 100644 index 0000000..ef69d45 --- /dev/null +++ b/feature-tests/key_sig.pl @@ -0,0 +1,51 @@ +use strict; +use warnings 'all'; + +use Irssi; +use Irssi::Irc; +use Irssi::TextUI; + +use Data::Dumper; + + +our $VERSION = '0.1'; +our %IRSSI = ( + authors => 'shabble', + contact => 'shabble+irssi@metavore.org', + name => '', + description => '', + license => 'Public Domain', + ); + +my $bacon = 10; + +Irssi::signal_register({'key created' => [qw/Irssi::UI::Key/ ] }); + +Irssi::signal_add('key created', \&sig_key_created); +Irssi::signal_register({'key command' => [qw/string/]}); +Irssi::signal_add_first('key command' => \&sig_key_cmd); + +Irssi::signal_register({'key nothing' => [qw/string/]}); +Irssi::signal_add_first('key nothing' => \&sig_key_cmd); + +Irssi::signal_register({'keyboard created' => [qw/Irssi::UI::Keyboard/]}); +Irssi::signal_add_first('keyboard created' => \&sig_keyboard); + +sub sig_keyboard { + my ($data) = @_; + print "keyboard: " . Dumper($data); +} + +sub sig_key_cmd { + my ($data) = @_; + print "key cmd: " . Dumper($data); + +} + +sub sig_key_created { + my @args = @_; + + print "Key Created, Args: " . Dumper(\@args); +} + +Irssi::command("bind meta-q /echo moo"); -- cgit v1.2.3 From 8b36ac6de6a096a396a8dc81861e213877d34c14 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Thu, 5 May 2011 00:53:48 +0100 Subject: added colour_test for testing implementations of 256-colour patches --- feature-tests/colour_test.pl | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 feature-tests/colour_test.pl (limited to 'feature-tests') diff --git a/feature-tests/colour_test.pl b/feature-tests/colour_test.pl new file mode 100644 index 0000000..875b63c --- /dev/null +++ b/feature-tests/colour_test.pl @@ -0,0 +1,16 @@ +use strict; +use warnings; + + +use Irssi; + +my @colors = (0..255); +my @names = qw/black red green yellow blue magenta cyan white/; +#my @bnames = map { "bold_$_" } @names; + +#@names = (@names, @bnames); + +foreach my $c (@colors) { + my $n = $names[$c] // $c; + Irssi::print("\%$c This is bg color $n\%n"); +} -- cgit v1.2.3 From d8f2fcff03fbb63b417679fe66f2f1c27676fe14 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 16 Jul 2011 04:54:07 +0100 Subject: added getchan to demonstrate how to retrieve, alter and restore a format string for easier parsing --- feature-tests/getchan.pl | 106 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 106 insertions(+) create mode 100644 feature-tests/getchan.pl (limited to 'feature-tests') diff --git a/feature-tests/getchan.pl b/feature-tests/getchan.pl new file mode 100644 index 0000000..98f116a --- /dev/null +++ b/feature-tests/getchan.pl @@ -0,0 +1,106 @@ +=pod + +=head1 NAME + +template.pl + +=head1 DESCRIPTION + +A minimalist template useful for basing actual scripts on. + +=head1 INSTALLATION + +Copy into your F<~/.irssi/scripts/> directory and load with +C>. + +=head1 USAGE + +None, since it doesn't actually do anything. + +=head1 AUTHORS + +Copyright E 2011 Tom Feist Cshabble+irssi@metavore.orgE> + +=head1 LICENCE + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +=head1 BUGS + +=head1 TODO + +Use this template to make an actual script. + +=cut + +use strict; +use warnings; + +use Irssi; +use Irssi::Irc; +use Irssi::TextUI; + +use Data::Dumper; + +our $VERSION = '0.1'; +our %IRSSI = ( + authors => 'shabble', + contact => 'shabble+irssi@metavore.org', + name => '', + description => '', + license => 'MIT', + updated => '$DATE' + ); + +sub get_format_string { + my ($module, $tag, $theme) = @_; + + $theme ||= Irssi::current_theme(); + my $format_str; + { + # deeeeeeep black magic. + #print "Trying to get format for $module, $tag"; + local *CORE::GLOBAL::caller = sub { $module }; + $format_str = $theme->get_format($module, $tag); + } + return $format_str; +} + +my $fmt = get_format_string('fe-common/core', 'chansetup_line'); + +if ($fmt) { + Irssi::command("^FORMAT chansetup_line Meep meep $fmt"); + Irssi::command("CHANNEL LIST"); + Irssi::command("^FORMAT chansetup_line $fmt"); +} else { + print "Failed to get format :("; +} + +# Irssi::UI::Theme::get_format(Irssi::UI::Theme $theme, string $module, string $tag) + +# in fe-common/core +# +# chansetup_not_found = "Channel {channel $0} not found"; +# chansetup_added = "Channel {channel $0} saved"; +# chansetup_removed = "Channel {channel $0} removed"; +# chansetup_header = "%#Channel Network Password Settings"; +# chansetup_line = "%#{channel $[15]0} %|$[10]1 $[10]2 $3"; +# chansetup_footer = ""; +# Irssi::active_win->actually_printformat(Irssi::MSGLEVEL_CRAP, 'fe-common/core', +# 'window_name_not_unique') -- cgit v1.2.3 From 3640cdc407c73ad80867144d72a820589ae651dd Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 16 Jul 2011 05:01:14 +0100 Subject: added a reference to the module names for formats --- feature-tests/getchan.pl | 1 + 1 file changed, 1 insertion(+) (limited to 'feature-tests') diff --git a/feature-tests/getchan.pl b/feature-tests/getchan.pl index 98f116a..b035337 100644 --- a/feature-tests/getchan.pl +++ b/feature-tests/getchan.pl @@ -82,6 +82,7 @@ sub get_format_string { return $format_str; } +# see here: https://github.com/shabble/irssi-docs/wiki/complete_themes my $fmt = get_format_string('fe-common/core', 'chansetup_line'); if ($fmt) { -- cgit v1.2.3 From ce74fad7456e2f259be3514c8999daf7f6f572c5 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 16 Jul 2011 05:34:48 +0100 Subject: getchan now actually parses the channel data --- feature-tests/getchan.pl | 84 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 74 insertions(+), 10 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/getchan.pl b/feature-tests/getchan.pl index b035337..cb3920d 100644 --- a/feature-tests/getchan.pl +++ b/feature-tests/getchan.pl @@ -68,6 +68,15 @@ our %IRSSI = ( updated => '$DATE' ); + +my $line_format; +my $head_format; +my $foot_format; + +my $channels = {}; +my @errors; +my $state; + sub get_format_string { my ($module, $tag, $theme) = @_; @@ -82,19 +91,76 @@ sub get_format_string { return $format_str; } -# see here: https://github.com/shabble/irssi-docs/wiki/complete_themes -my $fmt = get_format_string('fe-common/core', 'chansetup_line'); -if ($fmt) { - Irssi::command("^FORMAT chansetup_line Meep meep $fmt"); +sub get_channels { + # see here: https://github.com/shabble/irssi-docs/wiki/complete_themes + $line_format = get_format_string('fe-common/core', 'chansetup_line'); + $head_format = get_format_string('fe-common/core', 'chansetup_header'); + $foot_format = get_format_string('fe-common/core', 'chansetup_footer'); + + my $parse_line_format = "channel:\$0\tnet:\$1\tpass:\$2\tsettings:\$3"; + Irssi::command("^FORMAT chansetup_line $parse_line_format"); + Irssi::command("^FORMAT chansetup_header START"); + Irssi::command("^FORMAT chansetup_footer END"); + + $state = 0; + Irssi::signal_add_first('print text', 'sig_print_text'); Irssi::command("CHANNEL LIST"); - Irssi::command("^FORMAT chansetup_line $fmt"); -} else { - print "Failed to get format :("; + Irssi::signal_remove('print text', 'sig_print_text'); + +} + +sub restore_formats { + Irssi::command("^FORMAT chansetup_line $line_format"); + Irssi::command("^FORMAT chansetup_header $head_format"); + Irssi::command("^FORMAT chansetup_footer $foot_format"); +} + +sub sig_print_text { + my ($dest, $text, $stripped) = @_; + + my $entry = {}; + + if ($state == 0 && $text =~ m/START/) { + $state = 1; + return; + } elsif ($state == 1) { + # TODO: might we get multiple lines at once? + if ($text =~ m/channel:([^\t]+)\tnet:([^\t]+)\tpass:([^\t]*)\tsettings:(.*)$/) { + $entry->{channel} = $1; + $entry->{network} = $2; + $entry->{password} = $3; + $entry->{settings} = $4; + + my $tag = "$2/$1"; + $channels->{$tag} = $entry; + Irssi::signal_stop(); + } elsif ($text =~ m/END/) { + $state = 0; + return; + } else { + push @errors, "Failed to parse: '$text'"; + } + } } -# Irssi::UI::Theme::get_format(Irssi::UI::Theme $theme, string $module, string $tag) +sub go { + eval { + get_channels(); + }; + if ($@) { + print "Error: $@. Reloading theme to restore format"; + Irssi::themes_reload(); + } else { + restore_formats(); + } + if (@errors) { + print Dumper(\@errors); + } + print Dumper($channels); +} +Irssi::command_bind('getchan', \&go); # in fe-common/core # # chansetup_not_found = "Channel {channel $0} not found"; @@ -103,5 +169,3 @@ if ($fmt) { # chansetup_header = "%#Channel Network Password Settings"; # chansetup_line = "%#{channel $[15]0} %|$[10]1 $[10]2 $3"; # chansetup_footer = ""; -# Irssi::active_win->actually_printformat(Irssi::MSGLEVEL_CRAP, 'fe-common/core', -# 'window_name_not_unique') -- cgit v1.2.3 From 8c4633404a694388c95dd01f7895b506b57bfb19 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 16 Jul 2011 06:01:23 +0100 Subject: fix code-paths not properly stopping the print text signal --- feature-tests/getchan.pl | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/getchan.pl b/feature-tests/getchan.pl index cb3920d..622f708 100644 --- a/feature-tests/getchan.pl +++ b/feature-tests/getchan.pl @@ -113,7 +113,11 @@ sub get_channels { sub restore_formats { Irssi::command("^FORMAT chansetup_line $line_format"); Irssi::command("^FORMAT chansetup_header $head_format"); - Irssi::command("^FORMAT chansetup_footer $foot_format"); + if ($foot_format =~ m/^\s*$/) { + Irssi::command("^FORMAT -reset chansetup_footer"); + } else { + Irssi::command("^FORMAT chansetup_footer $foot_format"); + } } sub sig_print_text { @@ -123,7 +127,6 @@ sub sig_print_text { if ($state == 0 && $text =~ m/START/) { $state = 1; - return; } elsif ($state == 1) { # TODO: might we get multiple lines at once? if ($text =~ m/channel:([^\t]+)\tnet:([^\t]+)\tpass:([^\t]*)\tsettings:(.*)$/) { @@ -134,14 +137,14 @@ sub sig_print_text { my $tag = "$2/$1"; $channels->{$tag} = $entry; - Irssi::signal_stop(); + } elsif ($text =~ m/END/) { $state = 0; - return; } else { push @errors, "Failed to parse: '$text'"; } } + Irssi::signal_stop(); } sub go { @@ -155,6 +158,7 @@ sub go { restore_formats(); } if (@errors) { + @errors = map { s/\t/ /g } @errors; print Dumper(\@errors); } print Dumper($channels); -- cgit v1.2.3 From 87f860070566aeb037a8245c105c9b1b00dc620e Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 16 Jul 2011 06:50:17 +0100 Subject: trim out the caller() uglyness, since it's not actually needed for get_format(). --- feature-tests/getchan.pl | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/getchan.pl b/feature-tests/getchan.pl index 622f708..92044aa 100644 --- a/feature-tests/getchan.pl +++ b/feature-tests/getchan.pl @@ -80,15 +80,8 @@ my $state; sub get_format_string { my ($module, $tag, $theme) = @_; - $theme ||= Irssi::current_theme(); - my $format_str; - { - # deeeeeeep black magic. - #print "Trying to get format for $module, $tag"; - local *CORE::GLOBAL::caller = sub { $module }; - $format_str = $theme->get_format($module, $tag); - } - return $format_str; + $theme ||= Irssi::current_theme; + return $theme->get_format($module, $tag); } -- cgit v1.2.3 From 26c34ee399d3b3179c4c1c212c4e0d000bdb0016 Mon Sep 17 00:00:00 2001 From: Tom Feist Date: Sat, 16 Jul 2011 06:55:34 +0100 Subject: bit more cleanup on get_format_string --- feature-tests/getchan.pl | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) (limited to 'feature-tests') diff --git a/feature-tests/getchan.pl b/feature-tests/getchan.pl index 92044aa..7d4ee55 100644 --- a/feature-tests/getchan.pl +++ b/feature-tests/getchan.pl @@ -78,10 +78,7 @@ my @errors; my $state; sub get_format_string { - my ($module, $tag, $theme) = @_; - - $theme ||= Irssi::current_theme; - return $theme->get_format($module, $tag); + return Irssi::current_theme->get_format(@_); } -- cgit v1.2.3