Mercurial > pub > Impl
annotate Lib/IMPL/Object/Abstract.pm @ 195:7a920771fd8e
IMPL::Web::View changed document layout handling, docs, examples
| author | cin |
|---|---|
| date | Wed, 11 Apr 2012 17:50:33 +0400 |
| parents | 4d0e1962161c |
| children | 6b1dda998839 |
| rev | line source |
|---|---|
| 49 | 1 package IMPL::Object::Abstract; |
| 2 use strict; | |
| 3 use warnings; | |
| 4 | |
| 166 | 5 use parent qw(IMPL::Class::Meta); |
| 49 | 6 |
| 7 our $MemoryLeakProtection; | |
| 8 my $Cleanup = 0; | |
| 9 | |
| 10 my %cacheCTOR; | |
| 11 | |
| 12 my $t = 0; | |
| 13 sub cache_ctor { | |
| 14 my $class = shift; | |
| 15 | |
| 16 no strict 'refs'; | |
| 17 my @sequence; | |
| 18 | |
| 19 my $refCTORS = *{"${class}::CTOR"}{HASH}; | |
| 20 | |
| 21 foreach my $super ( @{"${class}::ISA"} ) { | |
| 194 | 22 my $superSequence = $cacheCTOR{$super} || cache_ctor($super); |
| 23 | |
| 24 my $mapper = $refCTORS ? $refCTORS->{$super} : undef; | |
| 25 if (ref $mapper eq 'CODE') { | |
| 26 if ($mapper == *_pass_through_mapper{CODE}) { | |
| 27 push @sequence,@$superSequence; | |
| 28 } else { | |
| 29 push @sequence, sub { | |
| 30 my $this = shift; | |
| 31 $this->$_($mapper->(@_)) foreach @$superSequence; | |
| 32 } if @$superSequence; | |
| 33 } | |
| 34 } else { | |
| 35 warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper; | |
| 36 push @sequence, sub { | |
| 37 my $this = shift; | |
| 38 $this->$_() foreach @$superSequence; | |
| 39 } if @$superSequence; | |
| 40 } | |
| 49 | 41 } |
| 42 | |
| 43 push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE}; | |
| 44 | |
| 45 $cacheCTOR{$class} = \@sequence; | |
| 46 return \@sequence; | |
| 47 } | |
| 48 | |
| 90 | 49 sub dump_ctor { |
| 194 | 50 my ($self) = @_; |
| 51 $self = ref $self || $self; | |
| 52 | |
| 53 warn "dumping $self .ctor"; | |
| 54 warn "$_" foreach @{$cacheCTOR{$self}||[]}; | |
| 90 | 55 } |
| 56 | |
| 49 | 57 sub callCTOR { |
| 58 my $self = shift; | |
| 59 my $class = ref $self; | |
| 60 | |
| 61 $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)}; | |
| 62 } | |
| 63 | |
| 64 sub toString { | |
| 65 my $self = shift; | |
| 66 | |
| 67 return (ref $self || $self); | |
| 68 } | |
| 69 | |
| 122 | 70 sub typeof { |
| 194 | 71 ref $_[0] || $_[0]; |
| 93 | 72 } |
| 73 | |
| 49 | 74 sub isDisposed { |
| 75 0; | |
| 76 } | |
| 77 | |
| 78 #sub DESTROY { | |
| 79 # if ($MemoryLeakProtection and $Cleanup) { | |
| 80 # my $this = shift; | |
| 81 # warn sprintf("Object leaks: %s of type %s %s",$this->can('ToString') ? $this->ToString : $this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : ''); | |
| 82 # } | |
| 83 #} | |
| 84 | |
| 85 sub END { | |
| 86 $Cleanup = 1; | |
| 87 } | |
| 88 | |
| 174 | 89 sub _pass_through_mapper { |
| 49 | 90 @_; |
| 91 } | |
| 92 | |
| 93 sub PassArgs { | |
| 174 | 94 \&_pass_through_mapper; |
| 49 | 95 } |
| 96 | |
| 97 sub PassThroughArgs { | |
| 98 my $class = shift; | |
| 99 $class = ref $class || $class; | |
| 100 no strict 'refs'; | |
| 101 no warnings 'once'; | |
| 174 | 102 ${"${class}::CTOR"}{$_} = \&_pass_through_mapper foreach @{"${class}::ISA"}; |
| 49 | 103 } |
| 104 | |
| 105 package self; | |
| 106 | |
| 107 our $AUTOLOAD; | |
| 108 sub AUTOLOAD { | |
| 108 | 109 goto &{caller(). substr $AUTOLOAD,6}; |
| 49 | 110 } |
| 111 | |
| 112 package supercall; | |
| 113 | |
| 114 our $AUTOLOAD; | |
| 115 sub AUTOLOAD { | |
| 116 my $sub; | |
| 117 my $methodName = substr $AUTOLOAD,11; | |
| 118 no strict 'refs'; | |
| 119 $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'}; | |
| 120 } | |
| 121 | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
122 1; |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
123 |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
124 __END__ |
|
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
125 |
| 49 | 126 =pod |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
127 =head1 SYNOPSIS |
| 49 | 128 |
| 129 package MyBaseObject; | |
| 166 | 130 use parent qw(IMPL::Object::Abstract); |
| 49 | 131 |
| 132 sub new { | |
| 133 # own implementation of the new opeator | |
| 134 } | |
| 135 | |
| 136 sub surrogate { | |
| 137 # own implementation of the surrogate operator | |
| 138 } | |
| 139 | |
|
63
76b878ad6596
Added serialization support for the IMPL::Object::List
wizard
parents:
49
diff
changeset
|
140 =head1 DESCRIPTION |
| 49 | 141 |
| 180 | 142 Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов |
| 143 создания экземпляров. | |
| 49 | 144 =cut |