|
407
|
1 package IMPL::declare;
|
|
|
2 use strict;
|
|
|
3
|
|
|
4 use Carp qw(carp);
|
|
|
5 use IMPL::Class::PropertyInfo();
|
|
|
6 use IMPL::Const qw(:access);
|
|
|
7 use IMPL::require();
|
|
|
8
|
|
|
9 BEGIN {
|
|
|
10 *_require = *IMPL::require::_require;
|
|
|
11 *_trace = *IMPL::require::_trace;
|
|
|
12 }
|
|
|
13
|
|
|
14 sub import {
|
|
|
15 my ( $self, $args ) = @_;
|
|
|
16
|
|
|
17 return unless $args;
|
|
|
18
|
|
|
19 die "A hash reference is required" unless ref $args eq 'HASH';
|
|
|
20
|
|
|
21 no strict 'refs';
|
|
|
22 no warnings 'once';
|
|
|
23
|
|
|
24 my $caller = caller;
|
|
|
25
|
|
|
26 my $aliases = $args->{require} || {};
|
|
|
27
|
|
|
28 $IMPL::require::PENDING{$caller} = 1;
|
|
|
29 _trace("declare $caller");
|
|
|
30 $IMPL::require::level++;
|
|
|
31
|
|
|
32 *{"${caller}::SELF"} = sub () {
|
|
|
33 $caller;
|
|
|
34 };
|
|
|
35
|
|
|
36 while ( my ( $alias, $class ) = each %$aliases ) {
|
|
|
37 _trace("$alias => $class");
|
|
|
38 $IMPL::require::level++;
|
|
|
39 my $c = _require($class);
|
|
|
40
|
|
411
|
41 *{"${caller}::$alias"} = sub () {
|
|
407
|
42 $c;
|
|
|
43 };
|
|
|
44 $IMPL::require::level--;
|
|
|
45 }
|
|
|
46
|
|
|
47 my $base = $args->{base} || {};
|
|
|
48
|
|
|
49 my %ctor;
|
|
|
50 my @isa;
|
|
|
51
|
|
|
52 if ( ref $base eq 'ARRAY' ) {
|
|
|
53 carp "Odd elements number in require"
|
|
|
54 unless scalar(@$base) % 2 == 0;
|
|
|
55 while ( my ( $class, $mapper ) = splice @$base, 0, 2 ) {
|
|
|
56 _trace("parent $class");
|
|
|
57 $IMPL::require::level++;
|
|
|
58 $class = $aliases->{$class} || _require($class);
|
|
|
59 $IMPL::require::level--;
|
|
|
60
|
|
|
61 push @isa, $class;
|
|
|
62 $ctor{$class} = $mapper;
|
|
|
63 }
|
|
|
64 }
|
|
|
65 elsif ( ref $base eq 'HASH' ) {
|
|
|
66 while ( my ( $class, $mapper ) = each %$base ) {
|
|
|
67 _trace("parent $class");
|
|
|
68 $IMPL::require::level++;
|
|
|
69 $class = $aliases->{$class} || _require($class);
|
|
|
70 $IMPL::require::level--;
|
|
|
71
|
|
|
72 push @isa, $class;
|
|
|
73 $ctor{$class} = $mapper;
|
|
|
74 }
|
|
|
75 }
|
|
|
76
|
|
|
77 %{"${caller}::CTOR"} = %ctor;
|
|
|
78 push @{"${caller}::ISA"}, @isa;
|
|
|
79
|
|
|
80 if ( ref( $args->{meta} ) eq 'ARRAY' ) {
|
|
|
81 $caller->SetMeta($_) foreach @{ $args->{meta} };
|
|
|
82 }
|
|
|
83
|
|
|
84 my $props = $args->{props} || [];
|
|
|
85
|
|
|
86 if ( $props eq 'HASH' ) {
|
|
|
87 $props = [%$props];
|
|
|
88 }
|
|
|
89
|
|
|
90 die "A hash or an array reference is required in the properties list"
|
|
|
91 unless ref $props eq 'ARRAY';
|
|
|
92
|
|
|
93 carp "Odd elements number in properties declaration of $caller"
|
|
|
94 unless scalar(@$props) % 2 == 0;
|
|
|
95
|
|
|
96 if (@$props) {
|
|
|
97 $self->_implementProps( $props, $caller );
|
|
|
98 }
|
|
|
99
|
|
|
100 if ( $args->{_implement} ) {
|
|
|
101 $self->_implementProps( $caller->abstractProps, $caller );
|
|
|
102 $caller->abstractProps( [] );
|
|
|
103 }
|
|
|
104
|
|
|
105 $IMPL::require::level--;
|
|
|
106 delete $IMPL::require::PENDING{$caller};
|
|
|
107 }
|
|
|
108
|
|
|
109 sub _implementProps {
|
|
|
110 my ( $self, $props, $caller ) = @_;
|
|
|
111
|
|
|
112 for ( my $i = 0 ; $i < @$props - 1 ; $i = $i + 2 ) {
|
|
|
113 my ( $prop, $spec ) = @{$props}[ $i, $i + 1 ];
|
|
|
114
|
|
|
115 $caller->ClassPropertyImplementor->Implement(
|
|
|
116 $spec,
|
|
|
117 {
|
|
|
118 name => $prop,
|
|
|
119 class => $caller,
|
|
|
120 access => $prop =~ /^_/
|
|
|
121 ? ACCESS_PRIVATE
|
|
|
122 : ACCESS_PUBLIC
|
|
|
123 }
|
|
|
124 );
|
|
|
125 }
|
|
|
126 }
|
|
|
127
|
|
|
128 1;
|
|
|
129
|
|
|
130 __END__
|
|
|
131
|
|
|
132 =pod
|
|
|
133
|
|
|
134 =head1 NAME
|
|
|
135
|
|
|
136 C<IMPL::declare> - описывает класс
|
|
|
137
|
|
|
138 =head1 SYNOPSIS
|
|
|
139
|
|
|
140 =begin code
|
|
|
141
|
|
|
142 package My::Bar;
|
|
|
143
|
|
|
144 use IMPL::declare {
|
|
|
145 require => {
|
|
|
146 TFoo => 'My::Foo',
|
|
|
147 TBox => 'My::Box'
|
|
|
148 },
|
|
|
149 base => {
|
|
|
150 TFoo => '@_',
|
|
|
151 'IMPL::Object' => undef,
|
|
|
152 }
|
|
|
153 }
|
|
|
154
|
|
|
155 sub CreateBox {
|
|
|
156 my ($this) = @_;
|
|
|
157 return TBox->new($this);
|
|
|
158 }
|
|
|
159
|
|
|
160 =end code
|
|
|
161
|
|
|
162 Специальная ситрока C<@_> означает передачу параметров конструктора текущего класса конструктору
|
|
|
163 базового класса без изменений.
|
|
|
164
|
|
|
165 =head1 DESCRIPTION
|
|
|
166
|
|
|
167 Описывает текущий пакет(модуль) как класс. В качестве параметра получает ссылку на хеш,
|
|
|
168 в которой храняться метаданные для объявления класса.
|
|
|
169
|
|
|
170 =head1 METADATA
|
|
|
171
|
|
|
172 =head2 C<require>
|
|
|
173
|
|
|
174 Содержит ссылку на хеш с синонимами модулей, которые будут доступны в текушем модуле,
|
|
|
175 аналогично использованию C<IMPL::require>. Однако, если модуль не требует загрузки при
|
|
|
176 помощи C<require> нужно использовать префикс C<'-'> в его имени
|
|
|
177
|
|
|
178 =begin code
|
|
|
179
|
|
|
180 {
|
|
|
181 require => {
|
|
|
182 TObject => 'IMPL::Object', # will be loaded with require
|
|
|
183 TFoo => '-My:App::Data::Foo' # will not use 'require' to load module
|
|
|
184 }
|
|
|
185 }
|
|
|
186
|
|
|
187 =end code
|
|
|
188
|
|
|
189 =head2 C<base>
|
|
|
190
|
|
|
191 Обисывает базове классы для текущего класса. Если данный параметр - ссылка массив, то
|
|
|
192 этот массив будет превращен в массив C<@ISA>. Если данный параметр - ссылка на хеш, то
|
|
|
193 его ключи опичавют список базовых классов, а значения - преобразование параметров для
|
|
|
194 вызова базовых конструкторов.
|
|
|
195
|
|
|
196 В качестве имен базовых классов могут быть как полные имена модулей, так и назначенные
|
|
|
197 ранее псевдонимы. Использование префикса C<'-'> перед B<полным именем модуля> означает,
|
|
|
198 что модуль не требуется загружать, в случае с псевдонимами, префикс C<'-'> уже был указан
|
|
|
199 при их объявлении.
|
|
|
200
|
|
|
201 =begin code
|
|
|
202
|
|
|
203 {
|
|
|
204 require => {
|
|
|
205 TFoo => '-My:App::Data::Foo' # will not use 'require' to load module
|
|
|
206 },
|
|
|
207 base => {
|
|
|
208 TFoo => '@_', # pass parameters unchanged
|
|
|
209 'My::Base::Class' => sub { name => $_[0], data => $_[1] }, # remap parameters
|
|
|
210 '-My::Extentions' => undef, # do not pass any parameters
|
|
|
211 }
|
|
|
212 }
|
|
|
213
|
|
|
214 =end code
|
|
|
215
|
|
|
216 =cut
|
