view release on metacpan or  search on metacpan

lib/autobox/Bless.pm  view on Meta::CPAN

package autobox::Bless;

use 5.010000;
use strict;
use warnings;

our $VERSION = '0.02';

use autobox;
use base 'autobox';
use Devel::Gladiator;
use Data::Dumper;
use Scalar::Util;
use Devel::Peek;
use Carp;
use Devel::Caller 'caller_cv'; # cx_type is 40 not CXt_SUB unless it's the current version

# use PadWalker;
# use B;

# could take one of three approaches; remember every field seen in every class; remember the top n closest matches as we go; take the first good match
# it's a memory vs accuracy tradeoff
# could also take a hybrid approach and if we don't find an exact match, look for a best match

sub HASH::AUTOLOAD {
    my $unblessed_hash = shift;
    return if $HASH::AUTOLOAD =~ m/::DESTROY$/;
    (my $method) = $HASH::AUTOLOAD =~ m/.*::(.*)/;
    # warn "``$method'' called";
    # my @contenders;  # ( [ package, score ], ... )
    my $keeper_type;
    for my $sv ( @{ Devel::Gladiator::walk_arena() } ) {
        next unless UNIVERSAL::isa($sv, 'HASH');
        next unless Scalar::Util::blessed $sv; 
        next unless $sv->can($method);
        # warn "considering type " . Scalar::Util::blessed $sv;
        for my $field ( %{ $unblessed_hash } ) {
            exists $sv->{$field} or next;
        }
        # use Devel::ArgNames; my @argnames = Devel::ArgNames::arg_names(@_ XXX before the shift); my $type = ref $sv; bless peek_my(0)->{'%'.$argnames[0]}, $type;
        $keeper_type = Scalar::Util::blessed $sv;
    }
    $keeper_type ||= autobox::Bless::_package_with_method($method);  # backup plan
    if( $keeper_type ) {
        # warn "won with type " . $keeper_type;
        # $keeper_type->can($method)->($unblessed_hash, @_);  # or even better:
        bless $unblessed_hash, $keeper_type; $unblessed_hash->$method(@_); 
    } else {
        Carp::confess qq{Can't call method "$method" without a package or object reference, and believe me, I tried};
    }
}

sub _package_with_method {
    # look through the package hierarchy looking for something with the given method (er, function)
    my $given_method = shift;
    sub {
        my $package = shift;
        # warn "considering package ``$package''";
        no strict 'refs';
        for my $k (keys %$package) {
            if(*{$package.$k}{CODE} and $k eq $given_method) {
                # warn "found it!";
                $package =~ s{::$}{};
                return $package; # success!
            }
        }
        for my $k (keys %$package) {
            next if $k =~ m/main::$/;
            next if $k =~ m/[^\w:]/;
            next unless $k =~ m/::$/;
            # recurse into that namespace unless it corresponds to a .pm module that got used at some point
            my $modulepath = $package.$k;
            # for($modulepath) { s{^main::}{}; s{::$}{}; s{::}{/}g; $_ .= '.pm'; }
            # next if exists $INC{$modulepath};
            my $maybe_result = caller_cv(0)->($package.$k);  # press on forward into darker depths
            return $maybe_result if $maybe_result;
        }
        return; # backtrack/failure