File Coverage

/.cpan/build/MOP-1.00-B2YG7M/blib/lib/MOP/MOP.pm

Criterion	Covered	Total	%
statement	40	40	100.0
branch	12	16	75.0
condition			n/a
subroutine	9	9	100.0
pod	2	3	66.6
total	63	68	92.6

###########################################
#    A Meta-Objects Protocol for Perl5    #
###########################################
# (c) Rodolphe Ortalo, 1997-1998
#Included in the ESOPE project of LAAS-CNRS

#$Id: MOP.pm,v 1.3 1999/02/10 15:16:41 ortalo Exp $

package MOP::MOP;

use strict;
use vars qw($VERSION);

$VERSION = '1.00';

use Filter::Util::Call;

#######################################
#    FILTER TRANSFORMATION FUNCTION   #
# Warning: black magic occuring here! #
#######################################

# At import time, the importer SOURCE CODE is
# MODIFIED to enable redirection of the reflective
# methods.
sub import
{
    my $type = shift;
    if (@_) {
	# We have some methods to make reflective
	my $pattern = join('|', @_);
	filter_add(
		   sub {
		       my ($status);
		       my $match = s/sub\s+($pattern)/sub $1_Refl/
			   if ($status = filter_read()) > 0;
		       if ($match) {
			   my $sub = $1;
			   # Adds the stub now
			   $_ = "sub $sub {"
			       ." unshift \@_,'".$sub."_Refl';"
			       ." MOP::MOP::REFLECT(\@_); }\n"
			       .$_;
		       }
		       $status;
		   } );
    } else {
	# We have not been given anything: the user probably
	# simply wants to access to MOP functions.
	# So we don't install any filter.
    }
}

##########################
# LOCAL CONSTANT SYMBOLS #
##########################
my $DEBUG = 0;

###################
# LOCAL VARIABLES #
###################
# Base-Object -> Meta-Object registration procedures
my %Meta_Thingy = ();

##############################
#    FURNISHED FUNCTIONS     #
##############################
sub register_meta ($$) {
   my $meta = shift;
   my $base = shift;
   print STDERR "Associating Meta:$meta to Base:$base\n" if $DEBUG;
   $Meta_Thingy{$base} = $meta;
   return;
}
sub find_meta ($) {
   my $base = shift;
   print STDERR "Looking for Meta of Base:$base\n" if $DEBUG;
   return $Meta_Thingy{$base};
}

sub REFLECT {
    my $b_reflect = $_[0]; # 'b' for 'base'
    my $b_that = $_[1];
    my $m_that = $Meta_Thingy{$b_that}; # 'm' for 'meta'
    if ($m_that) {
	print STDERR "Meta-thingy of $b_that ($b_reflect) is $m_that\n"
		if $DEBUG;
        $m_that->meta_method_call(@_);
    } else {
	no strict 'refs'; # We need to call a sub by its name
        print STDERR "REFLECTed $b_that ($b_reflect) has no meta-thingy
		- normal call\n" if $DEBUG;
        shift; # Get rid of method name
	shift; # and of thing ref.
	$b_that->$b_reflect(@_);
    }
}

####################################
1; # Final true ending (Perl module)

__END__