File Coverage

blib/lib/Class/Meta/Express.pm

Criterion	Covered	Total	%
statement	107	107	100.0
branch	21	24	87.5
condition	2	2	100.0
subroutine	22	22	100.0
pod	6	6	100.0
total	158	161	98.1

package Class::Meta::Express;

use strict;
use vars qw($VERSION);
use Class::Meta '0.60';

$VERSION = '0.13';

my %meta_for;

sub import {
    my $pkg = shift;
    my $caller = caller;
    no strict 'refs';
    return shift if defined &{"$caller\::meta"};
    *{"$caller\::$_"} = $pkg->can($_)
        for qw(class meta ctor has method build);
    return shift;
}

sub class (&) {
    my $code = shift;
    goto sub {
        $code->();
        goto &build;
    };
}

sub meta {
    _new_meta( scalar caller, @_ );
}

sub ctor {
    unshift @_, 'constructor';
    goto &_meth;
}

sub has {
    my $caller = caller;
    my $meta = _meta_for( $caller );
    unshift @_, $meta, 'name';
    splice @_, 3, 1, %{ $_[3] } if ref $_[3] eq 'HASH';
    goto &{ $meta->can('add_attribute') };
}

sub method {
    unshift @_, 'method';
    goto &_meth;
}

sub build {
    my $meta = delete $meta_for{ my $caller = caller };
    # Remove exported functions.
    _unimport($caller);

    # Build the class.
    unshift @_, $meta;
    goto &{ $meta->can('build') };
}

sub _new_meta {
    my ($caller, $key) = (shift, shift);
    my $args = ref $_[0] eq 'HASH' ? $_[0] : { @_ };
    $args->{key} = $key;
    _export(delete $args->{reexport}, $caller, $args) if $args->{reexport};
    my $meta_class = delete $args->{meta_class} || 'Class::Meta';
    my $meta = $meta_class->new( package => $caller, %{ $args } );
    $meta_for{$caller} = $meta;
    return $meta;
}

sub _meta_for {
    my $caller = shift;
    unless ( $meta_for{ $caller } ) {
        # Create a key from the last part of the package name.
        (my $key = $caller) =~ s/.*:://;
        $key = lcfirst $key;
        $key =~ s/([[:upper:]]+)/_\L$1/g;
        _new_meta( $caller, $key );
    }
    return $meta_for{ $caller };
}

sub _meth {
    my $method = 'add_' . shift;
    my $meta = _meta_for( scalar caller );
    unshift @_, $meta, 'name';
    if (my $ref = ref $_[3]) {
        if ($ref eq 'CODE') {
            splice @_, 3, 0, 'code';
        } else {
            splice @_, 3, 1, %{ $_[3] } if $ref eq 'HASH';
        }
    }
    goto &{ $meta->can($method) };
}

sub _unimport {
    my $caller = shift;
    for my $fn (qw(class meta ctor has method build)) {
        no strict 'refs';
        my $name = "$caller\::$fn";
        # Copy the current glob contents, excluding CODE.
        my %things = map  { $_ => *{$name}{$_} }
                     grep { defined *{$name}{$_} }
                     qw(SCALAR ARRAY HASH IO FORMAT);
        # Undefine the glob and reinstall the contents.
        undef *{$name};
        *{$name} = $things{$_} for keys %things;
    }
}

sub _export {
    my ($export, $pkg, $args) = @_;
    my @args = map { $_ => $args->{$_} } grep { exists $args->{$_} }
        Class::Meta::INHERITABLE, 'meta_class';

    my $meta = !@args ? \&meta : sub {
        splice @_, 1, 0, @args;
        goto &Class::Meta::Express::meta;
    };

    $export = 0 unless ref $export eq 'CODE';

    no strict 'refs';
    *{"$pkg\::import"} = sub {
        my $caller = caller;
        no strict 'refs';
        unless (defined &{"$caller\::meta"}) {
            *{"$caller\::meta"} = $meta;
            *{"$caller\::$_"} = \&{__PACKAGE__ . "::$_"}
                for qw(class ctor has method build);
        }
        goto $export if $export;
        return shift;
    };
}

1;
__END__