Mercurial > pub > Impl

comparison Lib/IMPL/Object.pm @ 0:03e58a454b20

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Создан репозитарий
author Sergey
date Tue, 14 Jul 2009 12:54:37 +0400
parents
children 78cd38551534
comparison
equal deleted inserted replaced
-1:000000000000 0:03e58a454b20
1 package IMPL::Object;
2 use strict;
3
4 use base qw(IMPL::Class::Meta);
5
6 our $MemoryLeakProtection;
7 my $Cleanup = 0;
8 our $Debug;
9 our %leaked_objects;
10
11 my %cacheCTOR;
12
13
14 sub new {
15 my $class = shift;
16 my $self = bless {}, ref($class) || $class;
17
18 $self->$_(@_) foreach @{$cacheCTOR{ref $self} || cache_ctor(ref $self)};
19
20 $self;
21 }
22 my $t = 0;
23 sub cache_ctor {
24 my $class = shift;
25
26 no strict 'refs';
27 my @sequence;
28
29 my $refCTORS = *{"${class}::CTOR"}{HASH};
30
31 foreach my $super ( @{"${class}::ISA"} ) {
32 my $superSequence = $cacheCTOR{$super} || cache_ctor($super);
33
34 my $mapper = $refCTORS ? $refCTORS->{$super} : undef;
35 if (ref $mapper eq 'CODE') {
36 if ($mapper == *_pass_throgh_mapper{CODE}) {
37 push @sequence,@$superSequence;
38 } else {
39 push @sequence, sub {
40 my $this = shift;
41 $this->$_($mapper->(@_)) foreach @$superSequence;
42 };
43 }
44 } else {
45 warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper;
46 push @sequence, sub {
47 my $this = shift;
48 $this->$_() foreach @$superSequence;
49 };
50 }
51 }
52
53 push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE};
54
55 $cacheCTOR{$class} = \@sequence;
56 return \@sequence;
57 }
58
59 sub callCTOR {
60 my $self = shift;
61 my $class = ref $self;
62
63 $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)};
64 }
65
66 sub surrogate {
67 bless {}, ref $_[0] || $_[0];
68 }
69
70 sub superCTOR {
71 my $this = shift;
72
73 warn "The mehod is deprecated, at " . caller;
74 }
75
76 sub toString {
77 my $self = shift;
78
79 return (ref $self || $self);
80 }
81
82 sub DESTROY {
83 if ($MemoryLeakProtection and $Cleanup) {
84 my $this = shift;
85 warn sprintf("Object leaks: %s of type %s %s",$this->can('ToString') ? $this->ToString : $this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : '');
86 }
87 }
88
89 sub END {
90 $Cleanup = 1;
91 $MemoryLeakProtection = 0 unless $Debug;
92 }
93
94 sub _pass_throgh_mapper {
95 @_;
96 }
97
98 sub PassThroughArgs {
99 my $class = shift;
100 $class = ref $class || $class;
101 no strict 'refs';
102 no warnings 'once';
103 ${"${class}::CTOR"}{$_} = \&_pass_throgh_mapper foreach @{"${class}::ISA"};
104 }
105
106 package self;
107
108 our $AUTOLOAD;
109 sub AUTOLOAD {
110 goto &{caller(). substr $AUTOLOAD,4};
111 }
112
113 package supercall;
114
115 our $AUTOLOAD;
116 sub AUTOLOAD {
117 my $sub;
118 my $methodName = substr $AUTOLOAD,11;
119 no strict 'refs';
120 $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'};
121 }
122
123 =pod
124 =h1 SYNOPSIS
125
126 package Foo;
127 use base qw(IMPL::Object);
128
129 sub CTOR {
130 my ($this,$arg) = @_;
131 print "Foo: $arg\n";
132 }
133
134 package Bar;
135 use base qw(IMPL::Object);
136
137 sub CTOR {
138 my ($this,$arg) = @_;
139 print "Bar: $arg\n";
140 }
141
142 package Baz;
143 use base qw(Foo Bar);
144
145 our %CTOR = (
146 Foo => sub { my %args = @_; $args{Mazzi}; },
147 Bar => sub { my %args = @_; $args{Fugi}; }
148 );
149
150 package Composite;
151 use base qw(Baz Foo Bar);
152
153 our %CTOR = (
154 Foo => undef,
155 Bar => undef
156 );
157
158 sub CTOR {
159 my ($this,%args) = @_;
160
161 print "Composite: $args{Text}\n";
162 }
163
164 package main;
165
166 my $obj = new Composite(
167 Text => 'Hello World!',
168 Mazzi => 'Mazzi',
169 Fugi => 'Fugi'
170 );
171
172 # will print
173 #
174 # Foo: Mazzi
175 # Bar: Fugi
176 # Foo:
177 # Bar:
178 # Composite: Hello World!
179
180 =h1 Description
181 Áàçîâûé êëàññ äëÿ îáúåêòîâ. Ðåàëèçóåò ìíîæåñòâåííîå íàñëåäîâàíèå
182
183
184 =h1 Members
185 =cut
186
187 1;