File Coverage

blib/lib/HO/class.pm

Criterion	Covered	Total	%
statement	92	97	94.8
branch	13	14	92.8
condition	3	5	60.0
subroutine	15	17	88.2
pod			n/a
total	123	133	92.4

  package HO::class
# *****************
; use strict; use warnings;
  our $VERSION='0.078';
# ********************

; require HO::accessor
; require Carp

; our (%mixin_classes,%class_args,%class_methods)

; sub import
    { my ($package,@args)=@_
    ; our (%mixin_classes,%class_args,%class_methods)
    ; my $makeconstr = 1
    ; # uncoverable branch false
      # uncoverable condition right
      # uncoverable condition false
      my $class = $HO::accessor::class ||
          CORE::caller    # uncoverable statement
    ; my @acc         # all internal accessors
    ; my @methods     # method changeable on a per object base
    ; my @lvalue      # lvalue accessor
    ; my @r_          # common accessors
    ; my $makeinit    # key for init method or subref used as init
    ; my @alias

    ; $class_methods{$class} = {}
    ; $class_args{$class} = [ @args ]
    ; if($mixin_classes{$class})
        { push @args, @{$mixin_classes{$class}}
        }

    ; while(@args)
        { my $action = lc(shift @args)
        ; my ($name,$type,$code)
        ;({ '_method' => sub
            { ($name,$code) = splice(@args,0,2)
            ; push @acc, "__$name",sub { $code } if defined $code
            ; push @acc, "_$name",'$'
            ; push @methods, $name, $code
            }
          , '_index' => sub
            { ($name,$type) = splice(@args,0,2)
            ; push @acc, $name, $type
            }
          , '_lvalue' => sub
            { ($name,$type) = splice(@args,0,2)
            ; push @acc, "_$name", $type
            ; push @lvalue, $name
            }
          , '_rw' => sub
            { ($name,$type) = splice(@args,0,2)
            ; push @acc, "_$name", $type
            ; if(defined($args[0]) && lc($args[0]) eq 'abstract')
                { shift @args
                }
              else
                { $type = _type_of($type) if ref($type) eq 'CODE'
                ; my $coderef = $HO::accessor::rw_accessor{$type}
                ; Carp::croak("Unknown property type '$type', in setup for class $class.")
                    unless defined $coderef
                ; push @r_, $name => [ $coderef, $name, $class ]
                }
            }
          , '_ro' => sub
            { ($name,$type) = splice(@args,0,2)
            ; push @acc, "_$name", $type
            # abstract is similar to _index, but there is TIMTOWTDI
            ; if(defined($args[0]) && lc($args[0]) eq 'abstract')
                { shift @args
                }
              else
                { $type = _type_of($type) if ref($type) eq 'CODE'
                ; my $coderef = $HO::accessor::ro_accessor{$type}
                ; Carp::croak("Unknown property type '$type', in setup for class $class.")
                    unless defined $coderef
                ; push @r_, $name => [ $coderef, $name, $class ]
                }
            }
          , 'init' => sub
              { $makeinit = shift @args
              }
          # no actions => options
          , 'noconstructor' => sub
            { $makeconstr = 0
            }
          , 'alias' => sub
            { push @alias, splice(@args,0,2)
            }
          }->{$action}||sub { die "Unknown action '$action' for $package."
                            })->()
    }
    ; { local $HO::accessor::class = $class
      ; import HO::accessor:: (\@acc,\@methods,$makeinit,$makeconstr)
      }

    ; { no strict 'refs'
      ; while(@methods)
          { my ($name,$code) = splice(@methods,0,2)

          ; my ($nidx,$ncdx) = ("_$name","__$name")
          ; my $idx = HO::accessor::_value_of($class, $nidx)
          ; my $cdx = HO::accessor::_value_of($class, $ncdx)

          ; if(defined $cdx)
              { *{join('::',$class,$name)} = sub
                  { my $self = shift
                  ; return $self->[$idx]
                       ? $self->[$idx]->($self,@_)
                       : $self->[$cdx]->($self,@_)
                  }
              }
            else
              { *{join('::',$class,$name)} = sub
                  { my $self = shift
                  ; return $self->[$idx]->($self,@_)
                  }
              }
          ; $class_methods{$class}{$name} = "_method"
          }

      ; while(@lvalue)
          { my $name = shift(@lvalue)
          ; my $acc = "_$name"
          # lvalue methods are inherited not copied, so they needs to have dynamic index
          ; *{join('::',$class,$name)} = sub : lvalue
               { my $self = shift();
               ; $self->[$self->$acc]
               }
          ; $class_methods{$class}{$name} = "_lvalue"
          }
      ; while(my ($name,$subdata) = splice(@r_,0,2))
          { my ($coderef,$name,$class) = @$subdata
          ; *{join('::',$class,$name)} = $coderef->($name,$class)
          ; $class_methods{$class}{$name} = "_data"
          }
      ; while(my ($new,$subname) = splice(@alias,0,2))
          { my $code = HO::accessor::_methods_code($class, $subname)
          ; *{join('::',$class,$new)} = $code
          ; $class_methods{$class}{$new} = "_alias"
          }
      }
    }

; sub _type_of ($)
  { my $coderef = shift
  ; my $val = $coderef->()
  ; return ref($val) eq 'HASH' ? '%' :
           ref($val) eq 'ARRAY' ? '@' : '$'
  }

; 1

__END__