# HG changeset patch # User cin # Date 1522643723 -10800 # Node ID 60c2892a577cc9e623af545dc24e6b4deab20326 # Parent b0481c071bea109b14c67d5fd0ae2f221ef894a4 working on base class system diff -r b0481c071bea -r 60c2892a577c _test/temp.pl --- 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; diff -r b0481c071bea -r 60c2892a577c lib/IMPL/Class/ClassBuilder.pm --- /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 diff -r b0481c071bea -r 60c2892a577c lib/IMPL/Class/ClassInfo.pm --- /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; diff -r b0481c071bea -r 60c2892a577c lib/IMPL/Class/FieldInfo.pm --- /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; diff -r b0481c071bea -r 60c2892a577c lib/IMPL/Object/_Base.pm --- /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