File Coverage

blib/lib/Object/Declare.pm

Criterion	Covered	Total	%
statement	140	146	95.8
branch	37	56	66.0
condition	9	20	45.0
subroutine	29	29	100.0
pod			n/a
total	215	251	85.6

package Object::Declare;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.24';

sub import {
    my $class       = shift;
    my %args        = ((@_ and ref($_[0])) ? (mapping => $_[0]) : @_) or return;
    my $from        = caller;

    my $mapping     = $args{mapping} or return;
    my $aliases     = $args{aliases}    || {};
    my $declarator  = $args{declarator} || ['declare'];
    my $copula      = $args{copula}     || ['is', 'are'];

    # Both declarator and copula can contain more than one entries;
    # normalize into an arrayref if we only have on entry.
    $mapping    = [$mapping]    unless ref($mapping);
    $declarator = [$declarator] unless ref($declarator);
    $copula     = [$copula]     unless ref($copula);

    if (ref($mapping) eq 'ARRAY') {
        # rewrite "MyApp::Foo" into simply "foo"
        $mapping = {
            map {
                my $helper = $_;
                $helper =~ s/.*:://;
                (lc($helper) => $_);
            } @$mapping
        };
    }

    # Convert mapping targets into instantiation closures
    if (ref($mapping) eq 'HASH') {
        foreach my $key (keys %$mapping) {
            my $val = $mapping->{$key};
            next if ref($val); # already a callback, don't bother
            $mapping->{$key} = sub { scalar($val->new(@_)) };
        }
    }

    if (ref($copula) eq 'ARRAY') {
        # add an empty prefix to all copula
        $copula = { map { $_ => '' } @$copula }
    }

    # Install declarator functions into caller's package, remembering
    # the mapping and copula set for this declarator.
    foreach my $sym (@$declarator) {
        no strict 'refs';

        *{"$from\::$sym"} = sub (&) {
            unshift @_, ($mapping, $copula, $aliases);
            goto &_declare;
        };
    }

    # Establish prototypes (same as "use subs") so Sub::Override can work
    {
        no strict 'refs';
        _predeclare(
            (map { "$from\::$_" } keys %$mapping),
            (map { ("UNIVERSAL::$_", "$_\::AUTOLOAD") } keys %$copula),
        );
    }
}

# Same as "use sub".  All is fair if you predeclare.
sub _predeclare {
    no strict 'refs';
    no warnings 'redefine';
    foreach my $sym (@_) {
        *$sym = \&$sym;
    }
}

sub _declare {
    my ($mapping, $copula, $aliases, $code) = @_;
    my $from = caller;

    # Table of collected objects.
    my @objects;

    # Establish a lexical extent for overrided symbols; they will be
    # restored automagically upon scope exit.
    my %subs_replaced;
    my $replace = sub {
        no strict 'refs';
        no warnings 'redefine';
        my ($sym, $code) = @_;

        # Do the "use subs" predeclaration again before overriding, because
        # Sub::Override cannot handle empty symbol slots.  This is normally
        # redundant (&import already did that), but we do it here anyway to
        # guard against runtime deletion of symbol table entries.
        _predeclare($sym);

        # Now replace the symbol for real.
        $subs_replaced{$sym} ||= *$sym{CODE};
        *$sym = $code;
    };

    # In DSL (domain-specific language) mode; install AUTOLOAD to handle all
    # unrecognized calls for "foo is 1" (which gets translated to "is->foo(1)",
    # and UNIVERSAL to collect "is foo" (which gets translated to "foo->is".
    # The arguments are rolled into a Katamari structure for later analysis.
    while (my ($sym, $prefix) = each %$copula) {
        $replace->( "UNIVERSAL::$sym" => sub {
            # Turn "is some_field" into "some_field is 1"
            my ($key, @vals) = ref($prefix) ? $prefix->(@_) : ($prefix.$_[0] => 1) or return;
            # If the copula returns a ready-to-use katamari object,
            # don't try to roll it by ourself.
            return $key
                if ref($key) && ref($key) eq 'Object::Declare::Katamari';
            $key = $aliases->{$key} if $aliases and exists $aliases->{$key};
            unshift @vals, $key;
            bless( \@vals => 'Object::Declare::Katamari' );
        } );
        $replace->( "$sym\::AUTOLOAD" => sub {
            # Handle "some_field is $some_value"
            shift;

            my $field = our $AUTOLOAD;
            return if $field =~ /DESTROY$/;

            $field =~ s/^\Q$sym\E:://;

            my ($key, @vals) = ref($prefix) ? $prefix->($field, @_) : ($prefix.$field => @_) or return;

            $key = $aliases->{$key} if $aliases and exists $aliases->{$key};
            unshift @vals, $key;
            bless( \@vals, 'Object::Declare::Katamari' );
        } );
    }

    my @overridden = map { "$from\::$_" } keys %$mapping;
    # Now install the collector symbols from class mappings
    my $toggle_subs = sub {
        foreach my $sym (@overridden) {
            no strict 'refs';
            no warnings 'redefine';
            ($subs_replaced{$sym}, *$sym) = (*$sym{CODE}, $subs_replaced{$sym});
        }
    };

    while (my ($sym, $build) = each %$mapping) {
        $replace->("$from\::$sym" => _make_object($build => \@objects, $toggle_subs));
    }

    # Let's play Katamari!
    &$code;

    # Restore overriden subs
    while (my ($sym, $code) = each %subs_replaced) {
        no strict 'refs';
        no warnings 'redefine';
        *$sym = $code;
    }

    # In scalar context, returns hashref; otherwise preserve ordering
    return(wantarray ? @objects : { @objects });
}

# Make a star from the Katamari!
sub _make_object {
    my ($build, $schema, $toggle_subs) = @_;

    return sub {
        # Restore overriden subs
        no strict 'refs';
        no warnings 'redefine';

        my $name   = ( ref( $_[0] ) ? undef : shift );
        my $args   = \@_;
        my $damacy = bless(sub {
            $toggle_subs->();

            my $rv = $build->(
                ( $_[0] ? ( name => $_[0] ) : () ),
                map { $_->unroll } @$args
            );

            $toggle_subs->();

            return $rv;
        } => 'Object::Declare::Damacy');

        if (wantarray) {
            return ($damacy);
        } else {
            push @$schema, $name => $damacy->($name);
        }
    };
}

package Object::Declare::Katamari;

use overload "!" => \&negation, fallback => 1;

sub negation {
    my @katamari = @{$_[0]} or return ();
    $katamari[1] = !$katamari[1];
    return bless(\@katamari, ref($_[0]));
}

# Unroll a Katamari structure into constructor arguments.
sub unroll {
    my @katamari = @{$_[0]} or return ();
    my $field = shift @katamari or return ();
    my @unrolled;

    unshift @unrolled, pop(@katamari)->unroll
        while ref($katamari[-1]) eq __PACKAGE__;

    if (@katamari == 1) {
        # single value: "is foo"
        if ( ref( $katamari[0] ) eq 'Object::Declare::Damacy' ) {
            $katamari[0] = $katamari[0]->($field);
        }
        return($field => @katamari, @unrolled);
    }
    else {
        # Multiple values: "are qw( foo bar baz )"
        foreach my $kata (@katamari) {
            $kata = $kata->() if ref($kata) eq 'Object::Declare::Damacy';
        }
        return($field => \@katamari, @unrolled);
    }
}

1;

__END__