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


line stmt bran cond sub pod time code
1 9     9   12453 use 5.006;
  9         33  
2 9     9   48 use strict;
  9         13  
  9         189  
3 9     9   37 no strict 'refs';
  9         17  
  9         268  
4 9     9   41 use warnings;
  9         14  
  9         493  
5              
6             package Class::Tiny;
7             # ABSTRACT: Minimalist class construction
8              
9             our $VERSION = '1.007'; # TRIAL
10              
11 9     9   64 use Carp ();
  9         24  
  9         7625  
12              
13             # load as .pm to hide from min version scanners
14             require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" ); ## no critic:
15              
16             my %CLASS_ATTRIBUTES;
17              
18             sub import {
19 16     16   1049 my $class = shift;
20 16         37 my $pkg = caller;
21 16         47 $class->prepare_class($pkg);
22 16 50       81 $class->create_attributes( $pkg, @_ ) if @_;
23             }
24              
25             sub prepare_class {
26 16     16 0 35 my ( $class, $pkg ) = @_;
27 16 100       25 @{"${pkg}::ISA"} = "Class::Tiny::Object" unless @{"${pkg}::ISA"};
  9         159  
  16         91  
28             }
29              
30             # adapted from Object::Tiny and Object::Tiny::RW
31             sub create_attributes {
32 16     16 0 145 my ( $class, $pkg, @spec ) = @_;
33 16 100       37 my %defaults = map { ref $_ eq 'HASH' ? %$_ : ( $_ => undef ) } @spec;
  31         137  
34             my @attr = grep {
35 16 50 33     49 defined and !ref and /^[^\W\d]\w*$/s
  35   33     330  
36             or Carp::croak "Invalid accessor name '$_'"
37             } keys %defaults;
38 16         82 $CLASS_ATTRIBUTES{$pkg}{$_} = $defaults{$_} for @attr;
39 16         30 $class->_gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr;
  35         49  
  35         190  
40 16 50       944 Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
41             }
42              
43             sub _gen_accessor {
44 33     33   80 my ( $class, $pkg, $name ) = @_;
45 33         57 my $outer_default = $CLASS_ATTRIBUTES{$pkg}{$name};
46              
47 33         101 my $sub =
48             $class->__gen_sub_body( $name, defined($outer_default), ref($outer_default) );
49              
50             # default = outer_default avoids "won't stay shared" bug
51 33 50 33 34 0 3672 eval "package $pkg; my \$default=\$outer_default; $sub"; ## no critic
  34 100 66 49 0 459  
  49 100 0 28 0 12360  
  28 100   12 0 206  
  12 50   0 0 531  
  0 100   0 0    
  0 0          
    0          
52 33 50       170 Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
53             }
54              
55             # NOTE: overriding __gen_sub_body in a subclass of Class::Tiny is risky and
56             # could break if the internals of Class::Tiny need to change for any
57             # reason. That said, I currently see no reason why this would be likely to
58             # change.
59             #
60             # The generated sub body should assume that a '$default' variable will be
61             # in scope (i.e. when the sub is evaluated) with any default value/coderef
62             sub __gen_sub_body {
63 33     33   109 my ( $self, $name, $has_default, $default_type ) = @_;
64              
65 33 100 100     188 if ( $has_default && $default_type eq 'CODE' ) {
    100          
66 4         19 return << "HERE";
67             sub $name {
68             return (
69             ( \@_ == 1 && exists \$_[0]{$name} )
70             ? ( \$_[0]{$name} )
71             : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default->( \$_[0] ) )
72             );
73             }
74             HERE
75             }
76             elsif ($has_default) {
77 4         20 return << "HERE";
78             sub $name {
79             return (
80             ( \@_ == 1 && exists \$_[0]{$name} )
81             ? ( \$_[0]{$name} )
82             : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default )
83             );
84             }
85             HERE
86             }
87             else {
88 25         95 return << "HERE";
89             sub $name {
90             return \@_ == 1 ? \$_[0]{$name} : ( \$_[0]{$name} = \$_[1] );
91             }
92             HERE
93             }
94             }
95              
96             sub get_all_attributes_for {
97 13     13 0 5732 my ( $class, $pkg ) = @_;
98             my %attr =
99 54         116 map { $_ => undef }
100 13 100       24 map { keys %{ $CLASS_ATTRIBUTES{$_} || {} } } @{ mro::get_linear_isa($pkg) };
  37         48  
  37         200  
  13         64  
101 13         98 return keys %attr;
102             }
103              
104             sub get_all_attribute_defaults_for {
105 3     3 0 6085 my ( $class, $pkg ) = @_;
106 3         10 my $defaults = {};
107 3         5 for my $p ( reverse @{ mro::get_linear_isa($pkg) } ) {
  3         25  
108 7 100       14 while ( my ( $k, $v ) = each %{ $CLASS_ATTRIBUTES{$p} || {} } ) {
  21         81  
109 14         27 $defaults->{$k} = $v;
110             }
111             }
112 3         13 return $defaults;
113             }
114              
115             package Class::Tiny::Object;
116             # ABSTRACT: Base class for classes built with Class::Tiny
117              
118             our $VERSION = '1.007'; # TRIAL
119              
120             my ( %HAS_BUILDARGS, %BUILD_CACHE, %DEMOLISH_CACHE, %ATTR_CACHE );
121              
122             my $_PRECACHE = sub {
123 9     9   71 no warnings 'once'; # needed to avoid downstream warnings
  9         17  
  9         6149  
124             my ($class) = @_;
125             my $linear_isa =
126             @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object"
127             ? [$class]
128             : mro::get_linear_isa($class);
129             $DEMOLISH_CACHE{$class} = [
130             map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
131             map { "$_\::DEMOLISH" } @$linear_isa
132             ];
133             $BUILD_CACHE{$class} = [
134             map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
135             map { "$_\::BUILD" } reverse @$linear_isa
136             ];
137             $HAS_BUILDARGS{$class} = $class->can("BUILDARGS");
138             return $ATTR_CACHE{$class} =
139             { map { $_ => 1 } Class::Tiny->get_all_attributes_for($class) };
140             };
141              
142             sub new {
143 41     41   75119 my $class = shift;
144 41   66     148 my $valid_attrs = $ATTR_CACHE{$class} || $_PRECACHE->($class);
145              
146             # handle hash ref or key/value arguments
147 41         60 my $args;
148 41 50       119 if ( $HAS_BUILDARGS{$class} ) {
149 0         0 $args = $class->BUILDARGS(@_);
150             }
151             else {
152 41 100 66     183 if ( @_ == 1 && ref $_[0] ) {
    100          
153 11         17 my %copy = eval { %{ $_[0] } }; # try shallow copy
  11         14  
  11         40  
154 11 100       114 Carp::croak("Argument to $class->new() could not be dereferenced as a hash") if $@;
155 10         17 $args = \%copy;
156             }
157             elsif ( @_ % 2 == 0 ) {
158 29         74 $args = {@_};
159             }
160             else {
161 1         161 Carp::croak("$class->new() got an odd number of elements");
162             }
163             }
164              
165             # create object and invoke BUILD (unless we were given __no_BUILD__)
166             my $self =
167 39         115 bless { map { $_ => $args->{$_} } grep { exists $valid_attrs->{$_} } keys %$args },
  59         135  
  61         165  
168             $class;
169 39 100 100     129 $self->BUILDALL($args) if !delete $args->{__no_BUILD__} && @{ $BUILD_CACHE{$class} };
  38         150  
170              
171 37         125 return $self;
172             }
173              
174 10     10   14 sub BUILDALL { $_->(@_) for @{ $BUILD_CACHE{ ref $_[0] } } }
  10         38  
175              
176             # Adapted from Moo and its dependencies
177             require Devel::GlobalDestruction unless defined ${^GLOBAL_PHASE};
178              
179             sub DESTROY {
180 39     39   19021 my $self = shift;
181 39         76 my $class = ref $self;
182 39 50       137 my $in_global_destruction =
183             defined ${^GLOBAL_PHASE}
184             ? ${^GLOBAL_PHASE} eq 'DESTRUCT'
185             : Devel::GlobalDestruction::in_global_destruction();
186 39         56 for my $demolisher ( @{ $DEMOLISH_CACHE{$class} } ) {
  39         135  
187 16         20 my $e = do {
188 16         38 local ( $?, $@ );
189 16         26 eval { $demolisher->( $self, $in_global_destruction ) };
  16         31  
190 16         99 $@;
191             };
192 9     9   107 no warnings 'misc'; # avoid (in cleanup) warnings
  9         30  
  9         693  
193 16 50       59 die $e if $e; # rethrow
194             }
195             }
196              
197             1;
198              
199              
200             # vim: ts=4 sts=4 sw=4 et:
201              
202             __END__