File Coverage

blib/lib/MRP/Introspection.pm

Criterion	Covered	Total	%
statement	44	129	34.1
branch	10	50	20.0
condition	5	30	16.6
subroutine	10	20	50.0
pod	7	14	50.0
total	76	243	31.2

package MRP::Introspection;

use strict;
use Exporter;

use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS $VERSION);

$VERSION = 1.0;

@EXPORT_OK = qw (functions function functionsMatching
		 scalars   scalar
		 arrays    array
		 hashes    hash
		 recursiveFunction recursiveInheritance ISA);
%EXPORT_TAGS = ( ALL => [@EXPORT_OK] );

@ISA = qw (Exporter);

sub symTable ( $ ) {
  my ($package) = shift;
  $package = (ref $package || $package) . '::';
  no strict 'refs';
  return \%$package;
}

sub ISA ( $ ) {
  my $thingy = shift;
  my $isa = array($thingy, 'ISA', @_);
  return () unless defined $isa;
    (wantarray) ?
      (defined $isa) ? return @$isa : return () :
	return $isa;
}

sub functions( $ ) {
  my $thingy = shift;
  my %funcs;
  my ($name, $glob);

  while(($name, $glob) = each %{symTable $thingy}) {
    defined (*$glob{CODE}) && do { $funcs{$name} = \&$glob };
  }

  return %funcs;
}

sub functionsMatching( $$ ) {
  my ($thingy,$pattern)=@_;
  my %funcs;
  my ($name, $glob);

  while(($name, $glob) = each %{symTable $thingy}) {
    $name =~ /^$pattern$/ &&
      defined (*$glob{CODE}) && do { $funcs{$name} = \&$glob };
  }
  return %funcs;
}

sub scalars( $ ) {
  my $thingy = shift;
  my %scalars;
  my ($name, $glob);

  while(($name, $glob) = each %{symTable $thingy}) {
    defined ${*$glob{SCALAR}} && do { $scalars{$name} = \$$glob };
  }
  (wantarray) ?
    return %scalars :
      return \%scalars;
}

sub arrays( $ ) {
  my $thingy = shift;
  my %arrays;
  my ($name, $glob);

  while(($name, $glob) = each %{symTable $thingy}) {
    defined (*$glob{ARRAY}) && do { $arrays{$name} = \@$glob };
  }
  (wantarray)
    ? return %arrays
      : return \%arrays;
}

sub hashes( $ ) {
  my $thingy = shift;
  my %hashes;
  my ($name, $glob);

  while(($name, $glob) = each %{symTable $thingy}) {
    $name =~ /::$/ && next; # don't return nested symbol tables
    defined (*$glob{HASH}) && do { $hashes{$name} = \%$glob };
  }
  (wantarray) ?
    return %hashes :
      return \%hashes;
}

no strict 'refs';

sub function($$;$) {
  my ($thingy,$sym,$val) = @_;
  my $fullName = join '::', ref $thingy || $thingy, $sym;
  *{$fullName} = $_[2] if(@_ == 3);
  return *{$fullName}{CODE};
}

sub scalar ( $$;$ ) {
  my ($thingy,$sym,$val) = @_;
  my $fullName = join '::', ref $thingy || $thingy, $sym;
  ${$fullName} = $_[2] if(@_ == 3);
  return *{$fullName}{SCALAR};
}

sub array ( $$;@ ) {
  my ($thingy,$sym) = (shift,shift);
  my $fullName = join '::', ref $thingy || $thingy, $sym;
  @{$fullName} = @_ if(@_ or not defined wantarray);
  my $ref = *{$fullName}{ARRAY};
  if($ref) {
    return (wantarray)
      ? @$ref
	: $ref;
  }
  return;
}

sub hash ( $$;@ ) {
  my ($thingy,$sym) = (shift,shift);
  my $fullName = join '::', ref $thingy || $thingy, $sym;
  %{$fullName} = @_ if(@_ or not defined wantarray);
  my $ref = *{$fullName}{HASH};
  return (wantarray)
    ? %$ref
      : $ref;
}

sub recursiveFunction ( $$;@ ) {
  my ($thingy,$function) = (shift,shift);
  my $package = ref $thingy || $thingy;
  my %functions = $thingy->$function(@_);
  my %return;
  my ($key,$val);
  my @ISA = $thingy->ISA;
  while(($key, $val) = each %functions) {
    $return{join '::',$package,$key} = $val;
  }

  %return = map { recursiveFunction $_, $function, @_ } @ISA;

  (wantarray) ?
    return %return :
      return \%return;
}

sub recursiveInheritance ( $$;@ ) {
  my ($thingy,$function) = (shift,shift);
  my $package = ref $thingy || $thingy;
  my %functions = $thingy->$function(@_);
  my %return;
  my ($key,$val);
  while(($key, $val) = each %functions) {
    $return{join '::',$package,$key} = $val;
  }

  foreach my $isa (ISA($thingy)) {
    my %parentFuncs = recursiveInheritance($isa, $function, @_);
    foreach my $name (keys %parentFuncs) {
      my ($fname) = $name =~ /([^:]+)$/;
      $return{$name} = $parentFuncs{$name} unless exists $functions{$fname};
    }
  }

  (wantarray) ?
    return %return :
      return \%return;
}

sub superAUTOLOAD ( $$@ ) {
  my ($thingy,$value) = (shift,shift);
  my ($func,$name);
  foreach(ISA($thingy)) {
    $func = _setAUTOLOAD($_,$value);
    return $func if $func;
  }
}

sub _setAUTOLOAD ( $$ ) {
  my ($thingy,$value) = (@_);
  my ($func);
  if($func = function($thingy,'AUTOLOAD')) {
    MRP::Introspection::scalar($thingy,'AUTOLOAD',$value);
    return $func;
  }

  foreach(ISA($thingy)) {
    $func = _setAUTOLOAD($_,$value) and last;
  }

  return $func;
}

$VERSION;

__END__