File Coverage

lib/Class/Usul/TraitFor/RunningMethods.pm
Criterion Covered Total %
statement 53 64 82.8
branch 8 20 40.0
condition 1 9 11.1
subroutine 16 18 88.8
pod 3 3 100.0
total 81 114 71.0


line stmt bran cond sub pod time code
1             package Class::Usul::TraitFor::RunningMethods;
2              
3 18     18   10470 use namespace::autoclean;
  18         60  
  18         153  
4              
5 18     18   1562 use Class::Usul::Constants qw( FAILED NUL OK TRUE UNDEFINED_RV );
  18         43  
  18         164  
6 18         123 use Class::Usul::Functions qw( dash2under elapsed emit_to exception is_hashref
7 18     18   16262 is_member logname throw untaint_identifier );
  18         167  
8 18     18   30060 use Class::Usul::Types qw( ArrayRef HashRef Int SimpleStr );
  18         56  
  18         138  
9 18     18   19884 use English qw( -no_match_vars );
  18         45  
  18         179  
10 18     18   6598 use File::DataClass::Types qw( OctalNum );
  18         55  
  18         191  
11 18     18   16391 use Scalar::Util qw( blessed );
  18         41  
  18         902  
12 18     18   119 use Try::Tiny;
  18         39  
  18         840  
13 18     18   108 use Moo::Role;
  18         43  
  18         190  
14 18     18   9318 use Class::Usul::Options;
  18         53  
  18         166  
