package Autoload::Hash;
require 5.5.0;

our ($VERSION) = '0.1';

# -- Documentation -----------------------------------------------------------

=head1 NAME

Autoload::Hash - Builds in AUTOLOAD functionality to objects

=head1 SYNOPSIS

    package MyObject;

    use Autoload::Hash;

    our (%DEFAULTS) = ( 'param1' => 'value1', ... );

    sub func1
    {
        my $self = shift;

        $self->param2 = "Data";         # Scalar assignment
        $self->param3 = {'x1'=>'v1'};   # Hash reference
        $self->param4 = ['x1','y1'];    # Array reference

        $self->func2();

        return;
    };

    package main;

    my ($object) = new MyObject();

    $object->reference1 = "Data";       # C++-style assignment
    print $object->reference1,"\n";

=head1 DESCRIPTION

C<Autoload> installs an AUTOLOAD sub in the current package space.
It operates on HASH-type objects, which are certainly one of the more
popular varieties.

Additionally, a default C<new> constructor is installed, but this may
be overridden as required. If the C<new> constructor is fine, but some
additional configuration is required, this can be stored in an C<init>
function.

    sub init
    {
        my ($self) = shift;

        $self->setting1 = "Setting 1 Data";
    }

Any data from the package C<%DEFAULTS> hash will be inserted into
newly created objects. Additional parameters can be added in the
C<new> call:

    my ($object) = new Object ('param1' => 'Param 1 Data');

The parameters supplied to C<new> will override any supplied in
C<%DEFAULTS>.

Calls to undefined values in the object will return 'C<undef>', which
may cause warnings when using 'C<perl -w>', but this is to be expected.

Additionally, objects can reference other objects and their methods:

    $object->subobject = new OtherObject();

    $object->subobject->reference = "Value";
    $object->subobject->An_OtherObject_Method();

=head1 OPTIONS

C<Autoload> can be instanced with a few different methods, any one
of which can be selected depending on the usage requirements:

    use Autoload::Hash 'public';

This is the default method, whereby any function can read and write to
the object's contents.

    use Autoload::Hash 'static';

This creates a static interface to the object properties, whereby nothing
can be modified, even by the object on itself.

    use Autoload::Hash 'private';

This creates a private interface, whereby the object can modify itself
by default, but others are prevented from making changes, and are reduced
to a 'static' capacity (read-only).

    use Autoload::Hash qw(friends PackageA ObjectB &MethodC &PackageD::MethodE);

This will allow read/write access to the object properties from the object
itself, or any calls originaiting in C<PackageA::>, C<ObjectB::>, or from
sub C<&MethodC> in any package, or from the sub C<&MethodE> only from the
C<PackageD::> package. The C<friends> usage will create a C<%FRIENDS>
hash in the calling package namespace where the access information is
stored. This data should not be modified directly.

=head1 LIMITATIONS

When using C<friends>, note that the call to the object must originate
within in one of the listed packages, and not in some manner that would
seem to go through one of them.

Consider this code:

        package Objet;

        use AutoLoad::Hash;

        our (%DEFAULTS) = ( value_x => 1, value_y => 'z' );

        package ObjetAmi;

        use Autoload::Hash qw( friends Objet );

        package main;

        my ($object) = new Objet;

        $object->friend = new ObjetAmi;         # OK

        $object->friend->x = "Something";       # Fails

The assignment of "friend->x" fails since the call is originating outside
of the "Object" package, and from C<main::> instead, which is not listed
as a friend. In a sense, the C<ObjectFriend> instance has no idea that it
is stored within a friendly C<Object>, as this information is not readily
available. Instead, it understands the call originated in C<main::>, which
is not listed, and is therefore invalid (read-only).

    package MyObject;

    use Autoload::Hash;

Presumably additional subroutines would be added after this code to
build some functionality into this object.

To develop a better understanding of Perl objects, visit some of the
on-line reference materials, such as:

        Tom's Object-Oriented Tutorial for Perl
        http://www.perl.com/pub/doc/manual/html/pod/perltoot.html

=head1 BUGS

Autoload performs as expected on HASH-type objects, but may behave
unexpectedly in other cases. Support for other techniques, such as
ARRAY-type objects, may be added at a later point in time.

=head1 AUTHOR

Scott Tadman <tadman@elyrium.com>

=cut

# ' <- Syntax catcher ("Tom*s")

# -- Imports -----------------------------------------------------------------

use Exporter;
use strict qw (vars subs);

use vars '$AUTOLOAD';

# -- Globals -----------------------------------------------------------------

my (%FRIENDS);  # Stunt double (calling packages have their own) (ORPHAN)
our ($temp);    # Throw-away value returned to callers

my (@EXPORT) = qw( new );

# assert{}() will send a message to STDERR unless the code returns a true value

sub assert (&@)
{
        my ($test) = shift;
        my (@callers);

        # If we pass, forget about it.
        return if (&$test);

        # Now complain about the calling caller (caller(1))
        warn sprintf ("%s at %s line %d\n", join ('', @_), (caller(1))[1,2]);
}

# import() loads the package methods into the importing package namespace

