view release on metacpan or  search on metacpan

lib/Astro/App/Satpass2/Macro/Code.pm  view on Meta::CPAN

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.057';

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 alphabetics.
	$name =~ m/ \A [[:alpha:]] /smx
	    or next;

	# We do not want symbols unless they contain at least one
	# lower-case character.
	$name =~ m/ [[:lower:]] /smx
	    or next;

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

	# If $name refers to an inlineable function, $val is going to be
	# its value. This is not what we want, so ...
	'GLOB' eq ref $glob
	    or next;

	# 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;
}