File Coverage

blib/lib/App/Rad.pm

Criterion	Covered	Total	%
statement	3	5	60.0
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	5	7	71.4

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

our $VERSION = '1.05_01';
{

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

my @OPTIONS = ();

# - "I'm so excited! Feels like I'm 14 again" (edenc on Rad)
sub _init {
	my $c = shift;

	# instantiate references for the first time
	$c->{'_ARGV'}    = [];
	$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,
	};

	# create our standard global command
	$c->register( '', sub {} );

	#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]");
	}
    # add plugin to $c->plugins() list
    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}{CODE};
	    }
	}
	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{$_};
	    }
	}
}

sub _run_full_round {
	my $c   = shift;

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

 	my $cmd_obj = $c->{'_commands'}->{ $c->cmd };

	$c->debug('executing command...');
	$c->{'output'} = $cmd_obj->run($c, @_);

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

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

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

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

#TODO save_config

sub path {
	require FindBin;
	return $FindBin::Bin;
}

sub real_path {
	require FindBin;
	return $FindBin::RealBin;
}

# - "Wow! you guys rock!" (zoso on Rad)
#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 we receive a hash ref, it could be commands or
	    # rules for fetching commands.
	    if ( ref($item) ) {
            Carp::croak '"register_commands" may receive only HASH references'
                unless ref $item eq 'HASH';

            foreach my $params ( keys %{$item} ) {
                Carp::croak 'registered elements may only receive strings or hash references'
                    if ref $item->{$params} and ref $item->{$params} ne 'HASH';

                # we got a rule - push it in.
                if (   $params eq '-ignore_prefix'
                    or $params eq '-ignore_suffix'
                    or $params eq '-ignore_regexp'
                ) {
                    $rules{$params} = $item->{$params};
                }

                # not a rule, so it's either a command with
                # help text or a command with an argument list.
                # either way, we push it to our 'help' hash.
                else {
                    $help_for_sub{$params} = $item->{$params};
                }
            }
	    }
	    else {
            $help_for_sub{$item} = undef;    # no help text
	    }
	}

	# hack, prevents registering methods from App::Rad namespace when
	# using shell-mode - Al Newkirk (awnstudio)
	# my $caller = ( caller(2) or 'main' );
	my $caller =
	    (
	     caller(2) &&
	     caller(2) ne 'App::Rad' &&
	     caller(2) ne 'App::Rad::Shell'
	    ) ?
	    caller(2) : 'main';
	my %subs = _get_subs_from($caller);

	# handles explicit command calls first, as
	# they have priority over generic rules (below)
	foreach my $cmd ( 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'}->{$cmd} ) {

            if ( $cmd eq '-globals' ) {
                # use may set it as a flag to enable global arguments
                # or elaborate on each available argument
                # globals is a command named ''
                $c->register( '', sub {} );
                # TODO: help showing 'Global options:'
            }

            # user wants to register a valid (existant) sub
            elsif ( exists $subs{$cmd} ) {
                $c->register( $cmd, $subs{$cmd}, $help_for_sub{$cmd} );
            }
            else {
                Carp::croak "'$cmd' 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->register( $subname, $subs{$subname} );
                }
            }
	    }
	}
}

sub register_command { return register(@_) }

sub register {
    my ( $c, $command_name, $coderef, $extra ) = @_;

	# short circuit
	return unless ref $coderef eq 'CODE';

	my %command_options = (
	    name => $command_name,
	    code => $coderef,
	);

	# the extra parameter may be a help string
	# or an argument hashref
	if ($extra) {
	    if ( ref $extra ) {
            $command_options{opts} = $extra;
	    }
	    else {
            $command_options{help} = $extra;
	    }
	}

	my $cmd_obj = App::Rad::Command->new( \%command_options );
	return unless $cmd_obj;

	#TODO: I don't think this message is ever being printed (wtf?)
	$c->debug("registering $command_name as a command.");

	$c->{'_commands'}->{$command_name} = $cmd_obj;
	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 commands {
	return ( grep { $_ ne '' } keys %{ $_[0]->{'_commands'} } );
}

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

# TODO: turn 'command' into an alias for ->cmd
sub command : lvalue { $_[0]->{'cmd'} }
sub cmd     : lvalue { $_[0]->{'cmd'} }

# - "I'm loving having something else write up the 80% drudge
#   code for the small things." (benh on Rad)
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!)
    my $arg = App::Rad::Parser::parse_input($c);
    my $cmd_obj = $c->{'_commands'}->{$c->cmd};

    # handle special cases (default and invalid)
	if ( defined $arg ) {
	    $c->debug( "'$arg' is not a valid command. Falling to invalid." );
	    $cmd_obj->{code} = $c->{'_functions'}->{'invalid'};
	}
	elsif ( $c->cmd eq '' ) {
	    $c->debug('no command detected. Falling to default');
	    $cmd_obj->{code} = $c->{'_functions'}->{'default'};
	}

	# run the specified command
	$c->_run_full_round($cmd_obj, $arg);

	# 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;
	require App::Rad::Shell;
	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
	}

	# valid command, run it and return the command name
	if ( $c->is_command($cmd) ) {
	    my $cmd_obj = $c->{'_commands'}->{$cmd};

	    # set default values for command (if available)
	    App::Rad::Parser::set_defaults($cmd_obj);

	    $c->_run_full_round( $cmd_obj, @_ );
	    return $cmd;
	}
	else {
	    # if not a command, return undef
	    return;
	}
}

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

# get user information via prompting - Al Newkirk (awnstudio)
sub prompt { return App::Rad::Shell::prompt(@_); }

# $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
	#TODO: how the new parser copes with this?
	%{ $c->options } = ();

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

	my @tARGV = @ARGV;    # we gotta stick to our API
	#FIXME: line below doesn't work with new internal structure
	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'}->run($c);
}

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

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