File: //usr/local/lib64/perl5/Cpanel/Class/Meta/Package.pm
package Cpanel::Class::Meta::Package;
use strict;
use warnings;
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype';
use base 'Cpanel::Class::Meta::Object';
our $VERSION = '1.0.5';
sub name { $_[0]->{'$!package'} }
sub namespace {
no strict 'refs';
\%{ $_[0]->name . '::' };
}
{
my %SIGIL_MAP = (
'$' => 'SCALAR',
'@' => 'ARRAY',
'%' => 'HASH',
'&' => 'CODE',
);
sub _deconstruct_variable_name {
my ( $self, $variable ) = @_;
( defined $variable )
|| confess "You must pass a variable name";
my ( $sigil, $name ) = ( $variable =~ /^(.)(.*)$/ );
( defined $sigil )
|| confess "The variable name must include a sigil";
( exists $SIGIL_MAP{$sigil} )
|| confess "I do not recognize that sigil '$sigil'";
return ( $name, $sigil, $SIGIL_MAP{$sigil} );
}
}
sub list_all_package_symbols {
my ( $self, $type_filter ) = @_;
return keys %{ $self->namespace } unless defined $type_filter;
# NOTE:
# or we can filter based on
# type (SCALAR|ARRAY|HASH|CODE)
my $namespace = $self->namespace;
return grep { ( ref( $namespace->{$_} ) ? ( ref( $namespace->{$_} ) eq 'SCALAR' && $type_filter eq 'CODE' ) : ( ref( \$namespace->{$_} ) eq 'GLOB' && defined( *{ $namespace->{$_} }{$type_filter} ) ) ); } keys %{$namespace};
}
sub get_package_symbol {
my ( $self, $variable ) = @_;
my ( $name, $sigil, $type ) = $self->_deconstruct_variable_name($variable);
$self->add_package_symbol($variable)
unless exists $self->namespace->{$name};
if ( ref( $self->namespace->{$name} ) eq 'SCALAR' ) {
if ( $type eq 'CODE' ) {
no strict 'refs';
return \&{ $self->name . '::' . $name };
}
else {
return undef;
}
}
else {
return *{ $self->namespace->{$name} }{$type};
}
}
sub add_package_symbol {
my ( $self, $variable, $initial_value ) = @_;
my ( $name, $sigil, $type ) = $self->_deconstruct_variable_name($variable);
no strict 'refs';
no warnings 'redefine', 'misc';
*{ $self->name . '::' . $name } = ref $initial_value ? $initial_value : \$initial_value;
}
sub has_package_symbol {
my ( $self, $variable ) = @_;
my ( $name, $sigil, $type ) = $self->_deconstruct_variable_name($variable);
return 0 unless exists $self->namespace->{$name};
if ( ref( $self->namespace->{$name} ) eq 'SCALAR' ) {
return ( $type eq 'CODE' ? 1 : 0 );
}
elsif ( $type eq 'SCALAR' ) {
my $val = *{ $self->namespace->{$name} }{$type};
return defined( ${$val} ) ? 1 : 0;
}
else {
defined( *{ $self->namespace->{$name} }{$type} ) ? 1 : 0;
}
}
sub remove_package_glob {
my ( $self, $name ) = @_;
no strict 'refs';
delete ${ $self->name . '::' }{$name};
}
sub remove_package_symbol {
my ( $self, $variable ) = @_;
my ( $name, $sigil, $type ) = $self->_deconstruct_variable_name($variable);
my ( $scalar, $array, $hash, $code );
if ( $type eq 'SCALAR' ) {
$array = $self->get_package_symbol( '@' . $name ) if $self->has_package_symbol( '@' . $name );
$hash = $self->get_package_symbol( '%' . $name ) if $self->has_package_symbol( '%' . $name );
$code = $self->get_package_symbol( '&' . $name ) if $self->has_package_symbol( '&' . $name );
}
elsif ( $type eq 'ARRAY' ) {
$scalar = $self->get_package_symbol( '$' . $name ) if $self->has_package_symbol( '$' . $name );
$hash = $self->get_package_symbol( '%' . $name ) if $self->has_package_symbol( '%' . $name );
$code = $self->get_package_symbol( '&' . $name ) if $self->has_package_symbol( '&' . $name );
}
elsif ( $type eq 'HASH' ) {
$scalar = $self->get_package_symbol( '$' . $name ) if $self->has_package_symbol( '$' . $name );
$array = $self->get_package_symbol( '@' . $name ) if $self->has_package_symbol( '@' . $name );
$code = $self->get_package_symbol( '&' . $name ) if $self->has_package_symbol( '&' . $name );
}
elsif ( $type eq 'CODE' ) {
$scalar = $self->get_package_symbol( '$' . $name ) if $self->has_package_symbol( '$' . $name );
$array = $self->get_package_symbol( '@' . $name ) if $self->has_package_symbol( '@' . $name );
$hash = $self->get_package_symbol( '%' . $name ) if $self->has_package_symbol( '%' . $name );
}
else {
confess "This should never ever ever happen";
}
$self->remove_package_glob($name);
$self->add_package_symbol( ( '$' . $name ) => $scalar ) if defined $scalar;
$self->add_package_symbol( ( '@' . $name ) => $array ) if defined $array;
$self->add_package_symbol( ( '%' . $name ) => $hash ) if defined $hash;
$self->add_package_symbol( ( '&' . $name ) => $code ) if defined $code;
}
sub find_all_methods_by_name {
my ( $self, $method_name ) = @_;
( defined $method_name && $method_name )
|| confess "You must define a method name to find";
my @methods;
foreach my $class ( $self->linearized_isa ) {
# fetch the meta-class ...
my $meta = $self->initialize($class);
push @methods => {
name => $method_name,
class => $class,
code => $meta->get_method($method_name)
} if $meta->has_method($method_name);
}
return @methods;
}
1;