view release on metacpan or  search on metacpan

lib/Class/Lite.pm  view on Meta::CPAN

package Class::Lite;
# Choose minimum perl interpreter version; delete the rest.
# Do you want to enforce the bugfix level?
#~ use 5.008008;   # 5.8.8     # 2006  # oldest sane version
#~ use 5.008009;   # 5.8.9     # 2008  # latest 5.8
#~ use 5.010001;   # 5.10.1    # 2009  # say, state, switch
#~ use 5.012003;   # 5.12.5    # 2011  # yada
#~ use 5.014002;   # 5.14.3    # 2012  # pop $arrayref, copy s///r
#~ use 5.016002;   # 5.16.2    # 2012  # __SUB__
use strict;
use warnings;
use version; our $VERSION = qv('v0.1.0');

# Alternate uses
#~ use Devel::Comments '###', ({ -file => 'debug.log' });                   #~

## use
#============================================================================#

#=========# CLASS METHOD
#~ my $self    = My::Class->new(@_);
#
#   Classic hashref-based-object constructor.
#   Passes any arguments to init().
#   
sub new {
    my $class   = shift;
    my $self    = {};
    bless ( $self => $class );
    $self->init(@_);
    return $self;
}; ## new

#=========# OBJECT METHOD
#~ $self->init(@_);
#
#   Abstract method does nothing. Override in your class.
#   
sub init {
    return shift;
}; ## init

#=========# CLASS METHOD
#~ use Class::Lite qw| attr1 attr2 attr3 |;
#~ use Class::Lite qw|             # Simple base class with get/put accessors
#~     attr1
#~     attr2
#~     attr3
#~ |;
#
#   @
#   
sub import {
    no warnings 'uninitialized';
    my $class       = shift;
    my $caller      = caller;
    my $bridge      = qq{Class::Lite::$caller};
    ### $class
    ### $bridge
    ### $caller
    
    # In case caller is eager.
    my @args        = $class->fore_import(@_);
    ### @args
    
    # Do most work in the bridge class.    
    eval join qq{\n},
        qq* package $bridge;                                            *,
        qq* our  \@ISA;                                                 *,
        qq* push \@ISA, '$class';                                       *,
        map {
            defined and ! ref and /^[^\W\d]\w*\z/s
                or die "Invalid accessor name '$_'";
              qq* sub get_$_ { return \$_[0]->{$_} };                   *
            . qq* sub put_$_ { \$_[0]->{$_} = \$_[1]; return \$_[0] };  *
        } @args,
    ;
    # <xiong> I cannot figure out a way to make this eval fail.
    #           When you find out, please let me know. 
    # uncoverable branch true
    die "Failed to generate $bridge: $@" if $@;
    
    # Make caller inherit from bridge.
    eval join qq{\n},
        qq* package $caller;                                            *,
        qq* our  \@ISA;                                                 *,
        qq* push \@ISA, '$bridge';                                      *,
    ;
    # This second eval fails in case recursive inheritance is attempted.