validate results from the CPAN

App-Basis


    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 ;
        } elsif ( $opt =~ /^(.*?)$/ ) {
            $long = $1 ;
            if ( $seen{$long} ) {
                $result
                    = "flag '$long' has already been used. option line '$opt' is at fault"
                    ;
                last ;
            }

lib/App/Basis.pm view on Meta::CPAN

            if ( $seen{$short} ) {
                $result
                    = "flag '$short' has already been used. option line '$opt' is at fault"
                    ;
                last ;
            }
            if ( $seen{$extra} ) {
                $result
                    = "flag '$extra' has already been used. option line '$opt' is at fault"
                    ;
                last ;
            }
            $seen{$long}  = 1 ;
            $seen{$short} = 1 ;
            $seen{$extra} = 1 ;
        }
    }
    return $result ;
}

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


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

    #
    my $msg = _validate_options( $args{options} ) ;
    if ($msg) {
        die "$msg" ;
    }

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

    # auto set verbose if it has been used
    set_verbose( $_cmd_line_options{verbose} ) ;

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

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

lib/App/Basis.pm view on Meta::CPAN

    }
}


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

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

lib/App/Basis.pm view on Meta::CPAN

  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

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

( run in 1.202 second using v1.01-cache-2.11-cpan-39bf76dae61 )