File Coverage

blib/lib/Class/props.pm

Criterion	Covered	Total	%
statement	70	79	88.6
branch	40	50	80.0
condition	19	29	65.5
subroutine	14	14	100.0
pod	1	1	100.0
total	144	173	83.2

package Class::props ;
$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 $tool = shift
   ; $tool->add_to(scalar caller, @_)
   }

; sub add_to
   { my ($tool, $pkg, @args) = @_
   ; foreach my $prop ( @args )
      { $prop = $tool->_init_prop_param( $prop )
      ; $tool->_add_prop( $pkg, $prop )
      }
   }

; sub _init_prop_param
   { my ( $tool, $prop ) = @_
   ; $prop = { name => $prop }
             unless ref $prop eq 'HASH'
   ; $$prop{name} = [ $$prop{name} ]
                    unless ref $$prop{name} eq 'ARRAY'
   ; $$prop{allowed} &&= [ $$prop{allowed} ]
                         unless ref $$prop{allowed} eq 'ARRAY'
   ; $prop
   }

; sub _add_prop
   { my ( $tool, $pkg, $prop ) = @_
   ; my $gr = delete $$prop{group}
   ; my $to_tie = (  defined $$prop{default}
                  || defined $$prop{protected}
                  || defined $$prop{allowed}
                  || defined $$prop{validation}
                  || defined $$prop{post_process}
                  )
   ; foreach my $n ( @{$$prop{name}} )     # foreach property
      { no strict 'refs'
      ; *{$pkg.'::'.$n}
        = sub : lvalue
           { (@_ > 2) && croak qq(Too many arguments for "$n" property, died)
           ; my $scalar
             = $tool =~ /^Class/   ? $gr
                                     ? \${(ref $_[0]||$_[0]).'::'.$gr}{$n}
                                     : \${(ref $_[0]||$_[0]).'::'.$n}
             : $tool =~ /^Package/ ? $gr
                                     ? \${$pkg.'::'.$gr}{$n}
                                     : \${$pkg.'::'.$n}
             : $gr
               ? \$_[0]{$gr}{$n}
               : \$_[0]{$n}
           ; my $Tscalar
           ; if ( $to_tie )
              { tie $$Tscalar
                  , 'Class::props::Tie'
                  , $_[0]                   # [0] object/class
                  , $n                      # [1] prop name
                  , $scalar                 # [2] lvalue ref
                  , $prop                   # [3] options ref
              }
             else
              { $Tscalar = $scalar
              }
           ; @_ == 2
             ? ( $$Tscalar = $_[1] )
             :   $$Tscalar
           }
      }
   }

; package Class::props::Tie
; use Carp
; $Carp::Internal{+__PACKAGE__}++
; use strict

; sub TIESCALAR
   { bless \@_, shift
   }

; sub FETCH
   { my $val = do
                { if ( defined ${$_[0][2]} )
                   { ${$_[0][2]}
                   }
                  elsif ( defined $_[0][3]{default} )
                   { my $def = ref $_[0][3]{default} eq 'CODE'
                               ? $_[0][3]{default}( $_[0][0] )
                               : $_[0][3]{default}
                   ; $_[0][3]{no_strict}
                     ? ${$_[0][2]} = $def
                     : $_[0]->STORE( $def )
                   }
                  else
                   { undef
                   }
                }
   ; local $_ = $val
   ; defined $_[0][3]{post_process}
     ? $_[0][3]{post_process}( $_[0][0], $val )
     : $val
   }

; sub STORE
   { my $from_FETCH = (caller(1))[3]
                   && (caller(1))[3] =~ /::FETCH$/
   ; my $default = $from_FETCH
                   ? 'default '
                   : ''
   ; if (   $_[0][3]{protected}   # if protected
        &&! $from_FETCH           # bypass for default
        &&! $Class::props::force  # bypass deliberately
        )
      { my ($OK, $f)
      ; until ( $OK )
         { last unless my $caller = caller($f++)
         ; $OK = $caller->can($_[0][1])
         }
      ; $OK || croak qq("$_[0][1]" is a read-only property, died)
      }
   ; if (   $_[0][3]{allowed}     # if restricted
        &&! $from_FETCH           # bypass for default
        &&! $Class::props::force  # bypass deliberately
        )
      { my ($OK, $f)
      ; until ( $OK )
         { last unless my $caller = (caller($f++))[3]
         ; $OK = grep { $caller =~ qr/$_/ } @{$_[0][3]{allowed}}
         }
        ; $OK || croak qq("$_[0][1]" is a read-only property, died)
      }
   ; local $_ = $_[1]
   ; if ( defined $_[0][3]{validation}  # validation subref
        && defined $_                   # bypass for undef (reset to default)
        )
      { $_[0][3]{validation}( $_[0][0], $_)
        || croak qq(Invalid ${default}value for "$_[0][1]" property, died)
      }
   ; ${$_[0][2]} = $_
   }

1 ;

__END__