view Lib/IMPL/Class/Meta.pm @ 22:da5bc24b3d3c

wmi tests
author Sergey
date Wed, 30 Sep 2009 17:41:32 +0400
parents 03e58a454b20
children 16ada169ca75
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;