File Coverage

blib/lib/CLI/Helpers.pm
Criterion Covered Total %
statement 125 309 40.4
branch 63 176 35.8
condition 25 93 26.8
subroutine 27 39 69.2
pod 14 14 100.0
total 254 631 40.2


line stmt bran cond sub pod time code
1             # ABSTRACT: Subroutines for making simple command line scripts
2             # RECOMMEND PREREQ: App::Nopaste
3             # RECOMMEND PREREQ: Term::ReadLine::Gnu
4              
5             use strict;
6 1     1   26398 use feature qw(state);
  1         9  
  1         26  
7 1     1   4 use warnings;
  1         2  
  1         95  
8 1     1   5  
  1         2  
  1         24  
9             use Capture::Tiny qw(capture);
10 1     1   4 use File::Basename;
  1         1  
  1         31  
11 1     1   4 use Getopt::Long qw(GetOptionsFromArray :config pass_through);
  1         2  
  1         97  
12 1     1   590 use IO::Interactive qw( is_interactive );
  1         8529  
  1         4  
13 1     1   502 use Module::Load qw(load);
  1         800  
  1         4  
14 1     1   415 use Ref::Util qw(is_ref is_arrayref is_hashref);
  1         905  
  1         8  
15 1     1   431 use Sys::Syslog qw(:standard);
  1         1296  
  1         60  
16 1     1   506 use Term::ANSIColor 2.01 qw(color colored colorstrip);
  1         16747  
  1         124  
17 1     1   548 use Term::ReadKey;
  1         6859  
  1         1399  
18 1     1   378 use Term::ReadLine;
  1         1633  
  1         58  
19 1     1   422 use YAML;
  1         2156  
  1         26  
20 1     1   365  
  1         5697  
  1         73  
21             our $VERSION = '1.9'; # VERSION
22              
23             # Capture ARGV at Load
24             my @ORIG_ARGS;
25             BEGIN {
26             @ORIG_ARGS = @ARGV;
27 1     1   200 }
28              
29              
30             require Exporter;
31             our @ISA = qw(Exporter);
32              
33             my @output_tags = qw(output verbose debug debug_var cli_helpers_initialize);
34             my @input_tags = qw(prompt menu text_input confirm pwprompt);
35              
36             our @EXPORT_OK = ( @output_tags, @input_tags );
37             our %EXPORT_TAGS = (
38             all => [@output_tags,@input_tags],
39             input => \@input_tags,
40             output => \@output_tags,
41             );
42              
43             my $ARGV_AT_INIT = 0;
44             my $COPY_ARGV = 0;
45             our $_init_complete = 0;
46              
47             my (@args) = @_;
48              
49 1     1   9 my @import = ();
50             # We need to process the config options
51 1         2 foreach my $arg ( @args ) {
52             if( $arg eq 'delay_argv' ) {
53 1         3 $ARGV_AT_INIT = 0;
54 3 100       8 }
    50          
    50          
55 1         1 elsif( $arg eq 'preprocess_argv' ) {
56             $ARGV_AT_INIT = 1;
57             }
58 0         0 elsif( $arg eq 'copy_argv' ) {
59             $COPY_ARGV = 1;
60             }
61 0         0 # Not a config option, pass through
62             else {
63             push @import, $arg;
64             }
65 2         4 }
66              
67             CLI::Helpers->export_to_level( 1, @import );
68             }
69 1         136  
70             {
71             ## no critic (ProhibitNoWarnings)
72             no warnings;
73             INIT {
74 1     1   6 return if $_init_complete++;
  1         2  
  1         3429  
75             cli_helpers_initialize() if $ARGV_AT_INIT;
76 1 50   1   4 }
77 1 50       5 ## use critic
78             }
79              
80              
81             {
82             my @argv_original = ();
83             my $parsed_argv = 0;
84             my ($opt_ref) = @_;
85             my @opt_spec = qw(
86             color!
87 7     7   11 verbose|v+
88 7         23 debug
89             debug-class=s
90             quiet
91             data-file=s
92             syslog!
93             syslog-facility=s
94             syslog-tag=s
95             syslog-debug!
96             tags=s
97             nopaste
98             nopaste-public
99             nopaste-service=s
100             );
101              
102             my $argv;
103             my %opt;
104             if( defined $opt_ref && is_arrayref($opt_ref) ) {
105 7         10 # If passed an argv array, use that
106             $argv = $COPY_ARGV ? [ @{ $opt_ref } ] : $opt_ref;
107 7 100 66     29 }
108             else {
109 5 50       11 # Ensure multiple calls to cli_helpers_initialize() yield the same results
  0         0  
110             if ( $parsed_argv ) {
111             ## no critic
112             @ARGV = @argv_original;
113 2 100       6 ## use critic
114             }
115 1         2 else {
116             @argv_original = @ARGV;
117             $parsed_argv++;
118             }
119 1         3 # Operate on @ARGV
120 1         2 $argv = $COPY_ARGV ? [ @ARGV ] : \@ARGV;
121             }
122             GetOptionsFromArray($argv, \%opt, @opt_spec );
123 2 50       5 return \%opt;
124             }
125 7         25 }
126 7         5341  
127             my $DATA_HANDLE = undef;
128             my $data_file = shift;
129             eval {
130             open($DATA_HANDLE, '>', $data_file) or die "data file unwritable: $!";
131             1;
132 0     0   0 } or do {
133             my $error = $@;
134 0 0       0 output({color=>'red',stderr=>1}, "Attempted to write to $data_file failed: $!");
135 0         0 };
136 0 0       0 }
137 0         0  
138 0         0  
139             # Set defaults
140             my %DEF = ();
141             my $TERM = undef;
142             my @STICKY = ();
143             my @NOPASTE = ();
144             my %TAGS = ();
145              
146              
147             my ($argv) = @_;
148              
149             my $opts = _parse_options($argv);
150             _open_data_file($opts->{'data-file'}) if $opts->{'data-file'};
151              
152 7     7 1 5585 # Initialize Global Definitions
153             %DEF = (
154 7         15 DEBUG => $opts->{debug} || 0,
155 7 50       20 DEBUG_CLASS => $opts->{'debug-class'} || 'main',
156             VERBOSE => $opts->{verbose} || 0,
157             KV_FORMAT => ': ',
158             QUIET => $opts->{quiet} || 0,
159             SYSLOG => $opts->{syslog} || 0,
160             SYSLOG_TAG => exists $opts->{'syslog-tag'} && length $opts->{'syslog-tag'} ? $opts->{'syslog-tag'} : basename($0),
161             SYSLOG_FACILITY => exists $opts->{'syslog-facility'} && length $opts->{'syslog-facility'} ? $opts->{'syslog-facility'} : 'local0',
162             SYSLOG_DEBUG => $opts->{'syslog-debug'} || 0,
163             TAGS => $opts->{tags} ? { map { $_ => 1 } split /,/, $opts->{tags} } : undef,
164             NOPASTE => $opts->{nopaste} || 0,
165             NOPASTE_SERVICE => $opts->{'nopaste-service'},
166             NOPASTE_PUBLIC => $opts->{'nopaste-public'},
167             );
168 0         0 $DEF{COLOR} = $opts->{color} // git_color_check();
169              
170             debug("DEFINITIONS");
171 7 50 100     324 debug_var(\%DEF);
    50 50        
    50 100        
      50        
      50        
      33        
      33        
      50        
      50        