sub import
{
        my ($caller_package, $caller_file, $caller_line) = caller;
        my ($package) = shift;
        my ($symbol);

        @_ = ('public') unless (@_);

        $symbol = shift;

        if ($symbol =~ /^(public|static|private)$/)
        {
                *{"${caller_package}::AUTOLOAD"} = \&{"${package}::AUTOLOAD_$symbol"};

                assert { @_ } "Too many parameters in 'use' call";
        }
        elsif ($symbol eq 'friends')
        {
                *{"${caller_package}::AUTOLOAD"} = \&{"${package}::AUTOLOAD_friends"};

                # At the very least, the object can make calls to itself (default)
                local (*FRIENDS)   = \%{"${caller_package}::FRIENDS"};

                %FRIENDS = ('X::*' => { $caller_package => 'rw' });

                my ($friend);
                foreach $friend (@_)
                {
                        print "Adding friend $friend\n";
                        if ($friend =~ /^&/)
                        {
                                if ($friend =~ /::/)
                                {
                                        $FRIENDS{'X::X'}{$friend} = 'rw';
                                }
                                }
                        }
                        else
                        {
                                $FRIENDS{'X::*'}{$friend} = 'rw';
                        }
                }

                my ($entry);
                foreach $entry (keys %FRIENDS)
                {
                        print "$entry:\n";
                        foreach (keys %{$FRIENDS{$entry}})
                        {
                                print "\t$_\n";
                        }
                }

                %{"${caller_package}::FRIENDS"} = %FRIENDS;
        }
        else
        {
                assert {} "Undefined import method '$symbol'";
        }

        # Load in the standard EXPORTs

        my ($export);
        foreach $export (@EXPORT)
        {
                *{"${caller_package}::$export"} = \&{"$export"};
        }
}

sub find_object_sub ($)
{
        my ($package,$sub) = @_;

        if (*{"${package}::${package}::$sub"}{CODE})
        {
                return \&{"${package}::${package}::$sub"};
        }

        return;
}

# -- AUTOLOAD Arsenal --------------------------------------------------------

sub AUTOLOAD_public : lvalue
{
        my ($caller_package) = caller;
        my ($self)           = shift;

        assert {ref ($self)} "Autoload.pm: Non-object reference to $AUTOLOAD for package $c
aller_package";

        $AUTOLOAD =~ s/.*://;

        @_?
                $self->{$AUTOLOAD} = shift
                : !defined($self->{$AUTOLOAD})?
                        $self->{$AUTOLOAD} = undef
                        : $self->{$AUTOLOAD};
}

sub AUTOLOAD_static
{
        my ($caller_package) = caller;
        my ($self)           = shift;

        assert {ref($self)} "Autoload.pm: Non-object reference to $AUTOLOAD for package $ca
ller_package";


        $AUTOLOAD =~ s/.*://;

        assert {@_}         "Invalid assignment to static property";

        return $self->{$AUTOLOAD};
}

sub AUTOLOAD_private : lvalue
{
        my ($caller_package) = caller;
        my ($self)           = shift;

        assert {ref($self)} "Autoload.pm: Non-object reference to $AUTOLOAD for package $ca
ller_package";

        $AUTOLOAD =~ s/.*://;

        # Invalid object reference. (FUTURE: Fix)
        assert { ref ($self) } "Autoload.pm: Undefined subroutine $AUTOLOAD";

        (ref($self) eq $caller_package)?
                @_?
                        $self->{$AUTOLOAD} = shift
                        : !defined($self->{$AUTOLOAD})?
                                $self->{$AUTOLOAD} = undef
                                : $self->{$AUTOLOAD}
                : $temp = $self->{$AUTOLOAD};
}

sub AUTOLOAD_friends : lvalue
{
        my ($caller_package, $caller_file, $caller_line, $caller_func) = caller(0);
        my ($self)         = shift;

        assert {ref($self)} "Autoload.pm: Non-object reference to $AUTOLOAD for package $ca
ller_package";

        my ($self_package) = ref($self);
        local (*FRIENDS)   = \%{"${self_package}::FRIENDS"};

        $AUTOLOAD =~ s/.*://;

        # Determine if this "friend" has access to these structures, or if a
        # temp should be returned as a decoy (to prevent any real damage)
        (
                ($FRIENDS{'X::*'} && $FRIENDS{'X::*'}{$caller_package}) ||
                ($FRIENDS{'*::X'} && $FRIENDS{'*::X'}{$caller_func})    ||
                ($FRIENDS{'X::X'} && $FRIENDS{'X::X'}{"$caller_package\::$caller_func"})
        )? @_ ? $self->{$AUTOLOAD} = shift : $self->{$AUTOLOAD} ||= undef : $temp = $self->
{$AUTOLOAD};
}

# -- Default Methods ---------------------------------------------------------

my (@SELF_STACK);

sub new (%)
{
        my ($this) = shift;

        my ($class) = ref ($this) || $this;

        # Assign (with optional defaults) as required
        my ($self) = (defined %{"${class}::DEFAULTS"})? { %{"${class}::DEFAULTS"}, @_ } : {
 @_ };

        # Bless accordingly, to assign proper class
        bless ($self, $class);

        # Operate the init() function, if defined properly
        $self->init() if (*{"${class}::init"}{CODE});

        # Return reference to the newly minted object
        return $self;
}

# -- Exit --------------------------------------------------------------------

1;