15              
16             requires qw( app_version can_call debug error exit_usage
17             extra_argv file next_argv output quiet );
18              
19             # Public attributes
20             option 'method' => is => 'rwp', isa => SimpleStr, format => 's',
21             documentation => 'Name of the method to call',
22             default => NUL, order => 1, short => 'c';
23              
24             option 'options' => is => 'ro', isa => HashRef, format => 's%',
25             documentation =>
26             'Zero, one or more key=value pairs available to the method call',
27 22     22   4402 builder => sub { {} }, short => 'o';
28              
29             option 'umask' => is => 'rw', isa => OctalNum, format => 's',
30             documentation => 'Set the umask to this octal number',
31 4     4   164 builder => sub { $_[ 0 ]->config->umask }, coerce => TRUE,
32             lazy => TRUE;
33              
34             option 'verbose' => is => 'ro', isa => Int,
35             documentation => 'Increase the verbosity of the output',
36             default => 0, repeatable => TRUE, short => 'v';
37              
38             has 'params' => is => 'lazy', isa => HashRef[ArrayRef],
39 3     3   118 builder => sub { {} };
40              
41             # Private functions
42             my $_output_stacktrace = sub {
43             my ($e, $verbose) = @_; ($e and blessed $e) or return; $verbose //= 0;
44              
45             $verbose > 0 and $e->can( 'trace' )
46             and return emit_to \*STDERR, $e->trace.NUL;
47              
48             $e->can( 'stacktrace' ) and emit_to \*STDERR, $e->stacktrace.NUL;
49             return;
50             };
51              
52             # Private methods
53             my $handle_result = sub {
54             my ($self, $method, $rv) = @_;
55              
56             my $params = $self->params->{ $method };
57             my $args = (defined $params ) ? $params->[ 0 ] : undef;
58             my $expected_rv = (is_hashref $args) ? $args->{expected_rv} // OK : OK;
59              
60             if (defined $rv and $rv <= $expected_rv) {
61             $self->quiet or $self->output
62             ( 'Finished in [_1] seconds', { args => [ elapsed ] } );
63             }
64             elsif (defined $rv and $rv > OK) {
65             $self->error( 'Terminated code [_1]', {
66             args => [ $rv ], no_quote_bind_values => TRUE } );
67             }
68             else {
69             if ($rv == UNDEFINED_RV) { $self->error( 'Terminated with undefined rv' )}
70             else {
71             if (defined $rv) {
72             $self->error
73             ( 'Method [_1] unknown rv [_2]', { args => [ $method, $rv ] } );
74             }
75             else {
76             $self->error( 'Method [_1] error uncaught or rv undefined',
77             { args => [ $method ] } );
78             $rv = UNDEFINED_RV;
79             }
80             }
81             }
82              
83             return $rv;
84             };
85              
86             my $_handle_run_exception = sub {
87             my ($self, $method, $error) = @_; my $e;
88              
89             unless ($e = exception $error) {
90             $self->error
91             ( 'Method [_1] exception without error', { args => [ $method ] } );
92             return UNDEFINED_RV;
93             }
94              
95             $e->can( 'out' ) and $e->out and $self->output( $e->out );
96             $self->error( $e->error, { args => $e->args } );
97             $self->debug and $_output_stacktrace->( $error, $self->verbose );
98              
99             return $e->can( 'rv' )
100             ? ($e->rv || (defined $e->rv ? FAILED : UNDEFINED_RV)) : UNDEFINED_RV;
101             };
102              
103             # Public methods
104             sub run {
105 4     4 1 8205 my $self = shift;
106 4         24 my $method = $self->select_method;
107 4         26 my $text = 'Started by [_1] Version [_2] Pid [_3]';
108 4         23 my $args = { args => [ logname, $self->app_version, abs $PID ] };
109              
110 4 50       24 (is_member $method, 'help', 'run_chain') and $self->quiet( TRUE );
111              
112 4 50       41 $self->quiet or $self->output( $text, $args ); umask $self->umask; my $rv;
  4         195  
  4         721  
113              
114 4 50 33     35 if ($method eq 'run_chain' or $self->can_call( $method )) {
115             my $params = exists $self->params->{ $method }
116 4 100       86 ? $self->params->{ $method } : [];
117              
118             try {
119 4 50   4   203 defined ($rv = $self->$method( @{ $params } ))
  4         25  
120             or throw 'Method [_1] return value undefined',
121             args => [ $method ], rv => UNDEFINED_RV;
122             }
123 4     0   198 catch { $rv = $self->$_handle_run_exception( $method, $_ ) };
  0         0  
124             }
125             else {
126 0         0 $self->error( 'Class [_1] method [_2] not found',
127             { args => [ blessed $self, $method ] } );
128 0         0 $rv = UNDEFINED_RV;
129             }
130              
131 4         121 $rv = $self->$handle_result( $method, $rv );
132 4         103 $self->file->delete_tmp_files;
133 4         146850 return $rv;
134             }
135              
136             sub run_chain {
137 0     0 1 0 my $self = shift; my $args = { args => [ $self->method ] };
  0         0  
138              
139 0 0       0 $self->method ? $self->error( 'Method [_1] unknown', $args )
140             : $self->error( 'Method not specified' );
141 0         0 $self->exit_usage( 0 );
142 0         0 return; # Not reached
143             }
144              
145             sub select_method {
146 4     4 1 12 my $self = shift; my $method = untaint_identifier dash2under $self->method;
  4         37  
147              
148 4 50       34 unless ($self->can_call( $method )) {
149 0         0 $method = untaint_identifier dash2under $self->extra_argv( 0 );
150 0 0       0 $method and $self->_set_method( $method );
151 0 0 0     0 ($method and $self->can_call( $method ) and $self->next_argv)
      0        
152             or $method = undef;
153             }
154              
155 4 50       20 return $method ? $method : 'run_chain';
156             }
157              
158             1;
159              
160             __END__
161              
162             =pod
163              
164             =encoding utf-8
165              
166             =head1 Name
167              
168             Class::Usul::TraitFor::RunningMethods - Try and run a method catch and handle any exceptions
169              
170             =head1 Synopsis
171              
172             use Moo;
173              
174             extends 'Class::Usul';
175             with 'Class::Usul::TraitFor::RunningMethods';
176              
177             =head1 Description
178              
179             Implements the L</run> method which calls the target method in a try / catch
180             block. Handles any resulting exceptions
181              
182             =head1 Configuration and Environment
183              
184             Defines the following command line options;
185              
186             =over 3
187              
188             =item C<c method>
189              
190             The method in the subclass to dispatch to
191              
192             =item C<o options key=value>
193              
194             The method that is dispatched to can access the key/value pairs
195             from the C<< $self->options >> hash ref
196              
197             =item C<umask>
198              
199             An octal number which is used to set the umask by the L</run> method
200              
201             =item C<v verbose>
202              
203             Repeatable boolean that increases the verbosity of the output
204              
205             =back
206              
207             Defines the following attributes;
208              
209             =over 3
210              
211             =item C<params>
212              
213             A hash reference keyed by method name. The values are array references which
214             are flattened and passed to the method call by L</run>
215              
216             =back
217              
218             =head1 Subroutines/Methods
219              
220             =head2 run
221              
222             $exit_code = $self->run;
223              
224             Call the method specified by the C<-c> option on the command
225             line. Returns the exit code
226              
227             =head2 run_chain
228              
229             $exit_code = $self->run_chain( $method );
230              
231             Called by L</run> when L</select_method> cannot determine which method to
232             call. Outputs usage if C<method> is undefined. Logs an error if
233             C<method> is defined but not (by definition a callable method).
234             Returns exit code C<FAILED>
235              
236             =head2 select_method
237              
238             $method = $self->select_method;
239              
240             Called by L</run> it examines the L</method> attribute and if necessary the
241             extra command line arguments to determine the method to call
242              
243             =head1 Diagnostics
244              
245             None
246              
247             =head1 Dependencies
248              
249             =over 3
250              
251             =item L<Class::Usul::Options>
252              
253             =item L<File::DataClass>
254              
255             =item L<Moo::Role>
256              
257             =item L<Try::Tiny>
258              
259             =back
260              
261             =head1 Incompatibilities
262              
263             There are no known incompatibilities in this module
264              
265             =head1 Bugs and Limitations
266              
267             There are no known bugs in this module. Please report problems to
268             http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Usul.
269             Patches are welcome
270              
271             =head1 Acknowledgements
272              
273             Larry Wall - For the Perl programming language
274              
275             =head1 Author
276              
277             Peter Flanigan, C<< <pjfl@cpan.org> >>
278              
279             =head1 License and Copyright
280              
281             Copyright (c) 2017 Peter Flanigan. All rights reserved
282              
283             This program is free software; you can redistribute it and/or modify it
284             under the same terms as Perl itself. See L<perlartistic>
285              
286             This program is distributed in the hope that it will be useful,
287             but WITHOUT WARRANTY; without even the implied warranty of
288             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
289              
290             =cut
291              
292             # Local Variables:
293             # mode: perl
294             # tab-width: 3
295             # End:
296             # vim: expandtab shiftwidth=3: