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