File Coverage

blib/lib/Class/constr.pm

Criterion	Covered	Total	%
statement	44	47	93.6
branch	17	24	70.8
condition	12	15	80.0
subroutine	6	6	100.0
pod			n/a
total	79	92	85.8

package Class::constr ;
$VERSION = 2.40 ;
use 5.006_001 ;
use strict ;

# This file uses the "Perlish" coding style
# please read http://perl.4pro.net/perlish_coding_style.html

; use Carp
; $Carp::Internal{+__PACKAGE__}++


; sub import
   { my ($pkg, @args) = @_
   ; my $callpkg = caller
   ; $args[0] ||= {}
   ; foreach my $constr ( @args )
      { my $n = $$constr{name} || 'new'
      ; $$constr{init} &&= [ $$constr{init} ]
                           unless ref $$constr{init} eq 'ARRAY'
      ; no strict 'refs'
      ; *{$callpkg.'::'.$n}
        = sub
           { &{$$constr{pre_process}} if defined $$constr{pre_process}
           ; my $c = shift
           ; my %props = ref $_[0] eq 'HASH' ? %{$_[0]} : @_
           ; my $class = ref($c) || $c
           ; my $s = bless {}, $class
           ; my $default_props = {}
           ; if (my $cdef = $$constr{default})
              { $default_props =  ref $cdef eq 'HASH' && $cdef
                               || ref $cdef eq 'CODE' && $s->$cdef(%props)
                               || not (ref $cdef)     && $s->$cdef(%props)
              ; ref $default_props eq 'HASH' or croak
                "Invalid default option for '$n' ($default_props), died"
              }
           # Values passed to the constructor   (%props)
           # will override copied values,       (%$c)
           # which will override default values (%$default_props)
           ; %props = ( %$default_props
                       , $$constr{copy} && ref $c ? %$c : ()
                       , %props
                       )
           # Set the initial values for the new object
           ; while ( my ($p, $v) = each %props )
              { if (my $a = $s->can($p))      # if accessor available, use it
                 { $s->$a( $v )
                 }
                else
                 { croak "No such property '$p', died"
                         unless $$constr{no_strict}
                 ; if ( $$constr{skip_autoload} )
                    { $$s{$p} = $v
                    }
                   else
                    { eval { $s->$p( $v ) }       # try AUTOLOAD
                    ; $@ && do{ $$s{$p} = $v }    # no strict so just set it
                    }
                 }
              }
           # Execute any initializer methods
           ; if ( $$constr{init} )
              { foreach my $m ( @{$$constr{init}} )
                 # any initializer can cancel construction by undefining the
                 # object or returning a Class::Error object (false)
                 # If this happens, no need to continue
                 { last unless $s
                 ; $s->$m(%props)
                 }
              }
           ; $s
           }#END sub
      }#END for $constr
   }#END import


; 1

__END__