Mercurial > pub > Impl
diff lib/IMPL/Object/_Base.pm @ 427:09e0086a82a7 ref20150831 tip
Merge
author | cin |
---|---|
date | Tue, 15 May 2018 00:51:33 +0300 |
parents | c27434cdd611 |
children |
line wrap: on
line diff
--- a/lib/IMPL/Object/_Base.pm Tue May 15 00:51:01 2018 +0300 +++ b/lib/IMPL/Object/_Base.pm Tue May 15 00:51:33 2018 +0300 @@ -7,104 +7,129 @@ sub __destroy; *__construct = _strap_ctor(__PACKAGE__); -*__destroy = _strap_dtor(__PACKAGE__); +*__destroy = _strap_dtor(__PACKAGE__); sub DESTROY { shift->__destroy(); } sub _strap_ctor { - my ($class, $ctor) = @_; + my ( $class, $ctor ) = @_; no strict 'refs'; no warnings 'redefine'; - - return sub { - my $self = ref shift; + + return $ctor + ? sub { + my $self = ref $_[0]; - if ($self ne $class) { - my $t = _get_ctor($self, undef, '@_'); - *{"${self}::__construct"} = _strap_ctor($self, $t); + if ( $self ne $class ) { + my $t = _get_ctor( $self, undef, '@_' ); + *{"${self}::__construct"} = _strap_ctor( $self, $t ); + goto &$t; + } + + goto &$ctor; + } + : sub { + my $self = ref $_[0]; + if ( $self ne $class ) { + my $t = _get_ctor( $self, undef, '@_' ); + *{"${self}::__construct"} = _strap_ctor( $self, $t ); goto &$t if $t; - } else { - goto &$ctor if $ctor; } - }; + }; } sub _strap_dtor { - my ($class, $dtor) = @_; - + my ( $class, $dtor ) = @_; no strict 'refs'; no warnings 'redefine'; - - return sub { - my $self = ref shift; + + return $dtor + ? sub { + my $self = ref $_[0]; - if ($self ne $class) { + if ( $self ne $class ) { my $t = _get_dtor($self); - *{"${self}::__destroy"} = _strap_dtor($self, $t); - goto &$t if $t; - } else { - goto &$dtor if $dtor; + *{"${self}::__destroy"} = _strap_dtor( $self, $t ); + goto &$t; } - }; + + goto &$dtor; + } + : sub { + my $self = ref $_[0]; + if ( $self ne $class ) { + my $t = _get_dtor($self); + *{"${self}::__destroy"} = _strap_dtor( $self, $t ); + goto &$t if $t; + } + }; } sub _get_ctor { - my ($class, $prev, $t) = @_; + my ( $class, $prev, $t ) = @_; no strict 'refs'; - + #say "_get_ctor($class, $prev, $t)"; - - my $isolate = ((not defined($t)) or ($t ne '@_')); - - my $ctor = $isolate ? *{"${class}::CTOR"}{CODE} : _chain_call(*{"${class}::CTOR"}{CODE}, $prev); - - foreach my $base (@{"${class}::ISA"}) { - $ctor = _get_ctor($base, $ctor, exists ${"${class}::ISA"}{$base} ? ${"${class}::ISA"}{$base} : '@_'); + + my $isolate = ( ( not defined($t) ) or ( $t ne '@_' ) ); + + my $ctor = + $isolate + ? *{"${class}::CTOR"}{CODE} + : _chain_call( *{"${class}::CTOR"}{CODE}, $prev ); + + foreach my $base ( @{"${class}::ISA"} ) { + $ctor = _get_ctor( $base, $ctor, + exists ${"${class}::ISA"}{$base} + ? ${"${class}::ISA"}{$base} + : '@_' ); } - + if ($isolate) { - $ctor = _chain_call(_chain_params($ctor, $t), $prev); + $ctor = _chain_call( _chain_params( $ctor, $t ), $prev ); } - + return $ctor; } sub _get_dtor { - my ($class, $prev) = @_; + my ( $class, $prev ) = @_; no strict 'refs'; - - my $dtor = _chain_call(*{"${class}::DTOR"}{CODE}, $prev); - $dtor = _get_dtor($_, $dtor) foreach @{"${class}::ISA"}; - + + my $dtor = _chain_call( *{"${class}::DTOR"}{CODE}, $prev ); + $dtor = _get_dtor( $_, $dtor ) foreach @{"${class}::ISA"}; + return $dtor; } sub _chain_call { - my ($method, $next) = @_; - + my ( $method, $next ) = @_; + return $method unless $next; - return $next unless $method; - + return $next unless $method; + return sub { &$method(@_); goto &$next; } } sub _chain_params { - my ($method, $prepare) = @_; - + my ( $method, $prepare ) = @_; + return unless $method; - - if (not defined $prepare) { + + if ( not defined $prepare ) { return sub { @_ = (shift); goto &$method }; - } elsif ($prepare eq '@_') { + } + elsif ( $prepare eq '@_' ) { return $method; - } elsif (ref $prepare eq 'CODE') { + } + elsif ( ref $prepare eq 'CODE' ) { return sub { - @_ = (shift, &$prepare(@_)); + @_ = ( shift, &$prepare(@_) ); goto &$method; - } + } } } -1; \ No newline at end of file +1;