File Coverage

blib/lib/Astro/App/Satpass2/Macro/Code.pm

Criterion	Covered	Total	%
statement	27	51	52.9
branch	2	12	16.6
condition	2	9	22.2
subroutine	8	12	66.6
pod	5	5	100.0
total	44	89	49.4

package Astro::App::Satpass2::Macro::Code;

use 5.008;

use strict;
use warnings;

use parent qw{ Astro::App::Satpass2::Macro };

use Astro::App::Satpass2::Utils qw{
    expand_tilde
    load_package
    quoter
    @CARP_NOT
};
use File::Spec;

our $VERSION = '0.051_01';

sub init {
    my ( $self ) = @_;
    $self->SUPER::init();
    my $parent = $self->parent();
    my %popt = ( complaint => 'wail', fatal => 'wail' );
    exists $self->{lib}
	and $popt{lib} = $self->expand_tilde( $self->{lib} );
    defined $self->{lib}
	and not $self->{relative}
	and not $self->{lib} =~ m/ \A ~ /smx
	and $self->{lib} = File::Spec->rel2abs( $self->{lib} );
    my $module = $self->load_package(
	\%popt, $self->name(), 'Astro::App::Satpass2::Macro::Code'
    );
    $module->isa( 'Astro::App::Satpass2' )
	or $self->wail( "$module is not a subclass of Astro::App::Satpass2" );

    my %implements;		# Names and references to found code
    my $stb = "${module}::";	# Name of loaded symbol table

    # Fairly deep magic begins here. We need symbolic references to
    # traverse the symbol table of the loaded code, so:
    no strict qw{ refs };

    foreach my $name ( keys %$stb ) {
	my $val = $stb->{$name};

	# We are only interested in symbols that start with word
	# characters, excluding '_'
	$name =~ m/ \A \w /smx
	    and not $name =~ m/ \A _ /smx
	    or next;

	# We need a reference to the entry's glob, which we obtain by
	# symbolic reference.
	my $glob = \$val;

	# If the code slot is empty we ignore it.
	*{$glob}{CODE}
	    or next;

	# If the code does not have the Verb() attribute, we ignore it.
	# TODO technically we have an encapsulation failure here which
	# needs to be fixed up.
	$parent->__get_attr( *{$glob}{CODE}, 'Verb' )
	or next;

	# Record the fact that the module defines this name.
	$implements{$name} = *{$glob}{CODE};
    }

    # End of symbol table magic.
    $self->{implements} = \%implements;
    return;
}

sub execute {
    my ( $self, $name, @args ) = @_;
    my $code = $self->implements( $name, required => 1 );
    return $code->( $self->parent(), @args );
}

sub has_lib {
    my ( $self ) = @_;
    return exists $self->{lib};
}

sub lib {
    my ( $self ) = @_;
    return $self->{lib};
}

sub relative {
    my ( $self ) = @_;
    return $self->{relative};
}

1;

__END__