Fukurama::Class::HideCaller - Pragma to hide wrapper-classes in callers stack

Fukurama-Class documentation Contained in the Fukurama-Class distribution.

Index

Code Index:

NAME

Top

Fukurama::Class::HideCaller - Pragma to hide wrapper-classes in callers stack

VERSION

Top

Version 0.01 (beta)

SYNOPSIS

Top

 package MyWrapperClass;
 use Fukurama::Class::HideCaller('MyWrapperClass');

 sub wrap_around_test {
 	my $sub = \&MyClass::test;
 	no warnings;
 	*MyClass::test = sub {
	 	print "before, ";
	 	&{$sub}(@_);
	 	print "after";
 	}
 }

 package MyClass;
 sub test {
 	no warnings;
 	print "middle, caller: " . [caller(0)]->[0] . ", ";
 }

 package main;
 MyWrapperClass->wrap_around_test();
 MyClass->test();
 # will print: before, middle, caller: main, after
 # without the HideCaller, it will print: before, middle, caller: MyWrapper, after

DESCRIPTION

Top

This pragma-like module provides functions to hide a wrapper-class in callers stack. It's a helper class to provide parameter and return value checking without changings in any caller stack.

CONFIG

Top

You can disable the whole behavior of this class by setting

 $Fukurama::Class::HideCaller::DISABLE = 1;

EXPORT

Top

CORE::GLOBAL::caller

would be decorated

METHODS

Top

register_class( hidden_wrapper_class:STRING ) return:VOID

Register a wrapper class to competely hide in caller stack.

AUTHOR, BUGS, SUPPORT, ACKNOWLEDGEMENTS, COPYRIGHT & LICENSE

Top

see perldoc of Fukurama::Class

Fukurama-Class documentation Contained in the Fukurama-Class distribution. 
package Fukurama::Class::HideCaller;
use Fukurama::Class::Version(0.01);
use Fukurama::Class::Rigid;
use Fukurama::Class::Carp;

my $IS_DECORATED = undef;
our $REGISTER = {};
our $DISABLE;
my $USAGE_ERROR;


# AUTOMAGIC void
sub import {
	my $class = $_[0];
	my $hidden_class = $_[1];
	
	if(!$IS_DECORATED) {
		$class->_decorate_caller();
		$IS_DECORATED = 1;
	}
	$class->register_class($hidden_class) if(defined($hidden_class));
	return;
}
# void
sub register_class {
	my $class = $_[0];
	my $hidden_class = $_[1];
	
	if(!$IS_DECORATED && !$USAGE_ERROR) {
		$USAGE_ERROR = 1;
		_croak("Wrong usage: you have to say\n\t'use " . __PACKAGE__ . ";' or\n\t'use " . __PACKAGE__ . "('CLASSNAME')'");
	}
	if(!UNIVERSAL::isa($hidden_class, $hidden_class)) {
		_croak("Class '$hidden_class' is not a valid class");
	}
	$REGISTER->{$hidden_class} = 1;
	return;
}
# AUTOMAGIC void
END {
	
	if(!$DISABLE && !$IS_DECORATED && !$USAGE_ERROR) {
		$USAGE_ERROR = 1;
		_croak("Wrong usage: you have to say\n\t'use " . __PACKAGE__ . ";' or\n\t'use " . __PACKAGE__ . "('CLASSNAME')'");
	}
}
# void
sub _decorate_caller {
	my $class = $_[0];
	
	no strict 'refs';
	
	my $old = *CORE::GLOBAL::caller{'CODE'};
	if($old) {
		
		no warnings 'redefine';
		
		# inspired by Hook::LexWrap code
		*CORE::GLOBAL::caller = sub {
			my $level = $_[0] || 0;
			my $i = 1;
			my $called_sub = undef;
			while(1) {
				my @caller = &$old($i++) or return;
				$caller[3] = $called_sub if($called_sub);
				$called_sub = ((${__PACKAGE__ . '::REGISTER'}->{$caller[0]} && !${__PACKAGE__ . '::DISABLE'}) ? $caller[3] : undef);
				next if($called_sub || $level-- != 0);
				return (wantarray ? (@_ ? @caller : @caller[0..2]) : $caller[0]);
			}
		};
	} else {
		# inspired by Hook::LexWrap code
		*CORE::GLOBAL::caller = sub {
			my $level = $_[0] || 0;
			my $i = 1;
			my $called_sub = undef;
			while(1) {
				my @caller = CORE::caller($i++) or return;
				$caller[3] = $called_sub if($called_sub);
				$called_sub = ((${__PACKAGE__ . '::REGISTER'}->{$caller[0]} && !${__PACKAGE__ . '::DISABLE'}) ? $caller[3] : undef);
				next if($called_sub || $level-- != 0);
				return (wantarray ? (@_ ? @caller : @caller[0..2]) : $caller[0]);
			}
		};
	}
	return;
}
1;