172              
173 7   33     25 # Setup the Syslog Subsystem
174             if( $DEF{SYSLOG} ) {
175 7         116 eval {
176 7         16 openlog($DEF{SYSLOG_TAG}, 'ndelay,pid', $DEF{SYSLOG_FACILITY});
177             1;
178             } or do {
179 7 50       42 my $error = $@;
180             $DEF{SYSLOG}=0;
181 0         0 output({stderr=>1,color=>'red'}, "CLI::Helpers could not open syslog: $error");
182 0         0 };
183 0 0       0 }
184 0         0  
185 0         0 # Optionally Attempt Loading App::NoPaste
186 0         0 if( $DEF{NOPASTE} ) {
187             eval {
188             load 'App::Nopaste';
189             1;
190             } or do {
191 7 50       17 $DEF{NOPASTE} = 0;
192             output({stderr=>1,color=>'red',sticky=>1},
193 0         0 'App::Nopaste is not installed, please cpanm App::Nopaste for --nopaste support',
194 0         0 );
195 0 0       0 };
196 0         0 }
197 0         0  
198             return 1;
199             }
200              
201              
202             # Allow some messages to be fired at the end the of program
203 7         16 END {
204             # Show discovered tags
205             if( keys %TAGS ) {
206             output({color=>'cyan',stderr=>1},
207             sprintf "# Tags discovered: %s",
208             join(', ', map { "$_=$TAGS{$_}" } sort keys %TAGS)
209             );
210 1 50   1   1018 }
211             # Show Sticky Output
212             if(@STICKY) {
213 0         0 foreach my $args (@STICKY) {
  0         0  
214             output(@{ $args });
215             }
216             }
217 1 50       3 # Do the Nopaste
218 0         0 if( @NOPASTE ) {
219 0         0 my $command_string = join(" ", $0, @ORIG_ARGS);
  0         0  
220             unshift @NOPASTE, "\$ $command_string";
221             # Figure out what services to use
222             my $services = $DEF{NOPASTE_SERVICE} ? [ split /,/, $DEF{NOPASTE_SERVICE} ]
223 1 50       3 : $ENV{NOPASTE_SERVICES} ? [ split /,/, $ENV{NOPASTE_SERVICES} ]
224 0         0 : undef;
225 0         0 my %paste = (
226             text => join("\n", @NOPASTE),
227             summary => $command_string,
228 0 0       0 desc => $command_string,
    0          
229             # Default to a Private Paste
230             private => $DEF{NOPASTE_PUBLIC} ? 0 : 1,
231             );
232             debug_var(\%paste);
233             if( $services ) {
234             output({color=>'cyan',stderr=>1}, "# NoPaste: "
235 0 0       0 . App::Nopaste->nopaste(%paste, services => $services)
236             );
237 0         0 }
238 0 0       0 else {
239 0         0 output({color=>'red',stderr=>1,clear=>1},
240             "!! In order to use --nopaste, you need to your environment variable",
241             "!! NOPASTE_SERVICES or pass --nopaste-service, e.g.:",
242             "!! export NOPASTE_SERVICES=Shadowcat,PastebinCom");
243             }
244 0         0 }
245             closelog() if $DEF{SYSLOG};
246             }
247              
248              
249              
250 1 50       6  
251             return unless is_interactive();
252              
253             my @cmd = qw(git config --global --get color.ui);
254 2 50   2 1 14 my($stdout,$stderr,$rc) = capture {
255             system @cmd;
256             };
257             if( $rc != 0 ) {
258 7 50   7 1 36 debug("git_color_check error: $stderr");
259             return 0;
260 0         0 }
261             debug("git_color_check out: $stdout");
262 0     0   0 if( $stdout =~ /auto/ || $stdout =~ /true/ ) {
263 0         0 return 1;
264 0 0       0 }
265 0         0  
266 0         0 return 0;
267             }
268 0         0  
269 0 0 0     0  
270 0         0 my ($color,$string) = @_;
271              
272             if( defined $color && $DEF{COLOR} ) {
273 0         0 $string=colored([ $color ], $string);
274             }
275             return $string;
276             }
277              
278 0     0 1 0  
279             my $opts = is_hashref($_[0]) ? shift @_ : {};
280 0 0 0     0  
281 0         0 # Return unless we have something to work with;
282             return unless @_;
283 0         0  
284             # Ensure we're all setup
285             cli_helpers_initialize() unless keys %DEF;
286              
287             # Input/output Arrays
288 16 100   16 1 5153 my @input = map { my $x=$_; chomp($x) if defined $x; $x; } @_;
289             my @output = ();
290              
291 16 50       34 # Determine the color
292             my $color = exists $opts->{color} && defined $opts->{color} ? $opts->{color} : undef;
293              
294 16 50       45 # Determine indentation
295             my $indent = exists $opts->{indent} ? " "x(2*$opts->{indent}) : '';
296              
297 16 50       24 # If tagged, we only output if the tag is requested
  16         19  
  16         32  
  16         37  
