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;
[download]