Mercurial > pub > Impl
changeset 165:76515373dac0
Added Class::Template,
Rewritten SQL::Schema
'use parent' directive instead of 'use base'
line wrap: on
line diff
--- a/Lib/CDBI/Map.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/CDBI/Map.pm Sat Apr 23 23:06:48 2011 +0400 @@ -87,12 +87,12 @@ =pod =head1 SYNOPSIS package App::CDBI; -use base 'Class::DBI'; +use parent 'Class::DBI'; #.... package App::MapString; -use base 'Class::DBI','CDBI::Map'; +use parent 'Class::DBI','CDBI::Map'; #....
--- a/Lib/CDBI/Meta.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/CDBI/Meta.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::Object); +use parent qw(IMPL::Object); use IMPL::Class::Property; use IMPL::Class::Property::Direct;
--- a/Lib/CDBI/Transform.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/CDBI/Transform.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::Object::Autofill Form::Transform ); +use parent qw(IMPL::Object::Autofill Form::Transform ); use IMPL::Class::Property; require IMPL::Exception; @@ -71,7 +71,7 @@ } package CDBI::Transform::ObjectToForm; -use base qw(IMPL::Transform); +use parent qw(IMPL::Transform); use IMPL::Class::Property;
--- a/Lib/Common.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Common.pm Sat Apr 23 23:06:48 2011 +0400 @@ -154,7 +154,7 @@ } package Exception; -use base qw(IMPL::Exception); +use parent qw(IMPL::Exception); package Persistent; import Common;
--- a/Lib/Deployment/Batch/Backup.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Deployment/Batch/Backup.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,5 +1,5 @@ package Deployment::Batch::Backup; -use base qw(Deployment::Batch::Generic); +use parent qw(Deployment::Batch::Generic); use Common; use File::Copy;
--- a/Lib/Deployment/Batch/CDBIUpdate.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Deployment/Batch/CDBIUpdate.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ use strict; package Deployment::Batch::CDBIUpdate; use Common; -use base qw(Deployment::Batch::Generic); +use parent qw(Deployment::Batch::Generic); use DBI; use Schema::DataSource;
--- a/Lib/Deployment/Batch/CopyFile.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Deployment/Batch/CopyFile.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ package Deployment::Batch; our %Dirs; package Deployment::Batch::CopyFile; -use base qw(Deployment::Batch::Generic); +use parent qw(Deployment::Batch::Generic); use File::Copy; require URI::file; use Common;
--- a/Lib/Deployment/Batch/CopyTree.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Deployment/Batch/CopyTree.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,5 +1,5 @@ package Deployment::Batch::CopyTree; -use base 'Deployment::Batch::Generic'; +use parent 'Deployment::Batch::Generic'; use Common; 1;
--- a/Lib/Deployment/Batch/CustomAction.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Deployment/Batch/CustomAction.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ use strict; package Deployment::Batch::CustomAction; -use base qw(Deployment::Batch::Generic); +use parent qw(Deployment::Batch::Generic); use Common; BEGIN {
--- a/Lib/Deployment/Batch/Temp.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Deployment/Batch/Temp.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ use strict; package Deployment::Batch::Temp; -use base qw(Deployment::Batch::Generic); +use parent qw(Deployment::Batch::Generic); use Common; use File::Temp;
--- a/Lib/Engine/Action.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Engine/Action.pm Sat Apr 23 23:06:48 2011 +0400 @@ -4,7 +4,7 @@ use Engine::CGI; use Common; use URI; -use base qw(IMPL::Object IMPL::Object::Disposable IMPL::Object::Autofill IMPL::Object::EventSource); +use parent qw(IMPL::Object IMPL::Object::Disposable IMPL::Object::Autofill IMPL::Object::EventSource); use IMPL::Class::Property; use IMPL::Class::Property::Direct;
--- a/Lib/Engine/CGI.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Engine/CGI.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ use strict; package Engine::CGI; -use base 'CGI'; +use parent 'CGI'; use Encode; use Common;
--- a/Lib/Form/Container.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Form/Container.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use Common; use Form::Filter; -use base qw(Form::Item); +use parent qw(Form::Item); BEGIN { DeclareProperty Schema => ACCESS_READ;
--- a/Lib/Form/Filter/Depends.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Form/Filter/Depends.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,5 +1,5 @@ package Form::Filter::Depends; -use base qw(Form::Filter); +use parent qw(Form::Filter); use Common;
--- a/Lib/Form/Filter/Mandatory.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Form/Filter/Mandatory.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ package Form::Filter::Mandatory; use strict; use Common; -use base qw(Form::Filter); +use parent qw(Form::Filter); sub SUPPORTED_CONTEXT { Form::Filter::CTX_SINGLE | Form::Filter::CTX_SET }
--- a/Lib/Form/Filter/Regexp.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Form/Filter/Regexp.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use Common; use Form::Filter; -use base qw(Form::Filter); +use parent qw(Form::Filter); BEGIN { DeclareProperty Regexp => ACCESS_READ;
--- a/Lib/Form/Transform.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Form/Transform.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ package Form::Transform; use strict; use warnings; -use base qw(IMPL::Transform); +use parent qw(IMPL::Transform); sub CTOR { my ($this) = @_;
--- a/Lib/Form/ValueItem.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Form/ValueItem.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ package Form::ValueItem; use strict; -use base qw(Form::Item); +use parent qw(Form::Item); use Common; use Form::Filter;
--- a/Lib/Form/ValueItem/List.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/Form/ValueItem/List.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ package Form::ValueItem::List; use Common; -use base qw(Form::ValueItem); +use parent qw(Form::ValueItem); BEGIN { DeclareProperty ListValues => ACCESS_READ;
--- a/Lib/IMPL/Class/Member.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Class/Member.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ package IMPL::Class::Member; use strict; -use base qw(Exporter); +use parent qw(Exporter); our @EXPORT = qw(virtual public private protected); use IMPL::Class::Meta;
--- a/Lib/IMPL/Class/MemberInfo.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Class/MemberInfo.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ package IMPL::Class::MemberInfo; use strict; use IMPL::_core::version; -use base qw(IMPL::Object::Accessor); +use parent qw(IMPL::Object::Accessor); require IMPL::Exception; require IMPL::Class::Member;
--- a/Lib/IMPL/Class/Meta.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Class/Meta.pm Sat Apr 23 23:06:48 2011 +0400 @@ -107,7 +107,7 @@ package InfoMeta; -use base qw(IMPL::Object IMPL::Object::Autofill); +use parent qw(IMPL::Object IMPL::Object::Autofill); use IMPL::Class::Property; __PACKAGE__->PassThroughArgs; @@ -117,7 +117,7 @@ } package InfoExMeta; -use base qw(InfoMeta); +use parent qw(InfoMeta); __PACKAGE__->PassThroughArgs; @@ -215,7 +215,7 @@ =begin code package Foo; -use base qw(IMPL::Class::Meta); +use parent qw(IMPL::Class::Meta); __PACKAGE__->class_data( info => { version => 1 } ); # will be default for all subclasses @@ -226,7 +226,7 @@ } package Bar; -use base qw(Foo); +use parent qw(Foo); __PACKAGE__->class_data('info')->{ language } = 'English'; @@ -249,12 +249,12 @@ =begin code package Foo; -use base qw(IMPL::Class::Meta); +use parent qw(IMPL::Class::Meta); __PACKAGE__->static_accessor( info => { version => 1 } ); package Bar; -use base qw(Foo); +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.
--- a/Lib/IMPL/Class/MethodInfo.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Class/MethodInfo.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ use strict; package IMPL::Class::MethodInfo; -use base qw(IMPL::Class::MemberInfo); +use parent qw(IMPL::Class::MemberInfo); __PACKAGE__->PassThroughArgs;
--- a/Lib/IMPL/Class/Property.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Class/Property.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ package IMPL::Class::Property; use strict; -use base qw(Exporter); +use parent qw(Exporter); BEGIN { our @EXPORT = qw(property prop_get prop_set owner_set prop_none prop_all prop_list CreateProperty); }
--- a/Lib/IMPL/Class/Property/Accessor.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Class/Property/Accessor.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ package IMPL::Class::Property::Accessor; use strict; -use base qw(IMPL::Class::Property::Base); +use parent qw(IMPL::Class::Property::Base); sub factoryParams { $_[0]->SUPER::factoryParams, qw($field);
--- a/Lib/IMPL/Class/Property/Direct.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Class/Property/Direct.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ package IMPL::Class::Property::Direct; use strict; -use base qw(Exporter IMPL::Object::Accessor IMPL::Class::Property::Base); +use parent qw(Exporter IMPL::Object::Accessor IMPL::Class::Property::Base); our @EXPORT = qw(_direct); require IMPL::Object::List;
--- a/Lib/IMPL/Class/PropertyInfo.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Class/PropertyInfo.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use IMPL::_core::version; -use base qw(IMPL::Class::MemberInfo); +use parent qw(IMPL::Class::MemberInfo); __PACKAGE__->mk_accessors(qw(Type Mutators canGet canSet ownerSet)); __PACKAGE__->PassThroughArgs;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Class/Template.pm Sat Apr 23 23:06:48 2011 +0400 @@ -0,0 +1,113 @@ +package IMPL::Class::Template; +use strict; +use IMPL::lang; +use IMPL::_core::version; + +sub makeName { + my ($class,@params) = @_; + + $_ =~ s/^.*::(\w+)$/$1/ foreach @params; + return join('',$class,@params); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Class::Template> базовый класс для шаблонов. + +=head1 SYNPOSIS + +=begin code + +package KeyValuePair; + +use IMPL::Class::Property; + +use IMPL::template ( + parameters => [qw(TKey TValue))], + base => [qw(IMPL::Object IMPL::Object::Autofill)], + declare => sub { + my ($class) = @_; + public $class->CreateProperty(key => prop_get | owner_set, { type => $class->TKey } ); + public $class->CreateProperty(value => prop_all, { type => $class->TValue} ); + + $class->PassThroughArgs; + } +); + +BEGIN { + public property id => prop_get | owner_set, { type => 'integer'}; +} + +__PACKAGE__->PassThroughArgs; + +package MyCollection; + +use IMPL::Class::Property; + +use IMPL::lang; +use IMPL::template( + parameters => [qw(TKey TValue)], + base => [qw(IMPL::Object)], + declare => sub { + my ($class) = @_; + my $item_t = spec KeyValuePair($class->TKey,$class->TValue); + + public $class->CreateProperty(items => prop_get | prop_list, { type => $item_t } ) + + $class->static_accessor( ItemType => $item_t ); + } +) + +sub Add { + my ($this,$key,$value) = @_; + + die new IMPL::ArgumentException( key => "Invalid argument type" ) unless is $key, $this->TKey; + die new IMPL::ArgumentException( value => "Invalid argument type" ) unless is $value, $this->TValue; + + $this->items->AddLast( $this->ItemType->new( key => $key, value => $value ) ); +} + +=end code + +=head1 DESCRIPTION + +Шаблоны используются для динамической генерации классов. Процесс создания класса +по шаблону называется специализацией, при этом создается новый класс: + +=over + +=item 1 + +Обявляется новый пакет с именем, вычисленным из имени и параметров шаблона + +=item 2 + +Формируется массив C<@ISA> для созаднного класса, в который добавляется имя шаблона + +=item 3 + +Формируются методы с именами параметров шаблона, возвращающие реальные значения параметров + +=item 4 + +Вызывается метод для конструирования специализиции + +=back + +=head1 MEMBERS + +=over + +=item C<spec(@params)> + +Метод, создающий специализацию шаблона. Может быть вызван как оператор. + +=back + +=cut \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Code/Loader.pm Sat Apr 23 23:06:48 2011 +0400 @@ -0,0 +1,34 @@ +package IMPL::Code::Loader; +use strict; +use warnings; + +my %packages; + +sub Provide { + my ($self,$package) = @_; + + my ($declaringPackage,$file) = caller(); + $packages{$package} = { declaringPackage => $declaringPackage, file => $file, evidence => 'provide' }; +} + +sub Require { + my ($self,$package) = @_; + + return 1 if $packages{$package}; + + if (my $file = $INC{$package}) { + $packages{$package} = { file => $file, evidence => 'inc' }; + return 1; + } + + undef $@; + + if ( eval "require $package; 1;" and not $packages{$package}) { + $packages{$package} = { file => $INC{$package}, evidence => 'inc' }; + }; + + die $@ if $@ and not $!; +} + +1; +
--- a/Lib/IMPL/Config.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Config.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::Object::Accessor IMPL::Object::Serializable IMPL::Object::Autofill); +use parent qw(IMPL::Object::Accessor IMPL::Object::Serializable IMPL::Object::Autofill); __PACKAGE__->PassThroughArgs; @@ -129,7 +129,7 @@ # define application package MyApp; -use base qw(IMPL::Config); +use parent qw(IMPL::Config); use IMPL::Class::Property; use IMPL::Config::Class; @@ -184,7 +184,7 @@ C<[Autofill]> -C<use base IMPL::Object::Accessor> +C<use parent IMPL::Object::Accessor> Базовый класс для приложений. Использует подход, что приложение является объектом, состояние которого предтавляет собой конфигурацию,
--- a/Lib/IMPL/Config/Activator.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Config/Activator.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ package IMPL::Config::Activator; use strict; -use base qw(IMPL::Object IMPL::Object::Autofill IMPL::Object::PublicSerializable); +use parent qw(IMPL::Object IMPL::Object::Autofill IMPL::Object::PublicSerializable); use IMPL::Class::Property; BEGIN {
--- a/Lib/IMPL/Config/Class.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Config/Class.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::Config); +use parent qw(IMPL::Config); use IMPL::Exception; use IMPL::Class::Property;
--- a/Lib/IMPL/Config/Container.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Config/Container.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::Config); +use parent qw(IMPL::Config); use IMPL::Class::Property; BEGIN {
--- a/Lib/IMPL/Config/Resolve.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Config/Resolve.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ package IMPL::Config::Resolve; use strict; -use base qw(IMPL::Object IMPL::Object::Serializable); +use parent qw(IMPL::Object IMPL::Object::Serializable); use IMPL::Class::Property; use IMPL::Exception;
--- a/Lib/IMPL/DOM/Document.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Document.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Node); +use parent qw(IMPL::DOM::Node); __PACKAGE__->PassThroughArgs; @@ -66,7 +66,7 @@ =begin code package MyDocument; -use base qw(IMPL::DOM::Document); +use parent qw(IMPL::DOM::Document); sub Create { my $this = shift;
--- a/Lib/IMPL/DOM/Navigator.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Navigator.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::Object); +use parent qw(IMPL::Object); use IMPL::Class::Property; use IMPL::Class::Property::Direct; BEGIN {
--- a/Lib/IMPL/DOM/Navigator/Builder.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Navigator/Builder.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Navigator); +use parent qw(IMPL::DOM::Navigator); use IMPL::Class::Property; use IMPL::Class::Property::Direct; require IMPL::DOM::Navigator::SchemaNavigator;
--- a/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Navigator/SchemaNavigator.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Navigator); +use parent qw(IMPL::DOM::Navigator); use IMPL::Class::Property; use IMPL::Class::Property::Direct;
--- a/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Navigator/SimpleBuilder.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Navigator); +use parent qw(IMPL::DOM::Navigator); use IMPL::Class::Property; use IMPL::Class::Property::Direct;
--- a/Lib/IMPL/DOM/Node.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Node.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::Object); +use parent qw(IMPL::Object); use IMPL::Object::List; use IMPL::Class::Property;
--- a/Lib/IMPL/DOM/Property.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Property.pm Sat Apr 23 23:06:48 2011 +0400 @@ -4,7 +4,7 @@ require IMPL::Exception; -use base qw(Exporter); +use parent qw(Exporter); our @EXPORT_OK = qw(_dom); sub _dom($) { @@ -21,7 +21,7 @@ package TypedNode; -use base qw(IMPL::DOM::Node); +use parent qw(IMPL::DOM::Node); use IMPL::DOM::Property qw(_dom); BEGIN {
--- a/Lib/IMPL/DOM/Schema/AnyNode.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/AnyNode.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Schema::Node); +use parent qw(IMPL::DOM::Schema::Node); our %CTOR = ( 'IMPL::DOM::Schema::Node' => sub {
--- a/Lib/IMPL/DOM/Schema/ComplexNode.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/ComplexNode.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Schema::Node); +use parent qw(IMPL::DOM::Schema::Node); use IMPL::Class::Property; BEGIN {
--- a/Lib/IMPL/DOM/Schema/ComplexType.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/ComplexType.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Schema::ComplexNode); +use parent qw(IMPL::DOM::Schema::ComplexNode); use IMPL::Class::Property; use IMPL::Class::Property::Direct; use IMPL::DOM::Property qw(_dom);
--- a/Lib/IMPL/DOM/Schema/Node.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/Node.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Node); +use parent qw(IMPL::DOM::Node); use IMPL::Class::Property; use IMPL::DOM::Property qw(_dom); use IMPL::Class::Property::Direct; @@ -75,7 +75,7 @@ =head1 SYNOPSIS package SchemaEntity; -use base qw(IMPL::DOM::Schema::Node); +use parent qw(IMPL::DOM::Schema::Node); sub Validate { my ($this,$node) = @_;
--- a/Lib/IMPL/DOM/Schema/NodeList.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/NodeList.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ package IMPL::DOM::Schema::NodeList; use strict; use warnings; -use base qw(IMPL::DOM::Node); +use parent qw(IMPL::DOM::Node); use IMPL::Class::Property; use IMPL::DOM::Property qw(_dom);
--- a/Lib/IMPL/DOM/Schema/NodeSet.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/NodeSet.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Node); +use parent qw(IMPL::DOM::Node); use IMPL::Class::Property; use IMPL::DOM::Property qw(_dom);
--- a/Lib/IMPL/DOM/Schema/Property.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/Property.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Schema::SimpleNode); +use parent qw(IMPL::DOM::Schema::SimpleNode); require IMPL::DOM::Schema; require IMPL::DOM::Node; use IMPL::Class::Property;
--- a/Lib/IMPL/DOM/Schema/SimpleNode.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/SimpleNode.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Schema::Node); +use parent qw(IMPL::DOM::Schema::Node); use IMPL::Class::Property; use IMPL::Class::Property::Direct; use IMPL::DOM::Property qw(_dom);
--- a/Lib/IMPL/DOM/Schema/SimpleType.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/SimpleType.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Schema::SimpleNode); +use parent qw(IMPL::DOM::Schema::SimpleNode); use IMPL::Class::Property; use IMPL::Class::Property::Direct; use IMPL::DOM::Property qw(_dom);
--- a/Lib/IMPL/DOM/Schema/SwitchNode.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/SwitchNode.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::DOM::Schema::AnyNode); +use parent qw(IMPL::DOM::Schema::AnyNode); use IMPL::Class::Property; require IMPL::DOM::Schema::ValidationError; use IMPL::DOM::Property qw(_dom);
--- a/Lib/IMPL/DOM/Schema/ValidationError.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/ValidationError.pm Sat Apr 23 23:06:48 2011 +0400 @@ -6,7 +6,7 @@ '""' => \&toString, 'fallback' => 1; -use base qw(IMPL::Object); +use parent qw(IMPL::Object); use IMPL::Class::Property; use IMPL::Class::Property::Direct; use IMPL::Resources::Format qw(FormatMessage);
--- a/Lib/IMPL/DOM/Schema/Validator/Compare.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/Validator/Compare.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ package IMPL::DOM::Schema::Validator::Compare; use strict; -use base qw(IMPL::DOM::Schema::Validator); +use parent qw(IMPL::DOM::Schema::Validator); use IMPL::Resources::Format qw(FormatMessage); use IMPL::Class::Property;
--- a/Lib/IMPL/DOM/Schema/Validator/RegExp.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/DOM/Schema/Validator/RegExp.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ package IMPL::DOM::Schema::Validator::RegExp; -use base qw(IMPL::DOM::Schema::Validator); +use parent qw(IMPL::DOM::Schema::Validator); our %CTOR = ( 'IMPL::DOM::Schema::Validator' => sub {
--- a/Lib/IMPL/Exception.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Exception.pm Sat Apr 23 23:06:48 2011 +0400 @@ -10,7 +10,7 @@ require Error; } -use base qw(IMPL::Object::Accessor Error); +use parent qw(IMPL::Object::Accessor Error); BEGIN { __PACKAGE__->mk_accessors( qw(Message Args CallStack Source) );
--- a/Lib/IMPL/Object.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Object.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ package IMPL::Object; use strict; -use base qw(IMPL::Object::Abstract); +use parent qw(IMPL::Object::Abstract); sub surrogate { bless {}, ref $_[0] || $_[0]; @@ -30,7 +30,7 @@ =begin code package Foo; -use base qw(IMPL::Object); +use parent qw(IMPL::Object); sub CTOR { my ($this,$arg) = @_; @@ -38,7 +38,7 @@ } package Bar; -use base qw(IMPL::Object); +use parent qw(IMPL::Object); sub CTOR { my ($this,$arg) = @_; @@ -46,7 +46,7 @@ } package Baz; -use base qw(Foo Bar); +use parent qw(Foo Bar); our %CTOR = ( Foo => sub { my %args = @_; $args{Mazzi}; }, @@ -54,7 +54,7 @@ ); package Composite; -use base qw(Baz Foo Bar); +use parent qw(Baz Foo Bar); our %CTOR = ( Foo => undef, @@ -104,7 +104,7 @@ =head1 Cavearts -Нужно заметить, что директива C<use base> работает не совсем прозрачно, если в нашем примере +Нужно заметить, что директива C<use parent> работает не совсем прозрачно, если в нашем примере класс C<Composite> наследуется от C<Baz>, а затем C<Foo>, то наследование от C<Foo> не произойдет поскольку он уже имеется в C<Baz>. Вот не задача:)
--- a/Lib/IMPL/Object/Clonable.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Object/Clonable.pm Sat Apr 23 23:06:48 2011 +0400 @@ -3,7 +3,7 @@ use Storable qw(dclone); -sub clone { +sub Clone { dclone($_[0]); }
--- a/Lib/IMPL/SQL/Schema.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/SQL/Schema.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,12 +1,15 @@ use strict; package IMPL::SQL::Schema; -use base qw( +use IMPL::_core::version; +use IMPL::lang; +use parent qw( IMPL::Object IMPL::Object::Disposable IMPL::Object::Autofill IMPL::Object::Clonable ); + use IMPL::Class::Property; use IMPL::Class::Property::Direct; @@ -15,36 +18,41 @@ __PACKAGE__->PassThroughArgs; BEGIN { - public _direct property Version => prop_get; - public _direct property Name => prop_get; - public _direct property Tables => prop_get; + public _direct property version => prop_get; + public _direct property name => prop_get; + private _direct property tables => prop_get; } sub AddTable { my ($this,$table) = @_; if (UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table')) { + $table->Schema == $this or die new IMPL::InvalidOperationException('The specified table must belong to the database'); - not exists $this->{$Tables}->{$table->Name} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); + not exists $this->{$tables}->{$table->name} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); + } elsif (UNIVERSAL::isa($table,'HASH')) { - not exists $this->{$Tables}->{$table->{'Name'}} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); - $table->{'Schema'} = $this; + + not exists $this->{$tables}->{$table->{'name'}} or die new IMPL::InvalidOperationException('a table with the same name already exists in the database'); + $table = { %$table }; + $table->{'schema'} = $this; $table = new IMPL::SQL::Schema::Table(%{$table}); } else { die new IMPL::InvalidArgumentException('Either a table object or a hash with table parameters is required'); } - $this->{$Tables}{$table->Name} = $table; + $this->{$tables}{$table->name} = $table; } sub RemoveTable { my ($this,$table) = @_; - my $tn = UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table') ? $table->Name : $table; - $table = delete $this->{$Tables}{$tn} or die new IMPL::InvalidArgumentException('The table doesn\'t exists',$tn); + my $tn = UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table') ? $table->name : $table; + + $table = delete $this->{$tables}{$tn} or die new IMPL::InvalidArgumentException('The table doesn\'t exists',$tn); # drop foreign keys - map { $_->Table->RemoveConstraint($_) } values %{$table->PrimaryKey->ConnectedFK} if $table->PrimaryKey; + map { $_->table->RemoveConstraint($_) } values %{$table->primaryKey->connectedFK} if $table->primaryKey; # drop table contents $table->Dispose(); @@ -55,26 +63,41 @@ sub ResolveTable { my ($this,$table) = @_; - UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table') ? $table : $this->{$Tables}{$table}; + UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table') ? $table : $this->{$tables}{$table}; +} + +sub Table { + goto &GetTable; } sub GetTable { my ($this,$tableName) = @_; - return $this->{$Tables}{$tableName}; + return $this->{$tables}{$tableName}; +} + +sub GetTables { + my ($this) = @_; + + return wantarray ? values %{$this->{$tables}} : [values %{$this->{$tables}}]; } sub RenameTable { my ($this,$oldName,$newName) = @_; + die new IMPL::InvalidOperationException("A source table doesn't exists", $oldName) unless exists $this->{$tables}{$oldName}; + die new IMPL::InvalidOperationException("A target table already exists", $newName) if exists $this->{$tables}{$newName}; + my $table = delete $this->{$tables}{$oldName}; + $table->_setName($newName); + $this->{$tables}{$newName} = $table; } sub Dispose { my ($this) = @_; - $_->Dispose foreach values %{$this->{$Tables}}; + $_->Dispose foreach values %{$this->{$tables}}; - delete $this->{$Tables}; + delete $this->{$tables}; $this->SUPER::Dispose; } @@ -84,7 +107,7 @@ __END__ =pod -=head1 SINOPSYS +=head1 SYNOPSIS =begin code @@ -93,15 +116,15 @@ my $dbSchema = new IMPL::SQL::Schema; -my $tbl = $dbSchema->AddTable({Name => 'Person' }); +my $tbl = $dbSchema->AddTable({name => 'Person' }); $tbl->AddColumn({ - Name => 'FirstName', - CanBeNull => 1, - Type => Varchar(255) + name => 'FirstName', + canBeNull => 1, + type => Varchar(255) }); $tbl->AddColumn({ - Name => 'Age', - Type => Integer + name => 'Age', + type => Integer }); # so on @@ -117,6 +140,51 @@ Схема реляциоонной базы данных, орентированная на язык SQL, содержит описания таблиц которые являются частью базы. Позволяет создавать и удалать таблицы. -Имея две схемы можно создавать скрипты для примениения изменений схемы данных C<<IMPL::SQL::Traits>> +=head1 MEMBERS + +=over + +=item C<CTOR(%props)> + +Конструктор заполняет объект свойствами из C<props>. + +=item C<[get]name> + +Имя схемы. + +=item C<[get]version> + +Версия схемы. + +=item C<AddTable($table)> + +Доавляет таблицу в схему. C<$table> может быть либо таблице, либо хешем с набором +свойств для создания новой таблицы. Если таблица с таким именем уже существует в сехеме, +то вызывается исключение. + +=item C<GetTable($name)> + +Возвращает таблицу с именем C<$name> или C<undef>. + +=item C<GetTables()> + +Возвращает список таблиц. В скалярном контексте - ссылку на массив с таблицами. + +=item C<ResolveTable($table)> + +Если параметр C<$table> - таблица, то возвращается C<$table>, если C<$table> строка, то +ищется таблица с таким именем, если таблица не найдена, возвращается C<undef>. + +=item C<RenameTable($oldName,$newName)> + +Происходит переименование таблицы. Если C<$oldName> не существует, либо если C<$newName> +существует, вызывается исключение. + +=item C<RemoveTable($table)> + +Удаляется таблица C<$table> с удалением всех связей и ограничений. Если такой таблицы нет, +то вызывается исключение. C<$table> может быть либо именем таблицы, либо объектом. + +=back =cut
--- a/Lib/IMPL/SQL/Schema/Column.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/SQL/Schema/Column.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,16 +1,16 @@ use strict; package IMPL::SQL::Schema::Column; -use base qw(IMPL::Object IMPL::Object::Autofill IMPL::Object::Clonable); +use parent qw(IMPL::Object IMPL::Object::Autofill); use IMPL::Class::Property; use IMPL::Class::Property::Direct; BEGIN { - public _direct property Name => prop_get; - public _direct property Type => prop_get; - public _direct property CanBeNull => prop_get; - public _direct property DefaultValue => prop_get; - public _direct property Tag => prop_get; + public _direct property name => prop_get; + public _direct property type => prop_get; + public _direct property isNullable => prop_get; + public _direct property defaultValue => prop_get; + public _direct property tag => prop_get; } __PACKAGE__->PassThroughArgs; @@ -18,9 +18,9 @@ sub CTOR { my $this = shift; - $this->{$Name} or die new IMPL::InvalidArgumentException('a column name is required'); - $this->{$CanBeNull} = 0 if not exists $this->{$CanBeNull}; - UNIVERSAL::isa($this->{$Type},'IMPL::SQL::Schema::Type') or die new IMPL::InvalidArgumentException('a type is required for the column',$this->{$Name}); + $this->{$name} or die new IMPL::InvalidArgumentException('a column name is required'); + $this->{$isNullable} = 0 if not exists $this->{$isNullable}; + UNIVERSAL::isa($this->{$type},'IMPL::SQL::Schema::Type') or die new IMPL::InvalidArgumentException('a type is required for the column',$this->{$name}); } sub isEqualsStr { @@ -54,7 +54,7 @@ sub isSame { my ($this,$other) = @_; - return ($this->{$Name} eq $other->{$Name} and $this->{$CanBeNull} == $other->{$CanBeNull} and isEqualsStr($this->{$DefaultValue}, $other->{$DefaultValue}) and $this->{$Type}->isSame($other->{$Type})); + return ($this->{$name} eq $other->{$name} and $this->{$isNullable} == $other->{$isNullable} and isEqualsStr($this->{$defaultValue}, $other->{$defaultValue}) and $this->{$type}->isSame($other->{$type})); } 1;
--- a/Lib/IMPL/SQL/Schema/Constraint.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/SQL/Schema/Constraint.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,31 +1,31 @@ use strict; package IMPL::SQL::Schema::Constraint; -use base qw(IMPL::Object IMPL::Object::Disposable IMPL::Object::Clonable); +use parent qw(IMPL::Object IMPL::Object::Disposable); use IMPL::Class::Property; use IMPL::Class::Property::Direct; BEGIN { - public _direct property Name => prop_get; - public _direct property Table => prop_get; - public _direct property Columns => prop_get; + public _direct property name => prop_get; + public _direct property table => prop_get; + public _direct property columns => prop_get; } sub CTOR { my ($this,%args) = @_; - die new IMPL::InvalidArgumentException("The table argument must be an instance of a table object") if not UNIVERSAL::isa($args{'Table'},'IMPL::SQL::Schema::Table'); - $this->{$Name} = $args{'Name'}; - $this->{$Table} = $args{'Table'}; - $this->{$Columns} = [map { ResolveColumn($this->Table,$_) } @{$args{'Columns'}}]; + die new IMPL::InvalidArgumentException("The table argument must be an instance of a table object") if not UNIVERSAL::isa($args{'table'},'IMPL::SQL::Schema::Table'); + $this->{$name} = $args{'name'}; + $this->{$table} = $args{'table'}; + $this->{$columns} = [map { ResolveColumn($this->table,$_) } @{$args{'columns'}}]; } sub ResolveColumn { my ($Table,$Column) = @_; - my $cn = UNIVERSAL::isa($Column,'IMPL::SQL::Schema::Column') ? $Column->Name : $Column; + my $cn = UNIVERSAL::isa($Column,'IMPL::SQL::Schema::Column') ? $Column->name : $Column; my $resolved = $Table->Column($cn); - die new IMPL::InvalidOperationException("The column is not found in the table", $cn, $Table->Name) if not $resolved; + die new IMPL::InvalidOperationException("The column is not found in the table", $cn, $Table->name) if not $resolved; return $resolved; } @@ -34,18 +34,18 @@ my %Columns = map { $_, 1} @Columns; - return scalar(grep { $Columns{$_->Name} } @{$this->Columns}) == scalar(@Columns); + return scalar(grep { $Columns{$_->name} } @{$this->columns}) == scalar(@Columns); } -sub UniqName { +sub uniqName { my ($this) = @_; - return $this->{$Table}->Name.'_'.$this->{$Name}; + return $this->{$table}->name.'_'.$this->{$name}; } sub Dispose { my ($this) = @_; - delete @$this{$Table,$Columns}; + delete @$this{$table,$columns}; $this->SUPER::Dispose; } 1;
--- a/Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,11 +1,11 @@ package IMPL::SQL::Schema::Constraint::ForeignKey; use strict; -use base qw(IMPL::SQL::Schema::Constraint); +use parent qw(IMPL::SQL::Schema::Constraint); use IMPL::Class::Property; use IMPL::Class::Property::Direct; BEGIN { - public _direct property ReferencedPrimaryKey => prop_get; + public _direct property referencedPrimaryKey => prop_get; public _direct property OnDelete => prop_get; public _direct property OnUpdate => prop_get; } @@ -15,22 +15,22 @@ sub CTOR { my ($this,%args) = @_; - die new Eexception("Referenced table must be an instance of a table object") if not UNIVERSAL::isa($args{'ReferencedTable'},'IMPL::SQL::Schema::Table'); + die new Eexception("Referenced table must be an instance of a table object") if not UNIVERSAL::isa($args{'referencedTable'},'IMPL::SQL::Schema::Table'); - die new Exception("Referenced columns must be a not empty list of columns") if not UNIVERSAL::isa($args{'ReferencedColumns'},'ARRAY') or not scalar(@{$args{'ReferencedColumns'}}); + die new Exception("Referenced columns must be a not empty list of columns") if not UNIVERSAL::isa($args{'referencedColumns'},'ARRAY') or not scalar(@{$args{'referencedColumns'}}); - my @ReferencedColumns = map {IMPL::SQL::Schema::Constraint::ResolveColumn($args{'ReferencedTable'},$_)} @{$args{'ReferencedColumns'}}; - my $ForeingPK = $args{'ReferencedTable'}->PrimaryKey or die new Exception('The referenced table doesn\'t have a primary key'); + my @ReferencedColumns = map {IMPL::SQL::Schema::Constraint::ResolveColumn($args{'referencedTable'},$_)} @{$args{'referencedColumns'}}; + my $ForeingPK = $args{'referencedTable'}->primaryKey or die new Exception('The referenced table doesn\'t have a primary key'); - scalar (@ReferencedColumns) == scalar(@{$this->Columns}) or die new Exception('A foreing key columns doesn\'t match refenced columns'); + scalar (@ReferencedColumns) == scalar(@{$this->columns}) or die new Exception('A foreing key columns doesn\'t match refenced columns'); my @ColumnsCopy = @ReferencedColumns; - die new Exception('A foreing key columns doesn\'t match refenced columns') if grep { not $_->Type->isSame((shift @ColumnsCopy)->Type)} @{$this->Columns}; + die new Exception('A foreing key columns doesn\'t match refenced columns') if grep { not $_->type->isSame((shift @ColumnsCopy)->type)} @{$this->columns}; @ColumnsCopy = @ReferencedColumns; - die new Exception('The foreign key must match to the primary key of the referenced table',$this->Name) if grep { not $_->Type->isSame(shift(@ColumnsCopy)->Type)} @{$ForeingPK->Columns}; + die new Exception('The foreign key must match to the primary key of the referenced table',$this->name) if grep { not $_->type->isSame(shift(@ColumnsCopy)->type)} @{$ForeingPK->columns}; - $this->{$ReferencedPrimaryKey} = $ForeingPK; + $this->{$referencedPrimaryKey} = $ForeingPK; $ForeingPK->ConnectFK($this); } @@ -38,8 +38,8 @@ sub Dispose { my ($this) = @_; - $this->{$ReferencedPrimaryKey}->DisconnectFK($this) if not $this->{$ReferencedPrimaryKey}->isDisposed; - delete $this->{$ReferencedPrimaryKey}; + $this->{$referencedPrimaryKey}->DisconnectFK($this) if not $this->{$referencedPrimaryKey}->isDisposed; + delete $this->{$referencedPrimaryKey}; $this->SUPER::Dispose; }
--- a/Lib/IMPL/SQL/Schema/Constraint/Index.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/SQL/Schema/Constraint/Index.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ package IMPL::SQL::Schema::Constraint::Index; use strict; -use base qw(IMPL::SQL::Schema::Constraint); +use parent qw(IMPL::SQL::Schema::Constraint); __PACKAGE__->PassThroughArgs; @@ -8,7 +8,7 @@ my $this = shift; my %colnames; - not grep { $colnames{$_}++ } @{$this->Columns} or die new Exception('Each column in the index can occur only once'); + not grep { $colnames{$_}++ } @{$this->columns} or die new Exception('Each column in the index can occur only once'); } 1;
--- a/Lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/SQL/Schema/Constraint/PrimaryKey.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,42 +1,41 @@ package IMPL::SQL::Schema::Constraint::PrimaryKey; use strict; -use base qw(IMPL::SQL::Schema::Constraint::Index); +use parent qw(IMPL::SQL::Schema::Constraint::Index); use IMPL::Class::Property; use IMPL::Class::Property::Direct; __PACKAGE__->PassThroughArgs; BEGIN { - public _direct property ConnectedFK => prop_get; + public _direct property connectedFK => prop_get; } sub CTOR { my ($this,%args) = @_; - $this->SUPER::CTOR(%args); - - $this->{$ConnectedFK} = {}; + $this->{$connectedFK} = {}; } sub ConnectFK { my ($this,$FK) = @_; UNIVERSAL::isa($FK,'IMPL::SQL::Schema::Constraint::ForeignKey') or die new Exception('Aprimary key could be connected only to a foreign key'); - not exists $this->{$ConnectedFK}->{$FK->UniqName} or die new Exception('This primary key already conneted with the specified foreing key',$FK->Name,$FK->Table->Name); + not exists $this->{$connectedFK}->{$FK->uniqName} or die new Exception('This primary key already conneted with the specified foreing key',$FK->name,$FK->table->name); - $this->{$ConnectedFK}->{$FK->UniqName} = $FK; + $this->{$connectedFK}->{$FK->uniqName} = $FK; } sub DisconnectFK { my ($this,$FK) = @_; - delete $this->{$ConnectedFK}->{$FK->UniqName}; + delete $this->{$connectedFK}->{$FK->uniqName}; } sub Dispose { my ($this) = @_; - delete $this->{$ConnectedFK}; + delete $this->{$connectedFK}; + $this->SUPER::Dispose; }
--- a/Lib/IMPL/SQL/Schema/Table.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/SQL/Schema/Table.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,42 +1,56 @@ use strict; package IMPL::SQL::Schema::Table; -use IMPL::SQL::Schema::Column; -use IMPL::SQL::Schema::Constraint; -use IMPL::SQL::Schema::Constraint::PrimaryKey; -use IMPL::SQL::Schema::Constraint::ForeignKey; +use IMPL::lang; -use base qw( +use parent qw( IMPL::Object IMPL::Object::Disposable - IMPL::Object::Clonable ); + +use IMPL::SQL::Schema::Column(); +use IMPL::SQL::Schema::Constraint(); +use IMPL::SQL::Schema::Constraint::PrimaryKey(); +use IMPL::SQL::Schema::Constraint::ForeignKey(); + use IMPL::Class::Property; use IMPL::Class::Property::Direct; BEGIN { - public _direct property Name => prop_get; - public _direct property Schema => prop_get; - public _direct property Columns => prop_get; - public _direct property Constraints => prop_get; - public _direct property ColumnsByName => prop_none; - public _direct property PrimaryKey => prop_get; - public _direct property Tag => prop_all; + public _direct property name => prop_get; + public _direct property schema => prop_get; + public _direct property columns => prop_get; + public _direct property constraints => prop_get; + public _direct property columnsByName => prop_none; + public _direct property primaryKey => prop_get; + public _direct property tag => prop_all; } sub CTOR { my ($this,%args) = @_; - $this->{$Name} = $args{'Name'} or die new IMPL::InvalidArgumentException('a table name is required'); - $this->{$Schema} = $args{'Schema'} or die new IMPL::InvalidArgumentException('a parent schema is required'); + $this->{$name} = $args{'name'} or die new IMPL::InvalidArgumentException('a table name is required'); + $this->{$schema} = $args{'schema'} or die new IMPL::InvalidArgumentException('a parent schema is required'); + + if ($args{columns}) { + die new IMPL::InvalidOperationException('A columns property should be a reference to an array') unless ref $args{columns} eq 'ARRAY'; + + $this->InsertColumn($_) foreach @{$args{columns}}; + } + + if ($args{constraints}) { + die new IMPL::InvalidOperationException('A constraints property should be a reference to an array') unless ref $args{constraints} eq 'ARRAY'; + + $this->AddConstraint($_) foreach @{$args{constraints}}; + } } sub InsertColumn { my ($this,$column,$index) = @_; - $index = ($this->{$Columns} ? scalar(@{$this->{$Columns}}) : 0) if not defined $index; + $index = ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0) if not defined $index; - die new IMPL::InvalidArgumentException("The index is out of range") if ($index < 0 || $index > ($this->{$Columns} ? scalar(@{$this->{$Columns}}) : 0)); + die new IMPL::InvalidArgumentException("The index is out of range") if ($index < 0 || $index > ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0)); if (UNIVERSAL::isa($column,'IMPL::SQL::Schema::Column')) { @@ -46,11 +60,11 @@ die new IMPL::InvalidArgumentException("The invalid column parameter"); } - if (exists $this->{$ColumnsByName}->{$column->Name}) { + if (exists $this->{$columnsByName}->{$column->name}) { die new IMPL::InvalidOperationException("The column already exists",$column->name); } else { - $this->{$ColumnsByName}->{$column->Name} = $column; - splice @{$this->{$Columns}},$index,0,$column; + $this->{$columnsByName}->{$column->name} = $column; + splice @{$this->{$columns}},$index,0,$column; } return $column; @@ -61,110 +75,129 @@ my $ColName; if (UNIVERSAL::isa($NameOrColumn,'IMPL::SQL::Schema::Column')) { - $ColName = $NameOrColumn->Name; + $ColName = $NameOrColumn->name; } elsif (not ref $NameOrColumn) { $ColName = $NameOrColumn; } - if (exists $this->{$ColumnsByName}->{$ColName}) { + if (exists $this->{$columnsByName}->{$ColName}) { my $index = 0; - foreach my $column(@{$this->{$Columns}}) { - last if $column->Name eq $ColName; + foreach my $column(@{$this->{$columns}}) { + last if $column->name eq $ColName; $index++; } - my $column = $this->{$Columns}[$index]; + my $column = $this->{$columns}[$index]; if (my @constraints = $this->GetColumnConstraints($column)){ $Force or die new IMPL::InvalidOperationException('Can\'t remove column which is used in the constraints',@constraints); $this->RemoveConstraint($_) foreach @constraints; } - my $removed = splice @{$this->{$Columns}},$index,1; - delete $this->{$ColumnsByName}->{$ColName}; + my $removed = splice @{$this->{$columns}},$index,1; + delete $this->{$columnsByName}->{$ColName}; return $removed; } else { - die new IMPL::InvalidOperationException("The column not found",$NameOrColumn->Name); + die new IMPL::InvalidOperationException("The column not found",$NameOrColumn->name); } } sub Column { my ($this,$name) = @_; - return $this->{$ColumnsByName}->{$name}; + return $this->{$columnsByName}->{$name}; } sub ColumnAt { my ($this,$index) = @_; - die new IMPL::InvalidArgumentException("The index is out of range") if $index < 0 || $index >= ($this->{$Columns} ? scalar(@{$this->{$Columns}}) : 0); + die new IMPL::InvalidArgumentException("The index is out of range") + if $index < 0 || $index >= ($this->{$columns} ? scalar(@{$this->{$columns}}) : 0); - return $this->{$Columns}[$index]; + return $this->{$columns}[$index]; +} + +sub ColumnsCount { + my ($this) = @_; + + return scalar(@{$this->{$columns}}); } sub AddConstraint { my ($this,$Constraint) = @_; - die new IMPL::InvalidArgumentException('The invalid parameter') if not UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint'); + if (ref $Constraint eq 'HASH') { + $Constraint = new IMPL::SQL::Schema::Constraint( %$Constraint, table => $this ); + } else { + die new IMPL::InvalidArgumentException('The invalid parameter') if not is($Constraint,typeof IMPL::SQL::Schema::Constraint); + } - $Constraint->Table == $this or die new IMPL::InvalidOperationException('The constaint must belong to the target table'); + $Constraint->table == $this or die new IMPL::InvalidOperationException('The constaint must belong to the target table'); - if (exists $this->{$Constraints}->{$Constraint->Name}) { - die new IMPL::InvalidOperationException('The table already has the specified constraint',$Constraint->Name); + if (exists $this->{$constraints}->{$Constraint->name}) { + die new IMPL::InvalidOperationException('The table already has the specified constraint',$Constraint->name); } else { if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { - not $this->{$PrimaryKey} or die new IMPL::InvalidOperationException('The table already has a primary key'); - $this->{$PrimaryKey} = $Constraint; + not $this->{$primaryKey} or die new IMPL::InvalidOperationException('The table already has a primary key'); + $this->{$primaryKey} = $Constraint; } - $this->{$Constraints}->{$Constraint->Name} = $Constraint; + $this->{$constraints}->{$Constraint->name} = $Constraint; } } sub RemoveConstraint { my ($this,$Constraint,$Force) = @_; - my $cn = UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint') ? $Constraint->Name : $Constraint; - $Constraint = $this->{$Constraints}->{$cn} or die new IMPL::InvalidOperationException('The specified constraint doesn\'t exists',$cn); + my $cn = UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint') ? $Constraint->name : $Constraint; + $Constraint = $this->{$constraints}->{$cn} or die new IMPL::InvalidOperationException('The specified constraint doesn\'t exists',$cn); if (UNIVERSAL::isa($Constraint,'IMPL::SQL::Schema::Constraint::PrimaryKey')) { - not scalar keys %{$this->{$PrimaryKey}->ConnectedFK} or die new IMPL::InvalidOperationException('Can\'t remove Primary Key unless some foreign keys referenses it'); + not scalar keys %{$this->{$primaryKey}->ConnectedFK} or die new IMPL::InvalidOperationException('Can\'t remove Primary Key unless some foreign keys referenses it'); - delete $this->{$PrimaryKey}; + delete $this->{$primaryKey}; } $Constraint->Dispose; - delete $this->{$Constraints}->{$cn}; + delete $this->{$constraints}->{$cn}; return $cn; } +sub GetConstraint { + my ($this,$name) = @_; + + return $this->{$constraints}{$name}; +} + sub GetColumnConstraints { my ($this,@Columns) = @_; - my @cn = map { UNIVERSAL::isa($_ ,'IMPL::SQL::Schema::Column') ? $_ ->Name : $_ } @Columns; - exists $this->{$ColumnsByName}->{$_} or die new IMPL::InvalidOperationException('The specified column isn\'t found',$_) foreach @cn; + my @cn = map { UNIVERSAL::isa($_ ,'IMPL::SQL::Schema::Column') ? $_ ->name : $_ } @Columns; + exists $this->{$columnsByName}->{$_} or die new IMPL::InvalidOperationException('The specified column isn\'t found',$_) foreach @cn; - return grep {$_->HasColumn(@cn)} values %{$this->{$Constraints}}; + return grep {$_->HasColumn(@cn)} values %{$this->{$constraints}}; } sub SetPrimaryKey { my ($this,@ColumnList) = @_; - $this->AddConstraint(new IMPL::SQL::Schema::Constraint::PrimaryKey(Name => $this->{$Name}.'_PK', Table => $this,Columns => \@ColumnList)); + $this->AddConstraint(new IMPL::SQL::Schema::Constraint::PrimaryKey(name => $this->{$name}.'_PK', table => $this, columns => \@ColumnList)); } sub LinkTo { my ($this,$table,@ColumnList) = @_; - $table->PrimaryKey or die new IMPL::InvalidOperationException('The referenced table must have a primary key'); - my $constraintName = $this->{$Name}.'_'.$table->Name.'_FK_'.join('_',map {ref $_ ? $_->Name : $_} @ColumnList); - $this->AddConstraint(new IMPL::SQL::Schema::Constraint::ForeignKey(Name => $constraintName, Table => $this,Columns => \@ColumnList, ReferencedTable => $table, ReferencedColumns => $table->PrimaryKey->Columns)); + $table->primaryKey or die new IMPL::InvalidOperationException('The referenced table must have a primary key'); + my $constraintName = $this->{$name}.'_'.$table->name.'_FK_'.join('_',map {ref $_ ? $_->name : $_} @ColumnList); + $this->AddConstraint(new IMPL::SQL::Schema::Constraint::ForeignKey(name => $constraintName, table => $this, columns => \@ColumnList, referencedTable => $table, referencedColumns => $table->primaryKey->columns)); } sub Dispose { my ($this) = @_; - $_->Dispose() foreach values %{$this->{$Constraints}}; + $_->Dispose() foreach values %{$this->{$constraints}}; undef %{$this}; $this->SUPER::Dispose(); } 1; + +
--- a/Lib/IMPL/SQL/Schema/Traits.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/SQL/Schema/Traits.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,14 +1,19 @@ -package IMPL::SQL::Traits; +package IMPL::SQL::Schema::Traits; use strict; use IMPL::_core::version; use IMPL::Exception(); -use IMPL::base qw(IMPL::Object); +use parent qw(IMPL::Object); +use IMPL::Code::Loader(); + +BEGIN { + IMPL::Code::Loader->Provide(__PACKAGE__); +} ################################################### -package IMPL::SQL::Traits::Table; -use IMPL::base qw(IMPL::Object::Fields); +package IMPL::SQL::Schema::Traits::Table; +use base qw(IMPL::Object::Fields); use fields qw( name @@ -20,16 +25,16 @@ sub CTOR { my ($this,$table,$columns,$constraints,$options) = @_; - $this->{name} = $table; - $this->{columns} = $columns; - $this->{constraints} = $constraints; - $this->{options} = $options; + $this->{name} = $table or die new IMPL::InvalidArgumentException(table => "A table name is required"); + $this->{columns} = $columns if defined $columns; + $this->{constraints} = $constraints if defined $constraints; + $this->{options} = $options if defined $options; } ################################################### -package IMPL::SQL::Traits::Column; -use IMPL::base qw(IMPL::Object::Fields); +package IMPL::SQL::Schema::Traits::Column; +use base qw(IMPL::Object::Fields); use fields qw( name @@ -51,8 +56,8 @@ ################################################## -package IMPL::SQL::Traits::Constraint; -use IMPL::base qw(IMPL::Object::Fields); +package IMPL::SQL::Schema::Traits::Constraint; +use base qw(IMPL::Object::Fields); use fields qw( name @@ -70,40 +75,40 @@ ################################################## -package IMPL::SQL::Traits::PrimaryKey; +package IMPL::SQL::Schema::Traits::PrimaryKey; -use IMPL::base qw(IMPL::SQL::Traits::Constraint); +use base qw(IMPL::SQL::Schema::Traits::Constraint); __PACKAGE__->PassThroughArgs; ################################################## -package IMPL::SQL::Traits::Index; +package IMPL::SQL::Schema::Traits::Index; -use IMPL::base qw(IMPL::SQL::Traits::Constraint); +use base qw(IMPL::SQL::Schema::Traits::Constraint); __PACKAGE__->PassThroughArgs; ################################################## -package IMPL::SQL::Traits::Unique; +package IMPL::SQL::Schema::Traits::Unique; -use IMPL::base qw(IMPL::SQL::Traits::Constraint); +use base qw(IMPL::SQL::Schema::Traits::Constraint); __PACKAGE__->PassThroughArgs; ################################################## -package IMPL::SQL::Traits::ForeignKey; +package IMPL::SQL::Schema::Traits::ForeignKey; -use IMPL::base qw(IMPL::SQL::Traits::Constraint); +use base qw(IMPL::SQL::Schema::Traits::Constraint); use fields qw( foreignTable foreignColumns ); our %CTOR = ( - 'IMPL::SQL::Traits::Constraint' => sub { @_[0..2] } + 'IMPL::SQL::Schema::Traits::Constraint' => sub { @_[0..2] } ); sub CTOR { @@ -116,9 +121,9 @@ ################################################## -package IMPL::SQL::Traits::CreateTable; +package IMPL::SQL::Schema::Traits::CreateTable; -use IMPL::base qw(IMPL::SQL::Traits); +use parent qw(-norequire IMPL::SQL::Schema::Traits); use IMPL::Class::Property; use IMPL::lang; @@ -129,8 +134,8 @@ sub CTOR { my ($this,$table) = @_; - die new IMPL::InvalidArgumentException("table", "An object of IMPL::SQL::Traits::Table type is required") - unless is $table, typeof IMPL::SQL::Traits::Table; + die new IMPL::InvalidArgumentException("table", "An object of IMPL::SQL::Schema::Traits::Table type is required") + unless is $table, typeof IMPL::SQL::Schema::Traits::Table; $this->table($table); } @@ -146,8 +151,8 @@ ################################################## -package IMPL::SQL::Traits::DropTable; -use IMPL::base qw(IMPL::SQL::Traits); +package IMPL::SQL::Schema::Traits::DropTable; +use parent qw(-norequire IMPL::SQL::Schema::Traits); use IMPL::Class::Property; BEGIN { @@ -172,8 +177,8 @@ ################################################## -package IMPL::SQL::Traits::RenameTable; -use IMPL::base qw(IMPL::SQL::Traits); +package IMPL::SQL::Schema::Traits::RenameTable; +use parent qw(-norequire IMPL::SQL::Schema::Traits); use IMPL::Class::Property; BEGIN { @@ -200,8 +205,8 @@ ################################################# -package IMPL::SQL::Traits::AlterTableAddColumn; -use IMPL::base qw(IMPL::SQL::Traits); +package IMPL::SQL::Schema::Traits::AlterTableAddColumn; +use parent qw(-norequire IMPL::SQL::Schema::Traits); use IMPL::Class::Property; use IMPL::lang; @@ -215,8 +220,8 @@ $this->tableName($tableName) or die new IMPL::InvalidArgumentException("A table name is required"); - die new IMPL::InvalidArgumentException("A column should be a IMPL::SQL::Traits::Column object") - unless is $column, typeof IMPL::SQL::Traits::Column; + die new IMPL::InvalidArgumentException("A column should be a IMPL::SQL::Schema::Traits::Column object") + unless is $column, typeof IMPL::SQL::Schema::Traits::Column; $this->column($column); } @@ -235,8 +240,8 @@ ################################################# -package IMPL::SQL::Traits::AlterTableDropColumn; -use IMPL::base qw(IMPL::SQL::Traits); +package IMPL::SQL::Schema::Traits::AlterTableDropColumn; +use parent qw(-norequire IMPL::SQL::Schema::Traits); use IMPL::Class::Property; BEGIN { @@ -264,8 +269,8 @@ ################################################# -package IMPL::SQL::Traits::AlterTableChangeColumn; -use IMPL::base qw(IMPL::SQL::Traits); +package IMPL::SQL::Schema::Traits::AlterTableChangeColumn; +use parent qw(-norequire IMPL::SQL::Schema::Traits); use IMPL::Class::Property; BEGIN { @@ -305,8 +310,8 @@ ################################################# -package IMPL::SQL::Traits::AlterTableAddConstraint; -use IMPL::base qw(IMPL::SQL::Traits); +package IMPL::SQL::Schema::Traits::AlterTableAddConstraint; +use parent qw(-norequire IMPL::SQL::Schema::Traits); use IMPL::Class::Property; use IMPL::lang; @@ -320,8 +325,8 @@ $this->tableName($table) or die new IMPL::InvalidArgumentException( tableName => "A table name is required"); - die new IMPL::InvalidArgumentException(constaraint => "A valid IMPL::SQL::Traits::Constarint is required") - unless is $constraint, typeof IMPL::SQL::Traits::Constraint; + die new IMPL::InvalidArgumentException(constaraint => "A valid IMPL::SQL::Schema::Traits::Constarint is required") + unless is $constraint, typeof IMPL::SQL::Schema::Traits::Constraint; $this->constraint($constraint); } @@ -340,8 +345,8 @@ ################################################# -package IMPL::SQL::Traits::AlterTableDropConstraint; -use IMPL::base qw(IMPL::SQL::Traits); +package IMPL::SQL::Schema::Traits::AlterTableDropConstraint; +use parent qw(-norequire IMPL::SQL::Schema::Traits); use IMPL::Class::Property; BEGIN { @@ -382,7 +387,7 @@ Изменения схемы могу быть представлены в виде последовательности примитивных операций. Правила выполнения последовательности примитывных действий могут варьироваться -в зависимости от процессора, который их выполняет. Например C<IMPL::SQL::Traits::Processor>. +в зависимости от процессора, который их выполняет. Например C<IMPL::SQL::Schema::Traits::Processor>. Данные, которые содержаться в примитивных операциях не могут существовать независимо от схемы. @@ -418,7 +423,7 @@ =over -=item C<IMPL::SQL::Traits::CreateTable> +=item C<IMPL::SQL::Schema::Traits::CreateTable> Создает таблицу @@ -428,11 +433,11 @@ =item C<[get]table> -C<IMPL::SQL::Traits::Table> - описание создаваемой таблицы +C<IMPL::SQL::Schema::Traits::Table> - описание создаваемой таблицы =back -=item C<IMPL::SQL::Traits::DropTable> +=item C<IMPL::SQL::Schema::Traits::DropTable> Удалает таблицу по имени @@ -446,7 +451,7 @@ =back -=item C<IMPL::SQL::Traits::RenameTable> +=item C<IMPL::SQL::Schema::Traits::RenameTable> =over @@ -462,7 +467,7 @@ =back -=item C<IMPL::SQL::Traits::AlterTableAddColumn> +=item C<IMPL::SQL::Schema::Traits::AlterTableAddColumn> Добавляет столбец в таблицу @@ -476,11 +481,11 @@ =item C<[get]column> -C<IMPL::SQL::Traits::Column> - описание столбца который нужно добавить +C<IMPL::SQL::Schema::Traits::Column> - описание столбца который нужно добавить =back -=item C<IMPL::SQL::Traits::AlterTableDropColumn> +=item C<IMPL::SQL::Schema::Traits::AlterTableDropColumn> Удаляет столбец из таблицы @@ -498,7 +503,7 @@ =back -=item C<IMPL::SQL::Traits::AlterTableChangeColumn> +=item C<IMPL::SQL::Schema::Traits::AlterTableChangeColumn> Меняет описание столбца @@ -534,7 +539,7 @@ =back -=item C<IMPL::SQL::Traits::AlterTableAddConstraint> +=item C<IMPL::SQL::Schema::Traits::AlterTableAddConstraint> Базовый класс для операций по добавлению ограничений @@ -548,11 +553,11 @@ =item C<[get]constraint> -C<IMPL::SQL::Traits::Constraint> - описние ограничения, которое нужно добавить. +C<IMPL::SQL::Schema::Traits::Constraint> - описние ограничения, которое нужно добавить. =back -=item C<IMPL::SQL::Traits::AlterTableDropConstraint> +=item C<IMPL::SQL::Schema::Traits::AlterTableDropConstraint> Удаляет ограничение на таблицу
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/SQL/Schema/Traits/Diff.pm Sat Apr 23 23:06:48 2011 +0400 @@ -0,0 +1,35 @@ +package IMPL::SQL::Schema::Traits::Diff; +use strict; +use warnings; +use IMPL::lang; + +use IMPL::SQL::Schema(); +use IMPL::SQL::Schema::Traits(); + +use constant { + schema_t => typeof IMPL::SQL::Schema # defining a constant is a good style to enable compile checks +}; + +sub Diff { + my ($self,$src,$dst) = @_; + + die new IMPL::InvalidArgumentException( src => "A valid source schema is required") unless is($src,schema_t); + die new IMPL::InvalidArgumentException( dst => "A valid desctination schema is requried" ) unless is($src,schema_t); + + my %dstTables = map { $_->name, $_ } $dst->GetTables; + + my @operations; + + foreach my $srcTable ( $src->GetTables) { + my $dstTable = delete $dstTables{$srcTable->name}; + + if (not $dstTable) { + push @operations, new IMPL::SQL::Schema::Traits::DropTable() + } else { + + } + + } +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/SQL/Schema/Traits/Formatter.pm Sat Apr 23 23:06:48 2011 +0400 @@ -0,0 +1,9 @@ +package IMPL::SQL::Traits::Formatter; +use parent qw(IMPL::Object); + +sub ToSQL { + my ($this,$sequence) = @_; +} + + +1; \ No newline at end of file
--- a/Lib/IMPL/SQL/Schema/Traits/mysql.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/SQL/Schema/Traits/mysql.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,6 +1,6 @@ package IMPL::SQL::Schema::Traits::mysql::Handler; use strict; -use base qw(IMPL::Object); +use parent qw(IMPL::Object); use IMPL::Class::Property; use IMPL::Class::Property::Direct; @@ -469,7 +469,7 @@ package IMPL::SQL::Schema::Traits::mysql; use Common; -use base qw(IMPL::SQL::Schema::Traits); +use parent qw(IMPL::SQL::Schema::Traits); use IMPL::Class::Property; use IMPL::Class::Property::Direct; @@ -513,7 +513,7 @@ package IMPL::SQL::Schema::Traits::mysql::MetaTable; use Common; -use base qw(IMPL::Object); +use parent qw(IMPL::Object); use IMPL::Class::Property; use IMPL::Class::Property::Direct;
--- a/Lib/IMPL/SQL/Schema/Type.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/SQL/Schema/Type.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,16 +1,16 @@ use strict; package IMPL::SQL::Schema::Type; -use base qw(IMPL::Object IMPL::Object::Autofill); +use parent qw(IMPL::Object IMPL::Object::Autofill); use IMPL::Class::Property; use IMPL::Class::Property::Direct; BEGIN { - public _direct property Name => prop_get; - public _direct property MaxLength => prop_get; - public _direct property Scale => prop_get; - public _direct property Unsigned => prop_get; - public _direct property Zerofill => prop_get; - public _direct property Tag => prop_get; + public _direct property name => prop_get; + public _direct property maxLength => prop_get; + public _direct property scale => prop_get; + public _direct property unsigned => prop_get; + public _direct property zerofill => prop_get; + public _direct property tag => prop_get; } __PACKAGE__->PassThroughArgs; @@ -18,7 +18,7 @@ sub CTOR { my $this = shift; - $this->{$Scale} = 0 if not $this->{$Scale}; + $this->{$scale} = 0 if not $this->{$scale}; } sub isEquals { @@ -38,7 +38,67 @@ sub isSame { my ($this,$other) = @_; - return ($this->{$Name} eq $other->{$Name} and isEquals($this->{$MaxLength},$other->{$MaxLength}) and isEquals($this->{$Scale},$other->{$Scale})); + return ($this->{$name} eq $other->{$name} and isEquals($this->{$maxLength},$other->{$maxLength}) and isEquals($this->{$scale},$other->{$scale})); } 1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::SQL::Schema::Type> Описывает SQL типы данных + +=head1 SYNOPSIS + +=begin code + +use IMPL::SQL::Schema::Type; + +my $varchar_t = new IMPL::SQL::Schema::Type( name => 'varchar', maxLength => 255 ); + +my $real_t = new IMPL::SQL::Schema::Type( name => 'float', maxLength=> 10, scale => 4); # mysql: float(10,4) + +=end + +Данный класс используется для стандатрного описания SQL типов данных. В зависимости +от движка БД эти объекты могут быть представлены различными строковыми представлениями. + +=head1 MEMBERS + +=over + +=item C<CTOR(%props)> + +Конструктор, заполняет объект значениями которые были переданы в конструкторе. + +=item C<[get]name> + +Имя типа. Обязательно. + +=item C<[get]maxLength> + +Максимальная длина, используется только для типов, имеющих длину (либо переменную, +либо постоянную). + +=item C<[get]scale> + +Точность, количество знаков после запятой. Используется вместе с C<maxLength>. + +=item C<[get]unsigned> + +Используется с числовыми данными, обозначает беззнаковые типы. + +=item C<[get]zerofill> + +Нестандартный атрибут дополняющий числа лидирующими нулями до C<maxLength>. + +=item C<[get]tag> + +Хеш с дополнительными опциями. + +=back + +=cut \ No newline at end of file
--- a/Lib/IMPL/SQL/Types.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/SQL/Types.pm Sat Apr 23 23:06:48 2011 +0400 @@ -9,31 +9,31 @@ require IMPL::SQL::Schema::Type; sub Integer() { - return IMPL::SQL::Schema::Type->new(Name => 'INTEGER'); + return IMPL::SQL::Schema::Type->new(name => 'INTEGER'); } sub Varchar($) { - return IMPL::SQL::Schema::Type->new(Name => 'VARCHAR', MaxLength => shift); + return IMPL::SQL::Schema::Type->new(name => 'VARCHAR', maxLength => shift); } sub Float($) { - return IMPL::SQL::Schema::Type->new(Name => 'FLOAT', Scale => shift); + return IMPL::SQL::Schema::Type->new(name => 'FLOAT', scale => shift); } sub Real() { - return IMPL::SQL::Schema::Type->new(Name => 'REAL'); + return IMPL::SQL::Schema::Type->new(name => 'REAL'); } sub Text() { - return IMPL::SQL::Schema::Type->new(Name => 'TEXT'); + return IMPL::SQL::Schema::Type->new(name => 'TEXT'); } sub Binary() { - return IMPL::SQL::Schema::Type->new(Name => 'BINARY'); + return IMPL::SQL::Schema::Type->new(name => 'BINARY'); } sub DateTime() { - return IMPL::SQL::Schema::Type->new(Name => 'DATETIME'); + return IMPL::SQL::Schema::Type->new(name => 'DATETIME'); } 1;
--- a/Lib/IMPL/Test.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/Test.pm Sat Apr 23 23:06:48 2011 +0400 @@ -6,7 +6,7 @@ require Exporter; our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&test &shared &failed &cmparray &skip &run_plan); +our @EXPORT_OK = qw(&test &shared &failed &cmparray &skip &run_plan &assert); require IMPL::Test::Unit; require IMPL::Test::Plan; @@ -38,6 +38,12 @@ die new IMPL::Test::FailException(@_); } +sub assert { + my ($condition,@params) = @_; + + die new IMPL::Test::FailException(@params ? @params : ("Assertion failed" , _GetSourceLine( (caller)[1,2] )) ) unless $condition; +} + sub skip($;@) { die new IMPL::Test::SkipException(@_); } @@ -54,6 +60,18 @@ return 1; } +sub _GetSourceLine { + my ($file,$line) = @_; + + open my $hFile, $file or return "failed to open file: $file: $!"; + + my $text; + $text = <$hFile> for ( 1 .. $line); + chomp $text; + $text =~ s/^\s+//; + return "line $line: $text"; +} + sub run_plan { my (@units) = @_;
--- a/Lib/IMPL/_core.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/_core.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use IMPL::_core::version; -use base qw(Exporter); +use parent qw(Exporter); our @EXPORT_OK = qw( &isDebug &setDebug); our $Debug = 0;
--- a/Lib/IMPL/base.pm Mon Mar 28 01:36:24 2011 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,39 +0,0 @@ -package IMPL::base; -use strict; -use IMPL::_core::version; - -my %loaded; - -sub import { - shift; - - no strict 'refs'; - my $class = caller; - - foreach my $baseClass (@_) { - unless ($loaded{$baseClass}) { - undef $!; - undef $@; - $loaded{$baseClass} = 1; - eval "require $baseClass; 1;"; - - die $@ if $@ and not $!; - } - - #TODO debug warn if base class is empty; - - push @{"${class}::ISA"}, $baseClass; - } -} - -1; - -__END__ - -=pod - -=head1 NAME - -C<IMPL::base> быстрая версия директивы C<base>. - -=cut
--- a/Lib/IMPL/lang.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/Lib/IMPL/lang.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use IMPL::base qw(Exporter); +use parent qw(Exporter); use IMPL::_core::version;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/template.pm Sat Apr 23 23:06:48 2011 +0400 @@ -0,0 +1,146 @@ +package IMPL::template; +use strict; +use warnings; + +use IMPL::Class::Template(); + +sub import { + shift; + my %args = @_; + + my $class = caller; + + my @paramNames = grep /\w+/, @{$args{parameters} || []}; + my $declare = $args{declare}; + my @isa = (@{$args{base} || []}, $class); + my %instances; + + no strict 'refs'; + + push @{"${class}::ISA"}, 'IMPL::Class::Template'; + + *{"${class}::$_"} = sub { die IMPL::InvalidOperationException("A template parameter isn't available here") } + foreach @paramNames; + + *{"${class}::spec"} = sub { + my ($self,@params) = @_; + + my $specClass = $self->makeName(@params); + + return $specClass if $instances{$specClass}; + + $instances{$specClass} = 1; + + for (my $i=0; $i < @paramNames; $i++) { + my $param = $params[$i]; + *{"${specClass}::$paramNames[$i]"} = sub { $param }; + } + + @{"${specClass}::ISA"} = @isa; + + &$declare($specClass) if $declare; + return $specClass; + }; +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::template> директива для объявления шаблона. + +=head1 SYNPOSIS + +=begin code + +package KeyValuePair; + +use IMPL::Class::Property; + +use IMPL::template ( + parameters => [qw(TKey TValue))], + base => [qw(IMPL::Object IMPL::Object::Autofill)], + declare => sub { + my ($class) = @_; + public $class->CreateProperty(key => prop_get | owner_set, { type => $class->TKey } ); + public $class->CreateProperty(value => prop_all, { type => $class->TValue} ); + + $class->PassThroughArgs; + } +); + +BEGIN { + public property id => prop_get | owner_set, { type => 'integer'}; +} + +__PACKAGE__->PassThroughArgs; + +package MyCollection; + +use IMPL::Class::Property; + +use IMPL::lang; +use IMPL::template( + parameters => [qw(TKey TValue)], + base => [qw(IMPL::Object)], + declare => sub { + my ($class) = @_; + my $item_t = spec KeyValuePair($class->TKey,$class->TValue); + + public $class->CreateProperty(items => prop_get | prop_list, { type => $item_t } ) + + $class->static_accessor( ItemType => $item_t ); + } +) + +sub Add { + my ($this,$key,$value) = @_; + + die new IMPL::ArgumentException( key => "Invalid argument type" ) unless is $key, $this->TKey; + die new IMPL::ArgumentException( value => "Invalid argument type" ) unless is $value, $this->TValue; + + $this->items->AddLast( $this->ItemType->new( key => $key, value => $value ) ); +} + +=end code + +=head1 DESCRIPTION + +Шаблоны используются для динамической генерации классов. Процесс создания класса +по шаблону называется специализацией, при этом создается новый класс: + +=over + +=item 1 + +Обявляется новый пакет с именем, вычисленным из имени и параметров шаблона + +=item 2 + +Формируется массив C<@ISA> для созаднного класса, в который добавляется имя шаблона + +=item 3 + +Формируются методы с именами параметров шаблона, возвращающие реальные значения параметров + +=item 4 + +Вызывается метод для конструирования специализиции + +=back + +=head1 MEMBERS + +=over + +=item C<spec(@params)> + +Метод, создающий специализацию шаблона. Может быть вызван как оператор. + +=back + +=cut \ No newline at end of file
--- a/_test/ORM.t Mon Mar 28 01:36:24 2011 +0400 +++ b/_test/ORM.t Sat Apr 23 23:06:48 2011 +0400 @@ -7,9 +7,11 @@ use IMPL::Test::TAPListener; my $plan = new IMPL::Test::Plan qw( - Test::ORM::Schema + ); +#Test::ORM::Schema + $plan->AddListener(new IMPL::Test::TAPListener); $plan->Prepare(); $plan->Run();
--- a/_test/SQL.t Mon Mar 28 01:36:24 2011 +0400 +++ b/_test/SQL.t Sat Apr 23 23:06:48 2011 +0400 @@ -3,15 +3,11 @@ use lib '../Lib'; use lib '.'; -use IMPL::Test::Plan; -use IMPL::Test::TAPListener; +use IMPL::Test qw(run_plan); -my $plan = new IMPL::Test::Plan qw( +run_plan( qw( Test::SQL::Schema -); - -$plan->AddListener(new IMPL::Test::TAPListener); -$plan->Prepare(); -$plan->Run(); + Test::SQL::Traits +) ); 1;
--- a/_test/Test/Class/Meta.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/_test/Test/Class/Meta.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ use strict; package Test::Class::Meta; -use base qw(IMPL::Test::Unit); +use parent qw(IMPL::Test::Unit); __PACKAGE__->PassThroughArgs; @@ -46,12 +46,12 @@ package Foo; -use base qw(IMPL::Class::Meta); +use parent qw(IMPL::Class::Meta); package Bar; -use base qw(Foo); +use parent qw(-norequire Foo); package Baz; -use base qw(Foo); +use parent qw(-norequire Foo); 1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Test/Class/Template.pm Sat Apr 23 23:06:48 2011 +0400 @@ -0,0 +1,45 @@ +package Test::Class::Template; +use strict; +use warnings; + +use parent qw(IMPL::Test::Unit); + +__PACKAGE__->PassThroughArgs; + +use IMPL::Test qw(test failed); +use IMPL::lang; + +{ + package My::Collection; + use parent qw(IMPL::Object); + use IMPL::Class::Property; + + use IMPL::template ( + parameters => [qw(TValue)], + declare => sub { + my ($class) = @_; + + public $class->CreateProperty( items => prop_get | owner_set | prop_list, { type => $class->TValue } ); + } + ); + + BEGIN { + public property name => prop_all; + } +}; + +test IsDerivedFromTemplate => sub { + failed "My::Collection should be a subclass of IMPL::Class:Template" unless is('My::Collection','IMPL::Class::Template'); +}; + +test Specialize => sub { + my $colList = spec My::Collection('IMPL::Object::List'); + my $colObj = spec My::Collection('IMPL::Object'); + my $colList2 = spec My::Collection('IMPL::Object::List'); + + failed "Wrong class name", "expected: My::ColectionLis", "got: $colList" unless $colList eq 'My::CollectionList'; + failed "Wrong template parameter type", "expected: IMPL::Object::List", "got" . $colList->TValue unless $colList->TValue eq 'IMPL::Object::List'; + +}; + +1; \ No newline at end of file
--- a/_test/Test/ORM/Schema.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/_test/Test/ORM/Schema.pm Sat Apr 23 23:06:48 2011 +0400 @@ -1,7 +1,7 @@ package Test::ORM::Schema; use strict; use warnings; -use base qw(IMPL::Test::Unit); +use parent qw(IMPL::Test::Unit); require IMPL::SQL::Schema::Traits::mysql; @@ -49,7 +49,7 @@ package Test::ORM::Schema::Data::User; -use base qw(IMPL::ORM::Object); +use parent qw(IMPL::ORM::Object); use IMPL::Class::Property; BEGIN { @@ -59,7 +59,7 @@ } package Test::ORM::Schema::Data::Role; -use base qw(IMPL::ORM::Object); +use parent qw(IMPL::ORM::Object); use IMPL::Class::Property; BEGIN { @@ -67,7 +67,7 @@ } package Test::ORM::Schema::Data::Session; -use base qw(IMPL::ORM::Object); +use parent qw(IMPL::ORM::Object); use IMPL::Class::Property; use IMPL::ORM::Helpers qw(Map); @@ -79,7 +79,7 @@ } package Test::ORM::Schema::Data; -use base qw(IMPL::ORM::Schema); +use parent qw(IMPL::ORM::Schema); __PACKAGE__->ValueTypes ( String => 'IMPL::ORM::Value::String',
--- a/_test/Test/Object/Common.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/_test/Test/Object/Common.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,14 +2,14 @@ use strict; use warnings; -use base qw( IMPL::Test::Unit ); +use parent qw( IMPL::Test::Unit ); use IMPL::Test qw(test failed cmparray); __PACKAGE__->PassThroughArgs; { package Foo; - use base qw(IMPL::Object); + use parent qw(IMPL::Object); sub CTOR { my ($this,$refarg) = @_; @@ -17,7 +17,7 @@ } package Bar; - use base qw(Foo); + use parent qw(-norequire Foo); __PACKAGE__->PassThroughArgs; @@ -28,7 +28,7 @@ } package Baz; - use base qw(Bar); + use parent qw(-norequire Bar); our %CTOR = ( Bar => sub { @@ -43,7 +43,7 @@ } package Zoo; - use base qw(Bar); + use parent qw(-norequire Bar); __PACKAGE__->PassThroughArgs; @@ -54,7 +54,7 @@ }; package Complex; - use base qw(Baz Zoo); + use parent qw(-norequire Baz Zoo); our %CTOR = ( Baz => sub { @_ },
--- a/_test/Test/SQL/Schema.pm Mon Mar 28 01:36:24 2011 +0400 +++ b/_test/Test/SQL/Schema.pm Sat Apr 23 23:06:48 2011 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use base qw(IMPL::Test::Unit); +use parent qw(IMPL::Test::Unit); __PACKAGE__->PassThroughArgs; use IMPL::Class::Property; @@ -22,10 +22,10 @@ test CreateSchema => sub { my ($this) = @_; - my $schema = new IMPL::SQL::Schema(Name => 'dbTest', Version => 1) or failed "Failed to create schema"; + my $schema = new IMPL::SQL::Schema(name => 'dbTest', version => 1) or failed "Failed to create schema"; - failed "Failed to set a schema name" unless $schema->Name eq 'dbTest'; - failed "Failed to set a schema version" unless $schema->Version == 1; + failed "Failed to set a schema name" unless $schema->name eq 'dbTest'; + failed "Failed to set a schema version" unless $schema->version == 1; $this->schemaDB($schema); }; @@ -33,71 +33,127 @@ test AddTable => sub { my ($this) = @_; - my $table = $this->schemaDB->AddTable({Name => 'User'}) or failed "Failed to add a table to the schema"; + my $table = $this->schemaDB->AddTable({name => 'User'}) or failed "Failed to add a table to the schema"; $table->InsertColumn({ - Name => 'Id', - Type => Integer + name => 'Id', + type => Integer }); $table->InsertColumn({ - Name => 'Login', - Type => Varchar(255) + name => 'Login', + type => Varchar(255) }); $table->InsertColumn({ - Name => 'DisplayName', - CanBeNull => 1, - Type => Varchar(255) + name => 'DisplayName', + canBeNull => 1, + type => Varchar(255) }); $table->InsertColumn({ - Name => 'RoleId', - CanBeNull => 1, - Type => Integer + name => 'RoleId', + canBeNull => 1, + type => Integer }); - - $table->SetPrimaryKey('Id'); - - my $colCount = @{$table->Columns}; + + my $colCount = @{$table->columns}; failed "Failed to add columns", "Expected: 4", "Got: ".$colCount unless $colCount == 4; - failed "Failed to set a primary key" unless $table->PrimaryKey; - my $table2 = $this->schemaDB->AddTable({Name => 'Role'}); + my $table2 = $this->schemaDB->AddTable({name => 'Role'}); $table2->InsertColumn({ - Name => 'Id', - Type => Integer + name => 'Id', + type => Integer }); $table2->InsertColumn({ - Name => 'Description', - Type => Varchar(255) + name => 'Description', + type => Varchar(255) }); $table2->InsertColumn({ - Name => 'ObsoleteId', - Type => Integer + name => 'ObsoleteId', + type => Integer }); - $table2->SetPrimaryKey('Id'); - - $table->LinkTo($table2,'RoleId'); +}; + +test SetPrimaryKey => sub { + my ($this) = @_; + + my $tableUser = $this->schemaDB->GetTable('User'); + my $tableRole = $this->schemaDB->GetTable('Role'); + + $tableUser->SetPrimaryKey('Id'); + $tableRole->SetPrimaryKey('Id'); + + $tableUser->primaryKey->HasColumn('Id') or failed "A primary key of 'User' table should contain 'Id' column"; + $tableRole->primaryKey->HasColumn('Id') or failed "A primary key of 'Role' table should contain 'Id' column"; + }; -test Constraints => sub { +test LinkTables => sub { + my ($this) = @_; + + my $tableUser = $this->schemaDB->GetTable('User'); + my $tableRole = $this->schemaDB->GetTable('Role'); + + $tableUser->LinkTo($tableRole,'RoleId'); + + $tableUser->GetColumnConstraints('RoleId') == 1 or failed "Wrong constraints count for 'RoleId' column", $tableUser->GetColumnConstraints('RoleId'); +}; + +test AddConstraint => sub { my ($this) = @_; - my $table = $this->schemaDB->Tables->{Role} or failed "Failed to get a table"; + my $table = $this->schemaDB->GetTable('Role') or failed "Failed to get a table"; my $constraint = $table->AddConstraint( new IMPL::SQL::Schema::Constraint::Unique( - Name => 'Role_ObsoleteId_Uniq', - Table => $table, - Columns => ['ObsoleteId'] + name => 'Role_ObsoleteId_Uniq', + table => $table, + columns => ['ObsoleteId'] ) ) or failed "Failed to add constraint"; failed "Failed to retrieve a constraint" unless ($table->GetColumnConstraints('ObsoleteId'))[0] == $constraint; - $table->RemoveColumn('ObsoleteId',1); +}; + +test RemoveConstraint => sub { + my ($this) = @_; + + my $table = $this->schemaDB->GetTable('Role') or failed "Failed to get a table"; + my $constraint = $table->GetConstraint('Role_ObsoleteId_Uniq'); + + eval { + $table->RemoveColumn('ObsoleteId'); + 1; + } and failed "Should not remove column with constraint"; + + $table->RemoveColumn('ObsoleteId','force'); failed "A constraint remains alive after column deletion" unless $constraint->isDisposed; - + +}; + +test RemoveTable => sub { + my ($this) = @_; + + my $table = $this->schemaDB->GetTable('Role') or failed "Failed to get a table"; + + $this->schemaDB->RemoveTable('Role'); + + $table->isDisposed or failed "A table remains alive after deletion"; + + my $table2 = $this->schemaDB->GetTable('User'); + + $table2->GetColumnConstraints('RoleId') == 0 or failed "A foreign key keept alive"; +}; + +test Clone => sub { + my ($this) = @_; + + my $clone1 = $this->schemaDB->Clone(); + + $clone1->Dispose(); + + $this->schemaDB->isDisposed and failed "An original schema should not be disposed"; }; test Dispose => sub {
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Test/SQL/Traits.pm Sat Apr 23 23:06:48 2011 +0400 @@ -0,0 +1,100 @@ +package Test::SQL::Traits; +use parent qw(IMPL::Test::Unit); + +__PACKAGE__->PassThroughArgs; + +use IMPL::lang; +use IMPL::Class::Property; +use IMPL::Test qw(test failed shared assert); + +use IMPL::SQL::Schema; +use IMPL::SQL::Schema::Traits; +use IMPL::SQL::Types qw(Integer Varchar DateTime); + +BEGIN { + shared public property schema => prop_all; +} + +sub StartUnit { + return { + schema => new IMPL::SQL::Schema( name => 'testTraits', version => 1 ) + }; +} + +test CreateTable => sub { + my ($this) = @_; + + my $table = $this->schema->AddTable( + new IMPL::SQL::Schema::Traits::Table( + 'user' + ) + ) or failed "Failed to create table"; + + $this->schema->GetTable('user') or failed "Can't get a created table"; + +}; + +test InsertColumn => sub { + my ($this) = @_; + + my $table = $this->schema->GetTable('user'); + + $table->InsertColumn( + new IMPL::SQL::Schema::Traits::Column( + id => Integer, tag => { auto_increment => 1 } + ) + ); + + my $column = $table->Column('id') or failed "Column not found"; + + assert( $column->name eq 'id'); + assert( $column->type->isSame(Integer()) ); + assert( not $column->isNullable ); + assert( $column->tag->{auto_increment} ); + + $table->InsertColumn( + new IMPL::SQL::Schema::Traits::Column( + name => Varchar(255), isNullable => 1 + ) + ); + + $column = $table->Column('name'); + + assert($column); + assert($column->name eq 'name'); + assert($column->type->isSame(Varchar(255))); + assert($column->isNullable); +}; + +test CreateTableWithColumns => sub { + my ($this) = @_; + + my $table = $this->schema->AddTable( + new IMPL::SQL::Schema::Traits::Table( + session => [ + new IMPL::SQL::Schema::Traits::Column( id => Varchar(64)), + new IMPL::SQL::Schema::Traits::Column( expires => DateTime ), + new IMPL::SQL::Schema::Traits::Column( role => Varchar(64), defaultValue => 'user' ) + ] + ) + ) or failed "Failed to create table"; + + assert( $table->ColumnsCount == 3 ); + + assert( my $column = $table->Column('id') ); + assert($column->type->isSame(Varchar(64))); + assert(not $column->isNullable); + + assert( $column = $table->Column('role') ); + assert( $column->defaultValue eq 'user' ); +}; + +sub FinishUnit { + my ($self,$session) = @_; + + $self->supercall::FinishUnit(); + + $session->{schema}->Dispose(); +} + +1; \ No newline at end of file