changeset 423:60c2892a577c ref20150831

working on base class system
author cin
date Mon, 02 Apr 2018 07:35:23 +0300
parents b0481c071bea
children 87af445663d7
files _test/temp.pl lib/IMPL/Class/ClassBuilder.pm lib/IMPL/Class/ClassInfo.pm lib/IMPL/Class/FieldInfo.pm lib/IMPL/Object/_Base.pm
diffstat 5 files changed, 283 insertions(+), 18 deletions(-) [+]
line wrap: on
line diff
--- a/_test/temp.pl	Sun Aug 20 00:20:41 2017 +0300
+++ b/_test/temp.pl	Mon Apr 02 07:35:23 2018 +0300
@@ -1,5 +1,6 @@
 #!/usr/bin/perl
 use strict;
+use v5.10;
 use Carp;
 use Time::HiRes qw(gettimeofday tv_interval);
 use Scalar::Util qw(blessed refaddr);
@@ -7,31 +8,121 @@
 use Data::Dumper;
 use URI;
 
+#my $method = _get_ctor("Box", undef, '@_');
 
-use IMPL::require {
-	Container => 'IMPL::Config::Container',
-	Service => 'IMPL::Config::ServiceDescriptor',
-	Reference => 'IMPL::Config::ReferenceDescriptor',
-	Value => 'IMPL::Config::ValueDescriptor',
-	YAMLConfig => 'IMPL::Config::YAMLConfig'
-};
+_invoke_ctor("main","x","y","z");
+_invoke_ctor("main","x","y","z");
+
+sub _invoke_ctor {
+	my ($self) = @_;
+	no strict 'refs';
+	no warnings 'redefine';
+	
+	my $method = _get_ctor("Box", undef, '@_');
+	
+	*{"${self}::_invoke_ctor"} = $method;
+	
+	goto &$method;
+}
 
+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; }
+}
 
-my $t = [gettimeofday];
-my $config = YAMLConfig->new(load => 'sample.yaml');
-print "Loaded: ",tv_interval($t,[gettimeofday]),"\n";
+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;
+		}
+	}
+}
 
-my $container = Container->new()->AutoPtr;
-$config->ConfigureContainer($container);
+package Obj;
+
+sub CTOR {
+	say "Obj ", join (',', @_);
+	say Carp::longmess();
+}
 
+package Foo;
+
+BEGIN {
+	our @ISA = qw(Obj);
+	our %ISA = (
+		Obj => sub { "hi" }
+	);
+}
 
+sub CTOR {
+	say "Foo ", join (',', @_);
+}
 
-print "Configured: ",tv_interval($t,[gettimeofday]),"\n";
-#print Data::Dumper->Dump([$container]);
-#$container->Dispose();
+package Bar;
+
+BEGIN {
+	our @ISA = qw(Foo);
+	our %ISA = (
+		Foo => undef
+	);
+}
+
+sub CTOR {
+	say "Bar ", join(',', @_);
+}
+
+package Baz;
 
-my $base = URI->new('some/path');
-my $rel = URI->new('../other/path')->abs($base)->rel('/');
-print $rel,"\n";
+sub CTOR {
+	say "Baz ", join(',', @_);
+}
+
+package Box;
+
+BEGIN {
+	our @ISA = qw(Bar Baz);
+	our %ISA = (
+		Bar => sub { shift . "~Box->Bar", @_; },
+		Baz => sub { shift . "~Box->Baz", @_; }
+	);
+}
+
+sub CTOR {
+	say "Box ", join(',', @_);
+}
 
 1;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/IMPL/Class/ClassBuilder.pm	Mon Apr 02 07:35:23 2018 +0300
@@ -0,0 +1,22 @@
+package IMPL::Class::ClassBuilder;
+use strict;
+
+sub new {
+    my ($self, $class) = @_;
+    
+    return bless \$class, $self	
+}
+
+sub DefineProperty {
+	my ($self, $pi) = @_;
+}
+
+sub DefineField {
+	
+}
+
+sub DefineMethod {
+	
+}
+
+1;
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/IMPL/Class/ClassInfo.pm	Mon Apr 02 07:35:23 2018 +0300
@@ -0,0 +1,73 @@
+package IMPL::Class::ClassInfo;
+use strict;
+
+use Sub::Util qw(subname);
+use mro;
+
+my %props;
+
+sub new {
+	my ( $self, $class ) = @_;
+
+	return bless \$class, $self;
+}
+
+sub className {
+	${ $_[0] };
+}
+
+sub linearISA {
+	return mro::get_linear_isa( ${ $_[0] } );
+}
+
+sub members {
+
+}
+
+sub methods {
+	my ( $this, %opts ) = @_;
+
+	my %hide;
+
+	if ( !$opts{hidden} ) {
+		%hide =
+		  map ( ( $_, 1 ), map @{$_}{qw(getter setter)},
+			$this->properties(%opts) );
+	}
+
+	if ( !$opts{inherited} ) {
+		no strict 'refs';
+		my $class = $this->className();
+
+		my @members;
+
+		while ( my ( $k, $v ) = each %{"${class}::"} ) {
+			my $fn = *{$v}{CODE};
+			next unless $fn;
+
+			my ( $fqname, $pkg, $name ) =
+			  ( subname($fn) =~ m/^((.+)::(.+?))$/ );
+
+			push @members, $fqname if $pkg eq $class and not $hide{$name};
+		}
+
+		return @members;
+	}
+	else {
+
+		my @isa =
+		  reverse( $opts{inherited} ? $this->linearISA() : $this->className() );
+
+		my %methods = map { $_->memberName(), $_ }
+		  grep not( $hide{ $_->memberName() } ),
+		  map { IMPL::Class::ClassInfo->new($_)->methods( inherited => 0 ) } @isa;
+
+		return values %methods;
+	}
+}
+
+sub properties {
+
+}
+
+1;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/IMPL/Class/FieldInfo.pm	Mon Apr 02 07:35:23 2018 +0300
@@ -0,0 +1,19 @@
+package IMPL::Class::FieldInfo;
+use strict;
+
+use IMPL::declare {
+	base => [
+		'IMPL::Class::MemberInfo' => '@_'
+	]
+};
+
+use fields qw( fieldType backingFieldName generated);
+
+sub CTOR {
+	my ( $this, %args ) = @_;
+
+	$this->{$_} = $args{$_}
+	  foreach grep exists $args{$_} qw( fieldType backingFieldName generated);
+}
+
+1;
--- /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