File Coverage

lib/CLI/Framework/Application.pm
Criterion Covered Total %
statement 216 342 63.1
branch 51 132 38.6
condition 12 36 33.3
subroutine 45 57 78.9
pod 34 34 100.0
total 358 601 59.5


line stmt bran cond sub pod time code
1             package CLI::Framework::Application;
2              
3 5     5   40 use strict;
  5         13  
  5         229  
4 5     5   27 use warnings;
  5         17  
  5         250  
5              
6             our $VERSION = '0.04';
7              
8 5     5   7625 use Getopt::Long::Descriptive;
  5         362923  
  5         49  
9 5     5   7869 use Exception::Class::TryCatch;
  5         88428  
  5         343  
10              
11 5     5   3581 use CLI::Framework::Exceptions qw( :all );
  5         17  
  5         1408  
12 5     5   4241 use CLI::Framework::Command;
  5         18  
  5         200  
13              
14             # Certain built-in commands are required:
15 5         363 use constant REQUIRED_BUILTINS_PKGS => qw(
16             CLI::Framework::Command::Help
17 5     5   36 );
  5         9  
18 5         252 use constant REQUIRED_BUILTINS_NAMES => qw(
19             help
20 5     5   1598 );
  5         1282  
21             # Certain built-in commands are required only in interactive mode:
22 5         1654 use constant REQUIRED_BUILTINS_PKGS_INTERACTIVE => qw(
23             CLI::Framework::Command::Menu
24 5     5   25 );
  5         9  
25 5         21913 use constant REQUIRED_BUILTINS_NAMES_INTERACTIVE => qw(
26             menu
27 5     5   25 );
  5         9  
