view release on metacpan or  search on metacpan

lib/Kelp/Base.pm  view on Meta::CPAN

package Kelp::Base;

use strict;
use warnings;
use feature ();
use Carp;

require namespace::autoclean;
require Kelp::Util;

sub import
{
    my $class = shift;
    my $caller = caller;

    # Do not import into inherited classes
    return if $class ne __PACKAGE__;

    my $base = shift || $class;

    if ($base ne '-strict') {
        no strict 'refs';
        no warnings 'redefine';

        if ($base ne '-attr') {
            Kelp::Util::load_package($base);
            push @{"${caller}::ISA"}, $base;
        }

        *{"${caller}::attr"} = sub { attr($caller, @_) };

        namespace::autoclean->import(
            -cleanee => $caller
        );
    }

    strict->import;
    warnings->import;
    feature->import(':5.10');
}

sub new
{
    my $self = shift;
    return bless {@_}, $self;
}

sub attr
{
    my ($class, $name, $default) = @_;

    if (ref $default && ref $default ne 'CODE') {
        croak "Default value for '$name' can not be a reference.";
    }

    # Readonly attributes are marked with '-'
    my $readonly = $name =~ s/^\-//;

    # Remember if default is a function
    my $default_sub = ref $default eq 'CODE';

    {
        no strict 'refs';
        no warnings 'redefine';

        *{"${class}::$name"} = sub {
            return $_[0]->{$name} = $_[1] if @_ > 1 && !$readonly;
            return $_[0]->{$name} if exists $_[0]->{$name};
            return $_[0]->{$name} = $default_sub ? $default->($_[0]) : $default;
        };
    }
}

1;

__END__

=pod

=head1 NAME

Kelp::Base - Simple lazy attributes

=head1 SYNOPSIS

    use Kelp::Base;

    attr source => 'dbi:mysql:users';
    attr user   => 'test';
    attr pass   => 'secret';
    attr opts   =>  sub { { PrintError => 1, RaiseError => 1 } };

    attr dbh => sub {
        my $self = shift;
        DBI->connect( $self->sourse, $self->user, $self->pass, $self->opts );
    };