298 16         18 if( $DEF{TAGS} && exists $opts->{tag} ) {
299             # Skip this altogether
300             $TAGS{$opts->{tag}} ||= 0;
301 16 50 33     36 $TAGS{$opts->{tag}}++;
302             return unless $DEF{TAGS}->{$opts->{tag}};
303             }
304 16 50       31  
305             # Determine if we're doing Key Value Pairs
306             my $DO_KV = (scalar(@input) % 2 == 0 ) && (exists $opts->{kv} && $opts->{kv} == 1) ? 1 : 0;
307 16 0 33     28  
308             if( $DO_KV ) {
309 0   0     0 while( @input ) {
310 0         0 my $k = shift @input;
311 0 0       0 # We only colorize the value
312             my $v = shift @input;
313             $v ||= $DEF{KV_FORMAT} eq ': ' ? '~' : '';
314             push @output, join($DEF{KV_FORMAT}, $k, colorize($color,$v));
315 16 50 33     34 }
316             }
317 16 50       26 else {
318 0         0 @output = map { defined $color ? colorize($color, $_) : $_; } @input;
319 0         0 }
320              
321 0         0 # Out to the console
322 0 0 0     0 if( !$DEF{QUIET} || $opts->{IMPORTANT} ) {
323 0         0 my $out_handle = $opts->{stderr} ? \*STDERR : \*STDOUT;
324             # Do clearing
325             print $out_handle "\n"x$opts->{clear} if exists $opts->{clear};
326             # Print output
327 16 50       20 print $out_handle "${indent}$_\n" for @output;
  16         41  
328             }
329              
330             # Handle data, which is raw
331 16 50 33     31 if(defined $DATA_HANDLE && $opts->{data}) {
332 16 100       33 print $DATA_HANDLE "$_\n" for @input;
333             }
334 16 50       27 elsif( $DEF{SYSLOG} && !$opts->{no_syslog}) {
335             my $level = exists $opts->{syslog_level} ? $opts->{syslog_level} :
336 16         462 exists $opts->{stderr} ? 'err' :
337             'notice';
338              
339             # Warning for syslogging data file
340 16 50 33     84 unshift @output, "CLI::Helpers logging a data section, use --data-file to suppress this in syslog."
    50 33        
341 0         0 if $opts->{data};
342              
343             # Now syslog the message
344             debug({no_syslog=>1,color=>'magenta'}, sprintf "[%s] Syslogging %d messages, with: %s", $level, scalar(@output), join(",", map { $_=>$opts->{$_} } keys %{ $opts }));
345 0 0       0 for( @output ) {
    0          
346             # One bad message means no more syslogging
347             eval {
348             syslog($level, colorstrip($_));
349             1;
350 0 0       0 } or do {
351             my $error = $@;
352             $DEF{SYSLOG} = 0;
353 0         0 output({stderr=>1,color=>'red',no_syslog=>1}, "syslog() failed: $error");
  0         0  
  0         0  
354 0         0 };
355             }
356             }
357 0         0  
358 0         0 # Sticky messages don't just go away
359 0 0       0 if(exists $opts->{sticky}) {
360 0         0 my %o = %{ $opts }; # Make a copy because we shifted this off @_
361 0         0 # So this doesn't happen in the END block again
362 0         0 delete $o{$_} for grep { exists $o{$_} } qw(sticky data);
363             $o{no_syslog} = 1;
364             push @STICKY, [ \%o, @input ];
365             }
366             if( $DEF{NOPASTE} ) {
367             push @NOPASTE, map { $indent . colorstrip($_) } @output;
368 16 50       26 }
369 0         0 }
  0         0  
