Mercurial > pub > Impl
annotate _test/temp.pl @ 423:60c2892a577c ref20150831
working on base class system
| author | cin |
|---|---|
| date | Mon, 02 Apr 2018 07:35:23 +0300 |
| parents | b0481c071bea |
| children | 87af445663d7 |
| rev | line source |
|---|---|
| 210 | 1 #!/usr/bin/perl |
| 2 use strict; | |
| 423 | 3 use v5.10; |
| 412 | 4 use Carp; |
| 5 use Time::HiRes qw(gettimeofday tv_interval); | |
| 415 | 6 use Scalar::Util qw(blessed refaddr); |
| 418 | 7 use YAML::XS qw(Dump Load); |
|
422
b0481c071bea
IMPL::Config::Container tests, YAMLConfiguration now works and tested
cin
parents:
419
diff
changeset
|
8 use Data::Dumper; |
|
b0481c071bea
IMPL::Config::Container tests, YAMLConfiguration now works and tested
cin
parents:
419
diff
changeset
|
9 use URI; |
| 418 | 10 |
| 423 | 11 #my $method = _get_ctor("Box", undef, '@_'); |
| 417 | 12 |
| 423 | 13 _invoke_ctor("main","x","y","z"); |
| 14 _invoke_ctor("main","x","y","z"); | |
| 15 | |
| 16 sub _invoke_ctor { | |
| 17 my ($self) = @_; | |
| 18 no strict 'refs'; | |
| 19 no warnings 'redefine'; | |
| 20 | |
| 21 my $method = _get_ctor("Box", undef, '@_'); | |
| 22 | |
| 23 *{"${self}::_invoke_ctor"} = $method; | |
| 24 | |
| 25 goto &$method; | |
| 26 } | |
| 417 | 27 |
| 423 | 28 sub _get_ctor { |
| 29 my ($class, $prev, $t) = @_; | |
| 30 no strict 'refs'; | |
| 31 | |
| 32 #say "_get_ctor($class, $prev, $t)"; | |
| 33 | |
| 34 my $isolate = ((not defined($t)) or ($t ne '@_')); | |
| 35 | |
| 36 my $ctor = $isolate ? *{"${class}::CTOR"}{CODE} : _chain_call(*{"${class}::CTOR"}{CODE}, $prev); | |
| 37 | |
| 38 foreach my $base (@{"${class}::ISA"}) { | |
| 39 $ctor = _get_ctor($base, $ctor, exists ${"${class}::ISA"}{$base} ? ${"${class}::ISA"}{$base} : '@_'); | |
| 40 } | |
| 41 | |
| 42 if ($isolate) { | |
| 43 $ctor = _chain_call(_chain_params($ctor, $t), $prev); | |
| 44 } | |
| 45 | |
| 46 return $ctor; | |
| 47 } | |
| 48 | |
| 49 sub _chain_call { | |
| 50 my ($method, $next) = @_; | |
| 51 | |
| 52 return $method unless $next; | |
| 53 return $next unless $method; | |
| 54 | |
| 55 return sub { &$method(@_); goto &$next; } | |
| 56 } | |
| 417 | 57 |
| 423 | 58 sub _chain_params { |
| 59 my ($method, $prepare) = @_; | |
| 60 | |
| 61 return unless $method; | |
| 62 | |
| 63 if (not defined $prepare) { | |
| 64 return sub { @_ = (shift); goto &$method }; | |
| 65 } elsif ($prepare eq '@_') { | |
| 66 return $method; | |
| 67 } elsif (ref $prepare eq 'CODE') { | |
| 68 return sub { | |
| 69 @_ = (shift, &$prepare(@_)); | |
| 70 goto &$method; | |
| 71 } | |
| 72 } | |
| 73 } | |
| 417 | 74 |
| 423 | 75 package Obj; |
| 76 | |
| 77 sub CTOR { | |
| 78 say "Obj ", join (',', @_); | |
| 79 say Carp::longmess(); | |
| 80 } | |
| 417 | 81 |
| 423 | 82 package Foo; |
| 83 | |
| 84 BEGIN { | |
| 85 our @ISA = qw(Obj); | |
| 86 our %ISA = ( | |
| 87 Obj => sub { "hi" } | |
| 88 ); | |
| 89 } | |
| 417 | 90 |
| 423 | 91 sub CTOR { |
| 92 say "Foo ", join (',', @_); | |
| 93 } | |
| 417 | 94 |
| 423 | 95 package Bar; |
| 96 | |
| 97 BEGIN { | |
| 98 our @ISA = qw(Foo); | |
| 99 our %ISA = ( | |
| 100 Foo => undef | |
| 101 ); | |
| 102 } | |
| 103 | |
| 104 sub CTOR { | |
| 105 say "Bar ", join(',', @_); | |
| 106 } | |
| 107 | |
| 108 package Baz; | |
|
422
b0481c071bea
IMPL::Config::Container tests, YAMLConfiguration now works and tested
cin
parents:
419
diff
changeset
|
109 |
| 423 | 110 sub CTOR { |
| 111 say "Baz ", join(',', @_); | |
| 112 } | |
| 113 | |
| 114 package Box; | |
| 115 | |
| 116 BEGIN { | |
| 117 our @ISA = qw(Bar Baz); | |
| 118 our %ISA = ( | |
| 119 Bar => sub { shift . "~Box->Bar", @_; }, | |
| 120 Baz => sub { shift . "~Box->Baz", @_; } | |
| 121 ); | |
| 122 } | |
| 123 | |
| 124 sub CTOR { | |
| 125 say "Box ", join(',', @_); | |
| 126 } | |
|
422
b0481c071bea
IMPL::Config::Container tests, YAMLConfiguration now works and tested
cin
parents:
419
diff
changeset
|
127 |
| 407 | 128 1; |