File Coverage

blib/lib/XAO/DO/Config.pm
Criterion Covered Total %
statement 75 81 92.5
branch 20 26 76.9
condition 3 6 50.0
subroutine 18 24 75.0
pod 7 18 38.8
total 123 155 79.3


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   23 use strict;
  3         5  
  3         124  
49 3     3   27 use XAO::Utils;
  3         9  
  3         417  
50 3     3   21 use XAO::Objects;
  3         15  
  3         90  
51 3     3   1055 use XAO::Cache;
  3         9  
  3         143  
52              
53 3     3   22 use base XAO::Objects->load(objname => 'Atom');
  3         5  
  3         36  
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 131 my $self=shift;
97 3         38 my $args=get_args(\@_);
98              
99 3   33     28 my $name=$args->{'name'} ||
100             throw $self "cache - no 'name' argument";
101              
102 3         12 my $cache_list=$self->{'cache_list'};
103 3 100       15 if(! $cache_list) {
104 1         15 $cache_list=$self->{'cache_list'}={};
105             }
106              
107 3         11 my $cache=$cache_list->{$name};
108              
109 3 100       22 if(! $cache) {
110             $cache=$cache_list->{$name}=XAO::Cache->new($args,{
111 1         33 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 3 my $self=shift;
129 1         2 foreach my $name (keys %{$self->{names}}) {
  1         5  
130 2         12 my $obj=$self->{names}->{$name}->{obj};
131 2 50       17 $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         5  
  3         2013  
170              
171             sub embed ($%) {
172 7     7 1 50 my $self=shift;
173 7         28 my $args=get_args(\@_);
174              
175 7         51 foreach my $name (keys %$args) {
176              
177             throw $self "embed - object with that name ($name) was already embedded before"
178 7 50       31 if $self->{$name};
179              
180 7         19 my $obj=$args->{$name};
181 7 50       94 $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         41 my $set_base_config=$obj->can('set_base_config');
187 7 100       20 $set_base_config->($obj,$self) if $set_base_config;
188              
189             # Building perl code for proxy methods definitions
190             #
191 7         36 my @list=$obj->embeddable_methods();
192 7         37 my $code='';
193 7         17 foreach my $mn (@list) {
194 48 50       227 $obj->can($mn) ||
195             throw $self "embed - object (".ref($obj).") doesn't have embeddable method $mn()";
196              
197 48 50       121 $self->{methods}->{$mn} &&
198             throw $self "embed - method with such name ($mn) already exists, can't be embedded from ".ref($obj);
199              
200 48         250 $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       172 if(! $global_methods{$mn}) {
207 29         92 $code.="sub $mn { shift->{methods}->{$mn}->$mn(\@_); }\n";
208 29         60 $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       18 if($code) {
217 5     1 0 1142 eval $code;
  1     0 0 6  
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0     1 0 0  
  1     45 0 45  
  45     0 0 31538  
  0     1 0 0  
  1     1 0 54  
  1     0 0 47  
  0         0  
218 5 50       37 $@ && 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         49 $self->{names}->{$name}->{obj}=$obj;
225 7         53 $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 380 my $self=shift;
241 4         12 my $name=shift;
242              
243 4   66     88 my $desc=$self->{names}->{$name} ||
244             throw $self "embedded - no configuration with such name ($name)";
245 3         50 $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 37 my $self=shift;
258 23         54 my $name=shift;
259 23 100       500 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 77 my $self=shift;
275 3         6 foreach my $name (keys %{$self->{names}}) {
  3         30  
276 2         6 my $obj=$self->{names}->{$name}->{obj};
277 2 100       18 $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 45 my $proto=shift;
291 9         53 my $args=get_args(\@_);
292 9         366 $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__