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 noth
+ing
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 redu
+ced
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 ob
+ject
itself, or any calls originaiting in C<PackageA::>, C<ObjectB::>, or f
+rom
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 woul
+d
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 outs
+ide
of the "Object" package, and from C<main::> instead, which is not list
+ed
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 read
+ily
available. Instead, it understands the call originated in C<main::>, w
+hich
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) (ORPH
+AN)
our ($temp); # Throw-away value returned to callers
my (@EXPORT) = qw( new );
# assert{}() will send a message to STDERR unless the code returns a t
+rue 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 namesp
+ace
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}::AUT
+OLOAD_$symbol"};
assert { @_ } "Too many parameters in 'use' call";
}
elsif ($symbol eq 'friends')
{
*{"${caller_package}::AUTOLOAD"} = \&{"${package}::AUT
+OLOAD_friends"};
# At the very least, the object can make calls to itse
+lf (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} = 'r
+w';
}
}
}
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 $AU
+TOLOAD 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 $AUT
+OLOAD 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 $AUT
+OLOAD for package $ca
ller_package";
$AUTOLOAD =~ s/.*://;
# Invalid object reference. (FUTURE: Fix)
assert { ref ($self) } "Autoload.pm: Undefined subroutine $AUT
+OLOAD";
(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 $AUT
+OLOAD 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, o
+r if a
# temp should be returned as a decoy (to prevent any real dama
+ge)
(
($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} ||= un
+def : $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;
|