libdata-util-perl 0.62-1build1 / usr / lib / perl5 / Data / Util / PurePerl.pm

package Data::Util::PurePerl;

die qq{Don't use Data::Util::PurePerl directly, use Data::Util instead.\n} # ' for poor editors
	if caller() ne 'Data::Util';

package
	Data::Util;

use strict;
use warnings;

#use warnings::unused;

use Scalar::Util ();
use overload ();

sub _croak{
	require Data::Util::Error;
	goto &Data::Util::Error::croak;
}
sub _fail{
	my($name, $value) = @_;
	_croak(sprintf 'Validation failed: you must supply %s, not %s', $name, neat($value));
}

sub _overloaded{
	return Scalar::Util::blessed($_[0])
		&& overload::Method($_[0], $_[1]);
}

sub is_scalar_ref{
	return ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' || _overloaded($_[0], '${}');
}
sub is_array_ref{
	return ref($_[0]) eq 'ARRAY' || _overloaded($_[0], '@{}');
}
sub is_hash_ref{
	return ref($_[0]) eq 'HASH' || _overloaded($_[0], '%{}');
}
sub is_code_ref{
	return ref($_[0]) eq 'CODE' || _overloaded($_[0], '&{}');
}
sub is_glob_ref{
	return ref($_[0]) eq 'GLOB' || _overloaded($_[0], '*{}');
}
sub is_regex_ref{
	return ref($_[0]) eq 'Regexp';
}
sub is_rx{
	return ref($_[0]) eq 'Regexp';
}

sub is_instance{
	my($obj, $class) = @_;
	_fail('a class name', $class)
		unless is_string($class);

	return Scalar::Util::blessed($obj) && $obj->isa($class);
}
sub is_invocant{
	my($x) = @_;
	if(ref $x){
		return !!Scalar::Util::blessed($x);
	}
	else{
		return !!get_stash($x);
	}
}


sub scalar_ref{
	return ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' || _overloaded($_[0], '${}')
		? $_[0] : _fail('a SCALAR reference', $_[0]);

}
sub array_ref{
	return ref($_[0]) eq 'ARRAY' || _overloaded($_[0], '@{}')
		? $_[0] : _fail('an ARRAY reference', $_[0]);
}
sub hash_ref{
	return ref($_[0]) eq 'HASH' || _overloaded($_[0], '%{}')
		? $_[0] : _fail('a HASH reference', $_[0]);
}
sub code_ref{
	return ref($_[0]) eq 'CODE' || _overloaded($_[0], '&{}')
		? $_[0] : _fail('a CODE reference', $_[0]);
}
sub glob_ref{
	return ref($_[0]) eq 'GLOB' || _overloaded($_[0], '*{}')
		? $_[0] : _fail('a GLOB reference', $_[0]);
}
sub regex_ref{
	return ref($_[0]) eq 'Regexp'
		? $_[0] : _fail('a regular expression reference', $_[0]);
}
sub rx{
	return ref($_[0]) eq 'Regexp'
		? $_[0] : _fail('a regular expression reference', $_[0]);
}

sub instance{
	my($obj, $class) = @_;

	_fail('a class name', $class)
		unless is_string($class);

	return Scalar::Util::blessed($obj) && $obj->isa($class)
		? $obj : _fail("an instance of $class", $obj);
}

sub invocant{
	my($x) = @_;
	if(ref $x){
		if(Scalar::Util::blessed($x)){
			return $x;
		}
	}
	elsif(is_string($x)){
		if(get_stash($x)){
			$x =~ s/^:://;
			$x =~ s/(?:main::)+//;
			return $x;
		}
	}
	_fail('an invocant', $x);
}

sub is_value{
	return defined($_[0]) && !ref($_[0]) && ref(\$_[0]) ne 'GLOB';
}
sub is_string{
	no warnings 'uninitialized';
	return !ref($_[0]) && ref(\$_[0]) ne 'GLOB' && length($_[0]) > 0;
}

sub is_number{
	return 0 if !defined($_[0]) || ref($_[0]);

	return $_[0] =~ m{
		\A \s*
			[+-]?
			(?= \d | \.\d)
			\d*
			(\.\d*)?
			(?: [Ee] (?: [+-]? \d+) )?
		\s* \z
	}xms;
}

sub is_integer{
	return 0 if !defined($_[0]) || ref($_[0]);

	return $_[0] =~ m{
		\A \s*
			[+-]?
			\d+
		\s* \z
	}xms;
}

sub get_stash{
	my($invocant) = @_;

	if(Scalar::Util::blessed($invocant)){
		no strict 'refs';
		return \%{ref($invocant) . '::'};
	}
	elsif(!is_string($invocant)){
		return undef;
	}

	$invocant =~ s/^:://;

	my $pack = *main::;
	foreach my $part(split /::/, $invocant){
		return undef unless $pack = $pack->{$part . '::'};
	}
	return *{$pack}{HASH};
}

sub anon_scalar{
	my($s) = @_;
	return \$s;  # not \$_[0]
}

sub neat{
	my($s) = @_;

	if(ref $s){
		if(ref($s) eq 'CODE'){
			return sprintf '\\&%s(0x%x)', scalar(get_code_info($s)), Scalar::Util::refaddr($s);
		}
		elsif(ref($s) eq 'Regexp'){
			return qq{qr{$s}};
		}
		return overload::StrVal($s);
	}
	elsif(defined $s){
		return "$s" if is_number($s);
		return "$s" if is_glob_ref(\$s);

		require B;
		return B::perlstring($s);
	}
	else{
		return 'undef';
	}
}


sub install_subroutine{
	_croak('Usage: install_subroutine(package, name => code, ...)') unless @_;

	my $into = shift;
	is_string($into)  or _fail('a package name', $into);

	my $param = mkopt_hash(@_ == 1 ? shift : \@_, 'install_subroutine', 'CODE');

	while(my($as, $code) = each %{$param}){
		defined($code) or _fail('a CODE reference', $code);

		my $slot = do{ no strict 'refs'; \*{ $into . '::' . $as } };

		if(defined &{$slot}){
			warnings::warnif(redefine => "Subroutine $as redefined");
		}

		no warnings 'redefine';
		*{$slot} = \&{$code};
	}
	return;
}
sub uninstall_subroutine {
	_croak('Usage: uninstall_subroutine(package, name, ...)') unless @_;

	my $package = shift;

	is_string($package) or _fail('a package name', $package);
	my $stash = get_stash($package) or return 0;

	my $param = mkopt_hash(@_ == 1 && is_hash_ref($_[0]) ? shift : \@_, 'install_subroutine', 'CODE');

	require B;

	while(my($name, $specified_code) = each %{$param}){
		my $glob = $stash->{$name};

		if(ref(\$glob) ne 'GLOB'){
			if(ref $glob){
				warnings::warnif(misc => "Constant subroutine $name uninstalled");
			}
			delete $stash->{$name};
			next;
		}

		my $code = *{$glob}{CODE};
		if(not defined $code){
			next;
		}

		if(defined $specified_code && $specified_code != $code){
			next;
		}

		if(B::svref_2object($code)->CONST){
			warnings::warnif(misc => "Constant subroutine $name uninstalled");
		}

		delete $stash->{$name};

		my $newglob = do{ no strict 'refs'; \*{$package . '::' . $name} }; # vivify

		# copy all the slot except for CODE
		foreach my $slot( qw(SCALAR ARRAY HASH IO FORMAT) ){
			*{$newglob} = *{$glob}{$slot} if defined *{$glob}{$slot};
		}
	}

	return;
}

sub get_code_info{
	my($code) = @_;

	is_code_ref($code) or _fail('a CODE reference', $code);

	require B;
	my $gv = B::svref_2object(\&{$code})->GV;
	return unless $gv->isa('B::GV');
	return wantarray ? ($gv->STASH->NAME, $gv->NAME) : join('::', $gv->STASH->NAME, $gv->NAME);
}

sub get_code_ref{
	my($package, $name, @flags) = @_;

	is_string($package) or _fail('a package name', $package);
	is_string($name)    or _fail('a subroutine name', $name);

	if(@flags){
		if(grep{ $_ eq '-create' } @flags){
			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;
					$$current_ref = sub{ $ar->($base, @_) };
				}
			}
		}
		return @{$property} if defined wantarray;

		return;
	}
}
#
# mkopt() and mkopt_hash() are originated from Data::OptList
#

