line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package WebDAO::Engine; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
=head1 NAME |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 DESCRIPTION |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
WebDAO::Engine - Class for root object of application model |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=cut |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our $VERSION = '0.01'; |
12
|
|
|
|
|
|
|
|
13
|
6
|
|
|
6
|
|
38
|
use Data::Dumper; |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
285
|
|
14
|
6
|
|
|
6
|
|
767
|
use WebDAO::Container; |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
184
|
|
15
|
6
|
|
|
6
|
|
2350
|
use WebDAO::Lib::MethodByPath; |
|
6
|
|
|
|
|
16
|
|
|
6
|
|
|
|
|
165
|
|
16
|
6
|
|
|
6
|
|
2148
|
use WebDAO::Lib::RawHTML; |
|
6
|
|
|
|
|
18
|
|
|
6
|
|
|
|
|
206
|
|
17
|
6
|
|
|
6
|
|
42
|
use base qw(WebDAO::Container); |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
373
|
|
18
|
6
|
|
|
6
|
|
35
|
use Carp; |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
295
|
|
19
|
6
|
|
|
6
|
|
34
|
use strict; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
137
|
|
20
|
6
|
|
|
6
|
|
28
|
use warnings; |
|
6
|
|
|
|
|
11
|
|
|
6
|
|
|
|
|
8426
|
|
21
|
|
|
|
|
|
|
__PACKAGE__->mk_attr( _session=>undef, __obj=>undef, __events=>undef); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
sub new { |
24
|
1
|
|
|
1
|
1
|
3
|
my $class = shift; |
25
|
1
|
|
|
|
|
2
|
my $self = {}; |
26
|
1
|
|
|
|
|
3
|
my $stat; |
27
|
1
|
|
|
|
|
3
|
bless( $self, $class ); |
28
|
1
|
50
|
|
|
|
14
|
return ( $stat = $self->_init(@_) ) ? $self : $stat; |
29
|
|
|
|
|
|
|
} |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
sub _sysinit { |
32
|
1
|
|
|
1
|
|
4
|
my ( $self, $ref ) = @_; |
33
|
1
|
|
|
|
|
4
|
my %hash = @$ref; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# Setup $init_hash; |
36
|
1
|
|
50
|
|
|
6
|
my $my_name = $hash{id} || ''; |
37
|
|
|
|
|
|
|
unshift( |
38
|
1
|
|
|
|
|
3
|
@{$ref}, |
|
1
|
|
|
|
|
5
|
|
39
|
|
|
|
|
|
|
{ |
40
|
|
|
|
|
|
|
ref_engine => $self, #! Setup _engine refernce for childs! |
41
|
|
|
|
|
|
|
name_obj => "$my_name" |
42
|
|
|
|
|
|
|
} |
43
|
|
|
|
|
|
|
); #! Setup _my_name |
44
|
|
|
|
|
|
|
#Save session |
45
|
1
|
|
|
|
|
53
|
_session $self $hash{session}; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# name_obj=>"applic"}); #! Setup _my_name |
48
|
1
|
|
|
|
|
12
|
$self->SUPER::_sysinit($ref); |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
#!init _runtime variables; |
51
|
1
|
|
|
|
|
14
|
$self->_set_parent($self); |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
#hash "function" -"package" |
54
|
1
|
|
|
|
|
17
|
$self->__obj( {} ); |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
#init hash of evens names -> @Array of pointers of sub in objects |
57
|
1
|
|
|
|
|
22
|
$self->__events( {} ); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
sub init { |
62
|
1
|
|
|
1
|
0
|
12
|
my ( $self, %opt ) = @_; |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
#register default clasess |
65
|
1
|
|
|
|
|
6
|
$self->register_class( |
66
|
|
|
|
|
|
|
'WebDAO::Lib::RawHTML' => '_rawhtml_element', |
67
|
|
|
|
|
|
|
'WebDAO::Lib::MethodByPath' => '_method_call' |
68
|
|
|
|
|
|
|
); |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
#Register by init classes |
71
|
1
|
50
|
|
|
|
3
|
if ( ref( my $classes = $opt{register} ) ) { |
72
|
0
|
|
|
|
|
0
|
$self->register_class(%$classes); |
73
|
|
|
|
|
|
|
} |
74
|
1
|
50
|
|
|
|
21
|
if ( my $lexer = $opt{lexer} ) { |
|
|
50
|
|
|
|
|
|
75
|
0
|
|
|
|
|
0
|
map { $_->value($self) } @{ $lexer->auto }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
76
|
0
|
|
|
|
|
0
|
my @objs = map { $_->value($self) } @{ $lexer->tree }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
77
|
0
|
|
|
|
|
0
|
$self->_add_childs_(@objs); |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
elsif ( my $lex = $opt{lex} ) { |
80
|
0
|
0
|
|
|
|
0
|
my ( $pre, $fetch, $post ) = @{ $lex->value($self) || [] }; |
|
0
|
|
|
|
|
0
|
|
81
|
0
|
|
|
|
|
0
|
$self->__add_childs__( 0, @$pre ); |
82
|
0
|
|
|
|
|
0
|
$self->_add_childs_( @$fetch ); |
83
|
0
|
|
|
|
|
0
|
$self->__add_childs__( 2, @$post ); |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
sub response { |
89
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
90
|
0
|
|
|
|
|
0
|
return $self->_session->response_obj; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=head2 __handle_out__ ($sess, @output) |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
Process output by fetch methods |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
=cut |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
sub __handle_out__ { |
101
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
102
|
0
|
|
|
|
|
0
|
my $sess = shift; |
103
|
0
|
|
|
|
|
0
|
for (@_) { |
104
|
0
|
0
|
|
|
|
0
|
if ( UNIVERSAL::isa( $_, 'WebDAO::Element' ) ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
105
|
0
|
0
|
|
|
|
0
|
$self->__handle_out__( $sess, $_->pre_fetch($sess) ) |
106
|
|
|
|
|
|
|
if UNIVERSAL::can( $_, 'pre_fetch' ); |
107
|
|
|
|
|
|
|
|
108
|
0
|
|
|
|
|
0
|
$self->__handle_out__( $sess, $_->fetch($sess) ); |
109
|
0
|
0
|
|
|
|
0
|
$self->__handle_out__( $sess, $_->post_fetch($sess) ) |
110
|
|
|
|
|
|
|
if UNIVERSAL::can( $_, 'post_fetch' ); |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
elsif ( ref($_) eq 'CODE' ) { |
114
|
0
|
|
|
|
|
0
|
return $self->__handle_out__( $sess, $_->($sess) ); |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
elsif ( UNIVERSAL::isa( $_, 'WebDAO::Response' ) ) { |
117
|
0
|
|
|
|
|
0
|
$_->_is_headers_printed(1); |
118
|
0
|
0
|
|
|
|
0
|
$_->_print_dep_on_context($sess) unless $_->_is_file_send; |
119
|
0
|
|
|
|
|
0
|
$_->flush; |
120
|
0
|
|
|
|
|
0
|
$_->_destroy; |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
else { |
124
|
0
|
|
|
|
|
0
|
$sess->print($_); |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub __events__ { |
130
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
131
|
0
|
|
|
|
|
0
|
my $root = shift; |
132
|
0
|
|
|
|
|
0
|
my $inject_fetch = shift; |
133
|
0
|
|
|
|
|
0
|
my $path = $root->__path2me; |
134
|
0
|
|
|
|
|
0
|
my @childs = (); |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
#make inject event for objects |
137
|
0
|
0
|
|
|
|
0
|
if ( my $res = $inject_fetch->{$path} ) { |
138
|
0
|
|
|
|
|
0
|
@childs = ( |
139
|
|
|
|
|
|
|
{ |
140
|
|
|
|
|
|
|
fetch => $root->__path2me, |
141
|
|
|
|
|
|
|
pme => $path, |
142
|
|
|
|
|
|
|
, |
143
|
|
|
|
|
|
|
event => 'inject', |
144
|
|
|
|
|
|
|
obj => $root, |
145
|
|
|
|
|
|
|
res => $res |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
); |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
else { |
151
|
|
|
|
|
|
|
|
152
|
0
|
0
|
|
|
|
0
|
if ( UNIVERSAL::isa( $root, 'WebDAO::Container' ) ) { |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
#skip modal |
155
|
0
|
|
|
|
|
0
|
for ( @{ $root->__childs() } ) { |
|
0
|
|
|
|
|
0
|
|
156
|
0
|
0
|
|
|
|
0
|
push @childs, $self->__events__( $_, $inject_fetch ) |
157
|
|
|
|
|
|
|
unless UNIVERSAL::isa( $_, 'WebDAO::Modal' ); |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
else { |
161
|
0
|
|
|
|
|
0
|
@childs = ( |
162
|
|
|
|
|
|
|
{ |
163
|
|
|
|
|
|
|
fetch => $root->__path2me, |
164
|
|
|
|
|
|
|
pme => $path, |
165
|
|
|
|
|
|
|
, |
166
|
|
|
|
|
|
|
event => 'fetch', |
167
|
|
|
|
|
|
|
obj => $root |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
); |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
} |
172
|
0
|
|
|
|
|
0
|
my @res = ( |
173
|
|
|
|
|
|
|
{ |
174
|
|
|
|
|
|
|
st_ev => $root->__path2me, |
175
|
|
|
|
|
|
|
pme => $path, |
176
|
|
|
|
|
|
|
event => 'start', |
177
|
|
|
|
|
|
|
obj => $root |
178
|
|
|
|
|
|
|
}, |
179
|
|
|
|
|
|
|
@childs, |
180
|
|
|
|
|
|
|
{ |
181
|
|
|
|
|
|
|
end_ev => $root->__path2me, |
182
|
|
|
|
|
|
|
pme => $path, |
183
|
|
|
|
|
|
|
event => 'end', |
184
|
|
|
|
|
|
|
obj => $root |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
); |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub _execute { |
190
|
0
|
|
|
0
|
|
0
|
my $self =shift; |
191
|
0
|
|
|
|
|
0
|
return $self->execute2(@_) |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
sub execute2 { |
195
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
196
|
0
|
|
|
|
|
0
|
my $sess = shift; |
197
|
0
|
|
|
|
|
0
|
my $url = shift; |
198
|
0
|
|
|
|
|
0
|
my @path = @{ $sess->call_path($url) }; |
|
0
|
|
|
|
|
0
|
|
199
|
0
|
|
|
|
|
0
|
my ( $src, $res ) = $self->_traverse_( $sess, @path ); |
200
|
0
|
|
|
|
|
0
|
my $response = $self->response; |
201
|
|
|
|
|
|
|
#now analyze answers |
202
|
|
|
|
|
|
|
# undef -> not Found |
203
|
0
|
0
|
|
|
|
0
|
unless ( defined($res) ) { |
204
|
0
|
|
|
|
|
0
|
$response->error404( "Url not found:" . join "/", @path ); |
205
|
0
|
|
|
|
|
0
|
$response->flush; |
206
|
0
|
|
|
|
|
0
|
$response->_destroy; |
207
|
0
|
|
|
|
|
0
|
return; #end |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
#convert string and ref(scalar) to resonse with html |
211
|
|
|
|
|
|
|
#special handle strings |
212
|
0
|
0
|
0
|
|
|
0
|
if ( !ref($res) or ( ref($res) eq 'SCALAR' ) ) { |
213
|
0
|
0
|
|
|
|
0
|
$res = $response->set_html( ref($res) ? $$res : $res ); |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
#special handle HASH refs ( interpret as json) |
216
|
0
|
0
|
0
|
|
|
0
|
if ( ( ref($res) eq 'HASH' ) and $response->wantformat('json') ) { |
217
|
0
|
|
|
|
|
0
|
$res = $response->set_json( $res ); |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
#check if response modal |
220
|
0
|
0
|
|
|
|
0
|
if ( UNIVERSAL::isa( $res, 'WebDAO::Response' ) ) { |
221
|
|
|
|
|
|
|
#check empty response( $r->set_empty) |
222
|
0
|
0
|
|
|
|
0
|
return if $res->is_empty; |
223
|
0
|
0
|
|
|
|
0
|
if ( $res->_is_modal() ) { |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
#handle response |
226
|
0
|
0
|
|
|
|
0
|
$res->_print_dep_on_context($sess, $res) unless $res->_is_file_send; |
227
|
0
|
|
|
|
|
0
|
$res->flush; |
228
|
0
|
|
|
|
|
0
|
$res->_destroy; |
229
|
0
|
|
|
|
|
0
|
return; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
#extract all objects to evenets |
234
|
0
|
|
|
|
|
0
|
my $root = $self; |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
#if object modal ? |
237
|
0
|
0
|
|
|
|
0
|
if ( UNIVERSAL::isa( $src, 'WebDAO::Modal' ) ) { |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
#set him as root of putput |
240
|
0
|
|
|
|
|
0
|
$root = $src; |
241
|
|
|
|
|
|
|
} |
242
|
0
|
|
|
|
|
0
|
my $need_inject_result = 1; |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
#special handle strings |
245
|
0
|
0
|
0
|
|
|
0
|
if ( !ref($res) or ( ref($res) eq 'SCALAR' ) ) { |
|
|
0
|
|
|
|
|
|
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
#now walk |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
elsif |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
#if result ref to object and it eq $src run flow |
252
|
|
|
|
|
|
|
( $res == $src ) { |
253
|
0
|
|
|
|
|
0
|
$need_inject_result = 0; |
254
|
|
|
|
|
|
|
} |
255
|
0
|
0
|
|
|
|
0
|
if ( UNIVERSAL::isa( $res, 'WebDAO::Element' ) ) { |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
#nothing to do |
258
|
|
|
|
|
|
|
} |
259
|
0
|
|
|
|
|
0
|
my %injects = (); |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
#if need inject check flow by path |
262
|
0
|
0
|
|
|
|
0
|
if ($need_inject_result) { |
263
|
0
|
|
|
|
|
0
|
$injects{ $src->__path2me } = $res; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
#start out |
266
|
0
|
|
|
|
|
0
|
$response->print_header; |
267
|
|
|
|
|
|
|
|
268
|
0
|
|
|
|
|
0
|
my @ev_flow = $self->__events__( $root, \%injects ); |
269
|
0
|
|
|
|
|
0
|
foreach my $ev (@ev_flow) { |
270
|
0
|
|
|
|
|
0
|
my $obj = $ev->{obj}; |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
#_log1 $self "DO " . $ev->{event}. " for $obj"; |
273
|
0
|
0
|
|
|
|
0
|
if ( $ev->{event} eq 'start' ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
274
|
0
|
0
|
|
|
|
0
|
$self->__handle_out__( $sess, $obj->pre_fetch($sess) ) |
275
|
|
|
|
|
|
|
if UNIVERSAL::can( $obj, 'pre_fetch' ); |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
elsif ( $ev->{event} eq 'inject' ) { |
278
|
|
|
|
|
|
|
$self->__handle_out__( $sess, $ev->{res} ) |
279
|
|
|
|
|
|
|
|
280
|
0
|
|
|
|
|
0
|
} |
281
|
|
|
|
|
|
|
elsif ( $ev->{event} eq 'fetch' ) { |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
#skip fetch method for container |
284
|
|
|
|
|
|
|
|
285
|
0
|
0
|
|
|
|
0
|
$self->__handle_out__( $sess, $obj->fetch($sess) ) |
286
|
|
|
|
|
|
|
if UNIVERSAL::can( $obj, 'fetch' ); |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
elsif ( $ev->{event} eq 'end' ) { |
290
|
|
|
|
|
|
|
|
291
|
0
|
0
|
|
|
|
0
|
$self->__handle_out__( $sess, $obj->post_fetch($sess) ) |
292
|
|
|
|
|
|
|
if UNIVERSAL::can( $obj, 'post_fetch' ); |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
} |
296
|
0
|
|
|
|
|
0
|
$response->flush; |
297
|
0
|
|
|
|
|
0
|
$response->_destroy; |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
#fill $self->__events hash event - method |
302
|
|
|
|
|
|
|
sub __register_event__ { |
303
|
0
|
|
|
0
|
|
0
|
my ( $self, $ref_obj, $event_name, $ref_sub ) = @_; |
304
|
0
|
|
|
|
|
0
|
my $ev_hash = $self->__events; |
305
|
0
|
0
|
|
|
|
0
|
$ev_hash->{$event_name}->{ scalar($ref_obj) } = { |
306
|
|
|
|
|
|
|
ref_obj => $ref_obj, |
307
|
|
|
|
|
|
|
ref_sub => $ref_sub |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
if ( ref($ref_sub) ); |
310
|
0
|
|
|
|
|
0
|
return 1; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
sub __send_event__ { |
314
|
0
|
|
|
0
|
|
0
|
my ( $self, $event_name, @Par ) = @_; |
315
|
0
|
|
|
|
|
0
|
my $ev_hash = $self->__events; |
316
|
0
|
0
|
|
|
|
0
|
unless ( exists( $ev_hash->{$event_name} ) ) { |
317
|
0
|
|
|
|
|
0
|
_log2 $self "WARN: Event $event_name not exists."; |
318
|
0
|
|
|
|
|
0
|
return 0; |
319
|
|
|
|
|
|
|
} |
320
|
0
|
|
|
|
|
0
|
foreach my $ref_rec ( keys %{ $ev_hash->{$event_name} } ) { |
|
0
|
|
|
|
|
0
|
|
321
|
0
|
|
|
|
|
0
|
my $ref_sub = $ev_hash->{$event_name}->{$ref_rec}->{ref_sub}; |
322
|
0
|
|
|
|
|
0
|
my $ref_obj = $ev_hash->{$event_name}->{$ref_rec}->{ref_obj}; |
323
|
0
|
|
|
|
|
0
|
$ref_obj->$ref_sub( $event_name, @Par ); |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
=head3 _create_(<name>,<class or alias>,@parameters) |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
create object by <class or alias>. |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
=cut |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
sub _create_ { |
334
|
0
|
|
|
0
|
|
0
|
my ( $self, $name_obj, $name_func, @par ) = @_; |
335
|
0
|
|
0
|
|
|
0
|
my $pack = $self->_pack4name($name_func) || $name_func; |
336
|
0
|
|
|
|
|
0
|
my $ref_init_hash = { |
337
|
|
|
|
|
|
|
ref_engine => $self->_root_, #! Setup _engine refernce for childs! |
338
|
|
|
|
|
|
|
name_obj => $name_obj |
339
|
|
|
|
|
|
|
}; #! Setup _my_name |
340
|
0
|
0
|
|
|
|
0
|
my $obj_ref = |
341
|
|
|
|
|
|
|
$pack->isa('WebDAO::Element') |
342
|
|
|
|
|
|
|
? eval "'$pack'\-\>new(\@par)" |
343
|
|
|
|
|
|
|
: eval "'$pack'\-\>new(\@par)"; |
344
|
|
|
|
|
|
|
# ? eval "'$pack'\-\>new(\$ref_init_hash,\@par)" |
345
|
|
|
|
|
|
|
# : eval "'$pack'\-\>new(\@par)"; |
346
|
0
|
0
|
|
|
|
0
|
if ($pack->isa('WebDAO::Element') ) { |
347
|
0
|
|
|
|
|
0
|
$obj_ref->{_engine} = $self->_root_ ; |
348
|
0
|
|
|
|
|
0
|
$obj_ref->{__my_name} = $name_obj ; |
349
|
0
|
|
|
|
|
0
|
$obj_ref->_init($ref_init_hash,@par) |
350
|
|
|
|
|
|
|
} |
351
|
0
|
0
|
|
|
|
0
|
$self->_log1("Error in eval: _create_ $@") if $@; |
352
|
0
|
|
|
|
|
0
|
return $obj_ref; |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
sub _createObj { |
356
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
# _deprecated $self "_create_"; |
359
|
0
|
|
|
|
|
0
|
return $self->_create_(@_); |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
#Get package for functions name |
363
|
|
|
|
|
|
|
sub _pack4name { |
364
|
0
|
|
|
0
|
|
0
|
my ( $self, $name ) = @_; |
365
|
0
|
|
|
|
|
0
|
my $ref = $self->__obj; |
366
|
0
|
0
|
|
|
|
0
|
return $$ref{$name} if ( exists $$ref{$name} ); |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
sub register_class { |
370
|
1
|
|
|
1
|
0
|
5
|
my ( $self, %register ) = @_; |
371
|
1
|
|
|
|
|
18
|
my $_obj = $self->__obj; |
372
|
1
|
|
|
|
|
6
|
while ( my ( $class, $alias ) = each %register ) { |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
#check non loaded mods |
375
|
2
|
|
|
|
|
12
|
my ( $main, $module ) = $class =~ m/(.*\:\:)?(\S+)$/; |
376
|
2
|
|
50
|
|
|
7
|
$main ||= 'main::'; |
377
|
2
|
|
|
|
|
3
|
$module .= '::'; |
378
|
6
|
|
|
6
|
|
46
|
no strict 'refs'; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
532
|
|
379
|
2
|
50
|
|
|
|
9
|
unless ( exists $$main{$module} ) { |
380
|
0
|
|
|
|
|
0
|
_log1 $self "Try use $class"; |
381
|
0
|
|
|
|
|
0
|
eval "use $class"; |
382
|
0
|
0
|
|
|
|
0
|
if ($@) { |
383
|
0
|
|
|
|
|
0
|
_log1 $self "Error register class :$class with $@ "; |
384
|
0
|
|
|
|
|
0
|
return "Error register class :$class with $@ "; |
385
|
0
|
|
|
|
|
0
|
next; |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
} |
388
|
6
|
|
|
6
|
|
33
|
use strict 'refs'; |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
602
|
|
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
#check if register_class used for eval ( see Lobject ) |
391
|
2
|
50
|
|
|
|
11
|
$$_obj{$alias} = $class if defined $alias; |
392
|
|
|
|
|
|
|
} |
393
|
1
|
|
|
|
|
3
|
return; |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
=head3 _commit |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
Method witch called after HTTP request |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
=cut |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
0
|
|
|
sub _commit { |
403
|
|
|
|
|
|
|
#nothing by default |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
sub _destroy { |
407
|
0
|
|
|
0
|
|
|
my $self = shift; |
408
|
0
|
|
|
|
|
|
$self->SUPER::_destroy; |
409
|
0
|
|
|
|
|
|
$self->_session(undef); |
410
|
0
|
|
|
|
|
|
$self->__obj(undef); |
411
|
0
|
|
|
|
|
|
$self->__events(undef); |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
1; |
414
|
|
|
|
|
|
|
__DATA__ |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
=head1 SEE ALSO |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
http://webdao.sourceforge.net |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
=head1 AUTHOR |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
Zahatski Aliaksandr, E<lt>zag@cpan.orgE<gt> |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
Copyright 2002-2015 by Zahatski Aliaksandr |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify |
429
|
|
|
|
|
|
|
it under the same terms as Perl itself. |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
=cut |
432
|
|
|
|
|
|
|
|