File Coverage

blib/lib/Devel/Spy/Util.pm

Criterion	Covered	Total	%
statement	33	53	62.2
branch	5	14	35.7
condition	0	3	0.0
subroutine	9	11	81.8
pod	4	4	100.0
total	51	85	60.0

package Devel::Spy::Util;
use strict;
use warnings;

use overload     ();
use Scalar::Util ();
use Carp         ();
use Symbol       ();

sub Y {    ## no critic (Prototype)
           # The Y combinator.
    my ( undef, $curried_rec ) = @_;
    my $p = sub {
        my $f = shift @_;
        return $curried_rec->( sub { $f->($f)->(@_) } );
    };
    return $p->($p);
}

sub compile_this {

    # Accepts some source code and expects to return a true
    # value. Devel::Spy::_obj uses this to compile a bunch of subs but
    # without having to repeat the "eval or croak" stuff all over the
    # place.
    #
    # Example:
    #   my $sub = Devel::Spy::Util::compile_this( <<"SRC" );
    #       sub ... {
    #           ...
    #       };
    #       1;
    #   SRC
    my ( undef, $src ) = @_;
    my ( $package, $filename, $line ) = caller;

    # Add some sugar to make the code appear in the proper location.
    $src = <<"CODE";
#line @{[$line]} "@{[$filename]}"
package $package;
$src
CODE

    ## no critic (Eval)
    my $result = eval $src
        or Carp::confess "$@ while compiling:\n$src";
    return $result;
}

my %class_rx_cache;

sub comes_from {
    my $class    = shift @_;
    my $class_rx = $class_rx_cache{$class} ||= qr/\A\Q$class\E(?:\z|::)/;

    # Returns a string showing the location of the non-Devel::Spy code
    # that's higher in the call stack.
    my $cx = 1;
    while ( my ( $pkg, undef, $line ) = caller $cx++ ) {

        # Find !Devel::Spy
        unless ( $pkg =~ $class_rx ) {
            return "($pkg:$line)";
        }
    }

    # Huh? I suppose this only occurs if Devel::Spy is the *only*
    # thing in the call stack and I'm not even sure how that happens.
    return;
}

sub wrap_thing {
    my ( $class, $thing, $code ) = @_;

    # Use a tied proxy to $thing instead of $thing directly. But only
    # if $thing is a reference.
    my $reftype = Scalar::Util::reftype $thing;
    return $thing unless defined $reftype;

    # This may be a really bad idea.
    $class =~ s/::Util\z//;

    # Return a tied wrapper over $thing.
    if ( 'HASH' eq $reftype ) {
        tie my %pretend_self, "$class\::TieHash", $thing, $code;
        return \%pretend_self;
    }
    elsif ( 'ARRAY' eq $reftype ) {
        tie my @pretend_self, "$class\::TieArray", $thing, $code;
        return \@pretend_self;
    }
    elsif ( $reftype =~ /^(?:SCALAR|REF|CODE|LVALUE|REGEXP|VSTRING|BIND)\z/ ) {
        tie my $pretend_self, "$class\::TieScalar", $thing, $code;
        return \$pretend_self;
    }
    elsif ( $reftype =~ /^(?:GLOB|FORMAT|IO)\z/ ) {
        my $pretend_self = Symbol::gensym();
        tie *$pretend_self, "$class\::TieHandle", $thing, $code;
        return $pretend_self;
    }

    # Missing implementations?
    Carp::croak "Unsupported reftype: $reftype on "
        . overload::StrVal($thing);
}

1;

__END__