49
+ − 1 package IMPL::Class::Meta;
+ − 2 use strict;
+ − 3
90
+ − 4 use Class::Data::Inheritable;
+ − 5 use Storable qw(dclone);
+ − 6
49
+ − 7 my %class_meta;
90
+ − 8 my %class_data;
49
+ − 9
+ − 10 sub set_meta {
+ − 11 my ($class,$meta_data) = @_;
+ − 12 $class = ref $class if ref $class;
+ − 13
+ − 14 # ��� ������ ������������ ����������� ����������, ��������� ��� ���� ������������
+ − 15 # ����� IMPL::Object::Accessor, ������� ����������� �� �������� ������
+ − 16 die "The meta_data parameter should be an object" if not ref $meta_data;
+ − 17
+ − 18 push @{$class_meta{$class}{ref $meta_data}},$meta_data;
+ − 19 }
+ − 20
+ − 21 sub get_meta {
+ − 22 my ($class,$meta_class,$predicate,$deep) = @_;
+ − 23 $class = ref $class if ref $class;
+ − 24 no strict 'refs';
+ − 25 my @result;
+ − 26
+ − 27 if ($deep) {
+ − 28 @result = map { $_->can('get_meta') ? $_->get_meta($meta_class,$predicate,$deep) : () } @{$class.'::ISA'};
+ − 29 }
+ − 30
+ − 31 if ($predicate) {
+ − 32 push @result,grep( &$predicate($_), map( @{$class_meta{$class}{$_}}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ) );
+ − 33 } else {
+ − 34 push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) );
+ − 35 }
+ − 36 wantarray ? @result : \@result;
+ − 37 }
+ − 38
90
+ − 39 sub class_data {
+ − 40 my $class = shift;
+ − 41 $class = ref $class || $class;
+ − 42
+ − 43 if (@_ > 1) {
+ − 44 my ($name,$value) = @_;
+ − 45 return $class_data{$class}{$name} = $value;
+ − 46 } else {
+ − 47 my ($name) = @_;
+ − 48
+ − 49 if( exists $class_data{$class}{$name} ) {
+ − 50 $class_data{$class}{$name};
+ − 51 } else {
+ − 52 if ( my $value = $class->_find_class_data($name) ) {
+ − 53 $class_data{$class}{$name} = dclone($value);
+ − 54 } else {
+ − 55 undef;
+ − 56 }
+ − 57 }
+ − 58 }
+ − 59 }
+ − 60
+ − 61 sub _find_class_data {
+ − 62 my ($class,$name) = @_;
+ − 63
+ − 64 no strict 'refs';
+ − 65
+ − 66 exists $class_data{$_}{$name} and return $class_data{$_}{$name} foreach @{"${class}::ISA"};
+ − 67
+ − 68 my $val;
+ − 69 $val = $_->_find_class_data($name) and return $val foreach @{"${class}::ISA"};
+ − 70 }
49
+ − 71
+ − 72 1;
90
+ − 73
+ − 74 __END__
+ − 75
+ − 76 =pod
+ − 77
+ − 78 =head1 NAME
+ − 79
+ − 80 C<IMPL::Class::Meta> - ���������� �������� �� ������ ������.
+ − 81
+ − 82 =head1 SYNOPSIS
+ − 83
+ − 84 =begin code
+ − 85
+ − 86 package InfoMeta;
+ − 87
+ − 88 use base qw(IMPL::Object IMPL::Object::Autofill);
+ − 89 use IMPL::Class::Property;
+ − 90
+ − 91 __PACKAGE__->PassThroughArgs;
+ − 92
+ − 93 BEGIN {
+ − 94 public property name => prop_get | owner_set;
+ − 95 }
+ − 96
+ − 97 package InfoExMeta;
+ − 98 use base qw(InfoMeta);
+ − 99
+ − 100 __PACKAGE__->PassThroughArgs;
+ − 101
+ − 102 BEGIN {
+ − 103 public property description => prop_all;
+ − 104 }
+ − 105
+ − 106 package Foo;
+ − 107
+ − 108 __PACKAGE__->set_meta(new InfoMeta(name => 'info'));
+ − 109 __PACKAGE__->set_meta(new InfoExMeta(name => 'infoEx', description => 'extended info' ));
+ − 110
+ − 111 package main;
+ − 112
+ − 113 # get all InfoMeta, InfoExMeta will be included, becouse it's derived from InfoMeta
+ − 114 my @info = Foo->get_meta('InfoMeta'); # will get two objects, 'info' and 'infoEx';
+ − 115
+ − 116 # get all InfoExMeta meta
+ − 117 @info = Foo->get_meta('InfoExMeta'); # will get only 'infoEx'
+ − 118
+ − 119 # get filtered meta
+ − 120 @info = Foo->get_meta('InfoMeta', sub { $_->name eq 'info'} ); # will get only 'info'
+ − 121
+ − 122 =end code
+ − 123
+ − 124 =head1 DESCRIPTION
+ − 125
+ − 126 ��������� ��������� ���������� � ����� (������) ��� ������ ����������, ����������� �������� ����� �������,
+ − 127 ������ ������� ���������� ������������� �� �� ���� (������), ��� ��������� ������� ��� ���������� ����������.
+ − 128
+ − 129 ���������� ����������� ������� ���������� � ������ �������������� �� ������� �������
+ − 130
+ − 131 =head1 MEMBERS
+ − 132
+ − 133 =over
+ − 134
+ − 135 =item C<set_meta($meta_data)>
+ − 136
+ − 137 ��������� ���������� C<$meta_data> � ������.
+ − 138
+ − 139 =item C<get_meta($meta_class,$predicate,$deep)>
+ − 140
+ − 141 �������� ���������� ���� C<$meta_class> � ��� �����������, � ������������ ���������� � ���������
+ − 142 ���������� ������� �������.
+ − 143
+ − 144 =over
+ − 145
+ − 146 =item C<$meta_class>
+ − 147
+ − 148 ��� ����������
+ − 149
+ − 150 =item C<$predicate>
+ − 151
+ − 152 ������������, ������� ����� ���������� ��� ������ ��������� ���������� � �� ������ ����������
+ − 153 �� ���������� ���������� ����� �������� � ��������� ��� ���. �������� � �������� ���������
+ − 154 ������ � �����������, ���������� C<true> - �������� ���������� � ��������, C<false> - ����������
+ − 155 ���������� ��� �� ����������. ����� ���������� C<$_> ��������� �� ������� ������ � �����������.
+ − 156
+ − 157 =begin code
+ − 158
+ − 159 my @info = Foo->get_meta(
+ − 160 'InfoMeta',
+ − 161 sub { ref $_ eq 'InfoMeta'}, # exclude subclasses ('InfoExMeta')
+ − 162 1 # deep search
+ − 163 );
+ − 164
+ − 165 my @info = Foo->get_meta(
+ − 166 'InfoMeta',
+ − 167 sub {
+ − 168 my $item = shift;
+ − 169 ref $item eq 'InfoMeta' # exclude subclasses ('InfoExMeta')
+ − 170 },
+ − 171 1 # deep search
+ − 172 );
+ − 173
+ − 174 =end code
+ − 175
+ − 176 =item C<$deep>
+ − 177
+ − 178 ������������ ����� �� ������� �������.
+ − 179
+ − 180 =back
+ − 181
+ − 182 =item C<class_data($name,$new_value)>
+ − 183
+ − 184 � ������� �� ����������, C<class_data> �� ����������� ����������,
+ − 185 � ������ ������ ���� ��������� ��� ������ ����� C<$name>.
+ − 186
+ − 187 ���� ����� �������� �� ������, �� �������������� ������� ������������,
+ − 188 ���� ������� ����� �� ����� ������������ ��������, �� ��� ������ � �������
+ − 189 �������, ����� ����� ���������� �������� ����������� � ������� ������ �
+ − 190 ������������ ������. ��� ��������� ������� ������� �������� �������� ��-���������,
+ − 191 ������� ����� ���� �������� ��� �������� �����������.
+ − 192
+ − 193 =begin code
+ − 194
+ − 195 package Foo;
+ − 196 use base qw(IMPL::Class::Meta);
+ − 197
+ − 198 __PACKAGE__->class_data( info => { version => 1 } ); # will be default for all subclasses
+ − 199
+ − 200 sub say_version {
+ − 201 my ($self) = @_;
+ − 202
+ − 203 print $self->class_data(info)->{version};
+ − 204 }
+ − 205
+ − 206 package Bar;
+ − 207 use base qw(Foo);
+ − 208
+ − 209 __PACKAGE__->class_data('info')->{ language } = 'English';
+ − 210
+ − 211 package main;
+ − 212
+ − 213 Foo->class_data('info')->{version} = 2;
+ − 214 Bar->say_version; # will print '1';
+ − 215 Foo->say_version; # will print '2';
+ − 216
+ − 217 =end code
+ − 218
+ − 219 =back
+ − 220
+ − 221 =cut