File Coverage

blib/lib/Class/Lite.pm

Criterion	Covered	Total	%
statement	46	46	100.0
branch	5	6	100.0
condition	6	6	100.0
subroutine	18	18	100.0
pod	4	4	100.0
total	79	80	100.0

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,
    ;
    #  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.
    die "Failed to generate $caller: $@" if $@;

    # In case caller must get the last word.
    $class->rear_import(@_);

    return 1;
}; ## import

# Dummy methods do nothing.
sub fore_import { shift; return @_ };
sub rear_import { shift; return @_ };

## END MODULE
1;
#============================================================================#
__END__