line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
=head1 NAME |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
XAO::DO::Config - Base object for all configurations |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 SYNOPSIS |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
Useful in tandem with XAO::Projects to describe contexts. |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
use XAO::Projects qw(:all); |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
my $config=XAO::Objects->new(objname => 'Config', |
12
|
|
|
|
|
|
|
sitename => 'test'); |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
create_project(name => 'test', |
15
|
|
|
|
|
|
|
object => $config, |
16
|
|
|
|
|
|
|
set_current => 1); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
my $webconfig=XAO::Objects->new(objname => 'Web::Config'); |
19
|
|
|
|
|
|
|
my $fsconfig=XAO::Objects->new(objname => 'FS::Config'); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
$config->embed(web => $webconfig, |
22
|
|
|
|
|
|
|
fs => $fsconfig); |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# Now we have web and fs methods on the config itself: |
25
|
|
|
|
|
|
|
# |
26
|
|
|
|
|
|
|
my $cgi=$config->cgi; |
27
|
|
|
|
|
|
|
my $odb=$config->odb; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
=head1 DESCRIPTION |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
This object provides storage for project specific configuration |
32
|
|
|
|
|
|
|
variables and clipboard mechanism. |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
It can ``embed'' other configuration objects that describe specific |
35
|
|
|
|
|
|
|
parts of the system -- such as database, web or something else. This is |
36
|
|
|
|
|
|
|
done by using method embed() -- see below. |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
=head1 METHODS |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
XAO::DO::Config provides the following methods: |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
=over |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
=cut |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
############################################################################### |
47
|
|
|
|
|
|
|
package XAO::DO::Config; |
48
|
3
|
|
|
3
|
|
25
|
use strict; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
123
|
|
49
|
3
|
|
|
3
|
|
21
|
use XAO::Utils; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
404
|
|
50
|
3
|
|
|
3
|
|
26
|
use XAO::Objects; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
91
|
|
51
|
3
|
|
|
3
|
|
908
|
use XAO::Cache; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
148
|
|
52
|
|
|
|
|
|
|
|
53
|
3
|
|
|
3
|
|
21
|
use base XAO::Objects->load(objname => 'Atom'); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
45
|
|
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
############################################################################### |
56
|
|
|
|
|
|
|
# Prototypes |
57
|
|
|
|
|
|
|
# |
58
|
|
|
|
|
|
|
sub cache ($%); |
59
|
|
|
|
|
|
|
sub cleanup ($;@); |
60
|
|
|
|
|
|
|
sub embed ($%); |
61
|
|
|
|
|
|
|
sub embedded ($$); |
62
|
|
|
|
|
|
|
sub is_embedded ($$); |
63
|
|
|
|
|
|
|
sub new ($); |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
############################################################################### |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
=item cache (%) |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
Creates or retrieves a cache for use in various other XAO objects. |
70
|
|
|
|
|
|
|
Arguments are directly passed to XAO::Cache's new() method (see |
71
|
|
|
|
|
|
|
L). |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
The 'name' argument is required and is used to identify the requested |
74
|
|
|
|
|
|
|
cache. If a cache with the same name was requested before its previously |
75
|
|
|
|
|
|
|
created object is returned and all new arguments are silently ignored |
76
|
|
|
|
|
|
|
without making sure they match the previous request. |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
B Retrieve method SHOULD NOT rely on any locally available |
79
|
|
|
|
|
|
|
lexical variables, they will be taken from whatever scope existed first |
80
|
|
|
|
|
|
|
time cache() was called! |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
Example: |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
my $cache=$self->cache( |
85
|
|
|
|
|
|
|
name => 'fubar', |
86
|
|
|
|
|
|
|
retrieve => \&real_retrieve, |
87
|
|
|
|
|
|
|
coords => ['foo','bar'], |
88
|
|
|
|
|
|
|
expire => 60 |
89
|
|
|
|
|
|
|
); |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
Caches are kept between executions in mod_perl environment. |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
=cut |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
sub cache ($%) { |
96
|
3
|
|
|
3
|
1
|
121
|
my $self=shift; |
97
|
3
|
|
|
|
|
16
|
my $args=get_args(\@_); |
98
|
|
|
|
|
|
|
|
99
|
3
|
|
33
|
|
|
23
|
my $name=$args->{'name'} || |
100
|
|
|
|
|
|
|
throw $self "cache - no 'name' argument"; |
101
|
|
|
|
|
|
|
|
102
|
3
|
|
|
|
|
12
|
my $cache_list=$self->{'cache_list'}; |
103
|
3
|
100
|
|
|
|
22
|
if(! $cache_list) { |
104
|
1
|
|
|
|
|
14
|
$cache_list=$self->{'cache_list'}={}; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
3
|
|
|
|
|
12
|
my $cache=$cache_list->{$name}; |
108
|
|
|
|
|
|
|
|
109
|
3
|
100
|
|
|
|
20
|
if(! $cache) { |
110
|
|
|
|
|
|
|
$cache=$cache_list->{$name}=XAO::Cache->new($args,{ |
111
|
1
|
|
|
|
|
22
|
sitename => $self->{'sitename'}, |
112
|
|
|
|
|
|
|
}); |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
3
|
|
|
|
|
13
|
return $cache; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
############################################################################### |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=item cleanup () |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Calls cleanup method on all embedded configurations if it is |
123
|
|
|
|
|
|
|
available. Order of calls is random. |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
=cut |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
sub cleanup ($;@) { |
128
|
1
|
|
|
1
|
1
|
2
|
my $self=shift; |
129
|
1
|
|
|
|
|
3
|
foreach my $name (keys %{$self->{names}}) { |
|
1
|
|
|
|
|
8
|
|
130
|
2
|
|
|
|
|
6
|
my $obj=$self->{names}->{$name}->{obj}; |
131
|
2
|
50
|
|
|
|
18
|
$obj->cleanup(@_) if $obj->can('cleanup'); |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
############################################################################### |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=item embed (%) |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
This method allows to embed other configuration objects into |
140
|
|
|
|
|
|
|
Config. After embedding certain methods of embedded object become |
141
|
|
|
|
|
|
|
available as Config methods. For example, if you embed Web::Config into |
142
|
|
|
|
|
|
|
Config and Web::Config provides a method called cgi(), then you will be |
143
|
|
|
|
|
|
|
able to call that method on Config: |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
my $config=XAO::Objects->new(objname => 'Config'); |
146
|
|
|
|
|
|
|
my $webconfig=XAO::Objects->new(objname => 'Web::Config'); |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
$config->embed('Web::Config' => $webconfig); |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
my $cgi=$config->cgi(); |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
In order to support that hte object being embedded must have a method |
153
|
|
|
|
|
|
|
embeddable_methods() that returns an array of method names to be |
154
|
|
|
|
|
|
|
embedded. |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
sub embeddable_methods ($) { |
157
|
|
|
|
|
|
|
my $self=shift; |
158
|
|
|
|
|
|
|
return qw(cgi add_cookie del_cookie); |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
The idea behind embedding is to allow easy access to arbitrary context |
162
|
|
|
|
|
|
|
description objects (Configs). For example XAO::FS would provide its own |
163
|
|
|
|
|
|
|
config that creates and caches its database handler. Some other database |
164
|
|
|
|
|
|
|
module might provide its own config if for some reason XAO::FS can't be |
165
|
|
|
|
|
|
|
used. |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
=cut |
168
|
|
|
|
|
|
|
|
169
|
3
|
|
|
3
|
|
25
|
use vars qw(%global_methods); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
2037
|
|
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
sub embed ($%) { |
172
|
7
|
|
|
7
|
1
|
37
|
my $self=shift; |
173
|
7
|
|
|
|
|
23
|
my $args=get_args(\@_); |
174
|
|
|
|
|
|
|
|
175
|
7
|
|
|
|
|
30
|
foreach my $name (keys %$args) { |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
throw $self "embed - object with that name ($name) was already embedded before" |
178
|
7
|
50
|
|
|
|
23
|
if $self->{$name}; |
179
|
|
|
|
|
|
|
|
180
|
7
|
|
|
|
|
14
|
my $obj=$args->{$name}; |
181
|
7
|
50
|
|
|
|
95
|
$obj->can('embeddable_methods') || |
182
|
|
|
|
|
|
|
throw $self "embed - object (".ref($obj).") does not have embeddable_methods() method"; |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
# Setting base for the object we embed, it might need it |
185
|
|
|
|
|
|
|
# |
186
|
7
|
|
|
|
|
43
|
my $set_base_config=$obj->can('set_base_config'); |
187
|
7
|
100
|
|
|
|
21
|
$set_base_config->($obj,$self) if $set_base_config; |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# Building perl code for proxy methods definitions |
190
|
|
|
|
|
|
|
# |
191
|
7
|
|
|
|
|
39
|
my @list=$obj->embeddable_methods(); |
192
|
7
|
|
|
|
|
26
|
my $code=''; |
193
|
7
|
|
|
|
|
14
|
foreach my $mn (@list) { |
194
|
48
|
50
|
|
|
|
213
|
$obj->can($mn) || |
195
|
|
|
|
|
|
|
throw $self "embed - object (".ref($obj).") doesn't have embeddable method $mn()"; |
196
|
|
|
|
|
|
|
|
197
|
48
|
50
|
|
|
|
104
|
$self->{methods}->{$mn} && |
198
|
|
|
|
|
|
|
throw $self "embed - method with such name ($mn) already exists, can't be embedded from ".ref($obj); |
199
|
|
|
|
|
|
|
|
200
|
48
|
|
|
|
|
208
|
$self->{methods}->{$mn}=$obj; |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
## |
203
|
|
|
|
|
|
|
# We only add code if it is required, if that subroutine was |
204
|
|
|
|
|
|
|
# not defined before in another instance of Config object. |
205
|
|
|
|
|
|
|
# |
206
|
48
|
100
|
|
|
|
123
|
if(! $global_methods{$mn}) { |
207
|
29
|
|
|
|
|
86
|
$code.="sub $mn { shift->{methods}->{$mn}->$mn(\@_); }\n"; |
208
|
29
|
|
|
|
|
57
|
$global_methods{$mn}=1; |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
## |
213
|
|
|
|
|
|
|
# Now a bit of black magic, evaluating the code in the current |
214
|
|
|
|
|
|
|
# package context to add appropriate proxy methods. |
215
|
|
|
|
|
|
|
# |
216
|
7
|
100
|
|
|
|
23
|
if($code) { |
217
|
5
|
|
|
0
|
0
|
975
|
eval $code; |
|
0
|
|
|
0
|
0
|
0
|
|
|
0
|
|
|
0
|
0
|
0
|
|
|
0
|
|
|
0
|
0
|
0
|
|
|
0
|
|
|
46
|
0
|
0
|
|
|
46
|
|
|
0
|
0
|
30439
|
|
|
0
|
|
|
1
|
0
|
0
|
|
|
1
|
|
|
1
|
0
|
96
|
|
|
1
|
|
|
0
|
0
|
52
|
|
|
0
|
|
|
1
|
0
|
0
|
|
|
1
|
|
|
|
|
5
|
|
218
|
5
|
50
|
|
|
|
29
|
$@ && throw $self "embed - internal error; name=$name, obj=".ref($obj); |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
## |
222
|
|
|
|
|
|
|
# To operate with sub-configs by name later on. |
223
|
|
|
|
|
|
|
# |
224
|
7
|
|
|
|
|
36
|
$self->{names}->{$name}->{obj}=$obj; |
225
|
7
|
|
|
|
|
46
|
$self->{names}->{$name}->{methods}=\@list; |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
############################################################################### |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=item embedded ($) |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
Returns a reference to a previously embedded object by name. Can be used |
234
|
|
|
|
|
|
|
to call non-embedded method on that object. Throws an error if there is |
235
|
|
|
|
|
|
|
no such embedded object. |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
=cut |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub embedded ($$) { |
240
|
4
|
|
|
4
|
1
|
278
|
my $self=shift; |
241
|
4
|
|
|
|
|
19
|
my $name=shift; |
242
|
|
|
|
|
|
|
|
243
|
4
|
|
66
|
|
|
67
|
my $desc=$self->{names}->{$name} || |
244
|
|
|
|
|
|
|
throw $self "embedded - no configuration with such name ($name)"; |
245
|
3
|
|
|
|
|
35
|
$desc->{obj}; |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
############################################################################### |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
=item is_embedded ($) |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
Check if a named object is embedded. |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
=cut |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
sub is_embedded ($$) { |
257
|
23
|
|
|
23
|
1
|
60
|
my $self=shift; |
258
|
23
|
|
|
|
|
46
|
my $name=shift; |
259
|
23
|
100
|
|
|
|
506
|
return $self->{'names'}->{$name} ? 1 : 0; |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
############################################################################### |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
=item init (%) |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
Default method for project specific Config implementation |
267
|
|
|
|
|
|
|
initialization. This method would normally be called by various handlers |
268
|
|
|
|
|
|
|
after creating configuration and before making it current. It calls |
269
|
|
|
|
|
|
|
init() method on all embedded configs in unpredictable order. |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
=cut |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
sub init ($) { |
274
|
3
|
|
|
3
|
1
|
80
|
my $self=shift; |
275
|
3
|
|
|
|
|
8
|
foreach my $name (keys %{$self->{names}}) { |
|
3
|
|
|
|
|
31
|
|
276
|
2
|
|
|
|
|
6
|
my $obj=$self->{names}->{$name}->{obj}; |
277
|
2
|
100
|
|
|
|
35
|
$obj->init() if $obj->can('init'); |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
############################################################################### |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
=item new () |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
Creates new instance of abstract Config. |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
=cut |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
sub new ($) { |
290
|
9
|
|
|
9
|
1
|
30
|
my $proto=shift; |
291
|
9
|
|
|
|
|
56
|
my $args=get_args(\@_); |
292
|
9
|
|
|
|
|
216
|
$proto->SUPER::new(merge_refs($args,{ |
293
|
|
|
|
|
|
|
methods => { |
294
|
|
|
|
|
|
|
embed => 1, |
295
|
|
|
|
|
|
|
embedded => 1, |
296
|
|
|
|
|
|
|
new => 1, |
297
|
|
|
|
|
|
|
BEGIN => 1, |
298
|
|
|
|
|
|
|
END => 1, |
299
|
|
|
|
|
|
|
DESTROY => 1, |
300
|
|
|
|
|
|
|
AUTOLOAD => 1, |
301
|
|
|
|
|
|
|
}, |
302
|
|
|
|
|
|
|
})); |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
############################################################################### |
306
|
|
|
|
|
|
|
1; |
307
|
|
|
|
|
|
|
__END__ |