view release on metacpan or  search on metacpan

lib/MOP/Internal/Util.pm  view on Meta::CPAN

package MOP::Internal::Util;
# ABSTRACT: For MOP Internal Use Only

use strict;
use warnings;

use B                   (); # nasty stuff, all nasty stuff
use Carp                (); # errors and stuff
use Sub::Util           (); # handling some sub stuff
use Sub::Metadata       (); # handling other sub stuff
use Symbol              (); # creating the occasional symbol
use Scalar::Util        (); # I think I use blessed somewhere in here ...
use Devel::OverloadInfo (); # Sometimes I need to know about overloading
use Devel::Hook         (); # for scheduling UNITCHECK blocks ...

our $VERSION   = '0.14';
our $AUTHORITY = 'cpan:STEVAN';

## ------------------------------------------------------------------
## Basic Glob access
## ------------------------------------------------------------------

sub IS_VALID_MODULE_NAME {
    my ($name) = @_;
    $name =~ /[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/
}

sub IS_STASH_REF {
    my ($stash) = @_;
    Carp::confess('[ARGS] You must specify a stash')
        unless defined $stash;
    if ( my $name = B::svref_2object( $stash )->NAME ) {
        return IS_VALID_MODULE_NAME( $name );
    }
    return;
}

sub GET_NAME {
    my ($stash) = @_;
    Carp::confess('[ARGS] You must specify a stash')
        unless defined $stash;
    B::svref_2object( $stash )->NAME
}

sub GET_STASH_NAME {
    my ($stash) = @_;
    Carp::confess('[ARGS] You must specify a stash')
        unless defined $stash;
    B::svref_2object( $stash )->STASH->NAME
}

sub GET_GLOB_NAME {
    my ($stash) = @_;
    Carp::confess('[ARGS] You must specify a stash')
        unless defined $stash;
    B::svref_2object( $stash )->GV->NAME
}

sub GET_GLOB_STASH_NAME {
    my ($stash) = @_;
    Carp::confess('[ARGS] You must specify a stash')
        unless defined $stash;
    B::svref_2object( $stash )->GV->STASH->NAME
}

sub GET_GLOB_SLOT {
    my ($stash, $name, $slot) = @_;

    Carp::confess('[ARGS] You must specify a stash')
        unless defined $stash;
    Carp::confess('[ARGS] You must specify a name')
        unless defined $name;
    Carp::confess('[ARGS] You must specify a slot')
        unless defined $slot;

    # do my best to not autovivify, and
    # return undef if not
    return unless exists $stash->{ $name };
    # occasionally we need to auto-inflate
    # the optimized version of a required
    # method, its annoying, but the XS side
    # should not have to care about this so
    # it can be removed eventually.
    if (( $slot eq 'CODE' && $stash->{ $name } eq "-1" ) || ref $stash->{ $name } ne 'GLOB') {
        B::svref_2object( $stash )->NAME->can( $name );
    }


    # return the reference stored in the glob
    # which might be undef, but that can be
    # handled by the caller
    return *{ $stash->{ $name } }{ $slot };
}

sub SET_GLOB_SLOT {
    my ($stash, $name, $value_ref) = @_;

    Carp::confess('[ARGS] You must specify a stash')
        unless defined $stash;
    Carp::confess('[ARGS] You must specify a name')
        unless defined $name;
    Carp::confess('[ARGS] You must specify a value REF')
        unless defined $value_ref;

    {
        no strict 'refs';
        no warnings 'once';
        # get the name of the stash, we could have
        # passed this in, but it is easy to get in
        # XS, and so we can punt that down the road
        # for the time being
        my $pkg = B::svref_2object( $stash )->NAME;
        *{ $pkg . '::' . $name } = $value_ref;
    }
    return;
}

## ------------------------------------------------------------------
## UNITCHECK hook
## ------------------------------------------------------------------

sub ADD_UNITCHECK_HOOK {
    my ($cv) = @_;
    Carp::confess('[ARGS] You must specify a CODE reference')
        unless $cv;
    Carp::confess('[ARGS] You must specify a CODE reference')
        unless $cv && ref $cv eq 'CODE';
    Devel::Hook->push_UNITCHECK_hook( $cv );
}

## ------------------------------------------------------------------
## CV/Glob introspection
## ------------------------------------------------------------------

sub CAN_COERCE_TO_CODE_REF {
    my ($object) = @_;
    return 0 unless $object && Scalar::Util::blessed( $object );
    # might be just a blessed CODE ref ...
    return 1 if Scalar::Util::reftype( $object ) eq 'CODE';
    # or might be overloaded object ...
    return 0 unless Devel::OverloadInfo::is_overloaded( $object );
    return exists Devel::OverloadInfo::overload_info( $object )->{'&{}'};
}

sub IS_CV_NULL {
    my ($cv) = @_;
    Carp::confess('[ARGS] You must specify a CODE reference')
        unless $cv;
    Carp::confess('[ARGS] You must specify a CODE reference')
        unless $cv && ref $cv eq 'CODE'
            || CAN_COERCE_TO_CODE_REF( $cv );
    return Sub::Metadata::sub_body_type( $cv ) eq 'UNDEF';
}

sub DOES_GLOB_HAVE_NULL_CV {
    my ($glob) = @_;
    Carp::confess('[ARGS] You must specify a GLOB')
        unless $glob;

    # The glob may be -1 or a string, which is perl’s way
    # of optimizing null sub declarations like ‘sub foo;’
    # and ‘sub bar($);’.
    return 1 if ref \$glob eq 'SCALAR' && defined $glob;
    # We may have a reference to a scalar or array, which
    # represents a constant, so is not a null sub.
    return 0 if ref $glob and ref $glob ne 'CODE';
    # next lets see if we have a CODE slot (or a code
    # reference instead of a glob) ...
    if ( my $code = ref $glob ? $glob : *{ $glob }{CODE} ) {
        return Sub::Metadata::sub_body_type( $code ) eq 'UNDEF';
    }

    # if we had no CODE slot, it can't be a NULL CV ...
    return 0;
}

sub CREATE_NULL_CV {
    my ($in_pkg, $name) = @_;
    Carp::confess('[ARGS] You must specify a package name')
        unless defined $in_pkg;
    Carp::confess('[ARGS] You must specify a name')
        unless defined $name;
    # this just tries to eval the NULL CV into
    # place, it is ugly, but works for now
    eval "sub ${in_pkg}::${name}; 1;" or do { Carp::confess($@) };
    return;
}