Mercurial > pub > Impl

comparison _test/temp.pl @ 423:60c2892a577c ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
working on base class system
author cin
date Mon, 02 Apr 2018 07:35:23 +0300
parents b0481c071bea
children 87af445663d7
comparison
equal deleted inserted replaced
422:b0481c071bea 423:60c2892a577c
1 #!/usr/bin/perl 1 #!/usr/bin/perl
2 use strict; 2 use strict;
3 use v5.10;
3 use Carp; 4 use Carp;
4 use Time::HiRes qw(gettimeofday tv_interval); 5 use Time::HiRes qw(gettimeofday tv_interval);
5 use Scalar::Util qw(blessed refaddr); 6 use Scalar::Util qw(blessed refaddr);
6 use YAML::XS qw(Dump Load); 7 use YAML::XS qw(Dump Load);
7 use Data::Dumper; 8 use Data::Dumper;
8 use URI; 9 use URI;
9 10
11 #my $method = _get_ctor("Box", undef, '@_');
10 12
11 use IMPL::require { 13 _invoke_ctor("main","x","y","z");
12 Container => 'IMPL::Config::Container', 14 _invoke_ctor("main","x","y","z");
13 Service => 'IMPL::Config::ServiceDescriptor',
14 Reference => 'IMPL::Config::ReferenceDescriptor',
15 Value => 'IMPL::Config::ValueDescriptor',
16 YAMLConfig => 'IMPL::Config::YAMLConfig'
17 };
18 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 }
19 27
20 my $t = [gettimeofday]; 28 sub _get_ctor {
21 my $config = YAMLConfig->new(load => 'sample.yaml'); 29 my ($class, $prev, $t) = @_;
22 print "Loaded: ",tv_interval($t,[gettimeofday]),"\n"; 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 }
23 48
24 my $container = Container->new()->AutoPtr; 49 sub _chain_call {
25 $config->ConfigureContainer($container); 50 my ($method, $next) = @_;
51
52 return $method unless $next;
53 return $next unless $method;
54
55 return sub { &$method(@_); goto &$next; }
56 }
26 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 }
27 74
75 package Obj;
28 76
29 print "Configured: ",tv_interval($t,[gettimeofday]),"\n"; 77 sub CTOR {
30 #print Data::Dumper->Dump([$container]); 78 say "Obj ", join (',', @_);
31 #$container->Dispose(); 79 say Carp::longmess();
80 }
32 81
33 my $base = URI->new('some/path'); 82 package Foo;
34 my $rel = URI->new('../other/path')->abs($base)->rel('/'); 83
35 print $rel,"\n"; 84 BEGIN {
85 our @ISA = qw(Obj);
86 our %ISA = (
87 Obj => sub { "hi" }
88 );
89 }
90
91 sub CTOR {
92 say "Foo ", join (',', @_);
93 }
94
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;
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 }
36 127
37 1; 128 1;