File Coverage

blib/lib/Inline/Wrapper/Module.pm

Criterion	Covered	Total	%
statement	111	125	88.8
branch	21	42	50.0
condition	0	2	0.0
subroutine	26	29	89.6
pod	2	2	100.0
total	160	200	80.0

package Inline::Wrapper::Module;
#
#   Inline::* module dynamic loader and useful wrapper routines
#
#   Individual module handler object
#
#   $Id: Module.pm 14 2010-03-10 09:08:18Z infidel $
#
#   POD documentation after __END__
#

use strict;
use warnings;
use Carp qw( carp croak );
use Data::Dumper;
use base qw( Inline::Wrapper );
use Inline;
use vars qw( $TRUE $FALSE $VERSION );

###
### VARS
###

($VERSION) = q$Revision: 14 $ =~ /(\d+)/;
*TRUE    = \1;
*FALSE   = \0;

my $PARAMS = {
    module_name => sub { $_[0] },
    lang_ext    => sub { $_[0] },
};

###
### INITIALIZER
###

sub new
{
    my( $class, @args ) = @_;

    croak "Do not use this class directly; used internally by Inline::Wrapper"
        unless( caller eq 'Inline::Wrapper' );

    return( $class->SUPER::new( @args ) );
}

sub initialize
{
    my( $self, @args ) = @_;

    # Check parameters
    @args = %{ $args[0] } if( ref( $args[0] ) eq 'HASH' );
    croak "initialize(): \%args must be a hash; read the docs"
        if( @args & 1 );
    my %args = @args;

    for( keys %args )
    {
        next unless( exists( $PARAMS->{lc $_} ) );      # ignore unwanted args
        $self->{lc $_} = $PARAMS->{lc $_}->( $args{$_} );
        delete( $args{$_} );
    }

    $self->_set_function_list( [] );
    $self->_set_last_load_time( 0 );

    return;
}

###
### DESTRUCTOMATIC!
###

sub DESTROY
{
    my( $self ) = @_;

    $self->_delete_namespace();

    return;
}

###
### PRIVATE METHODS
###

# Load the self-corresponding sub-language code module.
# At this point in time, we should be a complete object.
sub _load
# "He who fights with monsters should be careful lest he thereby become a
# monster..."
{
    my( $self ) = @_;

    my $module_src = $self->_read_module_source();
    my $namespace  = $self->_namespace();

    # Try to bind via Inline::$language
    $self->_delete_namespace();
    # BugFix: For some reason, the package stash changed between
    # 5.11.1 and >= 5.11.1 commit-id 81693ff90925b7d196d1f339fa6f85555e38cab7
    # Needed to add own module name into the grep -v list.
    my $code = sprintf(q#package %s::%s;
                         use Inline;
                         Inline->bind( %s => $module_src );
                         package %s;
                         return( grep { !/^(?:BEGIN|ISA|Inline)$/ }
                                 keys %%%s::%s:: )#,
                        __PACKAGE__,        $namespace,
                        $self->language(),
                        __PACKAGE__,
                        __PACKAGE__,        $namespace );

    # DEAR LORD, STRING EVAL!  RUN AWAY!
    # http://perlmonks.org/index.pl?node_id=732598
    my @symbols = eval $code;
    if( $@ )
    {
        chomp $@;
        carp "Error compiling " . $self->_module_path() . ": '$@'";
        return();
    }

    # Update our state
    $self->_set_function_list( @symbols );
    $self->_set_last_load_time( time );

    # return loaded symbol list
    return( @symbols );
}

