# HG changeset patch # User cin # Date 1359502228 -14400 # Node ID 8d36073411b11e635fa61dec7a75901c4e40a7c6 # Parent ad93c9f4dd930842f90bc68606bb3e1c20a6c8ff +Added AutoDispose class *code cleanups diff -r ad93c9f4dd93 -r 8d36073411b1 Lib/IMPL/Class/PropertyInfo.pm --- a/Lib/IMPL/Class/PropertyInfo.pm Tue Jan 29 17:19:10 2013 +0400 +++ b/Lib/IMPL/Class/PropertyInfo.pm Wed Jan 30 03:30:28 2013 +0400 @@ -5,7 +5,7 @@ our %CTOR = ( 'IMPL::Class::MemberInfo' => '@_' ); -__PACKAGE__->mk_accessors(qw(Type Mutators canGet canSet ownerSet)); +__PACKAGE__->mk_accessors(qw(Type Mutators canGet canSet ownerSet isList)); my %LoadedModules; @@ -39,6 +39,10 @@ eval {$_[0]->Class->_PropertyImplementor} or die new IMPL::Exception('Can\'t find a property implementor for the specified class',$_[0]->Class); } +sub type { + goto &Type; +} + 1; __END__ diff -r ad93c9f4dd93 -r 8d36073411b1 Lib/IMPL/Code/Binding.pm --- a/Lib/IMPL/Code/Binding.pm Tue Jan 29 17:19:10 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -package IMPL::Code::Binding; -use strict; - -use IMPL::require { - Exception => 'IMPL::Exception', - ArgumentException => '-IMPL::ArgumentException' -}; - -sub new { - my ($self,$expr,$vars) = @_; - - $vars ||= []; - - die ArgumentException->new( vars => 'A reference to an array is required') - unless ref $vars eq 'ARRAY'; - - m/^\w+$/ or die ArgumentException->new( vars => 'A valid variable name is required', $_ ) - foreach @$vars; - - my $varnames = join (',', map { "\$$_" } @$vars); - - my $code = <reval($code,'strict'); - - return $method; -} - -1; - -__END__ - -=pod - -=head1 NAME - -C - превращает выражения в процедуру. - -=head1 SYNOPSIS - -=begin code - -use IMPL::require { - Binding => 'IMPL::Code::Binding' -} - -my $person = DB->SearchPerson({name => 'Peter'})->First; - -my $bind = Binding->new( - [qw(obj)] => - q{ $obj->addresses->[0]->country->code } -); - -print $bind->($person); - -=end - -=head1 DESCRIPTION - -Позвоялет преобразовать выражение в функцию, которую можно будет многократно -использовать для получения значения выражения. - -Выражение параметризуется произвольным количеством именованных параметров, -которые будут доступны внутри выражения как переменные. При создании связывателя -в конструктор передается выражение связывания, ссылка насписок из параметров. - -При создания связывателя будет проверен синтаксис, и если в выражении допущена -ошибка, возникнет исключение. - -Данный класс не является безопасным при создании связывателей из ненадежных -источников, поскольку внутри будет выполнен C. - -=head1 MEMBERS - -=head2 C - -Возвращает ссылку на процедуру. - -=cut \ No newline at end of file diff -r ad93c9f4dd93 -r 8d36073411b1 Lib/IMPL/Code/Loader.pm --- a/Lib/IMPL/Code/Loader.pm Tue Jan 29 17:19:10 2013 +0400 +++ b/Lib/IMPL/Code/Loader.pm Wed Jan 30 03:30:28 2013 +0400 @@ -3,7 +3,7 @@ use warnings; use IMPL::Const qw(:prop); - +use File::Spec; use IMPL::declare { require => { Exception => 'IMPL::Exception', @@ -53,6 +53,16 @@ return $package; } +sub ModuleExists { + my ($this,$package) = @_; + + my $file = join('/', split(/::/,$this->GetFullName($package))) . ".pm"; + + -f File::Spec->catfile($_,$file) and return 1 foreach @INC; + + return 0; +} + sub GetFullName { my ($this,$package) = @_; diff -r ad93c9f4dd93 -r 8d36073411b1 Lib/IMPL/Object/AutoDispose.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Object/AutoDispose.pm Wed Jan 30 03:30:28 2013 +0400 @@ -0,0 +1,52 @@ +package IMPL::Object::AutoDispose; +use strict; + +use IMPL::declare { + base => [ + 'IMPL::Object::Abstract' => undef + ] +}; + +sub new { + my $self = shift; + + if (ref $self) { + return ${$self}->new(@_); + } else { + my $obj = shift; + return bless \$obj, $self; + } +} + +sub isa { + ${shift(@_)}->isa(@_); +} + +sub can { + ${shift(@_)}->can(@_); +} + +sub DTOR { + ${shift(@_)}->Dispose(); +} + +sub typeof { + ${shift(@_)}->typeof(@_); +} + +sub toString { + ${shift(@_)}->toString(@_); +} + +sub AUTOLOAD { + our $AUTOLOAD; + my ($method) = ($AUTOLOAD =~ m/(\w+)$/); + + no strict 'refs'; + + goto &{*{$AUTOLOAD} = sub { + ${shift(@_)}->$method(@_); + }}; +} + +1; \ No newline at end of file diff -r ad93c9f4dd93 -r 8d36073411b1 Lib/IMPL/lang.pm --- a/Lib/IMPL/lang.pm Tue Jan 29 17:19:10 2013 +0400 +++ b/Lib/IMPL/lang.pm Wed Jan 30 03:30:28 2013 +0400 @@ -5,16 +5,18 @@ use parent qw(Exporter); use IMPL::_core::version; use IMPL::clone qw(clone); +use Scalar::Util qw(blessed); require IMPL::Class::PropertyInfo; -our @EXPORT = qw(&is &isclass); +our @EXPORT = qw(&is &isclass &typeof); our %EXPORT_TAGS = ( base => [ qw( &is &clone &isclass + &typeof ) ], @@ -70,6 +72,10 @@ eval {not ref $_[0] and $_[0]->isa( $_[1] ) }; } +sub typeof(*) { + eval { $_[0]->typeof } || blessed($_[0]); +} + sub virtual($) { $_[0]->Virtual(1); $_[0]; diff -r ad93c9f4dd93 -r 8d36073411b1 _test/Test/SQL/Diff.pm --- a/_test/Test/SQL/Diff.pm Tue Jan 29 17:19:10 2013 +0400 +++ b/_test/Test/SQL/Diff.pm Wed Jan 30 03:30:28 2013 +0400 @@ -52,9 +52,6 @@ my $processor = MySQLProcessor->new($schemaSrc); $processor->ProcessBatch($diff); - warn Dumper($diff); - warn Dumper($processor->sqlBatch); - $schemaSrc->Dispose; $schemaDst->Dispose; diff -r ad93c9f4dd93 -r 8d36073411b1 _test/temp.pl --- a/_test/temp.pl Tue Jan 29 17:19:10 2013 +0400 +++ b/_test/temp.pl Wed Jan 30 03:30:28 2013 +0400 @@ -1,29 +1,42 @@ #!/usr/bin/perl use strict; -use XML::Compile::Schema; -use XML::Compile::Util qw(pack_type pack_id); -use Data::Dumper; +{ + package Foo; + use IMPL::declare { + base => [ + 'IMPL::Object::Disposable' => undef + ] + }; +} + use Time::HiRes qw(gettimeofday tv_interval); - -my $schema = XML::Compile::Schema->new('Resources/resources.xsd'); -$schema->printIndex(); -my $type = pack_type 'http://implab.org/schemas/resources', 'resources'; -my $reader = $schema->compile( - READER => $type, - xsi_type => { - pack_type('http://implab.org/schemas/resources','AbstractResult') => 'AUTO' - } -); +use IMPL::lang; +use IMPL::require { + AutoDispose => 'IMPL::Object::AutoDispose', + DBSchema => 'IMPL::SQL::Schema' +}; + +my $real = DBSchema->new( name => 'simple', version => 1); +my $proxy = AutoDispose->new($real); + +print typeof($proxy),"\n"; my $t = [gettimeofday]; -my $obj = $reader->('Resources/sample.xml'); +for (1..1000000) { + $proxy->name; +} -print "Parsing small Xml file: ",tv_interval($t,[gettimeofday]),"\n"; +print "proxy: ",tv_interval($t,[gettimeofday]),"\n"; -print Dumper( $obj ); +$t = [gettimeofday]; + +for (1..1000000) { + $real->name; +} + +print "real: ",tv_interval($t,[gettimeofday]),"\n"; -