28              
29             #FIXME-TODO-CLASS_GENERATION:
30             #sub import {
31             # my ($class, $app_pkg, $app_def) = @_;
32             #
33             # # If caller has supplied import args, CLIF's "inline form" is being used.
34             # # The application class must be generated dynamically...
35             #
36             #}
37              
38             #-------
39              
40             sub new {
41 4     4 1 190 my ($class, %args) = @_;
42              
43 4         12 my $interactive = $args{ interactive }; # boolean: interactive mode?
44              
45 4         32 my $cache = CLI::Framework::Cache->new();
46              
47 4         32 my $app = {
48             _registered_command_objects => undef, # (k,v)=(cmd pkg name,cmd obj) for all registered commands
49             _default_command => 'help', # name of default command
50             _current_command => undef, # name of current (or last) command to run
51             _interactive => $interactive, # boolean: interactive state
52             _cache => $cache, # storage for data shared between app and cmd
53             _initialized => 0, # initialization status
54             };
55 4         13 bless $app, $class;
56              
57             # Validate some hook methods so we can assume that they behave properly...
58 4         37 $app->_validate_hooks();
59              
60 4         62 return $app;
61             }
62              
63             sub _validate_hooks {
64 4     4   10 my ($app) = @_;
65              
66             # Ensure that hook methods return expected data structure types according
67             # to their preconditions...
68              
69 4         11 my $class = ref $app;
70              
71             # Ensure that command_map() succeeds...
72 4         7 eval { $app->command_map() };
  4         23  
73 4 50       43 if( catch my $e ) {
74 0         0 throw_app_hook_exception( error =>
75             "method 'command_map' in class '$class' fails" );
76             }
77             # Ensure that command_map() returns a "hash-worthy" list...
78             else {
79 4         68 eval { $app->_list_to_hashref( 'command_map' ) };
  4         36  
80 4 50       24 if( catch my $e ) {
81 0 0       0 $e->isa( 'CLI::Framework::Exception' ) && do{ $e->rethrow() };
  0         0  
82 0         0 throw_app_hook_exception( error => $e );
83             }
84             }
85             # Ensure that command_alias() succeeds...
86 4         53 eval { $app->command_alias() };
  4         26  
87 4 50       21 if( catch my $e ) {
88 0         0 throw_app_hook_exception(
89             error => "method 'command_alias' in class '$class' fails" );
90             }
91             # Ensure that commandf_alias() returns a "hash-worthy" list...
92             else {
93 4         47 eval { $app->_list_to_hashref( 'command_alias' ) };
  4         14  
94 4 50       22 if( catch my $e ) {
95 0 0       0 $e->isa( 'CLI::Framework::Exception' ) && do{ $e->rethrow() };
  0         0  
96 0         0 throw_app_hook_exception( error => $e );
97             }
98             }
99             }
100              
101 8     8 1 93 sub cache { $_[0]->{_cache} }
102              
103             ###############################
104             #
105             # COMMAND INTROSPECTION & REGISTRATION
106             #
107             ###############################
108              
109             # convert a list to a HASH ref if list is hash-worthy
110             sub _list_to_hashref {
111 65     65   95 my ($app, $method) = @_;
112              
113 65         98 my $class = ref $app;
114 65         198 my @map = $app->$method;
115              
116             # throw exception if command_map list is of odd length
117 65 50       611 if( scalar @map % 2 ) {
118 0         0 throw_app_hook_exception( error =>
119             "odd-length list returned by application hook '$method' in class '$class' is not hash-worthy\n" );
120             }
121 65         81 my %h;
122 65         141 for my $i (0..$#map-1) {
123 975 100       1757 if($i % 2 == 0) {
124 519         727 my ($k,$v) = ( $map[$i], $map[$i+1] );
125             # throw exception if command_map list-to-hash conversion would
126             # lose data due to duplicate keys
127 519 50       1000 if( exists $h{$k} ) {
128 0         0 throw_app_hook_exception( error =>
129             "list returned by application hook '$method' in class '$class' is not hash-worthy (duplicate keys for $i)\n" );
130             }
131 519         1252 $h{ $map[$i] } = $map[$i+1];
132             }
133             }
134 65         404 return \%h;
135             }
136              
137             # Transform command map to hashref
138             sub command_map_hashref {
139 57     57 1 72 my ($app) = @_;
140 57         112 return $app->_list_to_hashref('command_map');
141             }
142              
143             # Return names of all valid commands in same order as specified by
144             # command_map()
145             sub _valid_command_names {
146 7     7   11 my ($app) = @_;
147              
148             # ordered pairs of (command name, command class)
149 7         28 my @valid_command_name_class_pairs = $app->command_map();
150            
151             # unordered command names
152 7         56 my @command_names = keys %{ { @valid_command_name_class_pairs } };
  7         130  
153              
154 7         24 my @ordered_command_names;
155 7         15 for my $c (@valid_command_name_class_pairs) {
156 854         1398 push @ordered_command_names, $c
157 98 100       121 if grep {$_ eq $c} @command_names;
158             }
159 7         41 return @ordered_command_names;
160             }
161              
162             # Return package names for all valid commands
163             sub _valid_command_pkgs {
164 5     5   11 my ($app) = @_;
165 5         10 my $valid_commands_hashref = $app->command_map_hashref;
166 5         39 return values %$valid_commands_hashref;
167             }
168              
169             ## Given a command name, return its package name
170             #sub _find_command_pkg_named {
171             # my ($app, $cmd_name) = @_;
172             #
173             # my $valid_commands_hashref = $app->command_map_hashref;
174             # return $valid_commands_hashref->{$cmd_name};
175             #}
176              
177             sub is_valid_command_pkg {
178 7     7 1 17 my ($app, $cmd_pkg) = @_;
179 7 100       34 return unless $cmd_pkg;
180              
181 5         28 my @valid_pkgs = ( $app->_valid_command_pkgs(), REQUIRED_BUILTINS_PKGS );
182 5 50       22 push @valid_pkgs, REQUIRED_BUILTINS_PKGS_INTERACTIVE
183             if $app->get_interactivity_mode();
184              
185 5         12 return grep { $cmd_pkg eq $_ } @valid_pkgs;
  41         85  
186             }
187              
188             sub is_valid_command_name {
189 4     4 1 12 my ($app, $cmd_name) = @_;
190 4 50       12 return unless $cmd_name;
191              
192 4         24 my @valid_aliases = ( $app->_valid_command_names() );
193 4         10 push @valid_aliases, REQUIRED_BUILTINS_NAMES;
194 4 50       19 push @valid_aliases, REQUIRED_BUILTINS_NAMES_INTERACTIVE
195             if $app->get_interactivity_mode();
196              
197 4         8 return grep { $cmd_name eq $_ } @valid_aliases;
  23         53  
198             }
199              
200             sub registered_command_names {
201 1     1 1 3 my ($app) = @_;
202              
203 1         2 my @names;
204              
205             # For each registered command package (name)...
206 1         2 for my $cmd_pkg_name (keys %{ $app->{_registered_command_objects} }) {
  1         5  
207             # Find command names that this command package was registered under...
208 30 100       52 push @names, grep { $_ } map {
  30         66  
209 3         10 $_ if $app->command_map_hashref->{$_} eq $cmd_pkg_name
210             } $app->_valid_command_names
211             }
212 1         5 return @names;
213             }
214              
215             sub registered_command_object {
216 10     10 1 22 my ($app, $cmd_name) = @_;
217 10 50       65 return unless $cmd_name;
218              
219 10         44 my $cmd_pkg = $app->command_map_hashref->{$cmd_name};
220              
221 10 100 66     248 return unless $cmd_pkg
      100        
222             && exists $app->{_registered_command_objects}
223             && exists $app->{_registered_command_objects}->{$cmd_pkg};
224              
225 5         18 return $app->{_registered_command_objects}->{$cmd_pkg};
226             }
227              
228             sub register_command {
229 7     7 1 16 my ($app, $cmd) = @_;
230 7 50       63 return unless $cmd;
231              
232 7 50 33     48 if( ref $cmd && $app->is_valid_command_pkg(ref $cmd) ) {
    100 0        
    50          
    0          
233             # Register by reference...
234 0 0       0 return unless $cmd->isa( 'CLI::Framework::Command' );
235 0         0 $app->{_registered_command_objects}->{ref $cmd} = $cmd;
236             }
237             elsif( $app->is_valid_command_pkg($app->command_map_hashref->{$cmd}) ) {
238             # Register by command name...
239 5         14 my $pkg = $app->command_map_hashref->{$cmd};
240 5         42 $cmd = CLI::Framework::Command->manufacture( $pkg );
241 5         30 $app->{_registered_command_objects}->{ref $cmd} = $cmd;
242             }
243             #FIXME:use REQUIRED_BUILTINS_PKGS_INTERACTIVE & REQUIRED_BUILTINS_NAMES_INTERACTIVE
244             elsif( $cmd eq 'help' ) {
245             # Required built-in is always valid...
246 2         21 $cmd = CLI::Framework::Command->manufacture( 'CLI::Framework::Command::Help' );
247 2         21 $app->{_registered_command_objects}->{'CLI::Framework::Command::Help'} = $cmd;
248             }
249             elsif( $app->get_interactivity_mode() && $cmd eq 'menu' ) {
250             # Required built-in for interactive usage is always valid...
251 0         0 $cmd = CLI::Framework::Command->manufacture( 'CLI::Framework::Command::Menu' );
252 0         0 $app->{_registered_command_objects}->{'CLI::Framework::Command::Menu'} = $cmd;
253             }
254             else {
255 0         0 throw_cmd_registration_exception(
256             error => "Error: failed attempt to register invalid command '$cmd'" );
257             }
258             # Metacommands should be app-aware...
259 7 100       130 $cmd->set_app( $app ) if $cmd->isa( 'CLI::Framework::Command::Meta' );
260              
261 7         57 return $cmd;
262             }
263              
264 2     2 1 7 sub get_default_command { $_[0]->{_default_command} }
265 0     0 1 0 sub set_default_command { $_[0]->{_default_command} = $_[1] }
266              
267 5     5 1 20 sub get_current_command { $_[0]->{_current_command} }
268 5     5 1 21 sub set_current_command { $_[0]->{_current_command} = $_[1] }
269              
270 1     1 1 6 sub get_default_usage { $_[0]->{_default_usage} }
271 4     4 1 615 sub set_default_usage { $_[0]->{_default_usage} = $_[1] }
272              
273             ###############################
274             #
275             # PARSING & RUNNING COMMANDS
276             #
277             ###############################
278              
279             sub usage {
280 2     2 1 11 my ($app, $command_name, @args) = @_;
281              
282             # Allow aliases in place of command name...
283 2         15 $app->_canonicalize_cmd( $command_name );
284              
285 2         4 my $usage_text;
286 2 50 33     13 if( $command_name && $app->is_valid_command_name($command_name) ) {
287             # Get usage from Command object...
288 0   0     0 my $cmd = $app->registered_command_object( $command_name )
289             || $app->register_command( $command_name );
290 0         0 $usage_text = $cmd->usage(@args);
291             }
292             else {
293             # Get usage from Application object...
294 2         21 $usage_text = $app->usage_text();
295             }
296             # Finally, fall back to default application usage message...
297 2   66     15 $usage_text ||= $app->get_default_usage();
298              
299 2         9 return $usage_text;
300             }
301              
302             sub _canonicalize_cmd {
303 6     6   13 my ($self, $input) = @_;
304              
305             # Translate shorthand aliases for commands to full names...
306              
307 6 100       19 return unless $input;
308              
309 4         6 my $command_name;
310 4         15 my %aliases = $self->command_alias();
311 4 100       27 return unless %aliases;
312 3   66     15 $command_name = $aliases{$input} || $input;
313 3         8 $_[1] = $command_name;
314             }
315              
316             sub _handle_global_app_options {
317 4     4   8 my ($app) = @_;
318              
319             # Process the [app-opts] prefix of the command request...
320              
321             # preconditions:
322             # - tail of @ARGV has been parsed and removed, leaving only the
323             # [app-opts] portion of the request
324             # postconditions:
325             # - application options have been parsed and any application-specific
326             # validation and initialization that is defined has been performed
327             # - invalid tokens after [app-opts] and before are detected and
328             # handled
329              
330             # Parse [app-opts], consuming them from @ARGV...
331 4         8 my ($app_options, $app_usage);
332 4         8 eval { ($app_options, $app_usage) = describe_options( '%c %o ...', $app->option_spec ) };
  4         24  
333 4 50       3121 if( catch my $e ) { # (failed application options parsing)
334 0         0 throw_app_opts_parse_exception( error => $e );
335             }
336 4         71 $app->set_default_usage( $app_usage->text );
337              
338             # Detect invalid tokens in the [app-opts] part of the request
339             # (@ARGV should be empty unless such invalid tokens exist because has
340             # been removed and any valid options have been processed)...
341 4 50       20 if( @ARGV ) {
342 0 0       0 my $err = @ARGV > 1 ? 'Unrecognized options: ' : 'Unrecognized option: ';
343 0         0 $err .= join(' ', @ARGV ) . "\n";
344 0         0 throw_app_opts_parse_exception( error => $err );
345             }
346             # --- VALIDATE APP OPTIONS ---
347 4         8 eval { $app->validate_options($app_options) };
  4         36  
348 4 50       16 if( catch my $e ) { # (failed application options validation)
349 0 0       0 $e->isa( 'CLI::Framework::Exception' ) && do{ $e->rethrow() };
  0         0  
350 0         0 throw_app_opts_validation_exception( error => $e . "\n" . $app->usage );
351             }
352             # --- INITIALIZE APP ---
353 4         52 eval{ $app->init($app_options) };
  4         27  
354 4 50       32 if( catch my $e ) { # (application failed initialization)
355 0 0       0 $e->isa( 'CLI::Framework::Exception' ) && do{ $e->rethrow() };
  0         0  
356 0         0 throw_app_init_exception( error => $e );
357             }
358 4         80 $app->{_initialized} = 1;
359              
360 4         39 return 1;
361             }
362              
363             sub _parse_request {
364 5     5   46 my ($app, %param) = @_;
365              
366             # Parse options/arguments from a command request and set the name of the
367             # current command...
368              
369             # If requested, perform validation and initialization of the application.
370             # NOTE: Application validation/initialization should NOT be performed here
371             # in interactive mode for each command request because it should only be
372             # done once for the application, not every time a command is run.
373              
374             #~~~~~~~~~~~~~~~~~~~~~~~
375             # ARGV_Format
376             #
377             # non-interactive case: @ARGV: [app-opts] [cmd-opts] [cmd-args]
378             # interactive case: @ARGV: [cmd-opts] [cmd-args]
379             #~~~~~~~~~~~~~~~~~~~~~~~
380              
381 5         15 my $initialize_app = $param{initialize};
382              
383             # Parse options/arguments for the application and the command from @ARGV...
384 5         9 my ($command_name, @command_opts_and_args);
385 5         21 for my $i ( 0..$#ARGV ) {
386             # Find first valid command name in @ARGV...
387 4         24 $app->_canonicalize_cmd( $ARGV[$i] );
388 4 100       31 if( $app->is_valid_command_name($ARGV[$i]) ) {
389             # Extract and store ' [cmd-opts] [cmd-args]', leaving
390             # preceding contents (potentially '[app-opts]') in @ARGV...
391 3         19 ($command_name, @command_opts_and_args) = @ARGV[$i..@ARGV-1];
392 3         9 splice @ARGV, $i;
393 3         9 last;
394             }
395             }
396 5 100       21 unless( defined $command_name ) {
397             # If no valid command, fall back to default, ignoring any args...
398 2         18 $command_name = $app->get_default_command();
399 2         4 @command_opts_and_args = ();
400              
401             # If no valid command then any non-option tokens are invalid args...
402 2         6 my @invalid_args = grep { substr($_, 0, 1) ne '-' } @ARGV;
  0         0  
403 2 50       7 if( @invalid_args ) {
404 0 0       0 my $err = @invalid_args > 1 ? 'Invalid arguments: ' : 'Invalid argument: ';
405 0         0 $err .= join(' ', @invalid_args );
406 0         0 throw_invalid_cmd_exception( error => $err );
407             }
408             }
409             # Set internal current command name...
410 5         45 $app->set_current_command( $command_name );
411              
412             # If requested, parse [app-opts] and initialize application...
413             # (this is an optional step because in interactive mode, it should not be
414             # done for every request)
415 5 100       41 $app->_handle_global_app_options() if $initialize_app;
416              
417             # Leave '[cmd-opts] [cmd-args]' in @ARGV...
418 5         13 @ARGV = @command_opts_and_args;
419              
420 5         15 return 1;
421             }
422              
423             sub run {
424 5     5 1 138 my ($app, %param) = @_;
425              
426             # Auto-instantiate if necessary...
427 5 100       23 unless( ref $app ) {
428 1         2 my $class = $app;
429 1         44 $app = $class->new();
430             }
431             # Determine whether to do initialization -- if not explicitly indicated,
432             # default to doing initialization only if it has not yet been done...
433 5         12 my $initialize = $param{initialize};
434 5 50       43 $initialize = not $app->{_initialized} unless defined $initialize;
435              
436             # Parse request; perform initialization...
437 5         11 eval { $app->_parse_request( initialize => $initialize ) };
  5         40  
438 5 50       23 if( catch my $e ) { $app->handle_exception($e); return }
  0         0  
  0         0  
439              
440 5         92 my $command_name = $app->get_current_command();
441              
442             # Lazy registration of commands...
443 5   33     30 my $command = $app->registered_command_object( $command_name )
444             || $app->register_command( $command_name );
445              
446             # Parse command options and auto-generate minimal usage message...
447 5         12 my ($cmd_options, $cmd_usage);
448 5         36 my $currently_interactive = $app->get_interactivity_mode();
449 5         18 my $format = "$command_name %o ..."; # Getopt::Long::Descriptive format string
450 5 50       26 $format = '%c '.$format unless $currently_interactive; # (%c is command name -- irrelevant in interactive mode)
451              
452             # (configure Getopt::Long to stop consuming tokens when first non-option is
453             # encountered on input stream)
454 5         22 my $getopt_configuration = { getopt_conf => [qw(require_order)] };
455 5         13 eval { ($cmd_options, $cmd_usage) =
  5         71  
456             describe_options( $format, $command->option_spec, $getopt_configuration )
457             };
458             # (handle failed command options parsing)
459 5 50       1764 if( catch my $e ) {
460 0 0       0 if( $e->isa('CLI::Framework::Exception') ) {
461 0         0 $app->handle_exception($e);
462 0         0 return;
463             }
464 0         0 eval{ throw_cmd_opts_parse_exception( error => $e ) };
  0         0  
465 0 0       0 if( catch my $e ) { $app->handle_exception( $e ); return }
  0         0  
  0         0  
466             }
467 5         108 $command->set_default_usage( $cmd_usage->text );
468              
469             # Share session data with command...
470             # (init() method may have populated shared session data in cache for use by all commands)
471 5         42 $command->set_cache( $app->cache );
472              
473             # --- APP HOOK: COMMAND PRE-DISPATCH ---
474 5         43 $app->pre_dispatch( $command );
475              
476             # --- RUN COMMAND ---
477 5         7 my $output;
478 5         11 eval { $output = $command->dispatch( $cmd_options, @ARGV ) };
  5         51  
479 5 50       17 if( catch my $e ) { $app->handle_exception($e); return }
  0         0  
  0         0  
480              
481             # Display output of command, if any...
482 5 50       95 $app->render( $output ) if defined $output;
483              
484 5         68 return 1;
485             }
486              
487             ###############################
488             #
489             # INTERACTIVITY
490             #
491             ###############################
492              
493 14     14 1 62 sub get_interactivity_mode { $_[0]->{_interactive} }
494 0     0 1 0 sub set_interactivity_mode { $_[0]->{_interactive} = $_[1] }
495              
496             sub is_interactive_command {
497 0     0 1 0 my ($app, $command_name) = @_;
498              
499 0         0 my @noninteractive_commands = $app->noninteractive_commands();
500              
501             # Command must be valid...
502 0 0       0 return 0 unless $app->is_valid_command_name( $command_name );
503              
504             # Command must NOT be non-interactive...
505 0 0       0 return 1 unless grep { $command_name eq $_ } @noninteractive_commands;
  0         0  
506              
507 0         0 return 0;
508             }
509              
510             sub get_interactive_commands {
511 0     0 1 0 my ($app) = @_;
512              
513 0         0 my @valid_commands = $app->_valid_command_names;
514              
515             # All valid commands are enabled in non-interactive mode...
516 0 0       0 return @valid_commands unless( $app->get_interactivity_mode() );
517              
518             # ...otherwise, in interactive mode, include only interactive commands...
519 0         0 my @command_names;
520 0         0 for my $c ( @valid_commands ) {
521 0 0       0 push @command_names, $c if $app->is_interactive_command( $c );
522             }
523 0         0 return @command_names;
524             }
525              
526             sub run_interactive {
527 0     0 1 0 my ($app, %param) = @_;
528              
529             # Auto-instantiate if necessary...
530 0 0       0 unless( ref $app ) {
531 0         0 my $class = $app;
532 0         0 $app = $class->new();
533             }
534 0         0 $app->set_interactivity_mode(1);
535              
536             # If default command is non-interactive, reset it, remembering default...
537 0         0 my $orig_default_command = $app->get_default_command();
538 0 0       0 if( grep { $orig_default_command eq $_ } $app->noninteractive_commands() ) {
  0         0  
539 0         0 $app->set_default_command( 'help' );
540             }
541             # If initialization indicated, run init() and handle existing input...
542 0 0       0 eval { $app->_parse_request( initialize => $param{initialize} )
  0         0  
543             if $param{initialize}
544             };
545 0 0       0 if( catch my $e ) { $app->handle_exception($e); return }
  0         0  
  0         0  
546              
547             # Find how many prompts to display in sequence between displaying menu...
548 0   0     0 my $menu_cmd = $app->registered_command_object('menu')
549             || $app->register_command( 'menu' );
550 0 0       0 $menu_cmd->isa( 'CLI::Framework::Command::Menu' )
551             or throw_type_exception(
552             error => "Menu command must be a subtype of " .
553             "CLI::Framework::Command::Menu" );
554              
555 0   0     0 my $invalid_request_threshold = $param{invalid_request_threshold}
556             || $menu_cmd->line_count(); # num empty prompts b4 re-displaying menu
557              
558 0         0 $app->_run_cmd_processing_loop(
559             menu_cmd => $menu_cmd,
560             invalid_request_threshold => $invalid_request_threshold
561             );
562             # Restore original default command...
563 0         0 $app->set_default_command( $orig_default_command );
564             }
565              
566             sub _run_cmd_processing_loop {
567 0     0   0 my ($app, %param) = @_;
568              
569 0         0 my $menu_cmd = $param{menu_cmd};
570 0         0 my $invalid_request_threshold = $param{invalid_request_threshold};
571              
572 0         0 $app->render( $menu_cmd->run() );
573              
574 0         0 my ($cmd_succeeded, $invalid_request_count, $done) = (0,0,0);
575 0         0 until( $done ) {
576 0 0       0 if( $invalid_request_count >= $invalid_request_threshold ) {
    0          
577             # Reached threshold for invalid cmd requests => re-display menu...
578 0         0 $invalid_request_count = 0;
579 0         0 $app->render( $menu_cmd->run() );
580             }
581             elsif( $cmd_succeeded ) {
582             # Last command request was successful => re-display menu...
583 0         0 $app->render( $menu_cmd->run() );
584 0         0 $cmd_succeeded = $invalid_request_count = 0;
585             }
586             # Read a command request...
587 0         0 $app->read_cmd();
588              
589 0 0       0 if( @ARGV ) {
590             # Recognize quit requests...
591 0 0       0 if( $app->is_quit_signal($ARGV[0]) ) {
592 0         0 undef @ARGV;
593 0         0 last;
594             }
595 0         0 $app->_canonicalize_cmd($ARGV[0]); # translate cmd aliases
596              
597 0 0       0 if( $app->is_interactive_command($ARGV[0]) ) {
598 0 0       0 if( $app->run() ) {
599 0         0 $cmd_succeeded = 1;
600             }
601 0         0 else { $invalid_request_count++ }
602             }
603             else {
604 0         0 $app->render( 'unrecognized command request: ' . join(' ',@ARGV) . "\n");
605 0         0 $invalid_request_count++;
606             }
607             }
608 0         0 else { $invalid_request_count++ }
609             }
610             }
611              
612             sub read_cmd {
613 0     0 1 0 my ($app) = @_;
614              
615 0         0 require Text::ParseWords;
616              
617             # Retrieve or cache Term::ReadLine object (this is necessary to save
618             # command-line history in persistent object)...
619 0         0 my $term = $app->{_readline};
620 0 0       0 unless( $term ) {
621 0         0 require Term::ReadLine;
622 0         0 $term = Term::ReadLine->new('CLIF Application');
623 0         0 select $term->OUT;
624 0         0 $app->{_readline} = $term;
625              
626             #FIXME-TODO-CMDLINE_COMPLETION:
627             # # Arrange for command-line completion...
628             # my $attribs = $term->Attribs;
629             # $attribs->{completion_function} = $app->_cmd_request_completions();
630             }
631             # Prompt for the name of a command and read input from STDIN.
632             # Store the individual tokens that are read in @ARGV.
633 0         0 my $command_request = $term->readline('> ');
634 0 0       0 if(! defined $command_request ) {
635             # Interpret CTRL-D (EOF) as a quit signal...
636 0         0 @ARGV = $app->quit_signals();
637 0         0 print "\n"; # since EOF character is rendered as ''
638             }
639             else {
640             # Prepare command for usual parsing...
641 0         0 @ARGV = Text::ParseWords::shellwords( $command_request );
642 0 0 0     0 $term->addhistory($command_request)
643             if $command_request =~ /\S/ and !$term->Features->{autohistory};
644             }
645 0         0 return 1;
646             }
647              
648             ##FIXME-TODO-CMDLINE_COMPLETION:this should only return interactive commands; it should pay attention
649             ##to its text/line/start args, ...; also: make it work with subcommands
650             ## --see Term::Readline::Gnu
651             #sub _cmd_request_completions {
652             # my ($app) = @_;
653             # return sub {
654             # my ($text, $line, $start) = @_;
655             # return $app->_valid_command_names;
656             # }
657             #}
658              
659             sub is_quit_signal {
660 0     0 1 0 my ($app, $command_name) = @_;
661              
662 0         0 my @quit_signals = $app->quit_signals();
663 0         0 return grep { $command_name eq $_ } @quit_signals;
  0         0  
664             }
665              
666             ###############################
667             #
668             # APPLICATION SUBCLASS HOOKS
669             #
670             ###############################
671              
672             #XXX-CONSIDER: consider making default implementation of init():
673             # $app->set_current_command('help') if $opts->{help}
674 2     2 1 5 sub init { 1 }
675              
676 5     5 1 10 sub pre_dispatch { }
677              
678 1     1 1 3 sub usage_text { }
679              
680 1     1 1 5 sub option_spec { }
681              
682 4     4 1 9 sub validate_options { 1 }
683              
684             sub command_map {
685 0     0 1 0 help => 'CLI::Framework::Command::Help',
686             console => 'CLI::Framework::Command::Console',
687             menu => 'CLI::Framework::Command::Menu',
688             list => 'CLI::Framework::Command::List',
689             'dump' => 'CLI::Framework::Command::Dump',
690             tree => 'CLI::Framework::Command::Tree',
691             alias => 'CLI::Framework::Command::Alias',
692             }
693              
694 6     6 1 16 sub command_alias { }
695              
696 0     0 1 0 sub noninteractive_commands { qw( console menu ) }
697              
698 0     0 1 0 sub quit_signals { qw( q quit exit ) }
699              
700             sub handle_exception {
701 0     0 1 0 my ($app, $e) = @_;
702 0         0 $app->render( $e->description . "\n\n" . $e->error );
703 0         0 return;
704             }
705              
706             sub render {
707 5     5 1 12 my ($app, $output) = @_;
708              
709             #XXX-CONSIDER: consider built-in features to help simplify associating templates
710             #with commands (each command would probably have its own template for its
711             #output)
712 5         167 print $output;
713             }
714              
715             ###############################
716             #
717             # CACHING
718             #
719             ###############################
720              
721             package CLI::Framework::Cache;
722              
723 5     5   54 use strict;
  5         13  
  5         247  
724 5     5   37 use warnings;
  5         8  
  5         904  
725              
726             sub new {
727 4     4   10 my ($class) = @_;
728              
729 4         22 bless { _cache => { } }, $class;
730             }
731              
732             sub get {
733 3     3   7 my ($self, $k) = @_;
734              
735 3         7 my $v = $self->{_cache}->{$k};
736 3         16 return $v;
737             }
738              
739             sub set {
740 3     3   6 my ($self, $k, $v) = @_;
741              
742 3         12 $self->{_cache}->{$k} = $v;
743 3         7 return $v;
744             }
745              
746             #-------
747             1;
748              
749             __END__