File Coverage

blib/lib/App/Rad/Include.pm

Criterion	Covered	Total	%
statement	9	71	12.6
branch	0	20	0.0
condition			n/a
subroutine	3	11	27.2
pod	2	2	100.0
total	14	104	13.4

package App::Rad::Include;
use Carp qw/carp croak/;
use strict;
use warnings;

our $VERSION = '0.01';

sub load {
    my ($self, $c) = @_;
    $c->register('include', \&include, 'include one-liner as a command');
}

# translates one-liner into
# a complete, readable code
sub _get_oneliner_code {
    return _sanitize( _deparse($_[0]) );
}


#TODO: option to do it saving a backup file
# (behavior probably set via 'setup')
# inserts the string received
# (hopefully code) inside the
# user's program file as a 'sub'
sub _insert_code_in_file {
    my ($command_name, $code_text) = @_;

    my $sub =<<"EOSUB";
sub $command_name {
$code_text
}
EOSUB

    # tidy up the code, if Perl::Tidy is available
    eval "use Perl::Tidy ()";
    if (! $@) {
        my $new_code = '';
        Perl::Tidy::perltidy( argv => '', source => \$sub, destination => \$new_code );
        $sub = $new_code;
    }

#TODO: flock
#    eval {
#        use 'Fcntl qw(:flock)';
#    }
#    if ($@) {
#        carp 'Could not load file locking module';
#    }

    #TODO: I really should be using PPI
    #if the user has it installed...
    #or at least a decent parser
    open my $fh, '+<', $0
        or croak "error updating file $0: $!\n";

#    flock($fh, LOCK_EX) or carp "could not lock file $0: $!\n";

    my @file = <$fh>;
    _insert_code_into_array(\@file, $sub);

    # TODO: only change the file if
    # it's eval'd without errors
    seek ($fh, 0, 0) or croak "error seeking file $0: $!\n";
    print $fh @file or croak "error writing to file $0: $!\n";
    truncate($fh, tell($fh)) or croak "error truncating file $0: $!\n";

    close $fh;
}


sub _insert_code_into_array {
    my ($file_array_ref, $sub) = @_;
    my $changed = 0;

    $sub = "\n\n" . $sub . "\n\n";

    my $line_id = 0;
    while ( $file_array_ref->[$line_id] ) {

        # this is a very rudimentary parser. It assumes a simple
        # vanilla application as shown in the main example, and
        # tries to include the given subroutine just after the
        # App::Rad->run(); call.
        next unless $file_array_ref->[$line_id] =~ /App::Rad->run/;

        # now we add the sub (hopefully in the right place)
        splice (@{$file_array_ref}, $line_id + 1, 0, $sub);
        $changed = 1;
        last;
    }
    continue {
        $line_id++;
    }
    if ( not $changed ) {
        croak "error finding 'App::Rad->run' call. $0 does not seem a valid App::Rad application.\n";
    }
}


# deparses one-liner into a working subroutine code
sub _deparse {

    my $arg_ref = shift;

    # create array of perl command-line
    # parameters passed to this one-liner
    my @perl_args = ();
    while ( $arg_ref->[0] =~ m/^-/o ) {
        push @perl_args, (shift @{$arg_ref});
    }

    #TODO: I don't know if "O" and
    # "B::Deparse" can actually run the same way as
    # a module as it does via -MO=Deparse.
    # and while I can't figure out how to use B::Deparse
    # to do exactly what it does via 'compile', I should
    # at least catch the stderr buffer from qx via
    # IPC::Cmd's run(), but that's another TODO
    my $deparse = join ' ', @perl_args;
    my $code = $arg_ref->[0];
    my $body = qx{perl -MO=Deparse $deparse '$code'};
    return $body;
}


# tries to adjust a subroutine into
# App::Rad's API for commands
sub _sanitize {
    my $code = shift;

    # turns BEGIN variables into local() ones
    $code =~ s{(?:local\s*\(?\s*)?(\$\^I|\$/|\$\\)}
              {local ($1)}g;

    # and then we just strip any BEGIN blocks
    $code =~ s{BEGIN\s*\{\s*(.+)\s*\}\s*$}
              {$1}mg;

    my $codeprefix =<<'EOCODE';
my $c = shift;

EOCODE
    $code = $codeprefix . $code;

    return $code;
}


# includes a one-liner as a command.
# TODO: don't let the user include
# a control function!!!!
sub include {
    my $c = shift;

    my @args = @ARGV;

    if( @args < 3 ) {
        return "Sintax: $0 include [name] -perl_params 'code'.\n";
    }

    # figure out the name of
    # the command to insert.
    # Either the user chose it already
    # or we choose it for the user
    my $command_name = '';
    if ( $args[0] !~ m/^-/o ) {
        $command_name = shift @args;

        # don't let the user add a command
        # that already exists
        if ( $c->is_command($command_name) ) {
            return "Command '$command_name' already exists. Please remove it first with '$0 exclude $command_name";
        }
    }
    else {
        $command_name = $c->create_command_name();
    }
    $c->debug("including command '$command_name'...");

    my $code_text = _get_oneliner_code(\@args);

    _insert_code_in_file($command_name, $code_text);

    # turns code string into coderef so we
    # can register it (just in case the user
    # needs to run it right away)
    my $code_ref = sub { eval $code_text};
    $c->register($command_name, $code_ref);

    return;
}

42;
__END__