File Coverage

blib/lib/Scalar/Util/Reftype.pm

Criterion	Covered	Total	%
statement	107	122	87.7
branch	21	24	87.5
condition	15	18	83.3
subroutine	25	27	92.5
pod			n/a
total	168	191	87.9

package Scalar::Util::Reftype;
$Scalar::Util::Reftype::VERSION = '0.46';
use 5.010;
use strict;
use warnings;

use constant RESET_COUNTER  => -1;
# being kept for backwards compatibility, 5.10 and later have it
use constant HAS_FORMAT_REF =>  1;
use constant PRIMITIVES     => qw(
    ARRAY
    CODE
    FORMAT
    GLOB
    HASH
    IO
    LVALUE
    REF
    Regexp
    SCALAR
);
use subs qw(
    blessed
    class
    container
    object
    reftype
    type
);
use overload bool     => '_bool',
             fallback => 1,
            ;
use re           ();
use Scalar::Util ();
use base qw( Exporter );

our @EXPORT    = qw( reftype  );
our @EXPORT_OK = qw( type  HAS_FORMAT_REF );

my $OID;
BEGIN {
    $OID = RESET_COUNTER;
    foreach my $type ( PRIMITIVES ) {
        constant->import( 'TYPE_' . $type,             ++$OID );
        constant->import( 'TYPE_' . $type . '_OBJECT', ++$OID );
    }
}

use constant CONTAINER => ++$OID;
use constant BLESSED   => ++$OID;
use constant OVERRIDE  => ++$OID;
use constant MAXID     =>   $OID;

BEGIN {
    *class  = \*container;
    *type   = \*reftype;
    *object = \*blessed;
    my(@types, @obj_idx);
    no strict 'refs';
    foreach my $sym ( keys %{ __PACKAGE__ . q{::} } ) {
        if ( $sym =~ m{ \A TYPE_ (.+?) \z }xms ) {
            push @types, $1;
            push @obj_idx, $sym;
        }
    }

    foreach my $meth ( @types ) {
        *{ lc $meth } = sub {
            my $self = shift;
            my $id   = 'TYPE_' . $meth;
            return $self->[ $self->$id() ];
        }
    }

    *_dump = sub {
        my $self = shift;
        my %type = map { $self->$_() => $_          } @obj_idx;
        my %val  = map { $type{$_}   => $self->[$_] } 0..$#obj_idx;
        my $max  = ( sort { $b <=> $a } map { length $_ } keys %val)[0];
        my $rm   = 'TYPE_';
        $max -= length $rm;
        for my $name ( sort { lc $a cmp lc $b } keys %val) {
            (my $display = $name) =~ s{ \A $rm }{}xms;
            printf "% ${max}s: %s\n", $display, $val{ $name } ? 'true' : '';
        }
    };
}

sub reftype {
    my @args = @_;
    my $o    = __PACKAGE__->_new;
    return $o->_analyze( @args )
}

sub _new {
    my $class = shift;
    my $self  = [ map { 0 } 0..MAXID ];
    $self->[CONTAINER] = q{};
    bless  $self, $class;
    return $self;
}

sub _analyze {
    my $self  = shift;
    my $thing = shift || return $self;
    my $ref   = CORE::ref($thing) || return $self;

    foreach my $type ( PRIMITIVES ) {
        my $id = $ref eq $type                 ? sprintf( 'TYPE_%s',        $type )
               : $self->_object($thing, $type) ? sprintf( 'TYPE_%s_OBJECT', $type )
               :                                 undef
               ;
        if ( $id ) {
            $self->[ $self->$id() ] = 1 if ! $self->[OVERRIDE];
            # IO refs are always objects
            $self->[TYPE_IO]        = 1 if $id eq 'TYPE_IO_OBJECT';
            $self->[CONTAINER]      = $ref if $self->[BLESSED];
            last;
        }
    }

    return $self;
}

sub container { return shift->[CONTAINER] }
sub blessed   { return shift->[BLESSED]   }

sub _object {
    my($self, $object, $type)= @_;
    my $blessed = Scalar::Util::blessed( $object ) || return;
    my $rt      = Scalar::Util::reftype( $object );

    # new perl (5.24+ ?) messes the detection
    if (   $rt
        && $blessed
        #            new               5.10
        && ( $rt eq 'REGEXP' || $rt eq 'SCALAR')
        && $blessed eq 'Regexp'
    ) {
        return;
    }

    $self->[BLESSED] = 1;

    if ( $rt eq 'IO' ) { # special case: IO
        $self->[TYPE_IO_OBJECT] = 1;
        $self->[TYPE_IO]        = 1;
        $self->[OVERRIDE]       = 1;
        return 1;
    }

    if ( re::is_regexp( $object ) ) { # special case: Regexp
        $self->[TYPE_Regexp_OBJECT] = 1;
        $self->[OVERRIDE]           = 1;
        return 1;
    }

    return if $rt ne $type; #  || ! ( $blessed eq 'IO' && $blessed eq $type );
    return 1;
}

sub _bool {
    require Carp;
    Carp::croak(
         'reftype() objects can not be used in boolean contexts. '
        .'Please call one of the test methods on the return value instead. '
        .'Example: `print 42 if reftype( \$thing )->array;`'
    );
}

1;

__END__