Mercurial > pub > Impl

comparison Lib/IMPL/Object/Abstract.pm @ 1:3b418b134d8c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
ORM in progress
author Sergey
date Fri, 17 Jul 2009 13:30:46 +0400
parents
children 78cd38551534
comparison
equal deleted inserted replaced
0:03e58a454b20 1:3b418b134d8c
1 package IMPL::Object::Abstract;
2 use strict;
3 use warnings;
4 package IMPL::Object;
5 use strict;
6
7 use base qw(IMPL::Class::Meta);
8
9 our $MemoryLeakProtection;
10 my $Cleanup = 0;
11 our $Debug;
12 our %leaked_objects;
13
14 my %cacheCTOR;
15
16
17 sub new {
18 my $class = shift;
19 my $self = bless {}, ref($class) || $class;
20
21 $self->$_(@_) foreach @{$cacheCTOR{ref $self} || cache_ctor(ref $self)};
22
23 $self;
24 }
25 my $t = 0;
26 sub cache_ctor {
27 my $class = shift;
28
29 no strict 'refs';
30 my @sequence;
31
32 my $refCTORS = *{"${class}::CTOR"}{HASH};
33
34 foreach my $super ( @{"${class}::ISA"} ) {
35 my $superSequence = $cacheCTOR{$super} || cache_ctor($super);
36
37 my $mapper = $refCTORS ? $refCTORS->{$super} : undef;
38 if (ref $mapper eq 'CODE') {
39 if ($mapper == *_pass_throgh_mapper{CODE}) {
40 push @sequence,@$superSequence;
41 } else {
42 push @sequence, sub {
43 my $this = shift;
44 $this->$_($mapper->(@_)) foreach @$superSequence;
45 };
46 }
47 } else {
48 warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper;
49 push @sequence, sub {
50 my $this = shift;
51 $this->$_() foreach @$superSequence;
52 };
53 }
54 }
55
56 push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE};
57
58 $cacheCTOR{$class} = \@sequence;
59 return \@sequence;
60 }
61
62 sub callCTOR {
63 my $self = shift;
64 my $class = ref $self;
65
66 $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)};
67 }
68
69 sub surrogate {
70 bless {}, ref $_[0] || $_[0];
71 }
72
73 sub superCTOR {
74 my $this = shift;
75
76 warn "The mehod is deprecated, at " . caller;
77 }
78
79 sub toString {
80 my $self = shift;
81
82 return (ref $self || $self);
83 }
84
85 sub DESTROY {
86 if ($MemoryLeakProtection and $Cleanup) {
87 my $this = shift;
88 warn sprintf("Object leaks: %s of type %s %s",$this->can('ToString') ? $this->ToString : $this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : '');
89 }
90 }
91
92 sub END {
93 $Cleanup = 1;
94 $MemoryLeakProtection = 0 unless $Debug;
95 }
96
97 sub _pass_throgh_mapper {
98 @_;
99 }
100
101 sub PassThroughArgs {
102 my $class = shift;
103 $class = ref $class || $class;
104 no strict 'refs';
105 no warnings 'once';
106 ${"${class}::CTOR"}{$_} = \&_pass_throgh_mapper foreach @{"${class}::ISA"};
107 }
108
109 package self;
110
111 our $AUTOLOAD;
112 sub AUTOLOAD {
113 goto &{caller(). substr $AUTOLOAD,4};
114 }
115
116 package supercall;
117
118 our $AUTOLOAD;
119 sub AUTOLOAD {
120 my $sub;
121 my $methodName = substr $AUTOLOAD,11;
122 no strict 'refs';
123 $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'};
124 }
125
126 =pod
127 =h1 SYNOPSIS
128
129 package MyBaseObject;
130 use base qw(IMPL::Object::Abstract);
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
140 =h1 DESCRIPTION
141
142 Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов
143 создания экземпляров.
144
145
146 1;
147
148
149 1;