1package POE::Component::DebugShell;
2
3use warnings;
4use strict;
5
6use 5.006;
7
8use Carp;
9
10use POE;
11use POE::Wheel::ReadLine;
12use POE::API::Peek;
13
14our $VERSION = '1.412';
15our $RUNNING = 0;
16our %COMMANDS;
17our $SPAWN_TIME;
18
19sub spawn { #{{{
20    my $class = shift;
21
22    # Singleton check {{{
23    if($RUNNING) {
24        carp "A ".__PACKAGE__." session is already running. Will not start a second.";
25        return undef;
26    } else {
27        $RUNNING = 1;
28    }
29    # }}}
30
31    my $api = POE::API::Peek->new() or croak "Unable to create POE::API::Peek object";
32
33
34    # Session creation {{{
35    my $sess = POE::Session->create(
36        inline_states => {
37            _start      => \&_start,
38            _stop       => \&_stop,
39
40            term_input  => \&term_input,
41        },
42        heap => {
43            api         => $api,
44        },
45    );
46    # }}}
47
48    if($sess) {
49        $SPAWN_TIME = time();
50        return $sess;
51    } else {
52        return undef;
53    }
54} #}}}
55
56
57
58sub _start { #{{{
59    $_[KERNEL]->alias_set(__PACKAGE__." controller");
60
61    $_[HEAP]->{rl} = POE::Wheel::ReadLine->new( InputEvent => 'term_input' );
62    $_[HEAP]->{prompt} = 'debug> ';
63
64    tie *STDOUT, "POE::Component::DebugShell::Output", 'stdout', \&_output;
65    tie *STDERR, "POE::Component::DebugShell::Output", 'stderr', \&_output;
66
67    $_[HEAP]->{rl}->clear();
68    _output("Welcome to POE Debug Shell v$VERSION");
69
70    $_[HEAP]->{rl}->get($_[HEAP]->{prompt});
71
72} #}}}
73
74
75
76sub _stop { #{{{
77    # Shut things down
78    $_[HEAP]->{vt} && $_[HEAP]->{vt}->delete_window($_[HEAP]->{main_window});
79} #}}}
80
81
82
83sub term_input { #{{{
84    my ($input, $exception) = @_[ARG0, ARG1];
85
86    unless (defined $input) {
87        croak("Received exception from UI: $exception");
88    }
89
90    $_[HEAP]->{rl}->addhistory($input);
91
92    if($input =~ /^help (.*?)$/) {
93        my $cmd = $1;
94        if($COMMANDS{$cmd}) {
95            if($COMMANDS{$cmd}{help}) {
96                _output("Help for $cmd:");
97                _output($COMMANDS{$cmd}{help});
98            } else {
99                _output("Error: '$cmd' has no help.");
100            }
101        } else {
102            _output("Error: '$cmd' is not a known command");
103        }
104    } elsif ( ($input eq 'help') or ($input eq '?') ) {
105        my $text;
106        _output(' ');
107        _output("General help for POE::Component::DebugShell v$VERSION");
108        _output("The following commands are available:");
109        foreach my $cmd (sort keys %COMMANDS) {
110            no warnings;
111            my $short_help = $COMMANDS{$cmd}{short_help} || '[ No short help provided ]';
112            _output("\t* $cmd - $short_help");
113        }
114        _output(' ');
115
116    } else  {
117        my ($cmd, @args);
118        if($input =~ /^(.+?)\s+(.*)$/) {
119            $cmd = $1;
120            my $args = $2;
121            @args = split('\s+',$args) if $args;
122        } else {
123            $cmd = $input;
124        }
125
126        if($COMMANDS{$cmd}) {
127            my $txt = eval { $COMMANDS{$cmd}{cmd}->( api => $_[HEAP]->{api}, args => \@args); };
128            if($@) {
129                _output("Error running $cmd: $@");
130            } else {
131                my @lines = split(/\n/, $txt);
132                _output($_) for @lines;
133            }
134        } else {
135            _output("Error: '$cmd' is not a known command");
136        }
137    }
138
139    $_[HEAP]->{rl}->get($_[HEAP]->{prompt});
140
141} #}}}
142
143
144
145sub _output { #{{{
146    my $msg = shift || ' ';
147    my $heap = $poe_kernel->alias_resolve(__PACKAGE__." controller")->get_heap();
148    $heap->{rl}->put($msg);
149} #}}}
150
151sub _raw_commands { #{{{
152    return \%COMMANDS;
153} #}}}
154
155#   ____                                          _
156#  / ___|___  _ __ ___  _ __ ___   __ _ _ __   __| |___
157# | |   / _ \| '_ ` _ \| '_ ` _ \ / _` | '_ \ / _` / __|
158# | |__| (_) | | | | | | | | | | | (_| | | | | (_| \__ \
159#  \____\___/|_| |_| |_|_| |_| |_|\__,_|_| |_|\__,_|___/
160#
161# {{{
162
163%COMMANDS = ( #{{{
164
165    'reload' => {
166        help => "Reload the shell to catch updates.",
167        short_help => "Reload the shell to catch updates.",
168        cmd => \&cmd_reload,
169    },
170
171    show_sessions => {
172        help => 'Show a list of all sessions in the system. The output format is in the form of loggable session ids.',
173        short_help => 'Show a list of all sessions',
174        cmd => \&cmd_show_sessions,
175    },
176
177    'list_aliases' => {
178        help => 'List aliases for a given session id. Provide one session id as a parameter.',
179        short_help => 'List aliases for a given session id.',
180        cmd => \&cmd_list_aliases,
181    },
182
183    'session_stats' => {
184        help => 'Display various statistics for a given session id. Provide one session id as a parameter.',
185        short_help => 'Display various statistics for a given session id.',
186        cmd => \&cmd_session_stats,
187    },
188
189    'queue_dump' => {
190        help => 'Dump the contents of the event queue.',
191        short_help => 'Dump the contents of the event queue.',
192        cmd => \&cmd_queue_dump,
193    },
194
195    'status' => {
196        help => 'General shell status.',
197        short_help => 'General shell status.',
198        cmd => \&cmd_status,
199    },
200); #}}}
201
202###############
203
204sub cmd_reload { #{{{
205    my $ret;
206    $ret .= "Reloading....\n";
207    eval q|
208        no warnings qw(redefine);
209        $SIG{__WARN__} = sub { };
210
211        foreach my $key (keys %INC) {
212            if($key =~ m#POE/Component/DebugShell#) {
213                delete $INC{$key};
214            } elsif ($key =~ m#POE/API/Peek#) {
215                delete $INC{$key};
216            }
217        }
218        require POE::Component::DebugShell;
219    |;
220    $ret .= "Error: $@\n" if $@;
221
222    return $ret;
223} #}}}
224
225sub cmd_show_sessions { #{{{
226    my %args = @_;
227    my $api = $args{api};
228
229    my $ret;
230    $ret .= "Session List:\n";
231    my @sessions = $api->session_list;
232    foreach my $sess (@sessions) {
233        my $id = $sess->ID. " [ ".$api->session_id_loggable($sess)." ]";
234        $ret .= "\t* $id\n";
235    }
236
237    return $ret;
238} #}}}
239
240sub cmd_list_aliases { #{{{
241    my %args = @_;
242    my $user_args = $args{args};
243    my $api = $args{api};
244
245    my $ret;
246
247    if(my $id = shift @$user_args) {
248        if(my $sess = $api->resolve_session_to_ref($id)) {
249            my @aliases = $api->session_alias_list($sess);
250            if(@aliases) {
251                $ret .= "Alias list for session $id\n";
252                foreach my $alias (sort @aliases) {
253                    $ret .= "\t* $alias\n";
254                }
255            } else {
256                $ret .= "No aliases found for session $id\n";
257            }
258        } else {
259            $ret .= "** Error: ID $id does not resolve to a session. Sorry.\n";
260        }
261
262    } else {
263        $ret .= "** Error: Please provide a session id\n";
264    }
265    return $ret;
266}
267
268# }}}
269
270sub cmd_session_stats { #{{{
271    my %args = @_;
272    my $user_args = $args{args};
273    my $api = $args{api};
274
275    my $ret;
276
277    if(my $id = shift @$user_args) {
278        if(my $sess = $api->resolve_session_to_ref($id)) {
279            my $to = $api->event_count_to($sess);
280            my $from = $api->event_count_from($sess);
281            $ret .= "Statistics for Session $id\n";
282            $ret .= "\tEvents coming from: $from\n";
283            $ret .= "\tEvents going to: $to\n";
284
285        } else {
286            $ret .= "** Error: ID $id does not resolve to a session. Sorry.\n";
287        }
288
289
290    } else {
291        $ret .= "** Error: Please provide a session id\n";
292    }
293
294    return $ret;
295} #}}}
296
297sub cmd_queue_dump { #{{{
298    my %args = @_;
299    my $api = $args{api};
300    my $verbose;
301
302    my $ret;
303
304    if($args{args} && defined $args{args}) {
305        if(ref $args{args} eq 'ARRAY') {
306            if(@{$args{args}}[0] eq '-v') {
307                $verbose = 1;
308            }
309        }
310    }
311
312    my @queue = $api->event_queue_dump();
313
314    $ret .= "Event Queue:\n";
315
316    foreach my $item (@queue) {
317        $ret .= "\t* ID: ". $item->{ID}." - Index: ".$item->{index}."\n";
318        $ret .= "\t\tPriority: ".$item->{priority}."\n";
319        $ret .= "\t\tEvent: ".$item->{event}."\n";
320
321        if($verbose) {
322            $ret .= "\t\tSource: ".
323                    $api->session_id_loggable($item->{source}).
324                    "\n";
325            $ret .= "\t\tDestination: ".
326                    $api->session_id_loggable($item->{destination}).
327                    "\n";
328            $ret .= "\t\tType: ".$item->{type}."\n";
329            $ret .= "\n";
330        }
331    }
332    return $ret;
333} #}}}
334
335sub cmd_status { #{{{
336    my %args = @_;
337    my $api = $args{api};
338    my $sess_count = $api->session_count;
339    my $ret = "\n";
340    $ret .= "This is ".__PACKAGE__." v".$VERSION."\n";
341    $ret .= "running inside $0."."\n";
342    $ret .= "This console was spawned at ".localtime($SPAWN_TIME).".\n";
343    $ret .= "There are $sess_count known sessions (including the kernel).\n";
344    $ret .= "\n";
345    return $ret;
346} # }}}
347
348# }}}
349
3501;
351
352package POE::Component::DebugShell::Output;
353
354use strict;
355#use warnings FATAL => "all";
356
357sub PRINT {
358    my $self = shift;
359
360    my $txt = join('',@_);
361    $txt =~ s/\r?\n$//;
362    $self->{print}->($self->{type}."> $txt");
363}
364
365sub TIEHANDLE {
366    my $class = shift;
367    bless({
368        type => shift,
369        print => shift,
370    }, $class);
371}
372
3731;
374__END__
375
376=pod
377
378=head1 NAME
379
380POE::Component::DebugShell - Component to allow interactive peeking into a
381running POE application
382
383=head1 SYNOPSIS
384
385    use POE::Component::DebugShell;
386
387    POE::Component::DebugShell->spawn();
388
389=head1 DESCRIPTION
390
391This component allows for interactive peeking into a running POE
392application.
393
394C<spawn()> creates a ReadLine enabled shell equipped with various debug
395commands. The following commands are available.
396
397=head1 COMMANDS
398
399=head2 show_sessions
400
401 debug> show_sessions
402    * 3 [ session 3 (POE::Component::DebugShell controller) ]
403    * 2 [ session 2 (PIE, PIE2) ]
404
405Show a list of all sessions in the system. The output format is in the
406form of loggable session ids.
407
408=head2 session_stats
409
410 debug> session_stats 2
411    Statistics for Session 2
412        Events coming from: 1
413        Events going to: 1
414
415Display various statistics for a given session. Provide one session id
416as a parameter.
417
418=head2 list_aliases
419
420 debug> list_aliases 2
421    Alias list for session 2
422        * PIE
423        * PIE2
424
425List aliases for a given session id. Provide one session id as a
426parameter.
427
428=head2 queue_dump
429
430 debug> queue_dump
431    Event Queue:
432        * ID: 738 - Index: 0
433            Priority: 1078459009.06715
434            Event: _sigchld_poll
435        * ID: 704 - Index: 1
436            Priority: 1078459012.42691
437            Event: ping
438
439Dump the contents of the event queue. Add a C<-v> parameter to get
440verbose output.
441
442=head2 help
443
444 debug> help
445    The following commands are available:
446        ...
447
448Display help about available commands.
449
450=head2 status
451
452 debug> status
453    This is POE::Component::DebugShell v1.14
454    running inside examples/foo.perl.
455    This console spawned at Thu Mar 4 22:51:51 2004.
456    There are 3 known sessions (including the kernel).
457
458General shell status.
459
460=head2 reload
461
462 debug> reload
463 Reloading...
464
465Reload the shell
466
467=head2 exit
468
469 debug> exit
470 Exiting...
471
472Exit the shell
473
474=head1 DEVELOPERS
475
476For you wacky developers, I've provided access to the raw command data
477via the C<_raw_commands> method. The underbar at the beginning should
478let you know that this is an experimental interface for developers only.
479
480C<_raw_commands> returns a hash reference. The keys of this hash are the
481command names. The values are a hash of data about the command. This
482hash contains the following data:
483
484=over 4
485
486=item * short_help
487
488Short help text
489
490=item * help
491
492Long help text
493
494=item * cmd
495
496Code reference for the command. This command requires that a hash be
497passed to it containing an C<api> parameter, which is a
498C<POE::API::Peek> object, and an C<args> parameter, which is an array
499reference of arguments (think C<@ARGV>).
500
501=back
502
503=head1 AUTHOR
504
505Matt Cashner (sungo@pobox.com)
506
507=head1 LICENSE
508
509Copyright (c) 2003-2004, Matt Cashner
510
511Permission is hereby granted, free of charge, to any person obtaining
512a copy of this software and associated documentation files (the
513"Software"), to deal in the Software without restriction, including
514without limitation the rights to use, copy, modify, merge, publish,
515distribute, sublicense, and/or sell copies of the Software, and to
516permit persons to whom the Software is furnished to do so, subject
517to the following conditions:
518
519The above copyright notice and this permission notice shall be included
520in all copies or substantial portions of the Software.
521
522THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
523WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
524MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
525EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
526SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
527PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
528OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
529WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
530OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
531ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
532
533=cut
534
535# sungo // vim: ts=4 sw=4 expandtab
536