# Actually run the associated function and return its @retvals
sub _run
# ".. And if thou gaze long into an abyss, the abyss will also gaze into thee."
{
    my( $self, $funcname, @args ) = @_;
    croak "run(): $funcname is a required param; read the docs"
        unless( $funcname );

    $self->_load() if( $self->_issue_reload() );

    croak "run(): $funcname not found"
        unless( $self->_func_exists( $funcname ) );

    # Attempt to pull coderef out of package namespace
    my $namespace = $self->_namespace();
    my $sub = \&{__PACKAGE__ . "::${namespace}::${funcname}"};
    carp "No such module or function: '$namespace'::'$funcname'", return
        unless( ref( $sub ) eq 'CODE' );

    # Attempt to execute coderef
    my @retvals = eval { $sub->( @args ) };  # Ahhh, block eval.
    chomp $@ if( $@ );
    carp "Error executing ${namespace}::${funcname}: $@", return
        if( $@ );

    return( @retvals );
}

# Fairly self-explanatory.
sub _read_module_source
{
    my( $self ) = @_;

    my $path = $self->_module_path();

    open( my $fd, '<', $path )
        or carp "$path is inaccessible: $!", return( undef );
    my $module_src = do { local $/; <$fd> };
    close( $fd );

    return( $module_src );
}

sub _delete_namespace
{
    my( $self ) = @_;

    my $namespace = $self->_namespace();
    no strict 'refs';
    my $wiped     = delete( ${__PACKAGE__.'::'}{$namespace.'::'} );

    return( $wiped ? $TRUE : $FALSE );
}

###
### ACCESSORS
###

sub _module_name
{
    my( $self ) = @_;

    return( $self->{module_name} );
}

sub _set_module_name
{
    my( $self, $modname ) = @_;

    # Validate
    $modname = $PARAMS->{module_name}->( $modname );

    return( $modname
              ? $self->{module_name} = $modname
              : $self->{module_name} );
}

sub _function_list
{
    my( $self ) = @_;

    return( keys %{ $self->{functions} } );
}

sub _set_function_list
{
    my( $self, @funcs ) = @_;

    @funcs = @{ $funcs[0] } if( ref( $funcs[0] ) );

    return( $self->{functions} = { map { $_ => $TRUE } @funcs } );
}

sub _func_exists
{
    my( $self, $funcname ) = @_;

    return( exists( $self->{functions}->{$funcname} ) );
}

sub _last_load_time
{
    my( $self ) = @_;

    return( $self->{last_load_time} );
}

sub _set_last_load_time
{
    my( $self, $load_time ) = @_;

    return( $load_time =~ /^\d+$/
              ? $self->{last_load_time} = $load_time
              : $self->{last_load_time} );
}

###
### UTILITY ROUTINES
###

# Overload the parent classes' _lang_ext, as we've stored this as an attr
sub _lang_ext
{
    my( $self ) = @_;

    return( $self->{lang_ext} );
}

# Return boolean if source file has been updated
sub _issue_reload
{
    my( $self ) = @_;
    return( $FALSE ) unless( $self->auto_reload() );

    my $file_mod_time = $self->_module_mtime();

    return( $self->_last_load_time < $self->_module_mtime ? $TRUE : $FALSE );
}

# Return file modificiation time
sub _module_mtime
{
    my( $self ) = @_;

    my $path = $self->_module_path();

    return( (stat $path)[9] || 0 );
}

# What is our namespace, based on our object state?
# XXX: I don't think this is unique.
sub _namespace
{
    my( $self ) = @_;

    my $modname = $self->_module_name();
    $modname =~ s#[/\\]#_#;

    return( $modname );
}

# What is our path, based on our object state?
sub _module_path
{
    my( $self ) = @_;

    my $modname  = $self->_module_name();
    my $file_ext = $self->_lang_ext();
    my $src_file = ( $modname =~ m/.*\Q$file_ext\E$/ )
                     ? $modname
                     : $modname . $file_ext;
    my $path = _path_join( $self->base_dir(), $src_file );

    return( $path );
}

# Generate a joined path from @_
sub _path_join
{
    ref( $_[0] ) and shift;     # scrap instance ref, if passed

    my $pathchar = ( $^O eq 'MSWin32' ) ? "\\" : '/';
    return( join( $pathchar, @_ ) );
}

1;

__END__