File Coverage

blib/lib/CLI/Helpers.pm
Criterion Covered Total %
statement 124 291 42.6
branch 63 172 36.6
condition 25 96 26.0
subroutine 26 37 70.2
pod 15 15 100.0
total 253 611 41.4


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