view Lib/IMPL/ORM/Object.pm @ 134:44977efed303

Significant performance optimizations Fixed recursion problems due converting objects to JSON Added cache support for the templates Added discovery feature for the web methods
author wizard
date Mon, 21 Jun 2010 02:39:53 +0400
parents 16ada169ca75
children 4267a2ac3d46
line wrap: on
line source

package IMPL::ORM::Object;
use strict;
use warnings;

use base qw(IMPL::Object);
use IMPL::Class::Property;
use IMPL::Class::Property::Direct;

require IMPL::ORM::Entity;
require IMPL::ORM::Schema::Entity;
require IMPL::ORM::Schema::Field;
require IMPL::ORM::Schema::Relation::HasMany;
require IMPL::ORM::Schema::Relation::HasOne;
require IMPL::ORM::Schema::Relation::Subclass;

BEGIN {
    private _direct property _entities => prop_all;
    public property objectType => prop_all, {type => 'String'};
    
    sub _PropertyImplementor {
        'IMPL::ORM::PropertyImplementor'
    }
}

my %schemaCache;

sub CTOR {
    my ($this) = @_;
    
    while ( my ($class,$schema) = $this->ormGetSchema ) {
        $this->{$_entities}{$class} = new IMPL::ORM::Entity($class,$schema);
    }
}

sub ormStore {
    my ($this,$class,$prop,$value) = @_;
    
    die IMPL::InvalidOperationException("Cannot find entity for the specified class",$class) unless $this->{$_entities}{$class};
    
    $this->{$_entities}{$class}->Store($prop,$value);
}

sub ormGet {
    my ($this,$class,$prop,$value) = @_;
    
    return $this->{$_entities}{$class} ? $this->{$_entities}{$class}->Get($prop,$value) : undef;
}

sub entityName {
    (my $self = ref $_[0] || $_[0]) =~ s/^.*?(\w+)$/$1/;
    return $self;
}

sub ormGetSchema {
    my ($self,$dataSchema,$surrogate) = @_;
    
    my $schema = $surrogate || IMPL::ORM::Schema::Entity->new($self->entityName);
    
    # для текущего класса, проходим по всем свойствам
    foreach my $ormProp (
        $self->get_meta(
            'IMPL::Class::PropertyInfo',
            sub {
                UNIVERSAL::isa($_->Implementor, 'IMPL::ORM::PropertyImplementor' )
            },
            0
        )
    ){
        if ($ormProp->Mutators & prop_list) {
            # отношение 1 ко многим
            my $type = $dataSchema->resolveType($ormProp->Type) or die new IMPL::InvalidOperationException("Failed to resolve a reference type due building schema for a class", $ormProp->Class, $ormProp->Name);
            $schema->appendChild( new IMPL::ORM::Schema::Relation::HasMany($ormProp->Name, $type->entityName) );
        } elsif (my $type = $dataSchema->isValueType($ormProp->Type)) {
            # поле
            $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$ormProp->Type) );
        } elsif (my $entity = $dataSchema->resolveType($ormProp->Type)) {
            # отношение ссылка
            $schema->appendChild( new IMPL::ORM::Schema::Relation::HasOne($ormProp->Name,$entity->entityName));
        } else {
            # хз что. Скорее всего не удалось квалифицировать тип свойства не как ссылочный и как поле.
            die new IMPL::Exception('Uexpected error due building schema for a class', $ormProp->Class, $ormProp->Name,$ormProp->Type);
        }
    }
    
    # Формируем отношения наследования
    {
        # локализуем прагму
        no strict 'refs';
        
        my $class = ref $self || $self;
        
        # по всем классам
        foreach my $super (grep $_->isa(__PACKAGE__), @{"${class}::ISA"}) {
            my $type = $dataSchema->resolveType($super) or die new IMPL::InvalidOperationException("Failed to resolve a super class due building schema for a class", $class, $super);
            $schema->appendChild(new IMPL::ORM::Schema::Relation::Subclass($type));
        }
    }
    
    return $schema;
}

1;

__END__

=pod

=head1 DESCRIPTION

Базовый объект для реляционного отображения,
содержит в себе реляционные записи представляющие данный объект.

Каждый класс отображается в определенную сущность. Сущности хранят
состояние объектов в том виде в котором удобно записывать в реляционную базу.

=cut