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