File Coverage

blib/lib/Class/Tiny.pm

Criterion	Covered	Total	%
statement	109	117	93.1
branch	43	54	79.6
condition	12	18	66.6
subroutine	19	21	90.4
pod	0	10	0.0
total	183	220	83.1

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

package Class::Tiny;
# ABSTRACT: Minimalist class construction
our $VERSION = '0.014'; # VERSION

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;
    _gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr;
    Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
}

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

    my $sub = "sub $name { if (\@_ == 1) {";
    if ( defined $outer_default && ref $outer_default eq 'CODE' ) {
        $sub .= "if ( !exists \$_[0]{$name} ) { \$_[0]{$name} = \$default->(\$_[0]) }";
    }
    elsif ( defined $outer_default ) {
        $sub .= "if ( !exists \$_[0]{$name} ) { \$_[0]{$name} = \$default }";
    }
    $sub .= "return \$_[0]{$name} } else { return \$_[0]{$name}=\$_[1] } }";

    # 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 $@;
}

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 = '0.014'; # VERSION

my ( %LINEAR_ISA_CACHE, %BUILD_CACHE, %DEMOLISH_CACHE, %CAN_CACHE );

my $_PRECACHE = sub {
    my ($class) = @_;
    $LINEAR_ISA_CACHE{$class} =
      @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object"
      ? [$class]
      : mro::get_linear_isa($class);
    for my $s ( @{ $LINEAR_ISA_CACHE{$class} } ) {
        no warnings 'once'; # needed to avoid downstream warnings
        $BUILD_CACHE{$s}    = *{"$s\::BUILD"}{CODE};
        $DEMOLISH_CACHE{$s} = *{"$s\::DEMOLISH"}{CODE};
    }
    return $LINEAR_ISA_CACHE{$class};
};

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

    # handle hash ref or key/value arguments
    my $args;
    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
    my $self = bless {%$args}, $class;
    for my $s ( reverse @$linear_isa ) {
        next unless my $builder = $BUILD_CACHE{$s};
        $builder->( $self, $args );
    }

    # unknown attributes still in $args are fatal
    my @bad;
    for my $k ( keys %$args ) {
        push( @bad, $k )
          unless $CAN_CACHE{$class}{$k} ||= $self->can($k); # a heuristic to catch typos
    }
    Carp::croak("Invalid attributes for $class: @bad") if @bad;

    return $self;
}

# 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 $s ( @{ $LINEAR_ISA_CACHE{$class} } ) {
        next unless my $demolisher = $DEMOLISH_CACHE{$s};
        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__