Mercurial > pub > Impl
changeset 1:3b418b134d8c
ORM in progress
author | Sergey |
---|---|
date | Fri, 17 Jul 2009 13:30:46 +0400 |
parents | 03e58a454b20 |
children | 78cd38551534 |
files | Lib/IMPL/DOM/Node.pm Lib/IMPL/Object/Abstract.pm Lib/IMPL/Object/ArrayBased.pm impl.kpf |
diffstat | 4 files changed, 175 insertions(+), 1 deletions(-) [+] |
line wrap: on
line diff
--- a/Lib/IMPL/DOM/Node.pm Tue Jul 14 12:54:37 2009 +0400 +++ b/Lib/IMPL/DOM/Node.pm Fri Jul 17 13:30:46 2009 +0400 @@ -8,6 +8,8 @@ use IMPL::Class::Property::Direct; use Scalar::Util qw(weaken); +use IMPL::Exception; + __PACKAGE__->PassThroughArgs; BEGIN { @@ -20,8 +22,9 @@ } sub CTOR { - my $this = @_; + my ($this,$name) = @_; + $this->nodeName($name) or die new IMPL::InvalidArgumentException("A name is required"); $this->_propertyMap({}); }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Object/Abstract.pm Fri Jul 17 13:30:46 2009 +0400 @@ -0,0 +1,149 @@ +package IMPL::Object::Abstract; +use strict; +use warnings; +package IMPL::Object; +use strict; + +use base qw(IMPL::Class::Meta); + +our $MemoryLeakProtection; +my $Cleanup = 0; +our $Debug; +our %leaked_objects; + +my %cacheCTOR; + + +sub new { + my $class = shift; + my $self = bless {}, ref($class) || $class; + + $self->$_(@_) foreach @{$cacheCTOR{ref $self} || cache_ctor(ref $self)}; + + $self; +} +my $t = 0; +sub cache_ctor { + my $class = shift; + + no strict 'refs'; + my @sequence; + + my $refCTORS = *{"${class}::CTOR"}{HASH}; + + foreach my $super ( @{"${class}::ISA"} ) { + my $superSequence = $cacheCTOR{$super} || cache_ctor($super); + + my $mapper = $refCTORS ? $refCTORS->{$super} : undef; + if (ref $mapper eq 'CODE') { + if ($mapper == *_pass_throgh_mapper{CODE}) { + push @sequence,@$superSequence; + } else { + push @sequence, sub { + my $this = shift; + $this->$_($mapper->(@_)) foreach @$superSequence; + }; + } + } else { + warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper; + push @sequence, sub { + my $this = shift; + $this->$_() foreach @$superSequence; + }; + } + } + + push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE}; + + $cacheCTOR{$class} = \@sequence; + return \@sequence; +} + +sub callCTOR { + my $self = shift; + my $class = ref $self; + + $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)}; +} + +sub surrogate { + bless {}, ref $_[0] || $_[0]; +} + +sub superCTOR { + my $this = shift; + + warn "The mehod is deprecated, at " . caller; +} + +sub toString { + my $self = shift; + + return (ref $self || $self); +} + +sub DESTROY { + if ($MemoryLeakProtection and $Cleanup) { + my $this = shift; + warn sprintf("Object leaks: %s of type %s %s",$this->can('ToString') ? $this->ToString : $this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : ''); + } +} + +sub END { + $Cleanup = 1; + $MemoryLeakProtection = 0 unless $Debug; +} + +sub _pass_throgh_mapper { + @_; +} + +sub PassThroughArgs { + my $class = shift; + $class = ref $class || $class; + no strict 'refs'; + no warnings 'once'; + ${"${class}::CTOR"}{$_} = \&_pass_throgh_mapper foreach @{"${class}::ISA"}; +} + +package self; + +our $AUTOLOAD; +sub AUTOLOAD { + goto &{caller(). substr $AUTOLOAD,4}; +} + +package supercall; + +our $AUTOLOAD; +sub AUTOLOAD { + my $sub; + my $methodName = substr $AUTOLOAD,11; + no strict 'refs'; + $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'}; +} + +=pod +=h1 SYNOPSIS + +package MyBaseObject; +use base qw(IMPL::Object::Abstract); + +sub new { + # own implementation of the new opeator +} + +sub surrogate { + # own implementation of the surrogate operator +} + +=h1 DESCRIPTION + +Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов +создания экземпляров. + + +1; + + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Object/ArrayBased.pm Fri Jul 17 13:30:46 2009 +0400 @@ -0,0 +1,19 @@ +package IMPL::Object::ArrayBased; +use strict; +use warnings; + +use base qw(IMPL::Object); + +sub new { + my $class = shift; + my $self = bless [], ref $class || $class; + $self->callCTOR(@_); + return $self; +} + +sub surrogate { + return bless [], ref $_[0] || $_; +} + +1; +
--- a/impl.kpf Tue Jul 14 12:54:37 2009 +0400 +++ b/impl.kpf Fri Jul 17 13:30:46 2009 +0400 @@ -1,6 +1,8 @@ <?xml version="1.0" encoding="UTF-8"?> <!-- Komodo Project File - DO NOT EDIT --> <project id="66c7d414-175f-45b6-92fe-dbda51c64843" kpf_version="4" name="impl.kpf"> +<file id="91cab186-0c9b-4ed6-98e8-3de5c132e296" idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/Object" name="Node.pm" url="Lib/IMPL/DOM/Node.pm"> +</file> <preference-set idref="155f1fd9-8a20-46fe-90d5-8fbe879632d8"> <preference-set id="Invocations"> <preference-set id="default"> @@ -107,6 +109,7 @@ </preference-set> <preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843"> <boolean id="import_live">1</boolean> + <string relative="path" id="perlExtraPaths">Lib</string> </preference-set> <preference-set idref="7e7fa5c6-0123-4570-8540-b1366b09b7dd"> <preference-set id="Invocations">