File Coverage

blib/lib/Want.pm

Criterion	Covered	Total	%
statement	74	78	94.8
branch	67	74	90.5
condition	22	30	73.3
subroutine	12	12	100.0
pod	5	8	62.5
total	180	202	89.1

package Want;

require 5.006;
use Carp 'croak';
use strict;
use warnings;

require Exporter;
require DynaLoader;

our @ISA = qw(Exporter DynaLoader);

our @EXPORT = qw(want rreturn lnoreturn);
our @EXPORT_OK = qw(howmany wantref);
our $VERSION = '0.29';

bootstrap Want $VERSION;

my %reftype = (
    ARRAY  => 1,
    HASH   => 1,
    CODE   => 1,
    GLOB   => 1,
    OBJECT => 1,
);

sub _wantone {
    my ($uplevel, $arg) = @_;

    my $wantref = wantref($uplevel + 1);
    if	  ($arg =~ /^\d+$/) {
	my $want_count = want_count($uplevel);
	return ($want_count == -1 || $want_count >= $arg);
    }
    elsif (lc($arg) eq 'infinity') {
	return (want_count($uplevel) == -1);
    }
    elsif ($arg eq 'REF') {
	return $wantref;
    }
    elsif ($reftype{$arg}) {
	return ($wantref eq $arg);
    }
    elsif ($arg eq 'REFSCALAR') {
	return ($wantref eq 'SCALAR');
    }
    elsif ($arg eq 'LVALUE') {
	return want_lvalue($uplevel);
    }
    elsif ($arg eq 'RVALUE') {
	return !want_lvalue($uplevel);
    }
    elsif ($arg eq 'VOID') {
	return !defined(wantarray_up($uplevel));
    }
    elsif ($arg eq 'SCALAR') {
	my $gimme = wantarray_up($uplevel);
	return (defined($gimme) && 0 == $gimme);
    }
    elsif ($arg eq 'BOOL' || $arg eq 'BOOLEAN') {
	return want_boolean(bump_level($uplevel));
    }
    elsif ($arg eq 'LIST') {
	return wantarray_up($uplevel);
    }
    elsif ($arg eq 'COUNT') {
	croak("want: COUNT must be the *only* parameter");
    }
    elsif ($arg eq 'ASSIGN') {
	return !!wantassign($uplevel + 1);
    }
    else {
	croak ("want: Unrecognised specifier $arg");
    }
}

sub want {
    if (@_ == 1 && $_[0] eq 'ASSIGN') {
	@_ = (1);
	goto &wantassign;
    }
    want_uplevel(1, @_);
}

# Simulate the propagation of context through a return value.
sub bump_level {
    my ($level) = @_;
    for(;;) {
	my ($p, $r) = parent_op_name($level+1);
	if ($p eq "return"
        or  $p eq "(none)" && $r =~ /^leavesub(lv)?$/)
	{
	    ++$level
	}
	else {
	    return $level
	}
    }
}

sub want_uplevel {
    my ($level, @args) = @_;

    # Deal with special cases (for RFC21-consistency):
    if (1 == @args) {
	@_ = (1 + $level);
	goto &wantref    if $args[0] eq 'REF';
	goto &howmany    if $args[0] eq 'COUNT';
	goto &wantassign if $args[0] eq 'ASSIGN';
    }

    for my $arg (map split, @args) {
	if ($arg =~ /^!(.*)/) {
	    return 0 unless !_wantone(2 + $level, $1);
	}
	else {
	    return 0 unless _wantone(2 + $level, $arg);
	}
    }

    return 1;
}

sub howmany () {
    my $level = bump_level(@_, 1);
    my $count = want_count($level);
    return ($count < 0 ? undef : $count);
}

sub wantref {
    my $level = bump_level(@_, 1);
    my $n = parent_op_name($level);
    if    ($n eq 'rv2av') {
	return "ARRAY";
    }
    elsif ($n eq 'rv2hv') {
	return "HASH";
    }
    elsif ($n eq 'rv2cv' || $n eq 'entersub') {
	return "CODE";
    }
    elsif ($n eq 'rv2gv' || $n eq 'gelem') {
	return "GLOB";
    }
    elsif ($n eq 'rv2sv') {
	return "SCALAR";
    }
    elsif ($n eq 'method_call') {
	return 'OBJECT';
    }
    elsif ($n eq 'multideref') {
	return first_multideref_type($level);
    }
    else {
	return "";
    }
}

sub wantassign {
    my $uplevel = shift();
    return unless want_lvalue($uplevel);
    my $r = want_assign(bump_level($uplevel));
    if (want('BOOL')) {
	return (defined($r) && 0 != $r);
    }
    else {
	return $r ? (want('SCALAR') ? $r->[$#$r] : @$r) : ();
    }
}

sub double_return :lvalue;

sub rreturn (@) {
    if (want_lvalue(1)) {
        croak "Can't rreturn in lvalue context";
    }

    # Extra scope needed to work with perl-5.19.7 or greater.
    # Prevents the return being optimised out, which is needed
    # since it's actually going to be used a stack level above
    # this sub.
    {
        return double_return(@_);
    }
}

sub lnoreturn () : lvalue {
    if (!want_lvalue(1) || !want_assign(1)) {
        croak "Can't lnoreturn except in ASSIGN context";
    }

    # Extra scope needed to work with perl-5.19.7 or greater.
    # Prevents the return being optimised out, which is needed
    # since it's actually going to be used a stack level above
    # this sub.
    #
    # But in older versions of perl, adding the extra scope
    # causes the error:
    #   Can't modify loop exit in lvalue subroutine return
    # so we have to check the version.
    if ($] >= 5.019) {
        return double_return(disarm_temp(my $undef));
    }
    return double_return(disarm_temp(my $undef));
}

# Some naughty people were relying on these internal methods.
*_wantref = \&wantref;
*_wantassign = \&wantassign;

1;

__END__