# @(#)$Ident: Programs.pm 2013-05-02 14:04 pjf ; package Class::Usul::Programs; use attributes (); use version; our $VERSION = qv( sprintf '0.17.%d', q$Rev: 8 $ =~ /\d+/gmx ); use Class::Inspector; use Class::Usul::Moose; use Class::Usul::Constants; use Class::Usul::Functions qw(abs_path app_prefix arg_list assert_directory class2appdir classdir elapsed env_prefix exception find_source is_arrayref is_hashref is_member say throw untaint_identifier untaint_path); use Class::Usul::File; use Class::Usul::IPC; use Config; use Encode qw(decode); use English qw(-no_match_vars); use File::Basename qw(dirname); use File::HomeDir qw(); use File::Spec::Functions qw(catdir catfile); use IO::Interactive qw(is_interactive); use List::Util qw(first); use Pod::Man; use Pod::Usage; use Term::ReadKey; use Text::Autoformat; use Try::Tiny; use User::pwent; extends q(Class::Usul); with q(MooseX::Getopt::Dashes); with q(Class::Usul::TraitFor::LoadingClasses); with q(Class::Usul::TraitFor::UntaintedGetopts); # Override attributes in base class has '+config_class' => default => sub { 'Class::Usul::Config::Programs' }; has '+debug' => traits => [ 'Getopt' ], cmd_aliases => q(D), cmd_flag => 'debug'; has '+help_flag' => cmd_aliases => [ qw(usage ?) ]; # Public attributes has 'help_options' => is => 'ro', isa => Bool, default => FALSE, documentation => 'Uses Pod::Usage to describe the program options', traits => [ 'Getopt' ], cmd_aliases => q(h), cmd_flag => 'help_opt'; has 'help_manual' => is => 'ro', isa => Bool, default => FALSE, documentation => 'Uses Pod::Man to display the program documentation', traits => [ 'Getopt' ], cmd_aliases => q(H), cmd_flag => 'man_page'; has 'home' => is => 'ro', isa => SimpleStr, documentation => 'Directory containing the configuration file', traits => [ 'Getopt' ], cmd_flag => 'home'; has 'language' => is => 'ro', isa => SimpleStr, default => NUL, documentation => 'Loads the specified language message catalog', traits => [ 'Getopt' ], cmd_aliases => q(L), cmd_flag => 'language'; has 'method' => is => 'rw', isa => SimpleStr | Undef, default => NUL, documentation => 'Name of the method to call', traits => [ 'Getopt' ], cmd_aliases => q(c), cmd_flag => 'command'; has 'nodebug' => is => 'ro', isa => Bool, default => FALSE, documentation => 'Do not prompt for debugging', traits => [ 'Getopt' ], cmd_aliases => q(n), cmd_flag => 'nodebug'; has 'options' => is => 'ro', isa => HashRef, default => sub { {} }, documentation => 'Zero, one or more key/value pairs available to the method call', traits => [ 'Getopt' ], cmd_aliases => q(o), cmd_flag => 'option'; has '_quiet' => is => 'rw', isa => Bool, default => FALSE, documentation => 'Quiet the display of information messages', traits => [ 'Getopt' ], cmd_aliases => q(q), cmd_flag => 'quiet', init_arg => 'quiet'; has 'version' => is => 'ro', isa => Bool, default => FALSE, documentation => 'Displays the version number of the program class', traits => [ 'Getopt' ], cmd_aliases => q(V), cmd_flag => 'version'; # Private attributes has '_file' => is => 'lazy', isa => FileType, default => sub { Class::Usul::File->new( builder => $_[ 0 ] ) }, handles => [ qw(io) ], init_arg => undef, reader => 'file'; has '_ipc' => is => 'lazy', isa => IPCType, default => sub { Class::Usul::IPC->new( builder => $_[ 0 ] ) }, handles => [ qw(run_cmd) ], init_arg => undef, reader => 'ipc'; has '_logname' => is => 'lazy', isa => NonEmptySimpleStr, init_arg => undef, reader => 'logname'; has '_meta_class' => is => 'lazy', isa => LoadableClass, coerce => TRUE, default => sub { 'Class::Usul::Response::Meta' }, reader => 'meta_class'; has '_mode' => is => 'rw', isa => PositiveInt, accessor => 'mode', default => sub { $_[ 0 ]->config->mode }, init_arg => 'mode', lazy => TRUE; has '_os' => is => 'lazy', isa => HashRef, init_arg => undef, reader => 'os'; has '_params' => is => 'ro', isa => HashRef, default => sub { {} }, init_arg => 'params', reader => 'params'; has '_pwidth' => is => 'rw', isa => PositiveInt, accessor => 'pwidth', default => 60, init_arg => 'pwidth'; around 'BUILDARGS' => sub { my ($next, $self, @args) = @_; my $attr = $self->$next( @args ); my $cfg = $attr->{config} ||= {}; $cfg->{appclass} ||= delete $attr->{appclass} || blessed $self || $self; $cfg->{home } ||= __find_apphome( $cfg->{appclass}, $attr->{home} ); $cfg->{cfgfiles} ||= __get_cfgfiles( $cfg->{appclass}, $cfg->{home} ); return $attr; }; sub BUILD { my $self = shift; $self->_apply_encoding; $self->help_flag and $self->_output_usage( 0 ); $self->help_options and $self->_output_usage( 1 ); $self->help_manual and $self->_output_usage( 2 ); $self->version and $self->_output_version; $self->debug( $self->_get_debug_option ); return; } sub add_leader { my ($self, $text, $args) = @_; $text or return NUL; $args ||= {}; my $leader = exists $args->{no_lead} ? NUL : (ucfirst $self->config->name).BRK; if ($args->{fill}) { my $width = $args->{width} || WIDTH; $text = autoformat $text, { right => $width - 1 - length $leader }; } return join "\n", map { (m{ \A $leader }mx ? NUL : $leader).$_ } split m{ \n }mx, $text; } sub anykey { my $prompt = $_[ 1 ] || $_[ 0 ]->loc( 'Press any key to continue...' ); return __prompt( -p => $prompt, -e => NUL, -1 => TRUE ); } sub can_call { return ($_[ 0 ]->can( $_[ 1 ] ) && (is_member $_[ 1 ], __list_methods_of( $_[ 0 ] ))) ? TRUE : FALSE; } sub debug_flag { return $_[ 0 ]->debug ? q(-D) : q(-n); } sub dump_self : method { my $self = shift; $self->dumper( $self ); $self->dumper( $self->config ); return OK; } sub error { my ($self, $err, $args) = @_; my $text = $self->loc( $err || '[no message]', $args->{args} || [] ); $self->log->error( $_ ) for (split m{ \n }mx, NUL.$text); __print_fh( \*STDERR, $self->add_leader( $text, $args )."\n" ); $self->debug and __output_stacktrace( $err ); return; } sub fatal { my ($self, $err, $args) = @_; my (undef, $file, $line) = caller 0; my $posn = ' at '.abs_path( $file )." line ${line}"; my $text = $self->loc( $err || '[no message]', $args->{args} || [] ); $self->log->alert( $_ ) for (split m{ \n }mx, $text.$posn); __print_fh( \*STDERR, $self->add_leader( $text, $args ).$posn."\n" ); __output_stacktrace( $err ); exit FAILED; } sub get_line { # General text input routine. my ($self, $question, $default, $quit, $width, $multiline, $noecho) = @_; $question ||= 'Enter your answer'; $default = $default // NUL; my $advice = $quit ? '('.QUIT.' to quit)' : NUL; my $right_prompt = $advice.($multiline ? NUL : " [${default}]"); my $left_prompt = $question; if (defined $width) { my $total = $width || $self->pwidth; my $left_x = $total - (length $right_prompt); $left_prompt = sprintf '%-*s', $left_x, $question; } my $prompt = $left_prompt.SPC.$right_prompt; $prompt .= ($multiline ? "\n".q([).$default.q(]) : NUL).BRK; my $result = $noecho ? __prompt( -d => $default, -p => $prompt, -e => q(*) ) : __prompt( -d => $default, -p => $prompt ); $quit and defined $result and lc $result eq QUIT and exit FAILED; return NUL.$result; } sub get_meta { my ($self, $dir) = @_; my $cfg = $self->config; my @dirs = ($cfg->appldir, $cfg->ctrldir); $dir and unshift @dirs, $self->io( $dir ); return $self->meta_class->new( directories => \@dirs ); } sub get_option { my ($self, $question, $default, $quit, $width, $options) = @_; $question ||= 'Select one option from the following list:'; $self->output( $question, { cl => TRUE } ); my $count = 1; my $text = join "\n", map { $count++.q( - ).$_ } @{ $options }; $self->output( $text, { cl => TRUE, nl => TRUE } ); my $opt = $self->get_line( 'Select option', $default, $quit, $width ); $opt !~ m{ \A \d+ \z }mx and $opt = $default // 0; return $opt - 1; } sub info { my ($self, $text, $args) = @_; $text = $self->loc( $text || '[no message]', $args->{args} || [] ); $self->log->info( $_ ) for (split m{ [\n] }mx, $text); $self->quiet or say $self->add_leader( $text, $args ); return; } sub interpolate_cmd { my ($self, $cmd, @args) = @_; my $ref = $self->can( q(_interpolate_).$cmd.q(_cmd) ) or return [ $cmd, @args ]; return $self->$ref( $cmd, @args ); } sub list_methods : method { say __list_methods_of( shift ); return OK; } sub loc { my ($self, $key, @args) = @_; my $car = $args[ 0 ]; my $args = (is_hashref $car) ? { %{ $car } } : { params => (is_arrayref $car) ? $car : [ @args ] }; $args->{domain_names} ||= [ DEFAULT_L10N_DOMAIN, $self->config->name ]; $args->{locale } ||= $self->language; return $self->localize( $key, $args ); } sub output { my ($self, $text, $args) = @_; $args ||= {}; $self->quiet and return; $args->{cl} and say; $text = $self->loc( $text || '[no message]', $args->{args} || [] ); say $self->add_leader( $text, $args ); $args->{nl} and say; return; } sub print_usage_text { # Required to stop MX::Getopt from printing usage } sub quiet { my ($self, $v) = @_; defined $v or return $self->_quiet; $v = !!$v; $v != TRUE and throw 'Cannot turn quiet mode off'; return $self->_quiet( $v ); } sub run { my $self = shift; my $method = $self->_get_run_method; my $rv; my $text = 'Started by '.$self->logname.' Version '.$self->VERSION.SPC; $text .= 'Pid '.(abs $PID); $self->output( $text ); umask $self->mode; if ($method eq 'run_chain' or $self->can_call( $method )) { my $params = exists $self->params->{ $method } ? $self->params->{ $method } : []; try { defined ($rv = $self->$method( @{ $params } )) or throw error => 'Method [_1] return value undefined', args => [ $method ], rv => UNDEFINED_RV; } catch { $rv = $self->_catch_run_exception( $method, $_ ) }; } else { $self->error( 'Class '.(blessed $self)." method ${method} not found" ); $rv = UNDEFINED_RV; } if (defined $rv and $rv == OK) { $self->output( 'Finished in '.elapsed.' seconds' ); } elsif (defined $rv and $rv > OK) { $self->output( "Terminated code ${rv}" ) } else { not defined $rv and $rv = UNDEFINED_RV and $self->error( "Method ${method} error uncaught/rv undefined" ); $self->output( 'Terminated with undefined rv' ); } $self->file->delete_tmp_files; return $rv; } sub run_chain { my ($self, $method) = @_; $method or $self->_output_usage( 0 ); $self->fatal( exception "Method ${method} unknown" ); return FAILED; } sub warning { my ($self, $text, $args) = @_; $text = $self->loc( $text || '[no message]', $args->{args} || [] ); $self->log->warn( $_ ) for (split m{ \n }mx, $text); $self->quiet or say $self->add_leader( $text, $args ); return; } sub yorn { # General yes or no input routine my ($self, $question, $default, $quit, $width, $newline) = @_; my $no = NO; my $yes = YES; my $result; $default = $default ? $yes : $no; $quit = $quit ? QUIT : NUL; my $advice = $quit ? "(${yes}/${no}, ${quit}) " : "(${yes}/${no}) "; my $right_prompt = "${advice}[${default}]"; my $left_prompt = $question; if (defined $width) { my $max_width = $width || $self->pwidth; my $right_x = length $right_prompt; my $left_x = $max_width - $right_x; $left_prompt = sprintf '%-*s', $left_x, $question; } my $prompt = $left_prompt.SPC.$right_prompt.BRK; $newline and $prompt .= "\n"; while ($result = __prompt( -d => $default, -p => $prompt )) { $quit and $result =~ m{ \A (?: $quit | [\e] ) }imx and exit FAILED; $result =~ m{ \A $yes }imx and return TRUE; $result =~ m{ \A $no }imx and return FALSE; } return; } # Private methods sub _apply_encoding { my $self = shift; my $enc = $self->encoding; autoflush STDOUT TRUE; autoflush STDERR TRUE; binmode $_, ":encoding(${enc})" for (*STDIN, *STDOUT, *STDERR); $_ = decode( $enc, $_ ) for @ARGV; return; } sub _build__logname { return untaint_identifier( $ENV{USER} || $ENV{LOGNAME} || getpwuid( $UID )->name || 'unknown' ); } sub _build__os { my $self = shift; my $file = q(os_).$Config{osname}.$self->config->extension; my $path = $self->config->ctrldir->catfile( $file ); $path->exists or return {}; my $cfg = $self->file->data_load( paths => [ $path ] ); return $cfg->{os} || {}; } sub _catch_run_exception { my ($self, $method, $error) = @_; my $e; unless ($e = exception $error) { $self->error( 'Method [_1] exception without error', { args => [ $method ] } ); return UNDEFINED_RV; } $e->out and $self->output( $e->out ); $self->error( $e->error, { args => $e->args } ); $self->debug and __output_stacktrace( $e ); return $e->rv || (defined $e->rv ? FAILED : UNDEFINED_RV); } sub _dont_ask { return $_[ 0 ]->debug || $_[ 0 ]->help_flag || $_[ 0 ]->help_options || $_[ 0 ]->help_manual || ! is_interactive(); } sub _get_debug_option { my $self = shift; ($self->nodebug or $self->_dont_ask) and return $self->debug; return $self->yorn( 'Do you want debugging turned on', FALSE, TRUE ); } sub _get_run_method { my $self = shift; my $method = $self->method; unless ($method) { if ($method = $self->extra_argv->[ 0 ] and $self->can_call( $method )) { shift @{ $self->extra_argv }; } else { $method = NUL } } $method ||= 'run_chain'; $method eq 'run_chain' and $self->quiet( TRUE ); return $self->method( $method ); } sub _man_page_from { my ($self, $src) = @_; my $cfg = $self->config; my $parser = Pod::Man->new( center => $cfg->doc_title || NUL, name => $cfg->script, release => 'Version '.$self->VERSION, section => q(3m) ); my $tempfile = $self->file->tempfile; my $cmd = $cfg->man_page_cmd || []; $parser->parse_from_file( NUL.$src->pathname, $tempfile->pathname ); say $self->run_cmd( [ @{ $cmd }, $tempfile->pathname ] )->out; return OK; } sub _output_usage { my ($self, $verbose) = @_; my $method = $self->extra_argv ? $self->extra_argv->[ 0 ] : undef; $method and $self->can_call( $method ) and exit $self->_usage_for( $method ); $verbose > 1 and exit $self->_man_page_from( $self->config ); if ($verbose > 0) { pod2usage( { -input => NUL.$self->config->pathname, -message => SPC, -verbose => $verbose } ); # Never returns } my $usage = ucfirst $self->usage; warn $usage ? $usage : "Did we forget new_with_options?\n"; exit OK; } sub _output_version { $_[ 0 ]->output( 'Version '.$_[ 0 ]->VERSION ); exit OK; } sub _usage_for { my ($self, $method) = @_; my @classes = (blessed $self); $method = untaint_identifier $method; while (my $class = shift @classes) { no strict q(refs); if (defined &{ "${class}::${method}" }) { my $selector = Pod::Select->new(); $selector->select( "/${method}" ); my $tempfile = $self->file->tempfile; $selector->parse_from_file( find_source $class, $tempfile->pathname ); return $self->_man_page_from( $tempfile ); } push @classes, $_ for (@{ "${class}::ISA" }); } return FAILED; } # Private functions sub __find_apphome { my ($appclass, $home) = @_; my ($file, $path); # 0. Pass the directory in $path = assert_directory $home and return $path; my $app_prefix = app_prefix $appclass; my $appdir = class2appdir $appclass; my $classdir = classdir $appclass; my $env_prefix = env_prefix $appclass; my $my_home = File::HomeDir->my_home; # 1a. Environment variable - for application directory $path = $ENV{ "${env_prefix}_HOME" }; $path = assert_directory $path and return $path; # 1b. Environment variable - for config file $file = $ENV{ "${env_prefix}_CONFIG" }; $path = $file ? dirname( $file ) : NUL; $path = assert_directory $path and return $path; # 2a. Users home directory - contains application directory $path = catdir( $my_home, $appdir, qw(default lib), $classdir ); $path = assert_directory $path and return $path; # 2b. Users home directory - dot directory containing application $path = catdir( $my_home, ".${appdir}", qw(default lib), $classdir ); $path = assert_directory $path and return $path; # 2c. Users home directory - dot file containing shell env variable $file = catfile( $my_home, ".${app_prefix}" ); $path = __read_variable( $file, q(APPLDIR) ); $path and $path = catdir( $path, q(lib), $classdir ); $path = assert_directory $path and return $path; # 2d. Users home directory - dot directory is appldir $path = catdir( $my_home, ".${app_prefix}" ); $path = assert_directory $path and return $path; # 3. Well known path containing shell env file $file = catfile( @{ DEFAULT_DIR() }, $appdir ); $path = __read_variable( $file, q(APPLDIR) ); $path and $path = catdir( $path, q(lib), $classdir ); $path = assert_directory $path and return $path; # 4. Default install prefix $path = catdir( @{ PREFIX() }, $appdir, qw(default lib), $classdir ); $path = assert_directory $path and return $path; # 5. Config file found in @INC for $path (map { catdir( abs_path( $_ ), $classdir ) } @INC) { for my $extn (keys %{ Class::Usul::File->extensions }) { $file = untaint_path catfile( $path, $app_prefix.$extn ); -f $file and return dirname( $file ); } } # 6. Default to /tmp return untaint_path( File::Spec->tmpdir ); } sub __get_cfgfiles { my ($appclass, $home) = @_; my $files = []; my $file; my $app_prefix = app_prefix $appclass; my $env_prefix = env_prefix $appclass; my $suffix = $ENV{ "${env_prefix}_CONFIG_LOCAL_SUFFIX" } || '_local'; for my $extn (keys %{ Class::Usul::File->extensions }) { $file = untaint_path catfile( $home, "${app_prefix}${extn}" ); -f $file and push @{ $files }, $file; $file = untaint_path catfile( $home, "${app_prefix}${suffix}${extn}" ); -f $file and push @{ $files }, $file; } return $files; } sub __get_control_chars { my $handle = shift; my %cntl = GetControlChars $handle; return ((join q(|), values %cntl), %cntl); } sub __list_methods_of { return map { s{ \A .+ :: }{}msx; $_ } grep { my $method = $_; grep { $_ eq q(method) } attributes::get( \&{ $method } ) } @{ Class::Inspector->methods ( blessed $_[ 0 ] || $_[ 0 ], 'full', 'public' ) }; } sub __map_prompt_args { my $args = shift; my %map = ( qw(-1 onechar -d default -e echo -p prompt) ); for (grep { exists $map{ $_ } } keys %{ $args }) { $args->{ $map{ $_ } } = delete $args->{ $_ }; } return $args; } sub __output_stacktrace { my $e = shift; $e and blessed $e and $e->can( q(stacktrace) ) and __print_fh( \*STDERR, NUL.$e->stacktrace ); return; } sub __print_fh { my ($handle, $text) = @_; print {$handle} $text or throw error => 'IO error: [_1]', args =>[ $ERRNO ]; return; } sub __prompt { my $args = __map_prompt_args( arg_list @_ ); my $default = $args->{default}; my $echo = $args->{echo }; my $onechar = $args->{onechar}; my $OUT = \*STDOUT; my $IN = \*STDIN; my $input = NUL; my ($len, $newlines, $next, $text); unless (is_interactive()) { $ENV{PERL_MM_USE_DEFAULT} and return $default; $onechar and return getc $IN; return scalar <$IN>; } my ($cntl, %cntl) = __get_control_chars( $IN ); local $SIG{INT} = sub { __restore_mode( $IN ); exit FAILED }; __print_fh( $OUT, $args->{prompt} ); __raw_mode( $IN ); while (TRUE) { if (defined ($next = getc $IN)) { if ($next eq $cntl{INTERRUPT}) { __restore_mode( $IN ); exit FAILED; } elsif ($next eq $cntl{ERASE}) { if ($len = length $input) { $input = substr $input, 0, $len - 1; __print_fh( $OUT, "\b \b" ); } next; } elsif ($next eq $cntl{EOF}) { __restore_mode( $IN ); close $IN or throw error => 'IO error: [_1]', args =>[ $ERRNO ]; return $input; } elsif ($next !~ m{ $cntl }mx) { $input .= $next; if ($next eq "\n") { if ($input eq "\n" and defined $default) { $text = defined $echo ? $echo x length $default : $default; __print_fh( $OUT, "[${text}]\n" ); __restore_mode( $IN ); return $onechar ? substr $default, 0, 1 : $default; } $newlines .= "\n"; } else { __print_fh( $OUT, $echo // $next ) } } else { $input .= $next } } if ($onechar or not defined $next or $input =~ m{ \Q$RS\E \z }mx) { chomp $input; __restore_mode( $IN ); defined $newlines and __print_fh( $OUT, $newlines ); return $onechar ? substr $input, 0, 1 : $input; } } return; } sub __raw_mode { my $handle = shift; ReadMode q(raw), $handle; return; } sub __read_variable { my ($file, $variable) = @_; return -f $file ? first { length } map { (split q(=), $_)[ 1 ] } grep { m{ \A $variable [=] }mx } Class::Usul::File->io( $file )->chomp->getlines : undef; } sub __restore_mode { my $handle = shift; ReadMode q(restore), $handle; return; } __PACKAGE__->meta->make_immutable; 1; __END__ =pod =head1 Name Class::Usul::Programs - Provide support for command line programs =head1 Version This document describes Class::Usul::Programs version v0.17.$Rev: 8 $ =head1 Synopsis # In YourClass.pm use Class::Usul::Moose; extends qw(Class::Usul::Programs); # In yourProg.pl use YourClass; exit YourClass->new( appclass => 'YourApplicationClass' )->run; =head1 Description This base class provides methods common to command line programs. The constructor can initialise a multi-lingual message catalog if required =head1 Configuration and Environment Supports this list of command line options =over 3 =item c method The method in the subclass to dispatch to =item D Turn debugging on =item H Print long help text extracted from this POD =item h Print short help text extracted from this POD =item L language Print error messages in the selected language. If no language is supplied print the error code and attributes =item n Do not prompt to turn debugging on =item o key=value The method that is dispatched to can access the key/value pairs from the C<< $self->vars >> hash ref =item q Quietens the usual started/finished information messages =back =head1 Subroutines/Methods =head2 BUILDARGS Called just before the object is constructed this method modifier determines the location of the config file =head2 BUILD Called just after the object is constructed this methods handles dispatching to the help methods and prompting for the debug state =head2 add_leader $leader = $self->add_leader( $text, $args ); Prepend C<< $self->config->name >> to each line of C<$text>. If C<< $args->{no_lead} >> exists then do nothing. Return C<$text> with leader prepended =head2 anykey $key = $self->anykey( $prompt ); Prompt string defaults to 'Press any key to continue...'. Calls and returns L<prompt|/prompt>. Requires the user to press any key on the keyboard (that generates a character response) =head2 can_call $bool = $self->can_call( $method ); Returns true if C<$self> has a method given by C<$method> that has defined the I<method> method attribute =head2 debug_flag $cmd_line_option = $self->debug_flag Returns the command line debug flag to match the current debug state =head2 dump_self $self->dump_self; Dumps out the self referential object using L<Data::Dumper> =head2 error $self->error( $text, $args ); Calls L<Class::Usul::localize|Class::Usul/localize> with the passed args. Logs the result at the error level, then adds the program leader and prints the result to I<STDERR> =head2 fatal $self->fatal( $text, $args ); Calls L<Class::Usul::localize|Class::Usul/localize> with the passed args. Logs the result at the alert level, then adds the program leader and prints the result to I<STDERR>. Exits with a return code of one =head2 _get_debug_option $self->_get_debug_option(); If it is an interactive session prompts the user to turn debugging on. Returns true if debug is on. Also offers the option to quit =head2 _get_homedir $path = $self->_get_homedir( $args ); Environment variable containing the path to a file which contains the application installation directory. Defaults to the environment variable <uppercase application name>_HOME Search through sub directories of @INC looking for the file F<yourApplication.json>. Uses the location of this file to return the path to the installation directory =head2 get_line $line = $self->get_line( $question, $default, $quit, $width, $newline ); Prompts the user to enter a single line response to C<$question> which is printed to I<STDOUT> with a program leader. If C<$quit> is true then the options to quit is included in the prompt. If the C<$width> argument is defined then the string is formatted to the specified width which is C<$width> or C<< $self->pwdith >> or 40. If C<$newline> is true a newline character is appended to the prompt so that the user get a full line of input =head2 get_meta $res_obj = $self->get_meta( $dir ); Extracts; I<name>, I<version>, I<author> and I<abstract> from the F<META.json> or F<META.yml> file. Looks in the optional C<$dir> directory for the file in addition to C<< $self->appldir >> and C<< $self->ctrldir >>. Returns a response object with read-only accessors defined =head2 get_option $option = $self->get_option( $question, $default, $quit, $width, $options ); Returns the selected option number from the list of possible options passed in the C<$question> argument =head2 info $self->info( $text, $args ); Calls L<Class::Usul::localize|Class::Usul/localize> with the passed args. Logs the result at the info level, then adds the program leader and prints the result to I<STDOUT> =head2 interpolate_cmd $cmd = $self->interpolate_cmd( $cmd, @args ); Calls C<_interpolate_${cmd}_cmd> to apply the arguments to the command in a command specific way =head2 list_methods $self->list_methods Lists the methods (marked by the I<method> subroutine attribute) that can be called via the L<run method|/run> =head2 loc $localized_text = $self->loc( $key, @options ); Localizes the message. Calls L<Class::Usul::L10N/localize>. Adds the constant C<DEFAULT_L10N_DOMAINS> to the list of domain files that are searched. Adds C<< $self->language >> and C< $self->config->name >> (search domain) to the arguments passed to C<localize> =head2 output $self->output( $text, $args ); Calls L<Class::Usul::localize|Class::Usul/localize> with the passed args. Adds the program leader and prints the result to I<STDOUT> =head2 _output_version $self->_output_version Prints out the version of the C::U::Programs subclass and the exits =head2 print_usage_text Empty method used to override L<MooseX::Getop::Basic>'s latest API incantation. Used to be C<_getopt_full_usage> which we still have to maintain because *we* do not break backward compatibility =head2 __prompt $line = __prompt( 'key' => 'value', ... ); This was taken from L<IO::Prompt> which has an obscure bug in it. Much simplified the following keys are supported =over 3 =item -1 Return the first character typed =item -d Default response =item -e The character to echo in place of the one typed =item -p Prompt string =back =head2 quiet $bool = $self->quiet( $bool ); Custom accessor/mutator for the C<_quiet> attribute. Will throw if you try to turn quiet mode off =head2 run $rv = $self->run; Call the method specified by the C<-c> option on the command line. Returns the exit code =head2 run_chain $exit_code = $self->run_chain( $method ); Called by L</run> when C<_get_run_method> cannot determine which method to call. Outputs usage if C<$method> is undefined. Logs an error if C<$method> is defined but not (by definition a callable method). Returns exit code C<FAILED> =head2 _output_usage $self->_output_usage( $verbosity ); Print out usage information from POD. The C<$verbosity> is; 0, 1 or 2 =head2 warning $self->warning( $text, $args ); Calls L<Class::Usul::localize|Class::Usul/localize> with the passed args. Logs the result at the warning level, then adds the program leader and prints the result to I<STDOUT> =head2 yorn $self->yorn( $question, $default, $quit, $width ); Prompt the user to respond to a yes or no question. The C<$question> is printed to I<STDOUT> with a program leader. The C<$default> argument is C<0|1>. If C<$quit> is true then the option to quit is included in the prompt. If the C<$width> argument is defined then the string is formatted to the specified width which is C<$width> or C<< $self->pwdith >> or 40 =head2 __get_control_chars ($cntrl, %cntrl) = __get_control_chars( $handle ); Returns a string of pipe separated control characters and a hash of symbolic names and values =head2 __raw_mode __raw_mode( $handle ); Puts the terminal in raw input mode =head2 __restore_mode __restore_mode( $handle ); Restores line input mode to the terminal =head1 Diagnostics Turning debug on produces some more output =head1 Dependencies =over 3 =item L<Class::Inspector> =item L<Class::Usul> =item L<Class::Usul::IPC> =item L<Class::Usul::File> =item L<Class::Usul::TraitFor::LoadingClasses> =item L<Class::Usul::TraitFor::UntaintedGetopts> =item L<Encode> =item L<File::HomeDir> =item L<IO::Interactive> =item L<MooseX::Getopt::Dashes> =item L<Term::ReadKey> =item L<Text::Autoformat> =back =head1 Incompatibilities There are no known incompatibilities in this module =head1 Bugs and Limitations There are no known bugs in this module. Please report problems to the address below. Patches are welcome =head1 Author Peter Flanigan, C<< <Support at RoxSoft.co.uk> >> =head1 License and Copyright Copyright (c) 2013 Peter Flanigan. All rights reserved This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic> This program is distributed in the hope that it will be useful, but WITHOUT WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE =cut # Local Variables: # mode: perl # tab-width: 3 # End: