Mercurial > pub > Impl

comparison _test/temp.pl @ 424:87af445663d7 ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
IMPL::Object::_Base
author cin
date Tue, 03 Apr 2018 10:54:09 +0300
parents 60c2892a577c
children c27434cdd611 eed50c01e758
comparison
equal deleted inserted replaced
423:60c2892a577c 424:87af445663d7
6 use Scalar::Util qw(blessed refaddr); 6 use Scalar::Util qw(blessed refaddr);
7 use YAML::XS qw(Dump Load); 7 use YAML::XS qw(Dump Load);
8 use Data::Dumper; 8 use Data::Dumper;
9 use URI; 9 use URI;
10 10
11 #my $method = _get_ctor("Box", undef, '@_'); 11 package Bar;
12 use base qw(IMPL::Object);
12 13
13 _invoke_ctor("main","x","y","z"); 14 sub CTOR {
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 } 15 }
27 16
28 sub _get_ctor { 17 package Bar2;
29 my ($class, $prev, $t) = @_; 18 use base qw(Bar);
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 }
57
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 }
74
75 package Obj;
76 19
77 sub CTOR { 20 sub CTOR {
78 say "Obj ", join (',', @_);
79 say Carp::longmess();
80 } 21 }
81 22
82 package Foo; 23 package Foo;
24 use base qw(IMPL::Object::_Base);
83 25
84 BEGIN { 26 sub new {
85 our @ISA = qw(Obj); 27 my $instance = bless {}, shift;
86 our %ISA = ( 28 $instance->__construct();
87 Obj => sub { "hi" } 29 return $instance;
88 );
89 } 30 }
90 31
91 sub CTOR { 32 sub CTOR {
92 say "Foo ", join (',', @_);
93 } 33 }
94 34
95 package Bar; 35 package Foo2;
36 use base qw(Foo);
96 37
97 BEGIN { 38 sub CTOR {
98 our @ISA = qw(Foo); 39
99 our %ISA = ( 40 }
100 Foo => undef 41
101 ); 42 package main;
43
44 my $t = [gettimeofday];
45
46 for(my $i=0; $i <1000000; $i++) {
47 my $v = new Bar2;
102 } 48 }
103 49
104 sub CTOR { 50 say tv_interval($t);
105 say "Bar ", join(',', @_);
106 }
107
108 package Baz;
109
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 }
127 51
128 1; 52 1;