370              
371 0         0  
  0         0  
372 0         0 my $opts = is_hashref($_[0]) ? shift @_ : {};
373 0         0 $opts->{level} = 1 unless exists $opts->{level};
374             $opts->{syslog_level} = $opts->{level} > 1 ? 'debug' : 'info';
375 16 50       86 my @msgs=@_;
376 0         0  
  0         0  
377             # Ensure we're all configured
378             cli_helpers_initialize() unless keys %DEF;
379              
380             if( !$DEF{DEBUG} ) {
381             return unless $DEF{VERBOSE} >= $opts->{level};
382 10 100   10 1 44 }
383 10 100       25 output( $opts, @msgs );
384 10 100       21 }
385 10         19  
386              
387             my $opts = is_hashref($_[0]) ? shift @_ : {};
388 10 50       19 my @msgs=@_;
389              
390 10 100       25 # Ensure we're all configured
391 8 100       39 cli_helpers_initialize() unless keys %DEF;
392              
393 5         13 # Smarter handling of debug output
394             return unless $DEF{DEBUG};
395              
396             # Check against caller class
397             my $package = exists $opts->{_caller_package} ? $opts->{_caller_package} : (caller)[0];
398 19 100   19 1 34037 return unless lc $DEF{DEBUG_CLASS} eq 'all' || $package eq $DEF{DEBUG_CLASS};
399 19         38  
400             # Check if we really want to debug syslog data
401             $opts->{syslog_level} = 'debug';
402 19 50       38 $opts->{no_syslog} //= !$DEF{SYSLOG_DEBUG};
403              
404             # Output
405 19 100       53 output( $opts, @msgs );
406             }
407              
408 3 100       18  
409 3 100 66     17 my $opts = {
410             clear => 1, # Meant for the screen
411             no_syslog => 1, # Meant for the screen
412 1         3 _caller_package => (caller)[0], # Make sure this is set on entry
413 1   33     7 };
414             # Merge with options
415             if( is_hashref($_[0]) && defined $_[1] && is_ref($_[1]) ) {
416 1         3 my $ref = shift;
417             foreach my $k (keys %{ $ref } ) {
418             $opts->{$k} = $ref->{$k};
419             };
420             }
421 7     7 1 29 debug($opts, Dump shift);
422             }
423              
424              
425             my %_allow_override = map { $_ => 1 } qw(debug verbose);
426             my ($var,$value) = @_;
427 7 50 33     30  
      33        
428 0         0 return unless exists $_allow_override{lc $var};
429 0         0  
  0         0  
430 0         0 my $def_var = uc $var;
431             $DEF{$def_var} = $value;
432             }
433 7         21  
434              
435             my $_Confirm_Valid;
436             my ($question) = @_;
437              
438             # Initialize Globals
439 0     0 1   $_Confirm_Valid ||= {qw(y 1 yes 1 n 0 no 0)};
440              
441 0 0         $question =~ s/\s*$/ [yN] /;
442             my $answer = undef;
443 0           until( defined $answer && exists $_Confirm_Valid->{$answer} ) {
444 0           output({color=>'red',stderr=>1},"ERROR: must be one of 'y','n','yes','no'") if defined $answer;
445             $answer = lc _get_input($question);
446             }
447             return $_Confirm_Valid->{$answer};
448             }
449              
450 0     0 1    
451             my $question = shift;
452             my %args = @_;
453 0   0        
454             # Prompt fixes
455 0           chomp($question);
456 0           my $terminator = $question =~ s/([^a-zA-Z0-9\)\]\}])\s*$// ? $1 : ':';
457 0   0       if(exists $args{default}) {
458 0 0         $question .= " (default=$args{default}) ";
459 0           }
460             $question .= "$terminator ";
461 0            
462             # Make sure there's a space before the prompt
463             $question =~ s/\s*$/ /;
464             my $validate = exists $args{validate} ? $args{validate} : {};
465              
466 0     0 1   my $text;
467 0           my $error = undef;
468             until( defined $text && !defined $error ) {
469             output({color=>'red',stderr=>1},"ERROR: $error") if defined $error;
470 0            
471 0 0         # Try to have the user answer the question
472 0 0         $text = _get_input($question => \%args);
473 0           $error = undef;
474              
475 0           # Check the default if the person just hit enter
476             if( exists $args{default} && length($text) == 0 ) {
477             return $args{default};
478 0           }
479 0 0         foreach my $v (keys %{$validate}) {
480             local $_ = $text;
481 0           if( $validate->{$v}->() > 0 ) {
482 0           debug({indent=>1}," + Validated: $v");
483 0   0       next;
484 0 0         }
485             $error = $v;
486             last;
487 0           }
488 0           }
489             return $text;
490             }
491 0 0 0        
492 0            
493             my ($question,$opts) = @_;
494 0           my %desc = ();
  0            