my %test_for = (
	CODE   => \&is_code_ref,
	HASH   => \&is_hash_ref,
	ARRAY  => \&is_array_ref,
	SCALAR => \&is_scalar_ref,
	GLOB   => \&is_glob_ref,
);


sub __is_a {
	my ($got, $expected) = @_;

	return scalar grep{ __is_a($got, $_) } @{$expected} if ref $expected;

	my $t = $test_for{$expected};
	return defined($t) ? $t->($got) : is_instance($got, $expected);
}

sub mkopt{
	my($opt_list, $moniker, $require_unique, $must_be) = @_;

	return [] unless defined $opt_list;

	$opt_list = [
		map { $_ => (ref $opt_list->{$_} ? $opt_list->{$_} : ()) } keys %$opt_list
	] if is_hash_ref($opt_list);

	is_array_ref($opt_list) or _fail('an ARRAY or HASH reference', $opt_list);

	my @return;
	my %seen;

	my $vh = is_hash_ref($must_be);
	my $validator = $must_be;

	if(defined($validator) && (!$vh && !is_array_ref($validator) && !is_string($validator))){
		_fail('a type name, or ARRAY or HASH reference', $validator);
	}

	for(my $i = 0; $i < @$opt_list; $i++) {
		my $name = $opt_list->[$i];
		my $value;

		is_string($name) or _fail("a name in $moniker opt list", $name);

		if($require_unique && $seen{$name}++) {
			_croak("Validation failed: Multiple definitions provided for $name in $moniker opt list")
		}

		if   ($i == $#$opt_list)             { $value = undef;            }
		elsif(not defined $opt_list->[$i+1]) { $value = undef; $i++       }
		elsif(ref $opt_list->[$i+1])         { $value = $opt_list->[++$i] }
		else                                 { $value = undef;            }

		if (defined $value and defined( $vh ? ($validator = $must_be->{$name}) : $validator )){
			unless(__is_a($value, $validator)) {
				_croak("Validation failed: ".ref($value)."-ref values are not valid for $name in $moniker opt list");
			}
		}

		push @return, [ $name => $value ];
	}

	return \@return;
}

sub mkopt_hash {
	my($opt_list, $moniker, $must_be) = @_;
	return {} unless $opt_list;

	my %hash = map { $_->[0] => $_->[1] } @{ mkopt($opt_list, $moniker, 1, $must_be) };
	return \%hash;
}

1;
__END__

=head1 NAME

Data::Util::PurePerl - The Pure Perl backend for Data::Util

=head1 DESCRIPTION

This module is a backend for C<Data::Util>.

Don't use this module directly; C<use Data::Util> instead.

=cut