view Lib/IMPL/ORM/Object.pm @ 31:d59526f6310e

Small fixes to Test framework (correct handlinf of the compilation errors in the test units) Imported and refactored SQL DB schema from the old project
author Sergey
date Mon, 09 Nov 2009 01:39:16 +0300
parents dd4d72600c69
children d660fb38b7cc
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;
}

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 _PropertyImplementor {
    'IMPL::ORM::PropertyImplementor'
}

sub entityName {
    (my $self = ref $_[0] || $_[0]) =~ s/::/_/g;
    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,'IMPL::ORM::Object')) {
            # поле
            $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$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