Mercurial > pub > Impl

comparison Lib/IMPL/Object.pm @ 2:78cd38551534

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
in develop
author Sergey
date Mon, 10 Aug 2009 17:39:08 +0400
parents 03e58a454b20
children e59f44f75f20
comparison
equal deleted inserted replaced
1:3b418b134d8c 2:78cd38551534
1 package IMPL::Object; 1 package IMPL::Object;
2 use strict; 2 use strict;
3 3
4 use base qw(IMPL::Class::Meta); 4 use base qw(IMPL::Object::Abstract);
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 5
66 sub surrogate { 6 sub surrogate {
67 bless {}, ref $_[0] || $_[0]; 7 bless {}, ref $_[0] || $_[0];
68 } 8 }
69 9
70 sub superCTOR { 10 sub new {
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; 11 my $class = shift;
100 $class = ref $class || $class; 12 my $self = bless {}, ref($class) || $class;
101 no strict 'refs'; 13 $self->callCTOR(@_);
102 no warnings 'once'; 14
103 ${"${class}::CTOR"}{$_} = \&_pass_throgh_mapper foreach @{"${class}::ISA"}; 15 $self;
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 } 16 }
122 17
123 =pod 18 =pod
124 =h1 SYNOPSIS 19 =h1 SYNOPSIS
125 20
171 66
172 # will print 67 # will print
173 # 68 #
174 # Foo: Mazzi 69 # Foo: Mazzi
175 # Bar: Fugi 70 # Bar: Fugi
176 # Foo:
177 # Bar: 71 # Bar:
178 # Composite: Hello World! 72 # Composite: Hello World!
179 73
180 =h1 Description 74 =h1 Description
181 Базовый класс для объектов. Реализует множественное наследование 75 Базовый класс для объектов, основанных на хеше.
182
183 76
184 =h1 Members 77 =h1 Members
78
79 =level 4
80
81 =item operator C<new>(@args)
82
83 Создает экземпляр объекта и вызывает конструктор с параметрами @args.
84
85 =item operator C<surrogate>()
86
87 Создает неинициализированный экземпляр объекта.
88
89 =back
90
91 =р1 Cavearts
92
93 Нужно заметить, что директива C<use base> работает не совсем прозрачно, если в нашем примере
94 класс C<Composite> наследуется от C<Baz>, а затем C<Foo>, то наследование от
95 C<Foo> не произойдет поскольку он уже имеется в C<Baz>. Вот не задача:)
96
185 =cut 97 =cut
186 98
187 1; 99 1;