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;