Mercurial > pub > Impl

comparison lib/IMPL/declare.pm @ 407:c6e90e02dd17 ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
renamed Lib->lib
author cin
date Fri, 04 Sep 2015 19:40:23 +0300
parents
children ee36115f6a34
comparison
equal deleted inserted replaced
406:f23fcb19d3c1 407:c6e90e02dd17
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
41 *{"${caller}::$alias"} = sub() {
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