diff lib/IMPL/Object/_Base.pm @ 423:60c2892a577c ref20150831

working on base class system
author cin
date Mon, 02 Apr 2018 07:35:23 +0300
parents
children 87af445663d7
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/IMPL/Object/_Base.pm	Mon Apr 02 07:35:23 2018 +0300
@@ -0,0 +1,60 @@
+package IMPL::Object::_Base;
+use strict;
+use mro;
+
+sub _build_ctor {
+	my $class = shift;
+	
+	my @isa = reverse @{mro::get_linear_isa($class)};
+	
+	
+}
+
+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;
+		}
+	}
+}
+
+1;
\ No newline at end of file