Mercurial > pub > Impl
diff _test/temp.pl @ 424:87af445663d7 ref20150831
IMPL::Object::_Base
author | cin |
---|---|
date | Tue, 03 Apr 2018 10:54:09 +0300 |
parents | 60c2892a577c |
children | c27434cdd611 eed50c01e758 |
line wrap: on
line diff
--- a/_test/temp.pl Mon Apr 02 07:35:23 2018 +0300 +++ b/_test/temp.pl Tue Apr 03 10:54:09 2018 +0300 @@ -8,121 +8,45 @@ use Data::Dumper; use URI; -#my $method = _get_ctor("Box", undef, '@_'); - -_invoke_ctor("main","x","y","z"); -_invoke_ctor("main","x","y","z"); +package Bar; +use base qw(IMPL::Object); -sub _invoke_ctor { - my ($self) = @_; - no strict 'refs'; - no warnings 'redefine'; - - my $method = _get_ctor("Box", undef, '@_'); - - *{"${self}::_invoke_ctor"} = $method; - - goto &$method; +sub CTOR { } -sub _get_ctor { - 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} : '@_'); - } - - if ($isolate) { - $ctor = _chain_call(_chain_params($ctor, $t), $prev); - } - - return $ctor; -} - -sub _chain_call { - my ($method, $next) = @_; - - return $method unless $next; - return $next unless $method; - - return sub { &$method(@_); goto &$next; } -} - -sub _chain_params { - my ($method, $prepare) = @_; - - return unless $method; - - if (not defined $prepare) { - return sub { @_ = (shift); goto &$method }; - } elsif ($prepare eq '@_') { - return $method; - } elsif (ref $prepare eq 'CODE') { - return sub { - @_ = (shift, &$prepare(@_)); - goto &$method; - } - } -} - -package Obj; +package Bar2; +use base qw(Bar); sub CTOR { - say "Obj ", join (',', @_); - say Carp::longmess(); } package Foo; - -BEGIN { - our @ISA = qw(Obj); - our %ISA = ( - Obj => sub { "hi" } - ); -} +use base qw(IMPL::Object::_Base); -sub CTOR { - say "Foo ", join (',', @_); -} - -package Bar; - -BEGIN { - our @ISA = qw(Foo); - our %ISA = ( - Foo => undef - ); +sub new { + my $instance = bless {}, shift; + $instance->__construct(); + return $instance; } sub CTOR { - say "Bar ", join(',', @_); -} - -package Baz; - -sub CTOR { - say "Baz ", join(',', @_); } -package Box; +package Foo2; +use base qw(Foo); + +sub CTOR { + +} -BEGIN { - our @ISA = qw(Bar Baz); - our %ISA = ( - Bar => sub { shift . "~Box->Bar", @_; }, - Baz => sub { shift . "~Box->Baz", @_; } - ); +package main; + +my $t = [gettimeofday]; + +for(my $i=0; $i <1000000; $i++) { + my $v = new Bar2; } -sub CTOR { - say "Box ", join(',', @_); -} +say tv_interval($t); 1;