File Coverage

lib/Badger/Config/Filesystem.pm
Criterion Covered Total %
statement 3 254 1.1
branch 0 74 0.0
condition 0 100 0.0
subroutine 1 30 3.3
pod 16 29 55.1
total 20 487 4.1


line stmt bran cond sub pod time code
1             package Badger::Config::Filesystem;
2              
3             use Badger::Class
4 2         31 version => 0.01,
5             debug => 0,
6             import => 'class',
7             base => 'Badger::Config Badger::Workplace',
8             utils => 'split_to_list extend VFS join_uri resolve_uri',
9             accessors => 'root filespec encoding codecs extensions quiet',
10             words => 'ENCODING CODECS',
11             constants => 'DOT NONE TRUE FALSE YAML JSON UTF8 ARRAY HASH SCALAR',
12             constant => {
13             ABSOLUTE => 'absolute',
14             RELATIVE => 'relative',
15             # extra debugging flags
16             DEBUG_FETCH => 0,
17             },
18             messages => {
19             load_fail => 'Failed to load data from %s: %s',
20             no_config_file => 'Missing configuration file: %s',
21             merge_mismatch => 'Cannot merge items for %s: %s and %s',
22 2     2   1152 };
  2         5  
23              
24             our $EXTENSIONS = [YAML, JSON];
25             our $ENCODING = UTF8;
26             our $CODECS = { };
27             our $STAT_TTL = 0;
28              
29              
30             #-----------------------------------------------------------------------------
31             # Initialisation methods called at object creation time
32             #-----------------------------------------------------------------------------
33              
34             sub init {
35 0     0 1   my ($self, $config) = @_;
36              
37             # First call Badger::Config base class method to handle any 'items'
38             # definitions and other general initialisation
39 0           $self->init_config($config);
40              
41             # Then our own custom init method
42 0           $self->init_filesystem($config);
43             }
44              
45             sub init_filesystem {
46 0     0 1   my ($self, $config) = @_;
47 0           my $class = $self->class;
48              
49 0           $self->debug_data( filesystem_config => $config ) if DEBUG;
50              
51             # The filespec can be specified as a hash of options for file objects
52             # created by the top-level directory object. If unspecified, we construct
53             # it using any encoding option, or falling back on a $ENCODING package
54             # variable. This is then passed to init_workplace().
55             my $encoding = $config->{ encoding }
56 0   0       || $class->any_var(ENCODING);
57              
58             my $filespec = $config->{ filespec } ||= {
59 0   0       encoding => $encoding
60             };
61              
62             # now initialise the workplace root directory
63 0           $self->init_workplace($config);
64              
65             # Configuration files can be in any data format which Badger::Codecs can
66             # handle (e.g. JSON, YAML, etc). The 'extensions' configuration option
67             # and any $EXTENSIONS defined in package variables (for the current class
68             # and all base classes) will be tried in order
69             my $exts = $class->list_vars(
70             EXTENSIONS => $config->{ extensions }
71 0           );
72             $exts = [
73 0           map { @{ split_to_list($_) } }
  0            
  0            
74             @$exts
75             ];
76              
77             # Construct a regex to match any of the above
78 0           my $qm_ext = join('|', map { quotemeta $_ } @$exts);
  0            
79 0           my $ext_re = qr/.($qm_ext)$/i;
80              
81 0           $self->debug(
82             "extensions: ", $self->dump_data($exts), "\n",
83             "extension regex: $ext_re"
84             ) if DEBUG;
85              
86             # The 'codecs' option can provide additional mapping from filename extension
87             # to codec for any that Badger::Codecs can't grok automagically
88             my $codecs = $class->hash_vars(
89             CODECS => $config->{ codecs }
90 0           );
91              
92 0   0       my $data = $config->{ data } || { };
93              
94 0           $self->{ data } = $data;
95 0           $self->{ extensions } = $exts;
96 0           $self->{ match_ext } = $ext_re;
97 0           $self->{ codecs } = $codecs;
98 0           $self->{ encoding } = $encoding;
99 0           $self->{ filespec } = $filespec;
100 0   0       $self->{ quiet } = $config->{ quiet } || FALSE;
101 0   0       $self->{ dir_tree } = $config->{ dir_tree } // TRUE;
102 0   0       $self->{ stat_ttl } = $config->{ stat_ttl } // $data->{ stat_ttl } // $STAT_TTL;
      0        
103 0           $self->{ not_found } = { };
104              
105             # Add any item schemas
106             $self->items( $config->{ schemas } )
107 0 0         if $config->{ schemas };
108              
109             # Configuration file allows further data items (and schemas) to be defined
110             $self->init_file( $config->{ file } )
111 0 0         if $config->{ file };
112              
113 0           return $self;
114             }
115              
116             sub init_file {
117 0     0 0   my ($self, $file) = @_;
118 0           my $data = $self->get($file);
119              
120 0 0         if ($data) {
    0          
121             # must copy data so as not to damage cached version
122 0           $data = { %$data };
123              
124 0           $self->debug(
125             "config file data from $file: ",
126             $self->dump_data($data)
127             ) if DEBUG;
128              
129             # file can contain 'items' or 'schemas' (I don't love this, but it'll do for now)
130             $self->items(
131             delete $data->{ items },
132             delete $data->{ schemas }
133 0           );
134              
135             # anything else is config data
136 0           extend($self->{ data }, $data);
137              
138 0           $self->debug("merged data: ", $self->dump_data($self->{ data })) if DEBUG;
139             }
140             elsif (! $self->{ quiet }) {
141 0           return $self->no_config_file($file);
142             }
143              
144 0           return $self;
145             }
146              
147             sub no_config_file {
148 0     0 0   shift->warn_msg( no_config_file => @_ );
149             }
150              
151              
152             #-----------------------------------------------------------------------------
153             # Redefine head() method in Badger::Config to hook into fetch() to load data
154             #-----------------------------------------------------------------------------
155              
156             sub head {
157 0     0 1   my ($self, $name) = @_;
158 0   0       return $self->{ data }->{ $name }
159             // $self->fetch($name);
160             }
161              
162             sub tail {
163 0     0 1   my ($self, $name, $data) = @_;
164 0           return $data;
165             }
166              
167              
168             #-----------------------------------------------------------------------------
169             # Filesystem-specific fetch methods
170             #-----------------------------------------------------------------------------
171              
172             sub fetch {
173 0     0 1   my ($self, $uri) = @_;
174              
175 0 0         return if $self->previously_not_found($uri);
176              
177 0           $self->debug("fetch($uri)") if DEBUG or DEBUG_FETCH;
178              
179 0           my $file = $self->config_file($uri);
180 0           my $dir = $self->dir($uri);
181 0   0       my $fok = $file && $file->exists;
182 0   0       my $dok = $dir && $dir->exists;
183              
184 0 0         if ($dok) {
185 0           $self->debug("Found directory for $uri, loading tree") if DEBUG or DEBUG_FETCH;
186 0           return $self->config_tree($uri, $file, $dir);
187             }
188              
189 0 0         if ($fok) {
190 0           $self->debug("Found file for $uri, loading file data => ", $file->absolute) if DEBUG or DEBUG_FETCH;
191 0           my $data = $file->try->data;
192 0 0         return $self->error_msg( load_fail => $file => $@ ) if $@;
193 0           return $self->tail(
194             $uri, $data,
195             $self->item_schema_from_data(
196             $uri, $data
197             )
198             );
199             }
200              
201 0           $self->debug("No file or directory found for $uri") if DEBUG or DEBUG_FETCH;
202 0           $self->{ not_found }->{ $uri } = time();
203 0           return undef;
204             }
205              
206             sub previously_not_found {
207 0     0 0   my ($self, $uri) = @_;
208 0   0       my $sttl = $self->{ stat_ttl } || return 0;
209 0   0       my $when = $self->{ not_found }->{ $uri } || return 0;
210             # we maintain the "not_found" status until stat_ttl seconds have elapsed
211 0 0         if (time < $when + $sttl) {
212 0           $self->debug("$uri NOT FOUND at $when") if DEBUG; # or DEBUG_FETCH;
213 0           return 1
214             }
215             else {
216 0           return 0;
217             }
218             }
219              
220             #-----------------------------------------------------------------------------
221             # Tree walking
222             #-----------------------------------------------------------------------------
223              
224             sub config_tree {
225 0     0 1   my $self = shift;
226 0           my $name = shift;
227 0   0       my $file = shift || $self->config_file($name);
228 0   0       my $dir = shift || $self->dir($name);
229 0           my $do_tree = $self->{ dir_tree };
230 0           my $data = undef; #{ };
231 0           my ($file_data, $binder, $more);
232              
233 0 0 0       unless ($file && $file->exists || $dir->exists) {
      0        
234 0           return $self->decline_msg( not_found => 'file or directory' => $name );
235             }
236              
237             # start by looking for a data file
238 0 0 0       if ($file && $file->exists) {
239 0           $file_data = $file->try->data;
240 0 0         return $self->error_msg( load_fail => $file => $@ ) if $@;
241 0           $self->debug("Read metadata from file '$file':", $self->dump_data($file_data)) if DEBUG;
242             }
243              
244             # fetch a schema for this data item constructed from the default schema
245             # specification, any named schema for this item, any arguments, then any
246             # local schema defined in the data file
247 0           my $schema = $self->item_schema_from_data($name, $file_data);
248              
249 0           $self->debug(
250             "combined schema for $name: ",
251             $self->dump_data($schema)
252             ) if DEBUG;
253              
254 0 0         if ($more = $schema->{ tree_type }) {
255 0           $self->debug("schema.tree_type: $more") if DEBUG;
256 0 0         if ($more eq NONE) {
    0          
257 0           $self->debug("schema rules indicate we shouldn't descend into the tree") if DEBUG;
258 0           $do_tree = FALSE;
259             }
260             elsif ($binder = $self->tree_binder($more)) {
261 0           $self->debug("schema rules indicate a $more tree tree") if DEBUG;
262 0           $do_tree = TRUE;
263             }
264             else {
265 0           return $self->error_msg( invalid => tree_type => $more );
266             }
267             }
268              
269 0 0         if ($do_tree) {
270             # merge file data using binder
271 0   0       $data ||= { };
272 0   0       $binder ||= $self->tree_binder('nest');
273 0           $binder->($self, $data, [ ], $file_data, $schema);
274              
275 0 0         if ($dir->exists) {
276             # create a virtual file system rooted on the metadata directory
277             # so that all file paths are resolved relative to it
278 0           my $vfs = VFS->new( root => $dir );
279 0           $self->debug("Reading metadata from dir: ", $dir->name) if DEBUG;
280 0           $self->scan_config_dir($vfs->root, $data, [ ], $schema, $binder);
281             }
282             }
283             else {
284 0           $data = $file_data;
285             }
286              
287 0           $self->debug("$name config: ", $self->dump_data($data)) if DEBUG;
288              
289 0           return $self->tail(
290             $name, $data, $schema
291             );
292             }
293              
294             sub scan_config_dir {
295 0     0 1   my ($self, $dir, $data, $path, $schema, $binder) = @_;
296 0           my $files = $dir->files;
297 0           my $dirs = $dir->dirs;
298 0   0       $path ||= [ ];
299 0   0       $binder ||= $self->tree_binder;
300              
301 0           $self->debug(
302             "scan_config_dir($dir, $data, ",
303             $self->dump_data_inline($path), ", ",
304             $self->dump_data_inline($schema), ", ",
305             $binder, ")"
306             ) if DEBUG;
307              
308 0   0       $data ||= { };
309              
310 0           foreach my $file (@$files) {
311 0 0         next unless $file->name =~ $self->{ match_ext };
312 0           $self->debug("found file: ", $file->name, ' at ', $file->path) if DEBUG;
313 0           $self->scan_config_file($file, $data, $path, $schema, $binder);
314             }
315 0           foreach my $subdir (@$dirs) {
316 0           $self->debug("found dir: ", $subdir->name, ' at ', $subdir->path) if DEBUG;
317             # if we don't have a data binder then we need to create a sub-hash
318 0           my $name = $subdir->name;
319             #my $more = $binder ? $data : ($data->{ $name } = { });
320 0           push(@$path, $name);
321             #$self->scan_config_dir($subdir, $more, $path, $schema, $binder);
322 0           $self->scan_config_dir($subdir, $data, $path, $schema, $binder);
323 0           pop(@$path);
324             }
325             }
326              
327             sub scan_config_file {
328 0     0 1   my ($self, $file, $data, $path, $schema, $binder) = @_;
329 0           my $base = $file->basename;
330 0           my $ext = $file->extension;
331              
332 0           $self->debug(
333             "scan_config_file($file, $data, ",
334             $self->dump_data_inline($path), ", ",
335             $self->dump_data_inline($schema), ", ",
336             $binder, ")"
337             ) if DEBUG;
338              
339             # set the codec to match the extension (or any additional mapping)
340             # and set the data encoding
341 0           $file->codec( $self->codec($ext) );
342 0           $file->encoding( $self->{ encoding } );
343              
344 0           my $meta = $file->try->data;
345 0 0         return $self->error_msg( load_fail => $file => $@ ) if $@;
346              
347 0           $self->debug("Metadata: ", $self->dump_data($meta)) if DEBUG;
348              
349 0 0         if ($binder) {
350 0   0       $path ||= [ ];
351 0           push(@$path, $base);
352 0           $binder->($self, $data, $path, $meta, $schema);
353 0           pop(@$path);
354             }
355             else {
356 0           $base =~ s[^/][];
357 0           $data->{ $base } = $meta;
358             }
359             }
360              
361              
362             #-----------------------------------------------------------------------------
363             # Binder methods for combining multiple data sources (e.g. files in sub-
364             # directories) into a single tree.
365             #-----------------------------------------------------------------------------
366              
367             sub tree_binder {
368 0     0 1   my $self = shift;
369             my $name = shift
370             || $self->{ tree_type }
371 0   0       || return $self->error_msg( missing => 'tree_type' );
372              
373 0   0       return $self->can("${name}_tree_binder")
374             || return $self->decline_msg( invalid => binder => $name );
375             }
376              
377             sub nest_tree_binder {
378 0     0 1   my ($self, $parent, $path, $child, $schema) = @_;
379 0           my $data = $parent;
380 0           my $uri = join('/', @$path);
381 0           my @bits = @$path;
382 0           my $last = pop @bits;
383              
384 0           $self->debug("Adding [$uri] as ", $self->dump_data($child))if DEBUG;
385              
386 0           foreach my $key (@bits) {
387 0   0       $data = $data->{ $key } ||= { };
388             }
389              
390 0 0         if ($last) {
391 0           my $tail = $data->{ $last };
392              
393 0 0         if ($tail) {
394 0   0       my $tref = ref $tail || SCALAR;
395 0   0       my $cref = ref $child || SCALAR;
396              
397 0 0 0       if ($tref eq HASH && $cref eq HASH) {
398 0           $self->debug("Merging into $last") if DEBUG;
399 0           @$tail{ keys %$child } = values %$tail;
400             }
401             else {
402 0           return $self->error_msg( merge_mismatch => $uri, $tref, $cref );
403             }
404             }
405             else {
406 0           $self->debug("setting $last in data to $child") if DEBUG;
407 0           $data->{ $last } = $child;
408             }
409             }
410             else {
411 0           $self->debug("No path, simple merge of child into parent") if DEBUG;
412 0           @$data{ keys %$child } = values %$child;
413             }
414              
415 0           $self->debug("New parent: ", $self->dump_data($parent)) if DEBUG;
416             }
417              
418             sub flat_tree_binder {
419 0     0 1   my ($self, $parent, $path, $child, $schema) = @_;
420              
421 0           while (my ($key, $value) = each %$child) {
422 0           $parent->{ $key } = $value;
423             }
424             }
425              
426             sub join_tree_binder {
427 0     0 1   my ($self, $parent, $path, $child, $schema) = @_;
428 0   0       my $joint = $schema->{ tree_joint } || $self->{ tree_joint };
429 0           my $base = join($joint, @$path);
430              
431 0           $self->debug(
432             "join_binder path is set: ",
433             $self->dump_data($path),
434             "\nnew base is $base"
435             ) if DEBUG;
436              
437             # Similar to the above but this joins items with underscores
438             # e.g. an entry "foo" in site/bar.yaml will become "bar_foo"
439 0           while (my ($key, $value) = each %$child) {
440 0 0         if ($key =~ s/^\///) {
    0          
441             # if the child item has a leading '/' then we want to put it in
442             # the root so we leave $key unchanged
443             }
444             elsif (length $base) {
445             # otherwise the $key is appended onto $base
446 0           $key = join($joint, $base, $key);
447             }
448 0           $parent->{ $key } = $value;
449             }
450             }
451              
452             sub uri_tree_binder {
453 0     0 1   my ($self, $parent, $path, $child, $schema) = @_;
454 0   0       my $opt = $schema->{ uri_paths } || $self->{ uri_paths };
455 0           my $base = join_uri(@$path);
456              
457 0           $self->debug("uri_paths option: $opt") if DEBUG;
458              
459 0           $self->debug(
460             "uri_binder path is set: ",
461             $self->dump_data($path),
462             "\nnew base is $base"
463             ) if DEBUG;
464              
465             # This resolves base items as URIs relative to the parent
466             # e.g. an entry "foo" in the site/bar.yaml file will be stored in the parent
467             # site as "bar/foo", but an entry "/bam" will be stored as "/bam" because
468             # it's an absolute URI rather than a relative one (relative to the $base)
469 0           while (my ($key, $value) = each %$child) {
470 0 0         my $uri = $base ? resolve_uri($base, $key) : $key;
471 0 0         if ($opt) {
472 0           $uri = $self->fix_uri_path($uri, $opt);
473             }
474 0           $parent->{ $uri } = $value;
475 0           $self->debug(
476             "loaded metadata for [$base] + [$key] = [$uri]"
477             ) if DEBUG;
478             }
479             }
480              
481             sub fix_uri_path {
482 0     0 0   my ($self, $uri, $option) = @_;
483              
484 0   0       $option ||= $self->{ uri_paths } || return $uri;
      0        
485              
486 0 0         if ($option eq 'absolute') {
    0          
487 0           $self->debug("setting absolute URI path") if DEBUG;
488 0 0         $uri = "/$uri" unless $uri =~ /^\//;
489             }
490             elsif ($option eq 'relative') {
491 0           $self->debug("setting relative URI path") if DEBUG;
492 0           $uri =~ s/^\///;
493             }
494             else {
495 0           return $self->error_msg( invalid => 'uri_paths option' => $option );
496             }
497              
498 0           return $uri;
499             }
500              
501             #-----------------------------------------------------------------------------
502             # Internal methods
503             #-----------------------------------------------------------------------------
504              
505             sub config_file {
506 0     0 1   my ($self, $name) = @_;
507              
508 0   0       return $self->{ config_file }->{ $name }
509             ||= $self->find_config_file($name);
510             }
511              
512             sub config_file_data {
513 0     0 1   my $self = shift;
514 0   0       my $file = $self->config_file(@_) || return;
515 0           my $data = $file->try->data;
516 0 0         return $self->error_msg( load_fail => $file => $@ ) if $@;
517 0           return $data;
518             }
519              
520             sub config_filespec {
521 0     0 1   my $self = shift;
522 0           my $defaults = $self->{ filespec };
523              
524             return @_
525 0 0         ? extend({ }, $defaults, @_)
526             : { %$defaults };
527             }
528              
529             sub find_config_file {
530 0     0 0   my ($self, $name) = @_;
531 0           my $root = $self->root;
532 0           my $exts = $self->extensions;
533              
534 0           foreach my $ext (@$exts) {
535 0           my $path = $name.DOT.$ext;
536 0           my $file = $self->file($path);
537 0 0         if ($file->exists) {
538 0           $file->codec($self->codec($ext));
539 0           return $file;
540             }
541             }
542 0           return $self->decline_msg(
543             not_found => file => $name
544             );
545             }
546              
547             sub write_config_file {
548 0     0 0   my ($self, $name, $data) = @_;
549 0           my $root = $self->root;
550 0           my $exts = $self->extensions;
551 0           my $ext = $exts->[0];
552 0           my $path = $name.DOT.$ext;
553 0           my $file = $self->file($path);
554              
555 0           $file->codec($self->codec($ext));
556 0           $file->data($data);
557 0           return $file;
558             }
559              
560              
561             sub codec {
562 0     0 0   my ($self, $name) = @_;
563 0   0       return $self->codecs->{ $name }
564             || $name;
565             }
566              
567              
568             #-----------------------------------------------------------------------------
569             # item schema management
570             #-----------------------------------------------------------------------------
571              
572             sub items {
573             return extend(
574             shift->{ item },
575             @_
576 0     0 0   );
577             }
578              
579             sub item {
580 0     0 0   my ($self, $name) = @_;
581              
582 0           $self->debug_data("looking for $name in items: ", $self->{ item }) if DEBUG;
583              
584 0   0       return $self->{ item }->{ $name }
585             ||= $self->lookup_item($name);
586             }
587              
588             sub lookup_item {
589             # hook for subclasses
590 0     0 0   return undef;
591             }
592              
593             sub item_schema {
594 0     0 0   my ($self, $name, $schema) = @_;
595 0           my $data = $self->item($name);
596              
597 0           if (DEBUG) {
598             $self->debug_data("$name item schema data: ", $data);
599             $self->debug_data("$name file schema: ", $schema);
600             }
601              
602 0 0         if ($schema) {
603 0           $data = extend({ }, $data, $schema);
604             }
605              
606             # the schema we got may have been for a parent via lookup_item.
607 0           $self->{ item }->{ $name } = $data;
608 0           $self->debug_data("set new item $name data", $data) if DEBUG;
609              
610 0           return $data;
611             }
612              
613             sub item_schema_from_data {
614 0     0 0   my ($self, $name, $data) = @_;
615 0           my $more;
616              
617 0 0 0       if ($data && ref $data eq HASH) {
618             # In the event that someone needs to store a 'schema' item in the *real*
619             # configuration data, we look for '_schema_' first and delete that,
620             # leaving 'schema' untouched
621             $more = delete $data->{_schema_}
622 0   0       || delete $data->{ schema };
623             }
624 0           return$self->item_schema($name, $more);
625             }
626              
627              
628              
629             sub has_item {
630 0     0 0   my $self = shift->prototype;
631 0           my $name = shift;
632 0           my $item = $self->{ item }->{ $name };
633              
634             # This is all the same as in the base class up to the final test which
635             # looks for $self->config_file($name) as a last-ditch attempt
636              
637 0 0         if (defined $item) {
638             # A 1/0 entry in the item tells us if an item categorically does or
639             # doesn't exist in the config data set (or allowable set - it might
640             # be a valid configuration option that simply hasn't been set yet)
641 0           return $item;
642             }
643             else {
644             # Otherwise the existence (or not) of an item in the data set is
645             # enough to satisfy us one way or another
646             return 1
647 0 0         if exists $self->{ data }->{ $name };
648              
649             # Special case for B::C::Filesystem which looks to see if there's a
650             # matching config file. We cache the existence in $self->{ item }
651             # so we know if it's there (or not) for next time
652 0           return $self->{ item }->{ $name }
653             = $self->config_file($name);
654             }
655             }
656              
657              
658             1;
659              
660             __END__