App-Basis
view release on metacpan or search on metacpan
lib/App/Basis.pm view on Meta::CPAN
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 ;
}
sub verbose
{
my ($msg) = @_ ;
say STDERR $msg if ($verbose) ;
}
sub verbose_data
{
if ( @_ % 2 ) {
say STDERR Dump(@_) if ($verbose) ;
} else {
my ($data) = @_ ;
say STDERR Dump($data) if ($verbose) ;
}
}
# ----------------------------------------------------------------------------
# check that the option structure does not have repeated things in it
# returns string of any issue
sub _validate_options
{
my ($options) = @_ ;
my %seen ;
my $result = "" ;
foreach my $opt ( keys %{$options} ) {
# options are long|short=, or thing=, or flags long|sort, or long
my ( $long, $short ) ;
if ( $opt =~ /^(.*?)\|(.*?)=/ ) {
$long = $1 ;
$short = $2 ;
if ( $seen{$long} ) {
$result
= "Long option '$long' has already been used. option line '$opt' is at fault"
;
last ;
} elsif ( $seen{$short} ) {
$result
= "Short option '$short' has already been used. option line '$opt' is at fault"
;
last ;
}
$seen{$short} = 1 ;
$seen{$long} = 1 ;
} elsif ( $opt =~ /^(.*?)\|(.*?)$/ ) {
$long = $1 ;
$short = $2 ;
if ( $seen{$long} ) {
$result
= "Long flag '$long' has already been used. option line '$opt' is at fault"
;
last ;
}
if ( $seen{$short} ) {
$result
= "short flag '$short' has already been used. option line '$opt' is at fault"
;
last ;
}
$seen{$short} = 1 ;
$seen{$long} = 1 ;
} elsif ( $opt =~ /^(.*?)=/ ) {
$long = $1 ;
if ( $seen{$long} ) {
$result
= "Option '$long' has already been used. option line '$opt' is at fault"
;
last ;
}
$seen{$long} = 1 ;
lib/App/Basis.pm view on Meta::CPAN
} elsif ( $rgb eq "white" ) {
$out = "\x1B[37m" ;
} elsif ( $rgb eq "yellow" ) {
$out = "\x1B[39m" ;
} elsif ( $rgb eq "grey" ) {
$out = "\x1B[90m" ;
}
$out .= ( $out eq "" ) ? $3 : "$3\x1B[39m" ;
return ( !defined $bg ) ? $out : "\x1B[7m$out\x1B[27m" ;
}
sub _get_header
{
my ( $hash, $txt ) = @_ ;
if ( length($hash) eq 1 ) {
$txt = "\x1B[1m$txt\x1B[22m" ;
}
return "\x1B[7m $txt \x1B[27m" ;
}
# used to place parsed code back
sub _get_source
{
my ($hash) = @_ ;
my %code = %{ $_[1] } ;
for my $source ( keys %code ) {
if ( $code{$source} eq $hash ) {
return $source ;
}
}
}
# main transformer
# takes care of code blocks too
# without modifying their content
# inline `code blocks` as well as
# ```
# multiline code blocks
# ```
sub saymd
{
my ($txt) = @_ ;
my %code ;
# preserve code blocks
$txt =~ s{(`{2,})(.+?)(?<!`)\1(?!`)}
{$1.($code{$2}=md5_base64($2)).$1}egs ;
# preserve inline blocks too
$txt =~ s{(`)(.+?)\1}{$1.($code{$2}=md5_base64($2)).$1}egm ;
# converter everything else
$txt = _horizontal($txt) ;
$txt = _header($txt) ;
$txt = _bold_underline_strike($txt) ;
$txt = _list($txt) ;
$txt = _quote($txt) ;
$txt = _color($txt) ;
# put back inline blocks
$txt =~ s{(`)(.+?)\1}{$1._get_source($2,\%code).$1}egm ;
# put back code blocks too
$txt =~ s{(`{3})(.+?)(?<!`)\1(?!`)}
{$1._get_source($2,\%code).$1}egs ;
say $txt;
}
# ----------------------------------------------------------------------------
# make sure we do any cleanup required
END {
# call any user supplied cleanup
if ($_app_simple_cleanup_func) {
$_app_simple_cleanup_func->() ;
$_app_simple_cleanup_func = undef ;
}
}
# ----------------------------------------------------------------------------
1 ;
__END__
=pod
=encoding UTF-8
=head1 NAME
App::Basis - Simple way to create applications
=head1 VERSION
version 1.2
=head1 SYNOPSIS
use 5.10.0 ;
use strict ;
use warnings ;
use POSIX qw(strftime) ;
use App::Basis
sub ctrlc_func {
# code to decide what to do when CTRL-C is pressed
}
sub cleanup_func {
# optionally clean up things when the script ends
}
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) ;
verbose( "note that I performed some action") ;
=item verbose
Dump a data structure to STDERR if verbose has been turned on
its different to debug logging with generally will go to a file
set_verbose( 1) ;
verbose_data( \%some_hash) ;
=item init_app
B<Parameters> hash of these things
help_text - what to say when people do app --help
help_cmdline - extra things to put after the sample args on a sample command line (optional)
cleanup - coderef of function to call when your script ends (optional)
debug - coderef of function to call to save/output debug data (optional, recommended)
'verbose' - use verbose mode (optional) will trigger set_verbose by default
log_file - alternate name of file to store debug to
ctrlc_func - coderef of function to call when user presses ctrl-C
options - hashref of program arguments
simple way
'fred' => 'some description of fred'
'fred|f' => 'fred again, also allows -f as a variant'
'fred|f=s' => 'fred needs to be a string'
'fred|f=i' => 'fred needs to be an integer'
complex way, more features, validation, dependancies etc
'fred|f=s' => {
desc => 'description of argument',
# check if fred is one of the allowed things
validate => sub { my $fred = shift ; $fred =~ m/bill|mary|jane|sam/i ;},
# does this option need another option to exist
depends => 'otheroption'
}
'fred|f=s' => {
desc => 'description of argument',
default => 'default value for fred'
}
B<Note will die if not passed a HASH of arguments>
=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
( run in 2.836 seconds using v1.01-cache-2.11-cpan-d7a12ab2c7f )