File Coverage

blib/lib/App/Basis.pm

Criterion	Covered	Total	%
statement	137	174	78.7
branch	53	96	55.2
condition	11	17	64.7
subroutine	22	29	75.8
pod	12	13	92.3
total	235	329	71.4

# ABSTRACT: Simple way to create applications


package App::Basis;
$App::Basis::VERSION = '1.0';
use 5.014;
use warnings;
use strict;
use Getopt::Long;
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 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
);

# ----------------------------------------------------------------------------

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

# ----------------------------------------------------------------------------


sub init_app {
    my %args = @_ % 2 ? die("Odd number of values passed where even is expected.") : @_;
    my @options;
    my $has_required = 0;
    my %full_options;

    if ( $args{log_file} ) {
        $LOG_FILE = fix_filename( $args{log_file} );
    }

    if ( $args{debug} ) {
        set_debug( $args{debug} );
    }

    # get program description
    $_app_simple_help_text    = $args{help_text}    if ( $args{help_text} );
    $_app_simple_help_cmdline = $args{help_cmdline} if ( $args{help_cmdline} );

    die "options must be a hashref" if ( ref( $args{options} ) ne 'HASH' );

    $args{options}->{'help|h|?'} = 'Show help';

    my @keys         = sort keys %{ $args{options} };
    my %dnames       = _desc_names(@keys);
    my $max_desc_len = max( map length, values %dnames ) + 1;
    my $help_fmt     = "    %-${max_desc_len}s    %s\n";

    # add help text for 'help' first.
    $_app_simple_help_options .= sprintf $help_fmt, $dnames{'help|h|?'}, 'Show help';

    # get options and their descriptions
    foreach my $o (@keys) {

        # save the option
        push @options, $o;

        my $name = $o;

        # we want the long version of the name if its provided
        $name =~ s/.*?(\w+).*/$1/;

        # remove any type data
        $name =~ s/=(.*)//;

        if ( ref( $args{options}->{$o} ) eq 'HASH' ) {
            die "parameterised option '$name' require a desc option"
                if ( !$args{options}->{$o}->{desc} );
            $full_options{$name} = $args{options}->{$o};
            $has_required++ if ( $full_options{$name}->{required} );
        }
        else {
            $full_options{$name} = {
                desc => $args{options}->{$o},

                # possible options that can be passed
                # depends => '',
                # default => '',
                # required => 0,
                # validate => sub {}
            };
        }

        # save the option string too
        $full_options{$name}->{options} = $o;

        # build the entry for the help text
        my $desc = $full_options{$name}->{desc};
        if ( $name ne 'help' ) {
            my $desc = $full_options{$name}->{desc};

            # show the right way to use the options
            my $dname = $dnames{$o};
            $dname .= '*' if ( $full_options{$name}->{required} );

            $desc .= " [DEFAULT: $full_options{$name}->{default}]" if ( $full_options{$name}->{default} );
            $_app_simple_help_options .= sprintf $help_fmt, $dname, $desc;
        }

    }

    # show required options
    if ($has_required) {
        $_app_simple_help_options .= "* required option" . ( $has_required > 1 ? 's' : '' ) . "\n";
    }

    # catch control-c, user provided or our default
    $_app_simple_ctrlc_handler = $args{ctrl_c} ? $args{ctrl_c} : \&_app_simple_ctrlc_func;
    $SIG{'INT'} = $_app_simple_ctrlc_handler;

    # get an cleanup function handler
    $_app_simple_cleanup_func = $args{cleanup} if ( $args{cleanup} );

    # check command line args
    GetOptions( \%_cmd_line_options, @options );

    # help is a built in
    show_usage() if ( $_cmd_line_options{help} );

    # now if we have the extended version we can do some checking
    foreach my $name ( sort keys %full_options ) {
        warn "Missing desc field for $name" if ( !$full_options{$name}->{desc} );
        if ( $full_options{$name}->{required} ) {
            show_usage( "Required option '$name' is missing", 1 ) if ( !( $_cmd_line_options{$name} || $full_options{$name}->{default} ) );
        }
        if ( $full_options{$name}->{depends} ) {
            if ( !$_cmd_line_options{ $full_options{$name}->{depends} } ) {
                show_usage( "Option '$name' depends on option '$full_options{$name}->{depends}' but it is missing", 1 );
            }
        }

        # set a default if there is no value
        if ( $full_options{$name}->{default} ) {
            $_cmd_line_options{$name} = $full_options{$name}->{default} if ( !$_cmd_line_options{$name} );
        }

        # call the validation routine if we have one
        if ( $_cmd_line_options{$name} && $full_options{$name}->{validate} ) {
            die "need to pass a coderef to validate for option '$name'" if ( !ref( $full_options{$name}->{validate} ) eq 'CODE' );
            die "Option '$name' has validate and should either also have a default or be required"
                if ( !( $full_options{$name}->{required} || $full_options{$name}->{default} ) );
            my $coderef = $full_options{$name}->{validate};
            my $result  = $coderef->( $_cmd_line_options{$name} );
            show_usage("Option '$name' does not pass validation") if ( !$result );
        }
    }

    return %_cmd_line_options;
}

# ----------------------------------------------------------------------------


sub get_program {
    return $PROGRAM;
}

# ----------------------------------------------------------------------------


sub get_options {
    return %_cmd_line_options;
}

# ----------------------------------------------------------------------------
# handle the ctrl-c presses

sub _app_simple_ctrlc_func {

    # exit if we are already in ctrlC
    exit(2) if ( $_app_simple_ctrlc_count++ );
    _output( 'STDERR', "\nCaught Ctrl-C. press again to exit immediately" );

    # re-init the handler
    $SIG{'INT'} = $_app_simple_ctrlc_handler;
}

# ----------------------------------------------------------------------------

# to help with testing we may want to die, which can be caught rather than
# exiting, so lets find out

sub _exit_or_die {
    my $state = shift || 1;

    if ($_test_mode) {
        STDERR->flush();
        STDOUT->flush();
        die "exit state $state";
    }
    exit($state);
}

# ----------------------------------------------------------------------------


sub show_usage {
    my ( $msg, $state ) = @_;

    my $help = qq{
Syntax: $PROGRAM [options] $_app_simple_help_cmdline

About:  $_app_simple_help_text

[options]
$_app_simple_help_options};
    if ($msg) {

        # if we have an error message it MUST go to STDERR
        # to make sure that any program the output is piped to
        # does not get the message to process
        _output( 'STDERR', "$help\nError: $msg\n" );
    }
    else {
        _output( 'STDOUT', $help );
    }

    _exit_or_die($state);
}

# ----------------------------------------------------------------------------


sub msg_exit {
    my ( $msg, $state ) = @_;

    _output( 'STDERR', $msg ) if ($msg);
    _exit_or_die($state);
}

# -----------------------------------------------------------------------------


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

    my $r = IPC::Cmd::run_forked( $command, \%args );

    return $r;
}

# ----------------------------------------------------------------------------


sub run_cmd {
    my $cmd = shift;

    # use our local version of path so that it can pass taint checks
    local $ENV{PATH} = $ENV{PATH};

    my ( $ret, $err, $full_buff, $stdout_buff, $stderr_buff ) = run( command => $cmd );

    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;
    return $file;
}

# ----------------------------------------------------------------------------
# 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;
}

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