File Coverage

lib/Wanted.pm

Criterion	Covered	Total	%
statement	98	105	93.3
branch	90	102	88.2
condition	30	36	83.3
subroutine	14	14	100.0
pod	7	9	77.7
total	239	266	89.8

##----------------------------------------------------------------------------
## Wanted - ~/lib/Wanted.pm
## Version v0.1.2
## Copyright(c) 2026 DEGUEST Pte. Ltd.
## Author: Jacques Deguest
## Created 2025/05/16
## Modified 2026/06/14
## All rights reserved
##
##
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package Wanted;
use strict;
use warnings;
require Exporter;
require DynaLoader;
our @ISA = qw( Exporter DynaLoader );
our @EXPORT = qw( want rreturn lnoreturn );
our @EXPORT_OK = qw( context howmany wantref );
our $VERSION = 'v0.1.2';
our $DEBUG;

bootstrap Wanted $VERSION;

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

sub bump_level
{
    my( $level ) = @_;
    for(;;)
    {
        my( $p, $r ) = parent_op_name( $level + 1 );
        if( !defined( $p ) )
        {
            # Return undef if parent_op_name fails (outside subroutine)
            return;
        }
        if( $p eq 'return' ||
            $p eq '(none)' && $r =~ /^leavesub(lv)?$/ )
        {
            ++$level
        }
        else
        {
            return( $level );
        }
    }
}

sub context
{
    my $gimme = wantarray_up(1);
    return( 'VOID' ) unless( defined( $gimme ) );
    my $ref_type = wantref(2);
    if( $ref_type )
    {
        return( $ref_type eq 'SCALAR' ? 'REFSCALAR' : $ref_type );
    }
    # Boolean must come before scalar
    elsif( want_boolean( bump_level(1) ) )
    {
        return('BOOL');
    }
    elsif( !!wantassign(2) )
    {
        return( 'ASSIGN' );
    }
    elsif( $gimme )
    {
        return( 'LIST' );
    }
    elsif( $gimme == 0 )
    {
        return( 'SCALAR' );
    }
    # Should not happen
    else
    {
        return( '' );
    }
}

sub double_return :lvalue;

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

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

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

    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 )
    {
        my $is_neg = substr( $arg, 0, 1 ) eq '!';
        if( substr( $arg, 0, 1 ) eq '!' )
        {
            $is_neg = 1;
            $arg = substr( $arg, 1 );
        }
        my $result = _wantone( 2 + $level, $arg );
        # Return undef if context is invalid
        return unless( defined( $result ) );
        return(0) if( ( !$is_neg && !$result ) || ( $is_neg && $result ) );
    }
    return(1);
}

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

sub wantref
{
    my $level = bump_level( @_, 1 );
    # Return undef if bump_level fails
    return unless( defined( $level ) );
    my $n = parent_op_name( $level );
    return unless( defined( $n ) );
    if( $n eq 'rv2av' )
    {
        return( 'ARRAY' );
    }
    elsif( $n eq 'rv2hv' )
    {
        return( 'HASH' );
    }
    elsif( $n eq 'rv2cv' || $n eq 'entersub' )
    {
        return( 'CODE' );
        # Address issue No 47963: want() Confused by Prototypes (Jul 17, 2009)
        # Not working... Need to modify the XS 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' )
    {
        if( $] >= 5.022000 )
        {
            return( first_multideref_type( $level ) );
        }
        return( '' );
    }
    else
    {
        return( '' );
    }
}

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

    {
        return( double_return( @_ ) );
    }
}

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

    if( $] >= 5.019 )
    {
        return( double_return( disarm_temp( my $undef ) ) );
    }
    return( double_return( disarm_temp( my $undef ) ) );
}

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 } )
    {
        no warnings; # If $wantref is undef
        return( $wantref eq $arg );
    }
    elsif( $arg eq 'REFSCALAR' )
    {
        no warnings; # If $wantref is undef
        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 undef if context is invalid
        return unless( defined( $gimme ) );
        return( $gimme == 0 );
    }
    elsif( $arg eq 'BOOL' || $arg eq 'BOOLEAN' )
    {
        return( want_boolean( bump_level( $uplevel ) ) );
    }
    elsif( $arg eq 'LIST' )
    {
        my $gimme = wantarray_up( $uplevel );
        # Return undef if context is invalid
        return unless( defined( $gimme ) );
        return( $gimme );
    }
    elsif( $arg eq 'COUNT' )
    {
        die( "want: COUNT must be the *only* parameter" );
    }
    elsif( $arg eq 'ASSIGN' )
    {
        return( !!wantassign( $uplevel + 1 ) );
    }
    else
    {
        die( "want: Unrecognised specifier $arg" );
    }
}

*_wantref = \&wantref;

*_wantassign = \&wantassign;

1;
# NOTE: POD
__END__