/
Element.pm
executable file
·287 lines (210 loc) · 5.44 KB
/
Element.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
package WebDAO::Element;
#$Id$
=head1 NAME
WebDAO::Element - Base class for simple object
=head1 SYNOPSIS
=head1 DESCRIPTION
WebDAO::Element - Base class for simple object
=cut
use Data::Dumper;
use WebDAO::Base;
use base qw/ WebDAO::Base/;
use strict 'vars';
__PACKAGE__->mk_attr(
__attribute_names => undef,
__my_name => undef,
__parent => undef,
__path2me => undef,
__engine => undef,
__extra_path => undef
);
=head1 NAME
WebDAO::Element - WebDAO::Element.
=head1 SYNOPSIS
=cut
sub _init {
my $self = shift;
$self->_sysinit( \@_ ); #For system internal inherites
$self->init(@_); # if (@_);
return 1;
}
######## EVENTS ######
sub __register_event__ {
my $self = shift;
my $ref_eng = $self->_root_;
$ref_eng->__register_event__( $self, @_ );
}
sub __send_event__ {
my $self = shift;
my $parent = $self->__parent || $self->_root_;
$self->_log1( "Not def parent $self name:"
. ( $self->__my_name )
. Dumper( \@_ )
. Dumper( [ map { [ caller($_) ] } ( 1 .. 10 ) ] ) )
unless $parent;
$parent->__send_event__(@_);
}
#
sub _sysinit {
my $self = shift;
#get init hash reference
my $ref_init_hash = shift( @{ $_[0] } );
#_engine - reference to engine
$self->__engine( $ref_init_hash->{ref_engine} );
#_my_name - name of this object
$self->__my_name( $ref_init_hash->{name_obj} );
#init hash of attribute_names
my $ref_names_hash = {};
$self->__attribute_names($ref_names_hash);
}
sub init {
#Public Init metod for modules;
}
=head2 _get_childs_()
Return ref to childs array
=cut
sub _get_childs_ {
return [];
}
=head2 __any_path ($session, @path)
Call for unresolved path.
Return:
($resuilt, \@rest_of_the_path)
=cut
sub __any_path {
my $self = shift;
my $sess = shift;
my ( $method, @path ) = @_;
#first check if Method
#Check upper case First letter for method
if ( ucfirst($method) ne $method ) {
#warn "Deny method : $method";
return undef; #not found
}
#check if $self have method
if ( UNIVERSAL::can( $self, $method ) ) {
#now try call method
#Ok have method
#check if path have more elements
my %args = %{ $sess->Params };
if (@path) {
#add special variable
$args{__extra_path__} = \@path;
}
#call method (only one param may be return)
my ($res, @path1) = $self->$method(%args);
if ( scalar(@path1) ) {
#method may return extra path
return $res, \@path1;
}
return $res, \@path;
}
undef;
}
#return
# undef = not found
# [ array of object]
# <$self|| WebDAO::Element> ( ? for isert to parent container ?)
# "STRING"
# <WebDAO::Response>
sub _traverse_ {
my $self = shift;
my $sess = shift;
#if empty path return $self
unless ( scalar(@_) ) { return ( $self, $self ) }
my ( $next_name, @path ) = @_;
#try get objects by special methods
my ( $res, $last_path ) = $self->__any_path( $sess, $next_name, @path );
return ( $self, undef ) unless defined $res; #break search
return ( $self, $res );
}
sub __get_self_refs {
return $_[0];
}
sub _set_parent {
my ( $self, $parent ) = @_;
$self->__parent($parent);
$self->_set_path2me();
}
sub _set_path2me {
my $self = shift;
my $parent = $self->__parent;
if ( $self != $parent ) {
( my $parents_path = $parent->__path2me ) ||= "";
my $extr = $parent->__extra_path;
$extr = [] unless defined $extr;
$extr = [$extr] unless ( ref($extr) eq 'ARRAY' );
my $my_path = join "/", $parents_path, @$extr, $self->__my_name;
$self->__path2me($my_path);
}
else {
$self->__path2me('');
}
}
#deprecated -> $obj->__my_name
sub _obj_name {
return $_[0]->__my_name;
}
#deprecated -> self->_root_
sub getEngine {
my $self = shift;
return $self->__engine;
}
sub _root_ { return $_[0]->__engine }
sub fetch { undef } #return undef
sub _destroy {
my $self = shift;
$self->__parent(undef);
$self->__engine(undef);
}
sub url_method {
my $self = shift;
my $method = shift;
my @upath = ();
push @upath, $self->__path2me if $self->__path2me;
push @upath, $method if defined $method;
my $sess = $self->_root_->_session;
if ( $sess->set_absolute_url() ) {
my $root = $sess->Cgi_env->{base_url};
unshift @upath, $sess->Cgi_env->{base_url};
}
#hack !!! clear / on begin
#s{^/}{} for @upath;
my $path = join '/' => @upath;
my $str = '';
if (@_) {
my %args = @_;
my @pars;
while ( my ( $key, $val ) = each %args ) {
push @pars, "$key=$val";
}
$str .= "?" . join "&" => @pars;
}
return $path . $str;
}
=head2 response
Return response object
return $self->response->error404('Bad name')
=cut
sub response {
my $self = shift;
return $self->_root_->response;
}
=head2 request
Return request object
$self->request->param('id')
=cut
sub request {
return $_[0]->response->get_request();
}
1;
__DATA__
=head1 SEE ALSO
http://webdao.sourceforge.net
=head1 AUTHOR
Zahatski Aliaksandr, E<lt>zag@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2002-2012 by Zahatski Aliaksandr
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut