Mercurial > pub > Impl

changeset 2:78cd38551534

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
in develop
author Sergey
date Mon, 10 Aug 2009 17:39:08 +0400
parents 3b418b134d8c
children 2e546a5175dd
files Lib/IMPL/Object.pm Lib/IMPL/Object/Abstract.pm Lib/IMPL/Object/ArrayBased.pm Lib/IMPL/Object/ArrayObject.pm Lib/IMPL/Object/List.pm _test/object.t impl.kpf
diffstat 7 files changed, 146 insertions(+), 161 deletions(-) [+]
line wrap: on
line diff
--- a/Lib/IMPL/Object.pm	Fri Jul 17 13:30:46 2009 +0400
+++ b/Lib/IMPL/Object.pm	Mon Aug 10 17:39:08 2009 +0400
@@ -1,123 +1,18 @@
 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)};
-}
+use base qw(IMPL::Object::Abstract);
 
 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 {
+sub new {
     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'};
+    my $self = bless {}, ref($class) || $class;    
+    $self->callCTOR(@_);
+  
+    $self;
 }
 
 =pod
@@ -173,15 +68,32 @@
 #
 # Foo: Mazzi
 # Bar: Fugi
-# Foo:
 # Bar:
 # Composite: Hello World!
 
 =h1 Description
-Базовый класс для объектов. Реализует множественное наследование
-
+Базовый класс для объектов, основанных на хеше.
 
 =h1 Members
+
+=level 4
+
+=item operator C<new>(@args)
+
+Создает экземпляр объекта и вызывает конструктор с параметрами @args.
+
+=item operator C<surrogate>()
+
+Создает неинициализированный экземпляр объекта.
+
+=back
+
+=р1 Cavearts
+
+Нужно заметить, что директива C<use base> работает не совсем прозрачно, если в нашем примере
+класс C<Composite> наследуется от C<Baz>, а затем C<Foo>, то наследование от
+C<Foo> не произойдет поскольку он уже имеется в C<Baz>. Вот не задача:)
+
 =cut
 
 1;
\ No newline at end of file
--- a/Lib/IMPL/Object/Abstract.pm	Fri Jul 17 13:30:46 2009 +0400
+++ b/Lib/IMPL/Object/Abstract.pm	Mon Aug 10 17:39:08 2009 +0400
@@ -1,27 +1,14 @@
 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;
@@ -66,10 +53,6 @@
     $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)};
 }
 
