File Coverage

blib/lib/Class/Tiny.pm

Criterion	Covered	Total	%
statement	98	101	97.0
branch	37	50	74.0
condition	15	27	55.5
subroutine	21	23	91.3
pod	0	10	0.0
total	171	211	81.0

use 5.006;
use strict;
no strict 'refs';
use warnings;

package Class::Tiny;
# ABSTRACT: Minimalist class construction

our $VERSION = '1.007'; # TRIAL

use Carp ();

# load as .pm to hide from min version scanners
require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" ); ## no critic:

my %CLASS_ATTRIBUTES;

sub import {
    my $class = shift;
    my $pkg   = caller;
    $class->prepare_class($pkg);
    $class->create_attributes( $pkg, @_ ) if @_;
}

sub prepare_class {
    my ( $class, $pkg ) = @_;
    @{"${pkg}::ISA"} = "Class::Tiny::Object" unless @{"${pkg}::ISA"};
}

# adapted from Object::Tiny and Object::Tiny::RW
sub create_attributes {
    my ( $class, $pkg, @spec ) = @_;
    my %defaults = map { ref $_ eq 'HASH' ? %$_ : ( $_ => undef ) } @spec;
    my @attr = grep {
        defined and !ref and /^[^\W\d]\w*$/s
          or Carp::croak "Invalid accessor name '$_'"
    } keys %defaults;
    $CLASS_ATTRIBUTES{$pkg}{$_} = $defaults{$_} for @attr;
    $class->_gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr;
    Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
}

sub _gen_accessor {
    my ( $class, $pkg, $name ) = @_;
    my $outer_default = $CLASS_ATTRIBUTES{$pkg}{$name};

    my $sub =
      $class->__gen_sub_body( $name, defined($outer_default), ref($outer_default) );

    # default = outer_default avoids "won't stay shared" bug
    eval "package $pkg; my \$default=\$outer_default; $sub"; ## no critic
    Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
}

# NOTE: overriding __gen_sub_body in a subclass of Class::Tiny is risky and
# could break if the internals of Class::Tiny need to change for any
# reason.  That said, I currently see no reason why this would be likely to
# change.
#
# The generated sub body should assume that a '$default' variable will be
# in scope (i.e. when the sub is evaluated) with any default value/coderef
sub __gen_sub_body {
    my ( $self, $name, $has_default, $default_type ) = @_;

    if ( $has_default && $default_type eq 'CODE' ) {
        return << "HERE";
sub $name {
    return (
          ( \@_ == 1 && exists \$_[0]{$name} )
        ? ( \$_[0]{$name} )
        : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default->( \$_[0] ) )
    );
}
HERE
    }
    elsif ($has_default) {
        return << "HERE";
sub $name {
    return (
          ( \@_ == 1 && exists \$_[0]{$name} )
        ? ( \$_[0]{$name} )
        : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default )
    );
}
HERE
    }
    else {
        return << "HERE";
sub $name {
    return \@_ == 1 ? \$_[0]{$name} : ( \$_[0]{$name} =  \$_[1] );
}
HERE
    }
}

sub get_all_attributes_for {
    my ( $class, $pkg ) = @_;
    my %attr =
      map { $_ => undef }
      map { keys %{ $CLASS_ATTRIBUTES{$_} || {} } } @{ mro::get_linear_isa($pkg) };
    return keys %attr;
}

sub get_all_attribute_defaults_for {
    my ( $class, $pkg ) = @_;
    my $defaults = {};
    for my $p ( reverse @{ mro::get_linear_isa($pkg) } ) {
        while ( my ( $k, $v ) = each %{ $CLASS_ATTRIBUTES{$p} || {} } ) {
            $defaults->{$k} = $v;
        }
    }
    return $defaults;
}

package Class::Tiny::Object;
# ABSTRACT: Base class for classes built with Class::Tiny

our $VERSION = '1.007'; # TRIAL

my ( %HAS_BUILDARGS, %BUILD_CACHE, %DEMOLISH_CACHE, %ATTR_CACHE );

my $_PRECACHE = sub {
    no warnings 'once'; # needed to avoid downstream warnings
    my ($class) = @_;
    my $linear_isa =
      @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object"
      ? [$class]
      : mro::get_linear_isa($class);
    $DEMOLISH_CACHE{$class} = [
        map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
        map { "$_\::DEMOLISH" } @$linear_isa
    ];
    $BUILD_CACHE{$class} = [
        map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
        map { "$_\::BUILD" } reverse @$linear_isa
    ];
    $HAS_BUILDARGS{$class} = $class->can("BUILDARGS");
    return $ATTR_CACHE{$class} =
      { map { $_ => 1 } Class::Tiny->get_all_attributes_for($class) };
};

sub new {
    my $class = shift;
    my $valid_attrs = $ATTR_CACHE{$class} || $_PRECACHE->($class);

    # handle hash ref or key/value arguments
    my $args;
    if ( $HAS_BUILDARGS{$class} ) {
        $args = $class->BUILDARGS(@_);
    }
    else {
        if ( @_ == 1 && ref $_[0] ) {
            my %copy = eval { %{ $_[0] } }; # try shallow copy
            Carp::croak("Argument to $class->new() could not be dereferenced as a hash") if $@;
            $args = \%copy;
        }
        elsif ( @_ % 2 == 0 ) {
            $args = {@_};
        }
        else {
            Carp::croak("$class->new() got an odd number of elements");
        }
    }

    # create object and invoke BUILD (unless we were given __no_BUILD__)
    my $self =
      bless { map { $_ => $args->{$_} } grep { exists $valid_attrs->{$_} } keys %$args },
      $class;
    $self->BUILDALL($args) if !delete $args->{__no_BUILD__} && @{ $BUILD_CACHE{$class} };

    return $self;
}

sub BUILDALL { $_->(@_) for @{ $BUILD_CACHE{ ref $_[0] } } }

# Adapted from Moo and its dependencies
require Devel::GlobalDestruction unless defined ${^GLOBAL_PHASE};

sub DESTROY {
    my $self  = shift;
    my $class = ref $self;
    my $in_global_destruction =
      defined ${^GLOBAL_PHASE}
      ? ${^GLOBAL_PHASE} eq 'DESTRUCT'
      : Devel::GlobalDestruction::in_global_destruction();
    for my $demolisher ( @{ $DEMOLISH_CACHE{$class} } ) {
        my $e = do {
            local ( $?, $@ );
            eval { $demolisher->( $self, $in_global_destruction ) };
            $@;
        };
        no warnings 'misc'; # avoid (in cleanup) warnings
        die $e if $e;       # rethrow
    }
}

1;


# vim: ts=4 sts=4 sw=4 et:

__END__