view Lib/IMPL/Class/Meta.pm @ 59:0f3e369553bd

Rewritten property implementation (probably become slower but more flexible) Configuration infrastructure in progress (in the aspect of the lazy activation) Initial concept for the code generator
author wizard
date Tue, 09 Mar 2010 02:50:45 +0300
parents 16ada169ca75
children dc1da0389db7
line wrap: on
line source

package IMPL::Class::Meta;
use strict;

my %class_meta;

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;
}

=pod
__PACKAGE_->set_meta($metaObject);
__PACKAGE_->get_meta('MyMetaClass',sub {
    my ($item) = @_;
    $item->Name eq 'Something' ? 1 : 0
} );
=cut

1;