use strict;
use warnings;

package My::Object {
    BEGIN {
        *VERSION = \'0.01';
        *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__

=pod

=encoding utf8

=head1 NAME

My::Object - a simple object system for Perl 5


=head1 SYNOPSIS

    package Local::Pony {
        use My::Object { name => undef };

        sub BUILD_Pony {
            my ($self, $name) = @_;
            $self->name = $name;
        }

        sub eatCarrot {
            printf "%s eats a carrot.\n", shift->name;
        }
    }

    *pony = Local::Pony->NEW;

    my $cuddles = pony("Cuddles");
    $cuddles->eatCarrot;


=head1 STATUS

Unstable. Stuff might change. As I have no clue what I'm doing, the code
might be evil.


=head1 DESCRIPTION

A small object system using blessed hashes with autogenerated lvalue
accessors. Code reuse is achieved via composition instead of inheritance:
C<@ISA> is not used. Instead, all methods are flattened into the package.

This module takes a worse-is-better approach: There's no encapsulation,
no inheritance, no type checking or other bells and whistles.

This is not Moose; it is not even Mo.


=head2 CLASS DECLARATION

A class is just a package that invokes C<use> on another class, in
particular C<My::Object>. This composes the callee into the caller, copying
all sub declarations into the package.

The C<use> statement takes a hash of members as optional argument, mapping
names to initializers. Accessors for these members will be generated
automatically.

Any sub defined within the package may be used as a method, with a reference
to the object passed as first argument.

=head3 DYNAMIC INITIALIZATION

Initializers are treated as constants by default. If you need to initialize
a member dynamically, you may provide a sub reference as initializer.
You need to prefix the member name with a C<->. This prefix is not part of
the name proper.

    use Scalar::Util qw(refaddr);

    package Local::Node {
        use My::Object {
            name => undef,
            -children => sub { [] },
        };
    }

    my $n1 = Local::Node::NEW->();
    my $n2 = Local::Node::NEW->();
    printf "0x%X != 0x%X\n", refaddr($n1->children), refaddr($n2->children);

=head3 CONFLICT RESOLUTION

You may use multiple C<use> statements to compose several classes into
the same package. Conflicts arise if the classes have methods with the same
name. In contrast, members of the same name will map to the same slot
and no conflict arises.

Conflicts can be resolved by adding the line

    use subs qw(name_of_conflicting_method);

before using any of the conflicting classes and manually providing
an appropriate method implementation:

    package Local::Alice {
        use My::Object;
        sub transmogrify { print "I'm a tiger!\n" }
    }

    package Local::Bob {
        use My::Object;
        sub transmogrify { print "I'm a frog!\n" }
    }

    package Local::AliceAndBob {
        use Local::Alice;
        use Local::Bob;
    }

This will die with I<Subroutine transmogrify redefined>, so we need to resolve
the conflict:

    package Local::AliceAndBob {
        use subs qw(transmogrify);
        use Local::Alice;
        use Local::Bob;

        sub transmogrify {
            print "Alice: ";
            Local::Alice::transmogrify(@_);
            print "Bob: ";
            Local::Bob::transmogrify(@_);
        }
    }

    Local::AliceAndBob::NEW->()->transmogrify;


=head2 OBJECT CONSTRUCTION

Any class automatically gets a sub C<NEW> that returns a reference to the
default constructor, initializing member variables from named arguments:

    package Local::Point {
        use My::Object { x => 0, y => 0 };
    }

    my $p = Local::Point::NEW->(x => 0.1, y => 0.2);
    printf "x=%f, y=%f\n", $p->x, $p->y;

Use the symbol table to manually import the constructor into the current
package:

    *point = Local::Point::NEW;
    my $q = point(x => 0.5, y => 0.2);

It's best to do so at C<BEGIN> time.


=head3 CUSTOM CONSTRUCTORS

If you want to provide a custom constructor, prefix the sub's name with
C<BUILD_> and pass the name without prefix to C<NEW> :

    package Local::Point {
        use My::Object { x => 0, y => 0 };

        sub BUILD_from_coords {
            my ($self, $x, $y) = @_;
            $self->x = $x;
            $self->y = $y;
        }
    }

    BEGIN { *point = Local::Point::NEW('from_coords') }

If you name constructor and package the same (only the part after
the last C<::> is relevant), C<-E<gt>NEW> will do the right thing:

    package Local::Point {
        use My::Object { x => 0, y => 0 }

        sub BUILD_Point { ... }
    }

    BEGIN { *point = Local::Point->NEW }


=head1 BUGS AND DEVELOPMENT

Development happens at L<Bitbucket|https://bitbucket.org/cggaertner/plobj>.
If you found a bug or have a feature request, use the
L<issue tracker|https://bitbucket.org/cggaertner/plobj/issues> over there.


=head1 COPYRIGHT AND LICENSE

Copyright (C) 2014 by Christoph Gärtner <cygx@cpan.org>

Distributed under the
L<Boost Software License, Version 1.0|http://www.boost.org/LICENSE_1_0.txt>

=cut
