File Coverage

blib/lib/Verby/Action/Run.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             package Verby::Action::Run;
4 2     2   212074 use Moose::Role;
  0            
  0            
5              
6             with qw/Verby::Action/;
7              
8             use Carp qw/croak/;
9              
10             use POE qw/Wheel::Run Filter::Stream/;
11              
12             sub create_poe_session {
13             my ( $self, %heap ) = @_;
14             $heap{log_stderr} = 1 unless exists $heap{log_stderr};
15              
16             my $accum = $heap{accum} ||= {};
17              
18             foreach my $output ( qw/stdout stderr/ ) {
19             next if exists $accum->{$output};
20             $accum->{$output} = "";
21             }
22              
23             POE::Session->create(
24             object_states => [
25             $self => { $self->poe_states(\%heap) },
26             ],
27             heap => \%heap,
28             );
29             }
30              
31             sub poe_states {
32             my ( $self, $heap ) = @_;
33             return (
34             _start => "poe_start",
35             _stop => "poe_stop",
36             _parent => "poe_parent",
37             (map { ("std$_") x 2 } qw/in out err/),
38             (map { ($_) x 2 } qw(
39             error
40             close
41             sigchld_handler
42             DIE
43             )),
44             );
45             }
46              
47             sub exit_code_is_ok {
48             my ( $self, $c ) = @_;
49             $c->program_exit == 0;
50             }
51              
52             sub confirm_exit_code {
53             my ( $self, $c ) = @_;
54             $c->logger->log_and_die(level => "error", message => "subprogram " . $c->program_debug_string . " exited with non zero status: " . $c->program_exit)
55             unless $self->exit_code_is_ok($c);
56             }
57              
58             sub poe_start {
59             my ( $self, $kernel, $session, $heap ) = @_[OBJECT, KERNEL, SESSION, HEAP];
60              
61             $self->setup_wheel( $kernel, $session, $heap );
62             }
63              
64             sub poe_parent {
65             $_[HEAP]{c}->logger->debug("Attached to parent");
66             }
67              
68             sub sigchld_handler {
69             my ( $self, $kernel, $session, $heap, $pid, $child_error ) = @_[ OBJECT, KERNEL, SESSION, HEAP, ARG1, ARG2 ];
70              
71             $heap->{c}->logger->debug("sigchild $pid");
72              
73             $kernel->refcount_decrement( $session->ID, 'child_processes' );
74              
75             $heap->{program_exit} = $child_error;
76             }
77              
78             sub setup_wheel {
79             my ( $self, $kernel, $session, $heap ) = @_;
80              
81             my $wheel = $self->create_wheel( $heap );
82              
83             $kernel->refcount_increment( $session->ID, 'child_processes' );
84              
85             $kernel->sig_child( $wheel->PID, "sigchld_handler" );
86              
87             $heap->{pid_to_wheel}->{ $wheel->PID } = $wheel;
88             $heap->{id_to_wheel}->{ $wheel->ID } = $wheel;
89              
90             $self->send_child_input( $wheel, $heap );
91             }
92              
93             sub create_wheel {
94             my ( $self, $heap ) = @_;
95              
96             my $wheel = POE::Wheel::Run->new(
97             $self->wheel_program( $heap ),
98              
99             $self->default_poe_wheel_events( $heap ),
100              
101             $self->additional_poe_wheel_options( $heap ),
102             );
103            
104             $self->log_invocation($heap->{c}, "started $heap->{program_debug_string}");
105              
106             return $wheel;
107             }
108              
109             sub additional_poe_wheel_options {
110             my ( $self, $heap ) = @_;
111             return (
112             StdinFilter => POE::Filter::Stream->new(),
113             StdoutFilter => POE::Filter::Stream->new(),
114             StderrFilter => POE::Filter::Stream->new(),
115             );
116             }
117              
118             sub default_poe_wheel_events {
119             my ( $self, $heap ) = @_;
120             return (
121             StdinEvent => "stdin",
122             StdoutEvent => "stdout",
123             StderrEvent => "stderr",
124             ErrorEvent => "error",
125             CloseEvent => "close",
126             );
127             }
128              
129             sub wheel_program {
130             my ( $self, $heap ) = @_;
131              
132             if ( my $program = $heap->{program} ) {
133             $heap->{program_debug_string} ||= "'$program'";
134             return Program => $program;
135             } elsif( my $cli = $heap->{cli} ) {
136             if ( my $init = $heap->{init} ) {
137             $heap->{program_debug_string} ||= "'@$cli' with init block";
138             return Program => sub { $self->$init($heap); exec(@$cli) };
139             } else {
140             $heap->{program_debug_string} ||= "'@$cli'";
141             return Program => $cli;
142             }
143             } else {
144             croak "Either 'program' or 'cli' must be provided";
145             }
146             }
147              
148             sub send_child_input {
149             my ( $self, $wheel, $heap ) = @_;
150              
151             if ( my $in = $heap->{in} ) {
152             if ( ref($in) eq "SCALAR" ) {
153             $in = $$in;
154             $heap->{in} = undef;
155             } else {
156             $in = $in->();
157             $heap->{in} = undef unless defined $in;
158             }
159              
160             $wheel->put( $in );
161             } else {
162             $wheel->shutdown_stdin;
163             }
164             }
165              
166             sub DIE {
167             my ( $heap, $exception ) = @_[HEAP, ARG0];
168             push @{ $heap->{exceptions} ||= [] }, $exception;
169             }
170              
171             sub poe_stop {
172             my ( $self, $kernel, $heap ) = @_[OBJECT, KERNEL, HEAP];
173              
174             $heap->{c}->logger->info("Wheel::Run subsession closing");
175              
176             my $c = $heap->{c};
177              
178             $c->command_line( $heap->{cli} ) if exists $heap->{cli};
179             $c->program( $heap->{program} ) if exists $heap->{program};
180             $c->program_debug_string( $heap->{program_debug_string} );
181             $c->stdout( $heap->{accum}{stdout} );
182             $c->stderr( $heap->{accum}{stderr} );
183             $c->program_exit( $heap->{program_exit} >> 8 ) if defined $heap->{program_exit};
184             $c->program_exit_full( $heap->{program_exit} );
185              
186             $c->program_finished(1);
187              
188             $self->confirm_exit_code($c);
189              
190             $self->finished($c) if $self->can("finished");
191             }
192              
193             sub error {
194             my ( $self, $heap ) = @_[OBJECT, HEAP];
195             warn("subprogram $heap->{program_debug_string} error: @_[ARG0 .. $#_]") unless $_[ARG1] == 0;
196             $heap->{c}->logger->info("subprogram $heap->{program_debug_string} error: @_[ARG0 .. $#_]") unless $_[ARG1] == 0;
197             }
198              
199             sub stdin {
200             my ( $self, $heap, $wheel_id ) = @_[OBJECT, HEAP, ARG0];
201             $self->send_child_input( $heap->{id_to_wheel}{$wheel_id}, $heap );
202             }
203              
204             sub stdout {
205             my ( $self, $heap, $output ) = @_[OBJECT, HEAP, ARG0];
206             $heap->{accum}{stdout} .= $output;
207             $self->log_output( $heap->{c}, "stdout", $output ) if $heap->{log_stdout};
208             }
209              
210             sub stderr {
211             my ( $self, $heap, $output ) = @_[OBJECT, HEAP, ARG0];
212             $heap->{accum}{stderr} .= $output;
213             $self->log_output( $heap->{c}, "stderr", $output ) if $heap->{log_stderr};
214             }
215              
216             sub log_output {
217             my ( $self, $c, $name, $output ) = @_;
218              
219             chomp($output) if ($output =~ tr/\n// == 1); # if it's one line, trim it
220             foreach my $line (split /\n/, $output){ # if it's not split it looks chaotic
221             $c->logger->warning("$name: $line");
222             }
223             }
224              
225             sub close {
226             my ( $self, $heap ) = @_[OBJECT, HEAP];
227             $heap->{c}->logger->info("program $heap->{program_debug_string} closed all outputs");
228             }
229              
230             sub log_invocation {
231             my ( $self, $c, $msg ) = @_;
232              
233             $c->logger->info($msg . $self->log_extra($c));
234             }
235              
236             sub log_extra { "" }
237              
238             __PACKAGE__
239              
240             __END__
241              
242             =pod
243              
244             =head1 NAME
245              
246             Verby::Action::Run - a base role for actions which wrap L<POE::Wheel::Run>.
247              
248             =head1 SYNOPSIS
249              
250             package MyAction;
251             use Moose;
252              
253             with qw/Verby::Action::Run/;
254            
255             sub start {
256             my ($self, $c) = @_;
257             $self->create_poe_sessio($c, cli => [qw/touch file/]);
258             }
259              
260             =head1 DESCRIPTION
261              
262             =head1 METHODS
263              
264             =over 4
265              
266             =item B<create_poe_session %args>
267              
268             This methods creates a sub session that runs the wheel.
269              
270             =item B<log_extra>
271              
272             A method that given the context might append something to log messages. used by
273             L<Verby::Action::Make>, for example.
274              
275             =item B<log_invocation>
276              
277             Mostly internal - the default implementation of the logging operation used when
278             invoking the subcommand.
279              
280             =back
281              
282             =head1 BUGS
283              
284             None that we are aware of. Of course, if you find a bug, let us know, and we
285             will be sure to fix it.
286              
287             =head1 CODE COVERAGE
288              
289             We use B<Devel::Cover> to test the code coverage of the tests, please refer to
290             COVERAGE section of the L<Verby> module for more information.
291              
292             =head1 SEE ALSO
293              
294             L<Verby::Action::Copy> - a L<Verby::Action::Run> subclass.
295              
296             =head1 AUTHOR
297              
298             Yuval Kogman, E<lt>nothingmuch@woobling.orgE<gt>
299              
300             =head1 COPYRIGHT AND LICENSE
301              
302             Copyright 2005-2008 by Infinity Interactive, Inc.
303              
304             L<http://www.iinteractive.com>
305              
306             This library is free software; you can redistribute it and/or modify
307             it under the same terms as Perl itself.
308              
309             =cut