File Coverage

lib/Badger/Workspace.pm
Criterion Covered Total %
statement 3 130 2.3
branch 0 28 0.0
condition 0 37 0.0
subroutine 1 30 3.3
pod 17 28 60.7
total 21 253 8.3


line stmt bran cond sub pod time code
1             package Badger::Workspace;
2              
3             use Badger::Class
4 1         11 version => 0.01,
5             debug => 0,
6             base => 'Badger::Workplace',
7             import => 'class',
8             utils => 'params self_params Filter',
9             accessors => 'config_dir',
10             constants => 'ARRAY HASH SLASH DELIMITER NONE BLANK',
11             constant => {
12             # configuration directory and file
13             CONFIG_MODULE => 'Badger::Config::Filesystem',
14             CONFIG_DIR => 'config',
15             CONFIG_FILE => 'workspace',
16             DIRS => 'dirs',
17             SHARE => 'share', # parent to child
18             INHERIT => 'inherit', # child from parent
19             MERGE => 'merge', # child from parent with merging
20 1     1   552 };
  1         2  
21              
22              
23             #-----------------------------------------------------------------------------
24             # Initialisation methods
25             #-----------------------------------------------------------------------------
26              
27             sub init {
28 0     0 1   my ($self, $config) = @_;
29 0           $self->init_workplace($config);
30 0           $self->init_workspace($config);
31 0           return $self;
32             }
33              
34             sub init_workspace {
35 0     0 1   my ($self, $config) = @_;
36              
37             # Initialise any parent connection and bootstrap the configuration manager
38 0           $self->init_parent($config);
39 0           $self->init_config($config);
40              
41             # Everything after this point reads configuration values from the config
42             # object which includes $config above and also allows local configuration
43             # files to provide further configuration data.
44 0           $self->init_dirs;
45              
46 0           return $self;
47             }
48              
49             sub init_parent {
50 0     0 1   my ($self, $config) = @_;
51 0           $self->{ parent } = delete $config->{ parent };
52             #$self->attach(delete $config->{ parent });
53 0           return $self;
54             }
55              
56             sub init_config {
57 0     0 1   my ($self, $config) = @_;
58             my $conf_mod = (
59             delete $config->{ config_module }
60 0   0       || $self->CONFIG_MODULE
61             );
62             my $conf_dir = $self->dir(
63             delete $config->{ config_dir }
64             || delete $config->{ config_directory }
65 0   0       || $self->CONFIG_DIR
66             );
67             my $conf_file = (
68             delete $config->{ config_file }
69 0   0       || $self->CONFIG_FILE
70             );
71 0           my $parent = $self->parent;
72 0   0       my $pconfig = $parent && $parent->config;
73             my $schemas = $self->class->hash_vars(
74             SCHEMAS => $config->{ schemas }
75 0           );
76              
77             #$self->debug("parent config: ", $self->dump_data($pconfig));
78              
79             # load the configuration module
80 0           class($conf_mod)->load;
81              
82             # config directory
83 0           $self->{ config_dir } = $conf_dir;
84              
85             # config directory manager
86             $self->{ config } = $conf_mod->new(
87             uri => $self->config_uri,
88             parent => $pconfig,
89             data => $config,
90             directory => $conf_dir,
91             file => $conf_file,
92             quiet => $config->{ quiet },
93 0           schemas => $schemas,
94             );
95              
96 0           return $self;
97             }
98              
99             sub init_inheritance_NOT_USED {
100 0     0 0   my $self = shift;
101             # Nope, I'm going to keep this simple for now.
102             #$self->init_filter(SHARE);
103             #$self->init_filter(INHERIT);
104             #$self->init_filter(MERGE);
105 0           return $self;
106             }
107              
108             sub init_filter_NOT_USED {
109 0     0 0   my ($self, $name) = @_;
110 0           my $config = $self->config($name);
111              
112 0 0         if (! ref $config) {
    0          
113             # $config can be a single word like 'all' or 'none', or a shorthand
114             # specification string, e.g. foo +bar -baz
115 0           $config = {
116             accept => $config
117             };
118             }
119             elsif (ref $config ne HASH) {
120             # $config can be a reference to a list of items to include
121 0           $config = {
122             include => $config
123             };
124             }
125             # otherwise $config must be a HASH ref
126              
127             $self->debug(
128 0           "$self->{ uri } $name filter spec: ",
129             $self->dump_data($config),
130             ) if DEBUG;
131              
132 0           $self->{ $name } = Filter($config);
133              
134 0           $self->debug("$self $name filter: ", $self->{ $name }) if DEBUG;
135              
136 0           return $self;
137             }
138              
139              
140             sub init_dirs {
141 0     0 1   my $self = shift;
142 0   0       my $dirs = $self->config(DIRS) || return;
143 0           $self->dirs($dirs);
144 0           return $self;
145             }
146              
147              
148              
149             #-----------------------------------------------------------------------------
150             # Delegate method to fetch config data from the config object
151             #-----------------------------------------------------------------------------
152              
153             sub config {
154 0     0 1   my $self = shift;
155 0           my $config = $self->{ config };
156 0 0         return $config unless @_;
157 0   0       return $config->get(@_)
158             // $self->parent_config(@_);
159             }
160              
161             sub parent_config {
162 0     0 1   my $self = shift;
163 0   0       my $parent = $self->{ parent } || return;
164 0           return $parent->config(@_);
165             }
166              
167             sub config_uri {
168 0     0 0   shift->uri;
169             }
170              
171             sub share_config_NOT_USED {
172 0     0 0   my $self = shift;
173              
174 0 0         if ($self->can_share(@_)) {
175 0           $self->debug("$self->{ uri } can share $_[0]") if DEBUG;
176 0           return $self->config(@_);
177             }
178 0           elsif (DEBUG) {
179             $self->debug("$self->{ uri } cannot share $_[0]");
180             }
181 0           return undef;
182             }
183              
184             sub inherit_config_NOT_USED {
185 0     0 0   my $self = shift;
186 0   0       my $parent = $self->{ parent } || return undef;
187              
188 0 0         if ($self->can_inherit(@_)) {
189 0           $self->debug("$self->{ uri } can inherit $_[0]") if DEBUG;
190 0           return $parent->share_config(@_);
191             }
192 0           elsif (DEBUG) {
193             $self->debug("$self->{ uri } cannot inherit $_[0]");
194             }
195 0           return undef;
196             }
197              
198             sub can_share_NOT_USED {
199 0     0 0   shift->can_filter(SHARE, @_);
200             }
201              
202             sub can_inherit_NOT_USED {
203 0     0 0   shift->can_filter(INHERIT, @_);
204             }
205              
206             sub can_filter_NOT_USED {
207 0     0 0   my ($self, $type, $name) = @_;
208 0   0       my $filter = $self->{ $type } || return;
209 0           $self->debug("$self filter for [$type] is $filter") if DEBUG;
210 0           return $filter->item_accepted($name);
211             }
212              
213             sub write_config_file {
214 0     0 1   shift->config->write_config_file(@_);
215             }
216              
217             #-----------------------------------------------------------------------------
218             # A 'dirs' config file can provide mappings for local workspace directories in
219             # case that they're not 1:1, e.g. images => resource/images
220             #-----------------------------------------------------------------------------
221              
222             sub dir {
223 0     0 1   my $self = shift;
224              
225             return @_
226 0 0         ? $self->resolve_dir(@_)
227             : $self->root;
228             }
229              
230             sub dirs {
231 0     0 1   my $self = shift;
232 0   0       my $dirs = $self->{ dirs } ||= { };
233              
234 0 0         if (@_) {
235             # resolve all new directories relative to workspace directory
236 0           my $root = $self->root;
237 0           my $addin = params(@_);
238              
239 0           while (my ($key, $value) = each %$addin) {
240 0           my $subdir = $root->dir($value);
241             # I think for now we're just going to store the directory...
242 0           $dirs->{ $key } = $subdir;
243             # ...it's becoming really difficult to work with inheritance because
244             # child workspaces must always have all directories specifed by a
245             # parent
246             #if ($subdir->exists) {
247             # $dirs->{ $key } = $subdir;
248             #}
249             #else {
250             # return $self->error_msg(
251             # invalid => "directory for $key" => $value
252             # );
253             #}
254             }
255             $self->debug(
256 0           "set dirs: ",
257             $self->dump_data($dirs)
258             ) if DEBUG;
259             }
260              
261 0           return $dirs;
262             }
263              
264             sub resolve_dir {
265 0     0 1   my ($self, @path) = @_;
266 0           my $dirs = $self->dirs;
267 0           my $path = join(SLASH, @path);
268 0           my @pair = split(SLASH, $path, 2);
269 0           my $head = $pair[0];
270 0           my $tail = $pair[1];
271 0           my $alias;
272              
273 0           $self->debug_data( dirs => $dirs ) if DEBUG;
274              
275 0           $self->debug(
276             "[HEAD:$head] [TAIL:", $tail // BLANK, "]"
277             ) if DEBUG;
278              
279             # the first element of a directory path can be an alias defined in dirs
280 0 0         if ($alias = $dirs->{ $head }) {
281 0           $self->debug(
282             "resolve_dir($path) => [HEAD:$head=$alias] + [TAIL:",
283             $tail // BLANK, "]"
284             ) if DEBUG;
285 0 0         return defined($tail)
286             ? $alias->dir($tail)
287             : $alias;
288             }
289              
290             $self->debug(
291 0           "resolving: ", $self->dump_data(\@path)
292             ) if DEBUG;
293              
294 0           return $self->root->dir(@path);
295             }
296              
297             sub file {
298 0     0 1   my ($self, @path) = @_;
299 0 0 0       my $opts = @path && ref $path[-1] eq 'HASH' ? pop(@path) : { };
300 0           my $path = join(SLASH, @path);
301 0           my @bits = split(SLASH, $path);
302 0           my $file = pop(@bits);
303              
304 0 0         if (@bits) {
305 0           return $self->dir(@bits)->file($file, $opts);
306             }
307             else {
308 0           return $self->dir->file($file, $opts);
309             }
310             }
311              
312              
313              
314             #-----------------------------------------------------------------------------
315             # Workspaces can be attached to parent workspaces.
316             #-----------------------------------------------------------------------------
317              
318             sub attach {
319 0     0 1   my ($self, $parent) = @_;
320 0           $self->{ parent } = $parent;
321             }
322              
323             sub detach {
324 0     0 1   my $self = shift;
325 0           delete $self->{ parent };
326             }
327              
328             sub parent {
329 0     0 1   my $self = shift;
330 0   0       my $n = shift || 0;
331 0   0       my $rent = $self->{ parent } || return;
332 0 0         return $n
333             ? $rent->parent(--$n)
334             : $rent;
335             }
336              
337             sub ancestors {
338 0     0 1   my $self = shift;
339 0   0       my $list = shift || [ ];
340 0           push(@$list, $self);
341             return $self->{ parent }
342 0 0         ? $self->{ parent }->ancestors($list)
343             : $list;
344             }
345              
346             sub heritage {
347 0     0 1   my $self = shift;
348 0           my $ancs = $self->ancestors;
349 0           return [ reverse @$ancs ];
350             }
351              
352             #-----------------------------------------------------------------------------
353             # Methods to create a sub-workspace attached to the current one
354             #-----------------------------------------------------------------------------
355              
356             sub subspace {
357 0     0 0   my ($self, $params) = self_params(@_);
358 0           my $class = $self->subspace_module($params);
359              
360 0           $params->{ parent } = $self;
361              
362 0 0         if ($DEBUG) {
363 0           $self->debug("subspace() class: $class");
364 0           $self->debug("subspace() params: ", $self->dump_data($params));
365             }
366              
367 0           class($class)->load->instance($params);
368             }
369              
370             sub subspace_module {
371 0     0 0   my ($self, $params) = self_params(@_);
372 0   0       return ref $self || $self;
373             }
374              
375              
376             #-----------------------------------------------------------------------------
377             # Cleanup methods
378             #-----------------------------------------------------------------------------
379              
380             sub destroy {
381 0     0 0   my $self = shift;
382 0           $self->detach;
383             }
384              
385             sub DESTROY {
386 0     0     shift->destroy;
387             }
388              
389             1;
390              
391             __END__