File Coverage

blib/lib/PerlX/Maybe.pm

Criterion	Covered	Total	%
statement	62	75	82.6
branch	25	30	83.3
condition	3	6	50.0
subroutine	12	14	85.7
pod	2	2	100.0
total	104	127	81.8

use 5.006;
use strict;
use warnings;

package PerlX::Maybe;

BEGIN {
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '1.200';

	our @EXPORT      = qw/ maybe /;
	our @EXPORT_OK   = qw/ maybe provided provided_deref provided_deref_with_maybe/;
	our %EXPORT_TAGS = (all => \@EXPORT_OK, default => \@EXPORT);
}

sub import
{
	if (@_ == 1)
	{
		my $caller = caller;
		no strict 'refs';
		*{"$caller\::maybe"} = \&maybe;
		return;
	}
	elsif (grep ref||/^-/, @_)
	{
		require Exporter::Tiny;
		our @ISA = qw/ Exporter::Tiny /;
		no warnings 'redefine';
		*import = \&Exporter::Tiny::import;
		*unimport = \&Exporter::Tiny::unimport;
		goto \&Exporter::Tiny::import;
	}
	require Exporter;
	goto \&Exporter::import;
}

sub unimport
{
	require Exporter::Tiny;
	our @ISA = qw/ Exporter::Tiny /;
	no warnings 'redefine';
	*import = \&Exporter::Tiny::import;
	*unimport = \&Exporter::Tiny::unimport;
	goto \&Exporter::Tiny::unimport;
}

sub _croak
{
	require Carp;
	goto \&Carp::croak;
}

unless (($ENV{PERLX_MAYBE_IMPLEMENTATION}||'') =~ /pp/i)
{
	eval q{ use PerlX::Maybe::XS 0.003 ':all' };
}

__PACKAGE__->can('maybe') ? eval <<'END_XS' : eval <<'END_PP';

sub IMPLEMENTATION () { "XS" }

END_XS

sub IMPLEMENTATION () { "PP" }

sub maybe ($$@)
{
	if (defined $_[0] and defined $_[1])
	{
		@_
	}
	else
	{
		(scalar @_ > 1) ? @_[2 .. $#_] : qw()
	}
}

sub provided ($$$@)
{
	if (shift)
	{
		@_
	}
	else
	{
		(scalar @_ > 1) ? @_[2 .. $#_] : qw()
	}
}

END_PP

sub provided_deref ($$@)
{
	unshift @_, 0;
	goto \&_provided_magic;
}

sub provided_deref_with_maybe ($$@)
{
	unshift @_, 1;
	goto \&_provided_magic;
}

sub _provided_magic ($$$@)
{
	my $m = shift; # maybe, clean up private keys

	if (shift)
	{
		my $r = shift;
		my $t = ref $r;
		_croak "Not a reference, $r" unless $t;

		my @vals;
		if ($t eq 'ARRAY')
		{
			return (@$r, @_) unless $m;
			@vals = @$r;
		}

		elsif ($t eq 'CODE')
		{
			return ($r->(), @_) unless $m;
			@vals = $r->();
		}

		elsif ($t eq 'HASH')
		{
			return (%$r, @_) unless $m;
			@vals = %$r;
		}

		elsif (do { require Scalar::Util; Scalar::Util::blessed($r) })
		{
			my %vals = eval { %$r };
			_croak "Can not unwrap $r into a hash" if $@;
			return (%vals, @_) unless $m;

			delete $vals{$_} for grep /^_/, keys %vals;
			@vals = %vals;
		}

		else
		{
			_croak "Can not dereference, $r ... yet";
		}

		my @return;
		for (my $i = 0; $i < @vals; $i+=2) {
			push @return, $vals[$i], $vals[$i+1] if defined $vals[$i] && defined $vals[$i+1];
		}

		return (@return, @_);
	}
	else
	{
		(scalar @_ > 0) ? @_[1 .. $#_] : qw()
	}
}

__FILE__
__END__