File Coverage

blib/lib/App/Rad.pm

Criterion	Covered	Total	%
statement	147	223	65.9
branch	42	86	48.8
condition	10	17	58.8
subroutine	27	42	64.2
pod	28	28	100.0
total	254	396	64.1

package App::Rad;
use 5.006;
use App::Rad::Help;
use Carp                ();
use warnings;
use strict;

our $VERSION = '1.05';
{

#========================#
#   INTERNAL FUNCTIONS   #
#========================#

my @OPTIONS = ();

sub _init {
    my $c = shift;

    # instantiate references for the first time
    $c->{'_ARGV'    } = [];
    $c->{'_options'} = {};
    $c->{'_stash'  } = {};
    $c->{'_config' } = {};
    $c->{'_plugins'} = [];

    # this internal variable holds
    # references to all special
    # pre-defined control functions
    $c->{'_functions'} = {
        'setup'        => \&setup,
        'pre_process'  => \&pre_process,
        'post_process' => \&post_process,
        'default'      => \&default,
        'invalid'      => \&invalid,
        'teardown'     => \&teardown,
    };

    #load extensions
    App::Rad::Help->load($c);
    foreach (@OPTIONS) {
        if ($_ eq 'include') {
            eval 'use App::Rad::Include; App::Rad::Include->load($c)';
            Carp::croak 'error loading "include" extension.' if ($@);
        }
        elsif ($_ eq 'exclude') {
            eval 'use App::Rad::Exclude; App::Rad::Exclude->load($c)';
            Carp::croak 'error loading "exclude" extension.' if ($@);
        }
        elsif ($_ eq 'debug') {
            $c->{'debug'} = 1;
        }
        else {
        	$c->load_plugin($_);
        }
	}

    # tiny cheat to avoid doing a lot of processing
    # when not in debug mode. If needed, I'll create
    # an actual is_debugging() method or something
    if ($c->{'debug'}) {
        $c->debug('initializing: default commands are: '
            . join ( ', ', $c->commands() )
        );
    }
}

sub import {
    my $class = shift;
    @OPTIONS  = @_;
}

sub load_plugin {
    my $c      = shift;
    my $plugin = shift;
	my $class  = ref $c;

    my $plugin_fullname = '';
	if ($plugin =~ s{^\+}{} ) {
		$plugin_fullname = $plugin;
	}
    else {
        $plugin_fullname = "App::Rad::Plugin::$plugin";
    }
	eval "use $plugin_fullname ()";
    Carp::croak "error loading plugin '$plugin_fullname': $@\n"
        if $@;
    my %methods = _get_subs_from($plugin_fullname);

    Carp::croak "No methods found for plugin '$plugin_fullname'\n"
		unless keys %methods > 0;

	no strict 'refs';
	foreach my $method (keys %methods) {
        # don't add plugin's internal methods
        next if substr ($method, 0, 1) eq '_';

		*{"$class\::$method"} = $methods{$method};
		$c->debug("-- method '$method' added [$plugin_fullname]");

        # fill $c->plugins()
        push @{ $c->{'_plugins'} }, $plugin;
	}
}

# this function browses a file's
# symbol table (usually 'main') and maps
# each function to a hash
#
# FIXME: if I create a sub here (Rad.pm) and
# there is a global variable with that same name
# inside the user's program (e.g.: sub ARGV {}),
# the name will appear here as a command. It really
# shouldn't...
sub _get_subs_from {
    my $package = shift || 'main';
    $package .= '::';

    my %subs = ();

    no strict 'refs';
    while (my ($key, $value) = ( each %{*{$package}} )) {
        local (*SYMBOL) = $value;
        if ( defined $value && defined *SYMBOL{CODE} ) {
            $subs{$key} = $value;
        }
    }
    return %subs;
}


# overrides our pre-defined control
# functions with any available
# user-defined ones
sub _register_functions {
    my $c = shift;
    my %subs = _get_subs_from('main');

    # replaces only if the function is
    # in 'default', 'pre_process' or 'post_process'
    foreach ( keys %{$c->{'_functions'}} ) {
        if ( defined $subs{$_} ) {
            $c->debug("overriding $_ with user-defined function.");
            $c->{'_functions'}->{$_} = $subs{$_};
        }
    }
}

# retrieves command line arguments
# to be executed by the main program
sub _get_input {
    my $c = shift;

    my $cmd = (defined ($ARGV[0]) and substr($ARGV[0], 0, 1) ne '-')
            ? shift @ARGV
            : ''
            ;

    @{$c->argv} = @ARGV;
    $c->{'cmd'} = $cmd;

    $c->debug('received command: ' . $c->{'cmd'});
    $c->debug('received parameters: ' . join (' ', @{$c->argv} ));

    $c->_tinygetopt();
}

# stores arguments passed to a
# command via --param[=value] or -p
sub _tinygetopt {
    my $c = shift;

    my @argv = ();
    foreach ( @{$c->argv} ) {

        # single option (could be grouped)
        if ( m/^\-([^\-\=]+)$/o) {
            my @args = split //, $1;
            foreach (@args) {
				if ($c->options->{$_}) {
					$c->options->{$_}++;
				}
				else {
					$c->options->{$_} = 1;
				}
            }
        }
        # long option: --name or --name=value
        elsif (m/^\-\-([^\-\=]+)(?:\=(.+))?$/o) {
            $c->options->{$1} = defined $2 ? $2
			                  : 1
                              ;
        }
        else {
            push @argv, $_;
        }
    }
    @{$c->argv} = @argv;
}


#========================#
#     PUBLIC METHODS     #
#========================#

sub load_config {
    require App::Rad::Config;
    App::Rad::Config::load_config(@_);
}


#TODO: this code probably could use some optimization
sub register_commands {
    my $c = shift;
    my %help_for_sub = ();
    my %rules = ();

    # process parameters
    foreach my $item (@_) {
        if ( ref ($item) ) {
            Carp::croak '"register_commands" may receive only HASH references'
                unless ref ($item) eq 'HASH';
            foreach my $params (keys %{$item}) {
                if ($params eq '-ignore_prefix'
                 or $params eq '-ignore_suffix'
                 or $params eq '-ignore_regexp'
                ) {
                    $rules{$params} = $item->{$params};
                }
                else {
                    $help_for_sub{$params} = $item->{$params};
                }
            }
        }
        else {
            $help_for_sub{$item} = undef; # no help text
        }
    }

    my %subs = _get_subs_from('main');

    foreach (keys %help_for_sub) {

        # we only add the sub to the commands
        # list if it's *not* a control function
        if ( not defined $c->{'_functions'}->{$_} ) {

            # user want to register a valid (existant) sub
            if ( exists $subs{$_} ) {
                $c->debug("registering $_ as a command.");
                $c->{'_commands'}->{$_}->{'code'} = $subs{$_};
                App::Rad::Help->register_help($c, $_, $help_for_sub{$_});
            }
            else {
                Carp::croak "'$_' does not appear to be a valid sub. Registering seems impossible.\n";
            }
        }
    }

    # no parameters, or params+rules: try to register everything
    if ((!%help_for_sub) or %rules) {
        foreach my $subname (keys %subs) {

            # we only add the sub to the commands
            # list if it's *not* a control function
            if ( not defined $c->{'_functions'}->{$subname} ) {

                if ( $rules{'-ignore_prefix'} ) {
                    next if ( substr ($subname, 0, length($rules{'-ignore_prefix'}))
                           eq $rules{'-ignore_prefix'}
                            );
                }
                if ( $rules{'-ignore_suffix'} ) {
                    next if ( substr ($subname,
                                      length($subname) - length($rules{'-ignore_suffix'}),
                                      length($rules{'-ignore_suffix'})
                                     )
                              eq $rules{'-ignore_suffix'}
                            );
                }
                if ( $rules{'-ignore_regexp'} ) {
                    my $re = $rules{'-ignore_regexp'};
                    next if $subname =~ m/$re/o;
                }

                # avoid duplicate registration
                if ( !exists $help_for_sub{$subname} ) {
                    $c->{'_commands'}->{$subname}->{'code'} = $subs{$subname};
                    App::Rad::Help->register_help($c, $subname, undef);
                }
            }
        }
    }
}


sub register_command { return register(@_) }
sub register {
    my ($c, $command_name, $coderef, $helptext) = @_;
    $c->debug("got: " . ref $coderef);
    return undef
        unless ( (ref $coderef) eq 'CODE' );

    $c->debug("registering $command_name as a command.");
    $c->{'_commands'}->{$command_name}->{'code'} = $coderef;
    App::Rad::Help->register_help($c, $command_name, $helptext);
    return $command_name;
}

sub unregister_command { return unregister(@_) }
sub unregister {
    my ($c, $command_name) = @_;

    if ( $c->{'_commands'}->{$command_name} ) {
        delete $c->{'_commands'}->{$command_name};
    }
    else {
        return undef;
    }
}


sub create_command_name {
    my $id = 0;
    foreach (commands()) {
        if ( m/^cmd(\d+)$/ ) {
            $id = $1 if ($1 > $id);
        }
    }
    return 'cmd' . ($id + 1);
}


sub commands {
    return ( keys %{$_[0]->{'_commands'}} );
}


sub is_command {
    my ($c, $cmd) = @_;
    return (defined $c->{'_commands'}->{$cmd}
            ? 1
            : 0
           );
}

sub command :lvalue { cmd(@_) }
sub cmd :lvalue {
    $_[0]->{'cmd'};
}


sub run {
    my $class = shift;
    my $c = {};
    bless $c, $class;

    $c->_init();

    # first we update the control functions
    # with any overriden value
    $c->_register_functions();

    # then we run the setup to register
    # some commands
    $c->{'_functions'}->{'setup'}->($c);

    # now we get the actual input from
    # the command line (someone using the app!)
    $c->_get_input();

    # run the specified command
    $c->execute();

    # that's it. Tear down everything and go home :)
    $c->{'_functions'}->{'teardown'}->($c);

    return 0;
}

# run operations
# in a shell-like environment
#sub shell {
#    my $class = shift;
#    App::Rad::Shell::shell($class);
#}

sub execute {
    my ($c, $cmd) = @_;

    # given command has precedence
    if ($cmd) {
        $c->{'cmd'} = $cmd;
    }
    else {
        $cmd = $c->{'cmd'};  # now $cmd always has the called cmd
    }

    $c->debug('calling pre_process function...');
    $c->{'_functions'}->{'pre_process'}->($c);

    $c->debug("executing '$cmd'...");

    # valid command, run it
    if ($c->is_command($c->{'cmd'}) ) {
        $c->{'output'} = $c->{'_commands'}->{$cmd}->{'code'}->($c);
    }
    # no command, run default()
    elsif ( $cmd eq '' ) {
        $c->debug('no command detected. Falling to default');
        $c->{'output'} = $c->{'_functions'}->{'default'}->($c);
    }
    # invalid command, run invalid()
    else {
        $c->debug("'$cmd' is not a valid command. Falling to invalid.");
        $c->{'output'} = $c->{'_functions'}->{'invalid'}->($c);
    }

    # 3: post-process the result
    # from the command
    $c->debug('calling post_process function...');
    $c->{'_functions'}->{'post_process'}->($c);

    $c->debug('reseting output');
    $c->{'output'} = undef;
}

sub argv    { return $_[0]->{'_ARGV'}     }
sub options { return $_[0]->{'_options'} }
sub stash   { return $_[0]->{'_stash'}   }
sub config  { return $_[0]->{'_config'}  }

# $c->plugins is sort of "read-only" externally
sub plugins {
    my @plugins = @{$_[0]->{'_plugins'}};
    return @plugins;
}


sub getopt {
    require Getopt::Long;
    Carp::croak "Getopt::Long needs to be version 2.36 or above"
        unless $Getopt::Long::VERSION >= 2.36;

    my ($c, @options) = @_;

    # reset values from tinygetopt
    $c->{'_options'} = {};

    my $parser = new Getopt::Long::Parser;
    $parser->configure( qw(bundling) );

    my @tARGV = @ARGV; # we gotta stick to our API
    my $ret = $parser->getoptions($c->{'_options'}, @options);
    @{$c->argv} = @ARGV;
    @ARGV = @tARGV;

    return $ret;
}

sub debug {
    if (shift->{'debug'}) {
        print "[debug]   @_\n";
    }
}

# gets/sets the output (returned value)
# of a command, to be post processed
sub output {
    my ($c, @msg) = @_;
    if (@msg) {
        $c->{'output'} = join(' ', @msg);
    }
    else {
        return $c->{'output'};
    }
}


#=========================#
#     CONTROL FUNCTIONS   #
#=========================#

sub setup { $_[0]->register_commands( {-ignore_prefix => '_'} ) }

sub teardown {}

sub pre_process {}

sub post_process {
    my $c = shift;

    if ($c->output()) {
        print $c->output() . $/;
    }
}


sub default {
    my $c = shift;
    return $c->{'_commands'}->{'help'}->{'code'}->($c);
}


sub invalid {
    my $c = shift;
    return $c->{'_functions'}->{'default'}->($c);
}


}
42; # ...and thus ends thy module  ;)
__END__