view release on metacpan or  search on metacpan

lib/Data/Util/PurePerl.pm  view on Meta::CPAN

			no strict 'refs';
			return \&{$package . '::' . $name};
		}
		else{
			_fail('a flag', @flags);
		}
	}

	my $stash = get_stash($package) or return undef;

	if(defined(my $glob = $stash->{$name})){
		if(ref(\$glob) eq 'GLOB'){
			return *{$glob}{CODE};
		}
		else{ # a stub or special constant
			no strict 'refs';
			return *{$package . '::' . $name}{CODE};
		}
	}
	return undef;
}

sub curry{
	my $is_method = !is_code_ref($_[0]);

	my $proc;
	$proc = shift if !$is_method;

	my $args = \@_;

	my @tmpl;

	my $i = 0;
	my $max_ph = -1;
	my $min_ph =  0;

	foreach my $arg(@_){
		if(is_scalar_ref($arg) && is_integer($$arg)){
			push @tmpl, sprintf '$_[%d]', $$arg;

			if($$arg >= 0){
				$max_ph = $$arg if $$arg > $max_ph;
			}
			else{
				$min_ph = $$arg if $$arg < $min_ph;
			}
		}
		elsif(defined($arg) && (\$arg) == \*_){
			push @tmpl, '@_[$max_ph .. $#_ + $min_ph]';
		}
		else{
			push @tmpl, sprintf '$args->[%d]', $i;
		}
		$i++;
	}

	$max_ph++;

	my($pkg, $file, $line, $hints, $bitmask) = (caller 0 )[0, 1, 2, 8, 9];
	my $body = sprintf <<'END_CXT', $pkg, $line, $file;
BEGIN{ $^H = $hints; ${^WARNING_BITS} = $bitmask; }
package %s;
#line %s %s
END_CXT

	if($is_method){
		my $selfp = shift @tmpl;
		$proc     = shift @tmpl;
		$body .= sprintf q{ sub {
			my $self   = %s;
			my $method = %s;
			$self->$method(%s);
		} }, $selfp, defined($proc) ? $proc : 'undef', join(q{,}, @tmpl);
	}
	else{
		$body .= sprintf q{ sub { $proc->(%s) } }, join q{,}, @tmpl;
	}
	eval $body or die $@;
}

BEGIN{
	our %modifiers;

	my $initializer;
	$initializer = sub{
		require Hash::Util::FieldHash::Compat;
		Hash::Util::FieldHash::Compat::fieldhash(\%modifiers);
		undef $initializer;
	};

	sub modify_subroutine{
		my $code   = code_ref shift;

		if((@_ % 2) != 0){
			_croak('Odd number of arguments for modify_subroutine()');
		}
		my %args   = @_;

		my(@before, @around, @after);

		@before = map{ code_ref $_ } @{array_ref delete $args{before}} if exists $args{before};
		@around = map{ code_ref $_ } @{array_ref delete $args{around}} if exists $args{around};
		@after  = map{ code_ref $_ } @{array_ref delete $args{after}}  if exists $args{after};

		if(%args){
			_fail('a modifier property', join ', ', keys %args);
		}

		my %props = (
			before      => \@before,
			around      => \@around,
			after       => \@after,
			current_ref => \$code,
		);

		#$code = curry($_, (my $tmp = $code), *_) for @around;
		for my $ar_code(reverse @around){
			my $next = $code;
			$code = sub{ $ar_code->($next, @_) };
		}
		my($pkg, $file, $line, $hints, $bitmask) = (caller 0)[0, 1, 2, 8, 9];

		my $context = sprintf <<'END_CXT', $pkg, $line, $file;
BEGIN{ $^H = $hints; ${^WARNING_BITS} = $bitmask; }
package %s;
#line %s %s(modify_subroutine)
END_CXT

		my $modified = eval $context . q{sub{
			$_->(@_) for @before;
			if(wantarray){ # list context
				my @ret = $code->(@_);
				$_->(@_) for @after;
				return @ret;
			}
			elsif(defined wantarray){ # scalar context
				my $ret = $code->(@_);
				$_->(@_) for @after;
				return $ret;
			}
			else{ # void context
				$code->(@_);
				$_->(@_) for @after;
				return;
			}
		}} or die $@;

		$initializer->() if $initializer;

		$modifiers{$modified} = \%props;
		return $modified;
	}

	my %valid_modifiers = map{ $_ => undef } qw(before around after);

	sub subroutine_modifier{
		my $modified = code_ref shift;

		my $props_ref = $modifiers{$modified};

		unless(@_){ # subroutine_modifier($subr) - only checking
			return defined $props_ref;
		}
		unless($props_ref){ # otherwise, it should be modified subroutines
			_fail('a modified subroutine', $modified);
		}

		my($name, @subs) = @_;
		(is_string($name) && exists $valid_modifiers{$name}) or _fail('a modifier property', $name);


		my $property = $props_ref->{$name};
		if(@subs){
			if($name eq 'after'){
				push @{$property}, map{ code_ref $_ } @subs;
			}
			else{
				unshift @{$property}, reverse map{ code_ref $_ } @subs;
			}

			if($name eq 'around'){
				my $current_ref = $props_ref->{current_ref};
				for my $ar(reverse @subs){
					my $base = $$current_ref;