App-Basis
view release on metacpan or search on metacpan
lib/App/Basis.pm view on Meta::CPAN
use Exporter ;
use File::HomeDir ;
use Path::Tiny ;
use IPC::Cmd qw(run run_forked) ;
use List::Util qw(max) ;
use POSIX qw(strftime) ;
use utf8::all ;
use Digest::MD5 qw(md5_base64) ;
use YAML::Tiny::Color ;
use vars qw( @EXPORT @ISA) ;
@ISA = qw(Exporter) ;
# this is the list of things that will get imported into the loading packages
# namespace
@EXPORT = qw(
init_app
show_usage
msg_exit
get_program
debug set_debug
daemonise
execute_cmd run_cmd
set_log_file
fix_filename
set_test_mode
saymd
set_verbose
verbose
verbose_data
) ;
# ----------------------------------------------------------------------------
my $PROGRAM = path($0)->basename ;
my $LOG_FILE = fix_filename("~/$PROGRAM.log") ;
# these variables are held available throughout the life of the app
my $_app_simple_ctrlc_count = 0 ;
my $_app_simple_ctrlc_handler ;
my $_app_simple_help_text = 'Application has not defined help_text yet.' ;
my $_app_simple_help_options = '' ;
my $_app_simple_cleanup_func ;
my $_app_simple_help_cmdline = '' ;
my %_app_simple_objects = () ;
my %_cmd_line_options = () ;
# we may want to die rather than exiting, helps with testing!
my $_test_mode = 0 ;
# ----------------------------------------------------------------------------
# control how we output things to help with testing
sub _output
{
my ( $where, $msg ) = @_ ;
if ( !$_test_mode ) {
if ( $where =~ /stderr/i ) {
say STDERR $msg ;
} else {
say $msg ;
}
}
}
# ----------------------------------------------------------------------------
sub set_log_file
{
my ($file) = @_ ;
$LOG_FILE = $file ;
}
# ----------------------------------------------------------------------------
sub debug
{
my ( $level, @debug ) = @_ ;
# we may want to undef the debug object, so no debug comes out
if ( exists $_app_simple_objects{logger} ) {
# run the coderef for the logger
$_app_simple_objects{logger}->( $level, @debug )
if ( defined $_app_simple_objects{logger} ) ;
} else {
path($LOG_FILE)
->append_utf8( strftime( '%Y-%m-%d %H:%M:%S', gmtime( time() ) )
. " [$level] "
. join( ' ', @debug )
. "\n" ) ;
}
}
# ----------------------------------------------------------------------------
sub set_debug
{
my $func = shift ;
if ( !$func || ref($func) ne "CODE" ) {
warn "set_debug function expects a CODE, got a " . ref($func) ;
} else {
$_app_simple_objects{logger} = $func ;
}
}
# -----------------------------------------------------------------------------
my $verbose = 1 ;
sub set_verbose
{
$verbose = shift ;
}
lib/App/Basis.pm view on Meta::CPAN
sub daemonise
{
my $rootdir = shift ;
if ($rootdir) {
chroot($rootdir)
or die
"Could not chroot to $rootdir, only the root user can do this." ;
}
# fork once and let the parent exit
my $pid = fork() ;
# exit if $pid ;
# parent to return 0, as it is logical
if ($pid) {
return 0 ;
}
die "Couldn't fork: $!" unless defined $pid ;
# disassociate from controlling terminal, leave the
# process group behind
POSIX::setsid() or die "Can't start a new session" ;
# show that we have started a daemon process
return 1 ;
}
# ----------------------------------------------------------------------------
sub execute_cmd
{
my %args = @_ ;
my $command = $args{command} or die "command required" ;
# pass everything thought encode incase there is utf8 there
utf8::encode($command) ;
my $r = IPC::Cmd::run_forked( $command, \%args ) ;
return $r ;
}
# ----------------------------------------------------------------------------
sub run_cmd
{
my ( $cmd, $timeout ) = @_ ;
# use our local version of path so that it can pass taint checks
local $ENV{PATH} = $ENV{PATH} ;
# pass everything thought encode incase there is utf8 there
utf8::encode($cmd) ;
my %data = ( command => $cmd ) ;
$data{timeout} = $timeout if ($timeout) ;
my ( $ret, $err, $full_buff, $stdout_buff, $stderr_buff ) = run(%data) ;
my $stdout = join( "\n", @{$stdout_buff} ) ;
my $stderr = join( "\n", @{$stderr_buff} ) ;
return ( !$ret, $stdout, $stderr ) ;
}
# -----------------------------------------------------------------------------
sub fix_filename
{
my $file = shift ;
return if ( !$file ) ;
my $home = File::HomeDir->my_home ;
$file =~ s/^~/$home/ ;
if ( $file =~ m|^\.\./| ) {
my $parent = path( Path::Tiny->cwd )->dirname ;
$file =~ s|^(\.{2})/|$parent/| ;
}
if ( $file =~ m|^\./| || $file eq '.' ) {
my $cwd = Path::Tiny->cwd ;
$file =~ s|^(\.)/?|$cwd| ;
}
# replace multiple separators
$file =~ s|//|/|g ;
# get the OS specific path
return path($file)->canonpath ;
}
# ----------------------------------------------------------------------------
# Returns a hash containing a formatted name for each option. For example:
# ( 'help|h|?' ) -> { 'help|h|?' => '-h, -?, --help' }
sub _desc_names
{
my %descs ;
foreach my $o (@_) {
$_ = $o ; # Keep a copy of key in $o.
s/=.*$// ;
# Sort by length so single letter options are shown first.
my @parts = sort { length $a <=> length $b } split /\|/ ;
# Single chars get - prefix, names get -- prefix.
my $s = join ", ", map { ( length > 1 ? '--' : '-' ) . $_ } @parts ;
$descs{$o} = $s ;
}
return %descs ;
}
# ----------------------------------------------------------------------------
# special function to help us test this module, as it flags that we can die
# rather than exiting when doing some operations
# also test mode will not output to STDERR/STDOUT
sub set_test_mode
{
$_test_mode = shift ;
}
# ----------------------------------------------------------------------------
lib/App/Basis.pm view on Meta::CPAN
sub debug_func {
my ($lvl, $debug) = @_;
if(!$debug) {
$debug = $lvl ;
# set a default level
$lvl = 'INFO' ;
}
say STDERR strftime( '%Y-%m-%d %H:%M:%S', gmtime( time() ) ) . " [$lvl] " . get_program() . " " . $debug;
}
# main
my %opt = App::Basis::init_app(
help_text => 'Sample program description'
, help_cmdline => 'extra stuff to print about command line use'
, options => {
'file|f=s' => {
desc => 'local system location of xml data'
, required => 1
}
, 'url|u=s' => {
desc => 'where to find xml data on the internet'
, validate => sub { my $url = shift ; return $url =~ m{^(http|file|ftp)://} ; }
}
, 'keep|k' => {
# no point in having this if there is no file option
desc => 'keep the local file, do not rename it'
, depends => 'file'
}
, 'counter|c=i' => {
desc => 'check a counter'
, default => 5
}
, 'basic' => 'basic argument, needs no hashref data'
}
, ctrl_c => \&ctrl_c_handler # override built in ctrl-c handler
, cleanup => \&cleanup_func # optional func to call to clean up
, debug => \&debug_func # optional func to call with debugging data
, 'verbose|v' => 'be verbose about things',
, log_file => "~/log/fred.log" # alternative place to store default log messages
) ;
show_usage("need keep option") if( !$opt{keep}) ;
msg_exit( "spurious reason to exit with error code 3", 3) ;
=head1 DESCRIPTION
There are a number of ways to help script development and to encorage people to do the right thing.
One of thses is to make it easy to get parameters from the command line. Obviously you can play with Getopt::Long and
continuously write the same code and add in your own handlers for help etc, but then your co-workers and friends
make not be so consistent, leading to scripts that have no help and take lots of cryptic parameters.
So I created this module to help with command line arguments and displaying help, then I added L<App::Basis::Config> because
everyone needs config files and does not want to constantly repeat themselves there either.
So how is better than other similar modules? I can't say that it is, but it meets my needs.
There is app help available, there is basic debug functionality, which you can extend using your own function,
you can daemonise your script or run a shell command and get the output/stderr/return code.
If you choose to use App::Basis::Config then you will find easy methods to manage reading/saving YAML based config data.
There are (or will be) other App::Basis modules available to help you write scripts without you having to do complex things
or write lots of code.
There is a helper script to create the boilerplate for an appbasis script, see L<appbasis>
=head1 NAME
App::Basis
=head1 Public Functions
=over 4
=item set_log_file
Set the name of the log file for the debug function
set_log_file( "/tmp/lof_file_name") ;
debug( "INFO", "adding to the debug log") ;
=item debug
Write some debug data. If a debug function was passed to init_app that will be
used, otherwise we will write to STDERR.
debug( "WARN", "some message") ;
debug( "ERROR", "Something went wrong") ;
B<Parameters>
string used as a 'level' of the error
array of anything else, normally error description strings
If your script uses App::Basis make sure your modules do too, then any debug
can go to your default debug handler, like log4perl, but simpler!
=item set_debug
Tell App:Simple to use a different function for the debug calls.
Generally you don't need this if you are using init_app, add the link there.
B<Parameters>
coderef pointing to the function you want to do the debugging
=item set_verbose
Turn on use of verbose or verbose_data functions, verbose outputs to STDERR
its different to debug logging with generally will go to a file
set_verbose( 1) ;
verbose( "note that I performed some action") ;
=item verbose
Write to STDERR if verbose has been turned on
its different to debug logging with generally will go to a file
set_verbose( 1) ;
lib/App/Basis.pm view on Meta::CPAN
=item get_program
get the name of the running program
just a helper function
=item get_options
return the command line options hash
just a helper function
=item show_usage
show how this program is used, outputs help, parameters etc, this is written
to STDERR
B<Parameters>
msg - additional message to explain why help is displayed (optional)
state - int value to exit the program with
B<Sample output help>
Syntax: app [options] other things
About: Boiler plate code for an App::Basis app
[options]
-h, --help Show help
-i, --item another item [DEFAULT: 123]
-t, --test test item [DEFAULT: testing 123]
-v --verbose Dump extra useful information
=item msg_exit
Exit this program writting a message to to STDERR
B<Parameters>
msg - message to explain what is going on
state - int value to exit the program with
=item daemonise
create a daemon process, detach from the controlling tty
if called by root user, we can optionally specify a dir to chroot into to keep things safer
B<Parameters>
rootdir - dir to root the daemon into (optional, root user only)
B<Note: will die on errors>
=item execute_cmd
execute_cmd(command => ['/my/command','--args'], timeout => 10);
Executes a command using IPC::Cmd::run_forked, less restrictive than run_cmd
see L<IPC::Cmd> for more options that
Input hashref
command - string to execute (arrayrefs aren't supported, for some reason)
timeout - timeout (in seconds) before command is killed
stdout_handler - see IPC::Cmd docs
stderr_handler - see IPC::Cmd docs
child_stdin - pass data to STDIN of forked processes
discard_output - don't return output in hash
terminate_on_parent_sudden_death
Output HASHREF
exit_code - exit code
timeout - time taken to timeout or 0 if timeout not used
stdout - text written to STDOUT
stderr - text written to STDERR
merged - stdout and stderr merged into one stream
err_msg - description of any error that occurred.
=item run_cmd
Basic way to run a shell program and get its output, this is not interactive.
For interactiviness see execute_cmd.
By default if you do not pass a full path to the command, then unless the command
is in /bin, /usr/bin, /usr/local/bin then the command will not run.
my ($code, $out, $err) = run_cmd( 'ls') ;
#
($code, $out, $err) = run_cmd( 'ls -R /tmp') ;
B<Parameters>
string to run in the shell
timeout (optional) in seconds
=item fix_filename
Simple way to replace ~, ./ and ../ at the start of filenames
B<Parameters>
file name that needs fixing up
=item saymd
convert markdown text into something that can be output onto the terminal
saymd "# # Bringing MD Like Syntax To Bash Shell
It should be something as ***easy***
and as ___natural___ as writing text.
> Keep It Simple
> With quoted sections
Is the idea
* behind
* all this
~~~striking~~~ UX for `shell` users too.
- - -
#green(green text)
bg#red(red background text)
" ;
=back
=head1 AUTHOR
Kevin Mulholland <moodfarm@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2017 by Kevin Mulholland.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
( run in 1.799 second using v1.01-cache-2.11-cpan-39bf76dae61 )