-sub surrogate {
-    bless {}, ref $_[0] || $_[0];
-}
-
 sub superCTOR {
     my $this = shift;
 
@@ -91,7 +74,6 @@
 
 sub END {
     $Cleanup = 1;
-    $MemoryLeakProtection = 0 unless $Debug;
 }
 
 sub _pass_throgh_mapper {
@@ -141,9 +123,6 @@
 
 Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов
 создания экземпляров.
-
+=cut
 
 1;
-
-
-1;
--- a/Lib/IMPL/Object/ArrayBased.pm	Fri Jul 17 13:30:46 2009 +0400
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,19 +0,0 @@
-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;
-
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Object/ArrayObject.pm	Mon Aug 10 17:39:08 2009 +0400
@@ -0,0 +1,19 @@
+package IMPL::Object::ArrayObject;
+use strict;
+use warnings;
+
+use base qw(IMPL::Object::Abstract);
+
+sub new {
+    my $class = shift;
+    my $self = bless [], ref $class || $class;
+    $self->callCTOR(@_);
+    return $self;
+}
+    
+sub surrogate {
+    return bless [], ref $_[0] || $_;
+}
+
+1;
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Object/List.pm	Mon Aug 10 17:39:08 2009 +0400
@@ -0,0 +1,45 @@
+package IMPL::Object::List;
+use strict;
+use warnings;
+
+use base qw(IMPL::Object::ArrayObject);
+
+sub as_list {
+    return $_[0];
+}
+
+sub Append {
+    push @{$_[0]}, @_{1 .. @$_-1};
+}
+
+sub RemoveLast {
+    return pop @{$_[0]};
+}
+
+sub AddFirst {
+    return unshift @{$_[0]}, $_[1];
+}
+
+sub RemoveFirst {
+    return shift @{$_[0]};
+}
+
+sub Count {
+    return scalar @{$_[0]};
+}
+
+sub InsertAt {
+    my ($this,$index,@val) = @_;
+    
+    splice @$this,$index,0,@val;
+}
+
+sub RemoveAt {
+    my ($this,$index,$count) = @_;
+    
+    $count ||= 1;
+    
+    return splice @$this,$index,$count;
+}
+
+1;
--- a/_test/object.t	Fri Jul 17 13:30:46 2009 +0400
+++ b/_test/object.t	Mon Aug 10 17:39:08 2009 +0400
@@ -7,11 +7,11 @@
 
 sub CTOR {
     my ($this,%args) = @_;
-    print "CTOR Foo $args{Name}\n";
+    print "CTOR Foo says $args{Name}\n";
 }
 
 sub Hello {
-    print "Hello";
+    print "\tHello\n";
 }
 
 package Bar;
@@ -27,7 +27,4 @@
 
 my $obj = new Bar ( Name => 'Tom') ;
 
-Hello $obj;
-
-no strict 'refs';
-print "$_\n" foreach sort keys %{'Bar::'};
\ No newline at end of file
+Hello $obj;
\ No newline at end of file
--- a/impl.kpf	Fri Jul 17 13:30:46 2009 +0400
+++ b/impl.kpf	Mon Aug 10 17:39:08 2009 +0400
@@ -111,6 +111,58 @@
   <boolean id="import_live">1</boolean>
   <string relative="path" id="perlExtraPaths">Lib</string>
 </preference-set>
+<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/Lib/IMPL/Object.pm">
+<preference-set id="Invocations">
+<preference-set id="default">
+  <string id="cookieparams"></string>
+  <string id="cwd"></string>
+  <long id="debugger.io-port">9011</long>
+  <string id="documentRoot"></string>
+  <string id="executable-params"></string>
+  <string relative="path" id="filename">Lib/IMPL/Object.pm</string>
+  <string id="getparams"></string>
+  <string id="language">Perl</string>
+  <string id="mpostparams"></string>
+  <string id="params"></string>
+  <string id="postparams"></string>
+  <string id="posttype">application/x-www-form-urlencoded</string>
+  <string id="request-method">GET</string>
+  <boolean id="show-dialog">1</boolean>
+  <boolean id="sim-cgi">0</boolean>
+  <boolean id="use-console">0</boolean>
+  <string id="userCGIEnvironment"></string>
+  <string id="userEnvironment"></string>
+  <string id="warnings">enabled</string>
+</preference-set>
+</preference-set>
+  <string id="lastInvocation">default</string>
+</preference-set>
+<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/object.t">
+<preference-set id="Invocations">
+<preference-set id="default">
+  <string id="cookieparams"></string>
+  <string id="cwd"></string>
+  <long id="debugger.io-port">9011</long>
+  <string id="documentRoot"></string>
+  <string id="executable-params"></string>
+  <string relative="path" id="filename">_test/object.t</string>
+  <string id="getparams"></string>
+  <string id="language">Perl</string>
+  <string id="mpostparams"></string>
+  <string id="params"></string>
+  <string id="postparams"></string>
+  <string id="posttype">application/x-www-form-urlencoded</string>
+  <string id="request-method">GET</string>
+  <boolean id="show-dialog">1</boolean>
+  <boolean id="sim-cgi">0</boolean>
+  <boolean id="use-console">0</boolean>
+  <string id="userCGIEnvironment"></string>
+  <string id="userEnvironment"></string>
+  <string id="warnings">enabled</string>
+</preference-set>
+</preference-set>
+  <string id="lastInvocation">default</string>
+</preference-set>
 <preference-set idref="7e7fa5c6-0123-4570-8540-b1366b09b7dd">
 <preference-set id="Invocations">
 <preference-set id="default">