| 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 |