package Class::Basic;
use warnings;
use strict;
use Carp;
use version; our $VERSION = qv('0.2.1');
=pod
=head1 NAME
Class::Basic - Tool to help organize and build perl classes
=cut
my @exported_subs = qw{ new has AUTOLOAD };
sub import {
my $caller = caller;
no strict 'refs';
foreach my $sub (@exported_subs) {
*{ $caller . '::' . $sub } = \&{$sub};
}
}
=pod
=head1 new
Constructer
It will call a BUILD method on every class in the
inheritance tree starting at the parent. BUILD is
also passed a hash_ref with the arguments passed to new.
new is exported by default.
=cut
my %_init_args;
sub new {
my ( $class, $args ) = @_;
croak "Argument to new must be hash reference"
if @_ > 1 && ref $args ne 'HASH';
my $self = bless {}, ref $class || $class;
foreach my $init_arg ( keys %_init_args ) {
my $key = $_init_args{$init_arg};
$self->{$init_arg} = $args->{$key} || $args->{$init_arg};
delete $args->{$key} if exists $args->{$key};
delete $args->{$init_arg} if exists $args->{$init_arg};
}
my @build = _reverse_hierarchy_of($class);
foreach my $pkg (@build) {
no strict 'refs';
if ( my $build_ref = *{ $pkg . '::BUILD' }{CODE} ) {
$build_ref->( $self, $args );
}
}
return $self;
}
=pod
=head1 has
Create attributes.
=over 4
=item has attribute => ( is => 'rw' );
This would create the method $self->attribute that can get and set the
+ attribute
=item has attribute => ( is => 'rw', reader => 'get_attribute', writer
+ => 'set_attribute' );
This would create the methods $self->get_attribute and $self->set_attr
+ibute for the attribute
=item has attribute => ( is => 'ro', default => sub { 42 }, predicate
+=> 'has_attribute' );
This would create a read only method $self->attribute and the default
+value is 42. The default value must be a CODE ref.
The CODE ref will receive $self as an argument. The default is always
+lazily set and the attribute is not set until the
attribute method is called. The predicate key will create a boolean me
+thod for the attribute named after the value of the
predicate key.
=item has attribute => ( is => 'ro', init_arg => 1 ); Class->new( { at
+tribute => 'value' } );
A read only method will be created and the key 'attribute' will be ini
+tialized automatically at instantiation.
=back
has is exported by default.
=cut
sub has($;%) {
my ( $attr, %meta ) = @_;
my $caller = caller();
my $reader = $meta{'reader'} || $attr;
my $writer = $meta{'writer'} || $attr;
$_init_args{$attr} = $meta{'init_arg'}
if ( exists $meta{'init_arg'} and $meta{'init_arg'} );
croak 'Default must be a code ref'
if exists $meta{'default'} and ref $meta{'default'} ne 'CODE';
if ( $reader eq $writer ) {
if ( !exists $meta{'is'} or $meta{'is'} eq 'ro' ) {
_ro_method( $caller, $attr, $reader, $meta{'default'} );
}
elsif ( exists $meta{'is'} and $meta{'is'} eq 'wo' ) {
_wo_method( $caller, $attr, $writer, $meta{'default'} );
}
elsif ( exists $meta{'is'} and $meta{'is'} eq 'rw' ) {
_rw_method( $caller, $attr, $writer, $meta{'default'} );
}
}
else {
if ( !exists $meta{'is'} or $meta{'is'} eq 'ro' ) {
_ro_method( $caller, $attr, $reader, $meta{'default'} );
}
elsif ( exists $meta{'is'} and $meta{'is'} eq 'wo' ) {
_wo_method( $caller, $attr, $writer, $meta{'default'} );
}
elsif ( exists $meta{'is'} and $meta{'is'} eq 'rw' ) {
_ro_method( $caller, $attr, $reader, $meta{'default'} );
_wo_method( $caller, $attr, $writer, $meta{'default'} );
}
}
if ( exists $meta{'predicate'} and $meta{'predicate'} ) {
_predicate_method( $caller, $attr, $meta{'predicate'} );
}
}
=pod
=head1 _reverse_hierarchy_of
Walk the ISA tree and return the list of inheritance starting at the p
+arent/base.
=cut
my %_reverse_hierarchy_of;
sub _reverse_hierarchy_of {
my ($class) = @_;
return @{ $_reverse_hierarchy_of{$class} }
if exists $_reverse_hierarchy_of{$class};
no strict 'refs';
my @hierarchy = $class;
my @parents = reverse @{ $class . '::ISA' };
while ( defined( my $parent = shift @parents ) ) {
push @hierarchy, $parent;
push @parents, reverse @{ $parent . '::ISA' };
}
my %seen;
return @{ $_reverse_hierarchy_of{$class} } =
reverse sort { $a->isa($b) ? -1 : $b->isa($a) ? +1 : 0 }
grep !$seen{$_}++, @hierarchy;
}
sub _ro_method {
my ( $pkg, $attr, $reader, $default ) = @_;
no strict 'refs';
*{ $pkg . '::' . $reader } = sub {
my ($self) = @_;
carp $reader . ' is a read only accessor.' if scalar @_ > 1;
$self->{$attr} ||= $default->($self)
if $default and ref $default eq 'CODE';
return $self->{$attr};
};
}
sub _wo_method {
my ( $pkg, $attr, $writer, $default ) = @_;
no strict 'refs';
*{ $pkg . '::' . $writer } = sub {
my ( $self, $value ) = @_;
my $old = $self->{$attr} ||= $default->($self)
if $default and ref $default eq 'CODE';
$self->{$attr} = $value if $value;
return $old || $self->{$attr};
};
}
sub _rw_method {
my ( $pkg, $attr, $writer, $default ) = @_;
no strict 'refs';
*{ $pkg . '::' . $writer } = sub {
my ( $self, $value ) = @_;
my $old = $self->{$attr} ||= $default->($self)
if $default and ref $default eq 'CODE';
$self->{$attr} = $value if $value;
return $old || $self->{$attr};
};
}
sub _predicate_method {
my ( $pkg, $attr, $predicate ) = @_;
no strict 'refs';
*{ $pkg . '::' . $predicate } = sub {
my ($self) = @_;
if ( exists $self->{$attr} and ref $self->{$attr} ) {
if ( ref $self->{$attr} eq 'ARRAY' ) {
return ( @{ $self->{$attr} } ) ? 1 : 0;
}
elsif ( ref $self->{$attr} eq 'HASH' ) {
return ( %{ $self->{$attr} } ) ? 1 : 0;
}
else {
return ( defined $self->{$attr} ) ? 1 : 0;
}
}
elsif ( exists $self->{$attr} ) {
return ( defined $self->{$attr} ) ? 1 : 0;
}
else {
return 0;
}
};
}
sub AUTOLOAD {
my ($self) = @_;
my $invocant_class = ref $self || $self;
my ( $package_name, $method_name )
= our $AUTOLOAD =~ m/ (.*) :: (.*) /xms;
return if $method_name eq 'DESTROY';
for my $parent_class ( reverse _reverse_hierarchy_of($invocant_cla
+ss) ) {
no strict 'refs';
if ( my $automethod_ref = *{ $parent_class . '::AUTOMETHOD' }{
+CODE} )
{
local $CALLER::_ = $_;
local $_ = $method_name;
if ( my $method_impl
= $automethod_ref->( $self, @_[ 1 .. $#_ ] ) )
{
goto &$method_impl;
}
}
}
my $type = ref $self ? 'object' : 'class';
croak
qq{Can't locate $type method "$method_name" via package "$pack
+age_name"};
}
{
my $real_can = \&UNIVERSAL::can;
no warnings 'redefine', 'once';
*UNIVERSAL::can = sub {
my ( $self, $method_name ) = @_;
if ( my $sub_ref = $real_can->(@_) ) {
return $sub_ref;
}
for my $parent_class (
reverse _reverse_hierarchy_of( ref $self || $self ) )
{
no strict 'refs';
if ( my $automethod_ref
= *{ $parent_class . '::AUTOMETHOD' }{CODE} )
{
local $CALLER::_ = $_;
local $_ = $method_name;
if ( my $method_impl = $automethod_ref->(@_) ) {
return sub { my $inv = shift; $inv->$method_name(@
+_) }
}
}
}
return;
};
}
1;
rlb3 |