File Coverage

blib/lib/My/Object.pm

Criterion	Covered	Total	%
statement	74	75	98.6
branch	17	18	94.4
condition	4	6	66.6
subroutine	15	15	100.0
pod	0	1	0.0
total	110	115	95.6

use strict;
use warnings;

package My::Object;
BEGIN {
    *VERSION = \'0.02';
    *import = \&My::Object::Import::import;
}

our %PROTO;

sub BUILD {
    my ($obj, %ini) = @_;
    @$obj{keys %ini} = values %ini;
}

package My::Object::Import;
use Carp qw(carp);
use Module::Loaded qw(is_loaded mark_as_loaded);
use Scalar::Util qw(refaddr);

no strict 'refs';
no warnings 'once';

sub create_accessor {
    my ($name) = @_;
    return sub : lvalue { shift->{$name} };
}

sub create_NEW {
    my ($pkg) = @_;
    return sub {
        my $suffix = @_ ? '_'.($_[0] =~ /([^:]+)$/ && $1) : '';
        my $builder = \&{$pkg.'::BUILD'.$suffix};
        return sub {
            my $proto = \%{$pkg.'::PROTO'};
            my $obj = bless { map {
                ($_, s/^-// ? $proto->{"-$_"}->() : $proto->{$_} )
            } keys %$proto }, $pkg;

            $builder->($obj, @_);
            return $obj;
        };
    };
}

sub import {
    my ($parent, $defs) = @_;
    my $pkg = caller;

    my $proto = \%{$pkg.'::PROTO'};
    @{$proto}{keys %{$parent.'::PROTO'}} = values %{$parent.'::PROTO'};
    @{$proto}{keys %$defs} = values %$defs;

    *{$pkg.'::import'} = \&My::Object::Import::import;
    *{$pkg.'::NEW'} = create_NEW($pkg)
        unless exists &{$pkg.'::NEW'};

    for my $name (keys %{$parent.'::'}) {
        next if !exists &{$parent.'::'.$name}
            || $name =~ /^(?:NEW|import)$/;

        if (defined &{$pkg.'::'.$name}) {
            next if refaddr(\&{$pkg.'::'.$name})
                == refaddr(\&{$parent.'::'.$name});
            carp "Subroutine $name redefined in $pkg";
        }
        elsif (exists &{$pkg.'::'.$name}) {}
        else { *{$pkg.'::'.$name} = \&{$parent.'::'.$name} }
    }

    for my $name (keys %$proto) {
        $name =~ s/^-//;
        *{$pkg.'::'.$name} = create_accessor($name)
            unless exists &{$pkg.'::'.$name};
    }

    mark_as_loaded($pkg)
        unless is_loaded($pkg);
}

1;
__END__