File Coverage

blib/lib/Scalar/Util/Reftype.pm

Criterion	Covered	Total	%
statement	108	112	96.4
branch	20	22	90.9
condition	6	6	100.0
subroutine	25	26	96.1
pod			n/a
total	159	166	95.7

package Scalar::Util::Reftype;
use strict;
use warnings;
use vars qw( $VERSION @ISA $OID @EXPORT @EXPORT_OK );
use constant RESET_COUNTER  => -1;
use constant HAS_FORMAT_REF => $] >= 5.008; # old ones don't have it
use constant PRIMITIVES     => qw(
    Regexp IO SCALAR ARRAY HASH CODE GLOB REF LVALUE
),
( HAS_FORMAT_REF ? qw(FORMAT) : () )
;
use subs qw( container class reftype type blessed object );
use overload bool     => '_bool',
             fallback => 1,
            ;
use re           ();
use Scalar::Util ();
use base qw( Exporter );

BEGIN {
    $VERSION   = '0.44';
    @EXPORT    = qw( reftype  );
    @EXPORT_OK = qw( type  HAS_FORMAT_REF );

    $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;
    no strict 'refs';
    foreach my $sym ( keys %{ __PACKAGE__ . q{::} } ) {
        if ( $sym =~ m{ \A TYPE_ (.+?) \z }xms ) {
            push @types, $1;
        }
    }

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

    # http://perlmonks.org/?node_id=665339
    if ( ! defined &re::is_regexp ) {
        *re::is_regexp = sub($) {
            require Data::Dump::Streamer;
            return Data::Dump::Streamer::regex( shift );
        }
    }
}

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 );
    $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__