Mercurial > pub > Impl
view Lib/IMPL/Class/Meta.pm @ 171:59e5fcb59d86
Исправления, изменена концепция веб-форм
author | sourcer |
---|---|
date | Mon, 06 Jun 2011 03:30:36 +0400 |
parents | 76515373dac0 |
children | aaab45153411 |
line wrap: on
line source
package IMPL::Class::Meta; use strict; use Clone qw(clone); my %class_meta; my %class_data; sub set_meta { my ($class,$meta_data) = @_; $class = ref $class if ref $class; # , # IMPL::Object::Accessor, die "The meta_data parameter should be an object" if not ref $meta_data; push @{$class_meta{$class}{ref $meta_data}},$meta_data; } sub get_meta { my ($class,$meta_class,$predicate,$deep) = @_; $class = ref $class if ref $class; no strict 'refs'; my @result; if ($deep) { @result = map { $_->can('get_meta') ? $_->get_meta($meta_class,$predicate,$deep) : () } @{$class.'::ISA'}; } if ($predicate) { push @result,grep( &$predicate($_), map( @{$class_meta{$class}{$_}}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ) ); } else { push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ); } wantarray ? @result : \@result; } sub class_data { my $class = shift; $class = ref $class || $class; if (@_ > 1) { my ($name,$value) = @_; return $class_data{$class}{$name} = $value; } else { my ($name) = @_; if( exists $class_data{$class}{$name} ) { $class_data{$class}{$name}; } else { if ( my $value = $class->_find_class_data($name) ) { $class_data{$class}{$name} = clone($value); } else { undef; } } } } sub static_accessor { my ($class,$name,$value) = @_; $class = ref $class || $class; no strict 'refs'; *{"${class}::${name}"} = sub { if (@_ > 1) { my $self = shift; $self = ref $self || $self; if ($class ne $self) { $self->static_accessor( $name => $_[0]); # define own class data } else { $value = $_[0]; } } else { $value; } }; $value }; sub _find_class_data { my ($class,$name) = @_; no strict 'refs'; exists $class_data{$_}{$name} and return $class_data{$_}{$name} foreach @{"${class}::ISA"}; my $val; $val = $_->can('_find_class_data') ? $_->_find_class_data($name) : undef and return $val foreach @{"${class}::ISA"}; } 1; __END__ =pod =head1 NAME C<IMPL::Class::Meta> - . =head1 SYNOPSIS =begin code package InfoMeta; use parent qw(IMPL::Object IMPL::Object::Autofill); use IMPL::Class::Property; __PACKAGE__->PassThroughArgs; BEGIN { public property name => prop_get | owner_set; } package InfoExMeta; use parent qw(InfoMeta); __PACKAGE__->PassThroughArgs; BEGIN { public property description => prop_all; } package Foo; __PACKAGE__->set_meta(new InfoMeta(name => 'info')); __PACKAGE__->set_meta(new InfoExMeta(name => 'infoEx', description => 'extended info' )); package main; # get all InfoMeta, InfoExMeta will be included, becouse it's derived from InfoMeta my @info = Foo->get_meta('InfoMeta'); # will get two objects, 'info' and 'infoEx'; # get all InfoExMeta meta @info = Foo->get_meta('InfoExMeta'); # will get only 'infoEx' # get filtered meta @info = Foo->get_meta('InfoMeta', sub { $_->name eq 'info'} ); # will get only 'info' =end code =head1 DESCRIPTION () , , (), . =head1 MEMBERS =over =item C<set_meta($meta_data)> C<$meta_data> . =item C<get_meta($meta_class,$predicate,$deep)> C<$meta_class> , . =over =item C<$meta_class> =item C<$predicate> , . , C<true> - , C<false> - . C<$_> . =begin code my @info = Foo->get_meta( 'InfoMeta', sub { ref $_ eq 'InfoMeta'}, # exclude subclasses ('InfoExMeta') 1 # deep search ); my @info = Foo->get_meta( 'InfoMeta', sub { my $item = shift; ref $item eq 'InfoMeta' # exclude subclasses ('InfoExMeta') }, 1 # deep search ); =end code =item C<$deep> . =back =item C<class_data($name,$new_value)> , C<class_data> , C<$name>. , , , , . -, . =begin code package Foo; use parent qw(IMPL::Class::Meta); __PACKAGE__->class_data( info => { version => 1 } ); # will be default for all subclasses sub say_version { my ($self) = @_; print $self->class_data('info')->{version}; } package Bar; use parent qw(Foo); __PACKAGE__->class_data('info')->{ language } = 'English'; package main; Foo->class_data('info')->{version} = 2; Bar->say_version; # will print '1'; Foo->say_version; # will print '2'; =end code =item C<static_accessor($name[,$value])> C<$name> C<$value>. C<class_data>, , C<class_data> , , , . =begin code package Foo; use parent qw(IMPL::Class::Meta); __PACKAGE__->static_accessor( info => { version => 1 } ); package Bar; use parent qw(Foo); __PACKAGE__->info->{language} = 'English'; # Foo->info->{language} will become 'English' to!!! __PACKAGE__->info({language => 'English'}); # will define own 'info' but will loose original data. =end code =back =cut