495 0            
496 0 0         # Determine how to handle this list
497 0           if( is_arrayref($opts) ) {
498 0           %desc = map { $_ => $_ } @{ $opts };
499             }
500 0           elsif( is_hashref($opts) ) {
501 0           %desc = %{ $opts };
502             }
503              
504 0           print "$question\n\n";
505             my %ref = ();
506             my $id = 0;
507             foreach my $key (sort keys %desc) {
508             $ref{++$id} = $key;
509 0     0 1   }
510 0            
511             my $choice;
512             until( defined $choice && exists $ref{$choice} ) {
513 0 0         output({color=>'red',stderr=>1},"ERROR: invalid selection") if defined $choice;
    0          
514 0           foreach my $id (sort { $a <=> $b } keys %ref) {
  0            
  0            
515             printf " %d. %s\n", $id, $desc{$ref{$id}};
516             }
517 0           print "\n";
  0            
518             $choice = _get_input("Selection (1-$id): ");
519             }
520 0           return $ref{$choice};
521 0           }
522 0            
523 0            
524 0           my ($prompt, %args) = @_;
525             $prompt ||= "Password: ";
526             my @more_validate;
527 0           if (my $validate = $args{validate}){
528 0   0       @more_validate = %$validate;
529 0 0         }
530 0           return text_input($prompt,
  0            
531 0           noecho => 1,
532             validate => { "password length can't be zero." => sub { defined && length },
533 0           @more_validate,
534 0           },
535             );
536 0           }
537              
538              
539             my ($prompt) = shift;
540             my %args = @_;
541 0     0 1    
542 0   0       return confirm($prompt) if exists $args{yn};
543 0           return menu($prompt, $args{menu}) if exists $args{menu};
544 0 0         # Check for a password prompt
545 0           if( lc($prompt) =~ /passw(or)?d/ ) {
546             $args{noecho} = 1;
547             $args{validate} ||= {};
548             $args{validate}->{"password length can't be zero."} = sub { defined && length };
549 0 0   0     }
550 0           return text_input($prompt,%args);
551             }
552              
553             my ($prompt,$args) = @_;
554              
555             state $interactive = is_interactive();
556             state $term;
557 0     0 1    
558 0           my $text = '';
559             if( $interactive ) {
560 0 0         # Initialize Term
561 0 0         $term ||= Term::ReadLine->new($0);
562             $args ||= {};
563 0 0         if( exists $args->{noecho} ) {
564 0           my $attrs = $term->Attribs;
565 0   0       if( $attrs->{shadow_redisplay} ) {
566 0 0   0     my $restore = $attrs->{redisplay_function};
  0            
567             $attrs->{redisplay_function} = $attrs->{shadow_redisplay};
568 0           $text = $term->readline($prompt);
569             $attrs->{redisplay_function} = $restore;
570             }
571             else {
572 0     0     # Disable all the Term ReadLine magic
573             local $|=1;
574 0           print $prompt;
575 0           ReadMode('noecho');
576             1 until ReadKey(-1);
577 0           $text = ReadLine();
578 0 0         ReadMode('restore');
579             print "\n";
580 0   0       chomp($text);
581 0   0       }
582 0 0         }
583 0           else {
584 0 0         $text = $term->readline($prompt);
585 0           $term->addhistory($text) if length $text && $text =~ /\S/;
586 0           }
587 0           }
588 0           else {
589             # Read one line from STDIN
590             $text = <>;
591             }
592 0           return $text;
593 0           }
594 0            
595 0            
596 0            
597 0           # Return True
598 0           1;
599 0            
600              
601             =pod
602              
603 0           =encoding UTF-8
604 0 0 0        
605             =head1 NAME
606              
607             CLI::Helpers - Subroutines for making simple command line scripts
608              
609 0           =head1 VERSION
610              
611 0           version 1.9
612              
613             =head1 SYNOPSIS
614              
615             Use this module to make writing intelligent command line scripts easier.
616              
617             #!/usr/bin/env perl
618             use CLI::Helpers qw(:all);
619              
620             output({color=>'green'}, "Hello, World!");
621             verbose({indent=>1,color=>'yellow'}, "Shiny, happy people!");
622             verbose({level=>2,kv=>1,color=>'red'}, a => 1, b => 2);
623             debug_var({ c => 3, d => 4});
624              
625             # Data
626             output({data=>1}, join(',', qw(a b c d)));
627              
628             # Wait for confirmation
629             die "ABORTING" unless confirm("Are you sure?");
630              
631             # Ask for a number
632             my $integer = prompt "Enter an integer:", validate => { "not a number" => sub { /^\d+$/ } }
633              
634             # Ask for next move
635             my %menu = (
636             north => "Go north.",
637             south => "Go south.",
638             );
639             my $dir = prompt "Where to, adventurous explorer?", menu => \%menu;
640              
641             # Ask for a favorite animal
642             my $favorite = menu("Select your favorite animal:", [qw(dog cat pig fish otter)]);
643              
644             Running:
645              
646             $ ./test.pl
647             Hello, World!
648             a,b,c,d
649             $ ./test.pl --verbose
650             Hello, World!
651             Shiny, Happy people!
652             a,b,c,d
653             $ ./test.pl -vv
654             Hello, World!
655             Shiny, Happy people!
656             a: 1
657             b: 2
658             a,b,c,d
659             $ ./test.pl --debug
660             Hello, World!
661             Shiny, Happy people!
662             a: 1
663             b: 2
664             ---
665             c: 3
666             d: 4
667             a,b,c,d
668              
669             $ ./test.pl --data-file=output.csv
670             Hello, World!
671             a,b,c,d
672             $ cat output.csv
673             a,b,c,d
674              
675             Colors would be automatically enabled based on the user's ~/.gitconfig
676              
677             =head1 OVERVIEW
678              
679             This module provides a library of useful functions for constructing simple command
680             line interfaces. It is able to extract information from the environment and your
681             ~/.gitconfig to display data in a reasonable manner.
682              
683             Using this module adds argument parsing using L<Getopt::Long> to your script. It
684             enables pass-through, so you can still use your own argument parsing routines or
685             Getopt::Long in your script.
686              
687             =head1 FUNCTIONS
688              
689             =head2 cli_helpers_initialize
690              
691             This is called automatically when C<preprocess_argv> is set. By default, it'll
692             be run the first time a definition is needed, usually the first call to
693             C<output()>. If called automatically, it will operate on C<@ARGV>. You can
694             optionally pass an array reference to this function and it'll operate that
695             instead.
696              
697             In most cases, you don't need to call this function directly. It must be
698             explicitly requested in the import.
699              
700             use CLI::Helpers qw( :output );
701              
702             ...
703             # I want access to ARGV before CLI::Helpers;
704             my %opts = get_important_things_from(\@ARGV);
705              
706             # Now, let CLI::Helpers take the rest, implicit
707             # call to cli_helpers_initialize()
708             output("ready");
709              
710             Alternatively, you could:
711              
712             use CLI::Helpers qw( :output preprocess_argv );
713              
714             ...
715             # Since CLI::Helpers opts are stripped from @ARGV,
716             # Getopt::Long::Descriptive won't complain about extra args
717             my ($opt,$usage) = describe_option( ... );
718              
719             # Now, let CLI::Helpers take the rest, implicit
720             # call to cli_helpers_initialize()
721             output("ready");
722              
723             Or if you'd prefer not to touch C<@ARGV> at all, you pass in an array ref:
724              
725             use CLI::Helpers qw( :output );
726              
727             my ($opt,$usage) = describe_option( ... );
728              
729             cli_helpers_initialize([ qw( --verbose ) ]);
730              
731             output("ready?");
732             verbose("you bet I am");
733              
734             =head2 def
735              
736             Not exported by default, returns the setting defined.
737              
738             =head2 git_color_check
739              
740             Not exported by default. Returns 1 if git is configured to output
741             using color of 0 if color is not enabled.
742              
743             =head2 colorize( $color => 'message to be output' )
744              
745             Not exported by default. Checks if color is enabled and applies
746             the specified color to the string.
747              
748             =head2 output( \%opts, @messages )
749              
750             Exported. Takes an optional hash reference and a list of
751             messages to be output.
752              
753             =head2 verbose( \%opts, @messages )
754              
755             Exported. Takes an optional hash reference of formatting options. Automatically
756             overrides the B<level> parameter to 1 if it's not set.
757              
758             =head2 debug( \%opts, @messages )
759              
760             Exported. Takes an optional hash reference of formatting options.
761             Does not output anything unless DEBUG is set.
762              
763             =head2 debug_var( \%opts, \%Variable )
764              
765             Exported. Takes an optional hash reference of formatting options.
766             Does not output anything unless DEBUG is set.
767              
768             =head2 override( variable => 1 )
769              
770             Exported. Allows a block of code to override the debug or verbose level. This
771             can be used during development to enable/disable the DEBUG/VERBOSE settings.
772              
773             =head2 confirm("prompt")
774              
775             Exported. Creates a Yes/No Prompt which accepts y/n or yes/no case insensitively
776             but requires one or the other.
777              
778             Returns 1 for 'yes' and 0 for 'no'
779              
780             =head2 text_input("prompt", validate => { "too short" => sub { length $_ > 10 } })
781              
782             Exported. Provides a prompt to the user for input. If validate is passed, it should be a hash reference
783             containing keys of error messages and values which are subroutines to validate the input available as $_.
784             If a validator fails, it's error message will be displayed, and the user will be re-prompted.
785              
786             Valid options are:
787              
788             =over 4
789              
790             =item B<default>
791              
792             Any string which will be used as the default value if the user just presses enter.
793              
794             =item B<validate>
795              
796             A hashref, keys are error messages, values are sub routines that return true when the value meets the criteria.
797              
798             =item B<noecho>
799              
800             Set as a key with any value and the prompt will turn off echoing responses as well as disabling all
801             ReadLine magic. See also B<pwprompt>.
802              
803             =back
804              
805             Returns the text that has passed all validators.
806              
807             =head2 menu("prompt", $ArrayOrHashRef)
808              
809             Exported. Used to create a menu of options from a list. Can be either a hash or array reference
810             as the second argument. In the case of a hash reference, the values will be displayed as options while
811             the selected key is returned. In the case of an array reference, each element in the list is displayed
812             the selected element will be returned.
813              
814             Returns selected element (HashRef -> Key, ArrayRef -> The Element)
815              
816             =head2 pwprompt("Prompt", options )
817              
818             Exported. Synonym for text_input("Password: ", noecho => 1); Also requires the password to be longer than 0 characters.
819              
820             =head2 prompt("Prompt", options )
821              
822             Exported. Wrapper function with rudimentary mimicry of IO::Prompt(er).
823             Uses:
824              
825             # Mapping back to confirm();
826             my $value = prompt "Are you sure?", yn => 1;
827              
828             # Mapping back to text_input();
829             my $value = prompt "Enter something:";
830              
831             # With Validator
832             my $value = prompt "Enter an integer:", validate => { "not a number" => sub { /^\d+$/ } }
833              
834             # Pass to menu();
835             my $value = prompt "Select your favorite animal:", menu => [qw(dog cat pig fish otter)];
836              
837             # If you request a password, autodisable echo:
838             my $passwd = prompt "Password: "; # sets noecho => 1, disables ReadLine history.
839              
840             See also: B<text_input>
841              
842             =head1 EXPORT
843              
844             This module uses L<Sub::Exporter> for flexible imports, the defaults provided by
845             :all are as follows.
846              
847             =head2 Exported Functions
848              
849             output ( \%options, @messages )
850             verbose ( \%options, @messages )
851             debug ( \%options, @messages )
852             debug_var ( \$var )
853             override( option => $value )
854              
855             menu ( "Question", \%Options or \@Options )
856             text_input ( "Question", validate => { "error message" => sub { length $_[0] } } )
857             confirm ( "Question" )
858              
859             prompt() Wrapper which mimics IO::Prompt a bit
860             pwprompt() Wrapper to get sensitive data
861              
862             =head2 Import Time Configurations
863              
864             It's possible to change the behavior of the import process.
865              
866             =over 2
867              
868             =item B<copy_argv>
869              
870             Instead of messing with C<@ARGV>, operate on a copy of C<@ARGV>.
871              
872             use CLI::Helpers qw( :output copy_argv );
873              
874             =item B<preprocess_argv>
875              
876             This causes the C<@ARGV> processing to happen during the C<INIT> phase, after
877             import but before runtime. This is usually OK for scripts, but for use in
878             libraries, it may be undesirable.
879              
880             use CLI::Helpers qw( :output preprocess_argv );
881              
882             =item B<delay_argv>
883              
884             This causes the C<@ARGV> processing to happen when the first call to a function
885             needing it run, usually an C<output()> call. This is the default.
886              
887             use CLI::Helpers qw( :output delay_argv );
888              
889             =back
890              
891             =head1 ARGS
892              
893             From CLI::Helpers:
894              
895             --data-file Path to a file to write lines tagged with 'data => 1'
896             --tags A comma separated list of tags to display
897             --color Boolean, enable/disable color, default use git settings
898             --verbose Incremental, increase verbosity (Alias is -v)
899             --debug Show developer output
900             --debug-class Show debug messages originating from a specific package, default: main
901             --quiet Show no output (for cron)
902             --syslog Generate messages to syslog as well
903             --syslog-facility Default "local0"
904             --syslog-tag The program name, default is the script name
905             --syslog-debug Enable debug messages to syslog if in use, default false
906             --nopaste Use App::Nopaste to paste output to configured paste service
907             --nopaste-public Defaults to false, specify to use public paste services
908             --nopaste-service Comma-separated App::Nopaste service, defaults to Shadowcat
909              
910             =head1 NOPASTE
911              
912             This is optional and will only work if you have L<App::Nopaste> installed. If
913             you just specify C<--nopaste>, any output that would be displayed to the screen
914             is submitted to the L<App::Nopaste::Service::Shadowcat> paste bin. This
915             paste service is pretty simple, but works reliably.
916              
917             During the C<END> block, the output is submitted and the URL of the paste is
918             returned to the user.
919              
920             =head1 OUTPUT OPTIONS
921              
922             Every output function takes an optional HASH reference containing options for
923             that output. The hash may contain the following options:
924              
925             =over 4
926              
927             =item B<tag>
928              
929             Add a keyword to tag output with. The user may then specify C<--tags
930             keyword1,keyword2> to only view output at the appropriate level. This option
931             will affect C<data-file> and C<syslog> output. The output filter requires both
932             the presence of the C<tag> in the output options B<and> the user to specify
933             C<--tags> on the command line.
934              
935             Consider a script, C<status.pl>:
936              
937             output("System Status: Normal")
938             output({tag=>'foo'}, "Component Foo: OK");
939             output({tag=>'bar'}, "Component Bar: OK");
940              
941             If an operator runs:
942              
943             $ status.pl
944             System Status: Normal
945             Component Foo: OK
946             Component Bar: OK
947              
948             $ status.pl --tags bar
949             System Status: Normal
950             Component Bar: OK
951              
952             $ status.pl --tags foo
953             System Status: Normal
954             Component Foo: OK
955              
956             This could be helpful for selecting one or more pertinent tags to display.
957              
958             =item B<sticky>
959              
960             Any lines tagged with 'sticky' will be replayed at the end program's end. This
961             is to allow a developer to ensure message are seen at the termination of the program.
962              
963             =item B<color>
964              
965             String. Using Term::ANSIColor for output, use the color designated, i.e.:
966              
967             red,blue,green,yellow,cyan,magenta,white,black, etc..
968              
969             =item B<level>
970              
971             Integer. For verbose output, this is basically the number of -v's necessary to see
972             this output.
973              
974             =item B<syslog_level>
975              
976             String. Can be any valid syslog_level as a string: debug, info, notice, warning, err, crit,
977             alert, emerg.
978              
979             =item B<no_syslog>
980              
981             Bool. Even if the user specifies --syslog, these lines will not go to the syslog destination.
982             alert, emerg.
983              
984             =item B<IMPORTANT>
985              
986             Bool. Even if --quiet is specified, output this message. Use sparingly, and yes,
987             it is case sensitive. You need to yell at it for it to yell at your users.
988              
989             =item B<stderr>
990              
991             Bool. Use STDERR for this message instead of STDOUT. The advantage to using this is the
992             "quiet" option will silence these messages as well.
993              
994             =item B<indent>
995              
996             Integer. This will indent by 2 times the specified integer the next string. Useful
997             for creating nested output in a script.
998              
999             =item B<clear>
1000              
1001             Integer. The number of newlines before this output.
1002              
1003             =item B<kv>
1004              
1005             Bool. The array of messages is actually a key/value pair, this implements special coloring and
1006             expects the number of messages to be even.
1007              
1008             output(qw(a 1 b 2));
1009             # a
1010             # 1
1011             # b
1012             # 2
1013              
1014             Using kv, the output will look like this:
1015              
1016             output({kv=>1}, qw(a 1 b 2));
1017             # a: 1
1018             # b: 2
1019             #
1020              
1021             =item B<data>
1022              
1023             Bool. Lines tagged with "data => 1" will be output to the data-file if a user specifies it. This allows
1024             you to provide header/footers and inline context for the main CLI, but output just the data to a file for
1025             piping elsewhere.
1026              
1027             =back
1028              
1029             =head1 AUTHOR
1030              
1031             Brad Lhotsky <brad@divisionbyzero.net>
1032              
1033             =head1 COPYRIGHT AND LICENSE
1034              
1035             This software is Copyright (c) 2022 by Brad Lhotsky.
1036              
1037             This is free software, licensed under:
1038              
1039             The (three-clause) BSD License
1040              
1041             =head1 CONTRIBUTORS
1042              
1043             =for stopwords Kang-min Liu Kevin M. Goess Mohammad S Anwar
1044              
1045             =over 4
1046              
1047             =item *
1048              
1049             Kang-min Liu <gugod@gugod.org>
1050              
1051             =item *
1052              
1053             Kevin M. Goess <kgoess@craigslist.org>
1054              
1055             =item *
1056              
1057             Mohammad S Anwar <mohammad.anwar@yahoo.com>
1058              
1059             =back
1060              
1061             =for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
1062              
1063             =head1 SUPPORT
1064              
1065             =head2 Websites
1066              
1067             The following websites have more information about this module, and may be of help to you. As always,
1068             in addition to those websites please use your favorite search engine to discover more resources.
1069              
1070             =over 4
1071              
1072             =item *
1073              
1074             MetaCPAN
1075              
1076             A modern, open-source CPAN search engine, useful to view POD in HTML format.
1077              
1078             L<https://metacpan.org/release/CLI-Helpers>
1079              
1080             =item *
1081              
1082             RT: CPAN's Bug Tracker
1083              
1084             The RT ( Request Tracker ) website is the default bug/issue tracking system for CPAN.
1085              
1086             L<https://rt.cpan.org/Public/Dist/Display.html?Name=CLI-Helpers>
1087              
1088             =back
1089              
1090             =head2 Source Code
1091              
1092             This module's source code is available by visiting:
1093             L<https://github.com/reyjrar/CLI-Helpers>
1094              
1095             =cut