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

package Badger::Config::Filesystem;

use Badger::Class
    version   => 0.01,
    debug     => 0,
    import    => 'class',
    base      => 'Badger::Config Badger::Workplace',
    utils     => 'split_to_list extend VFS join_uri resolve_uri',
    accessors => 'root filespec encoding codecs extensions quiet',
    words     => 'ENCODING CODECS',
    constants => 'DOT NONE TRUE FALSE YAML JSON UTF8 ARRAY HASH SCALAR',
    constant  => {
        ABSOLUTE => 'absolute',
        RELATIVE => 'relative',
        # extra debugging flags
        DEBUG_FETCH => 0,
    },
    messages  => {
        load_fail      => 'Failed to load data from %s: %s',
        no_config_file => 'Missing configuration file: %s',
        merge_mismatch => 'Cannot merge items for %s: %s and %s',
    };

our $EXTENSIONS = [YAML, JSON];
our $ENCODING   = UTF8;
our $CODECS     = { };
our $STAT_TTL   = 0;


#-----------------------------------------------------------------------------
# Initialisation methods called at object creation time
#-----------------------------------------------------------------------------

sub init {
    my ($self, $config) = @_;

    # First call Badger::Config base class method to handle any 'items'
    # definitions and other general initialisation
    $self->init_config($config);

    # Then our own custom init method
    $self->init_filesystem($config);
}

sub init_filesystem {
    my ($self, $config) = @_;
    my $class = $self->class;

    $self->debug_data( filesystem_config => $config ) if DEBUG;

    # The filespec can be specified as a hash of options for file objects
    # created by the top-level directory object.  If unspecified, we construct
    # it using any encoding option, or falling back on a $ENCODING package
    # variable.  This is then passed to init_workplace().
    my $encoding = $config->{ encoding }
                || $class->any_var(ENCODING);

    my $filespec = $config->{ filespec } ||= {
        encoding => $encoding
    };

    # now initialise the workplace root directory
    $self->init_workplace($config);

    # Configuration files can be in any data format which Badger::Codecs can
    # handle (e.g. JSON, YAML, etc).  The 'extensions' configuration option
    # and any $EXTENSIONS defined in package variables (for the current class
    # and all base classes) will be tried in order
    my $exts = $class->list_vars(
        EXTENSIONS => $config->{ extensions }
    );
    $exts = [
        map { @{ split_to_list($_) } }
        @$exts
    ];

    # Construct a regex to match any of the above
    my $qm_ext = join('|', map { quotemeta $_ } @$exts);
    my $ext_re = qr/.($qm_ext)$/i;

    $self->debug(
        "extensions: ", $self->dump_data($exts), "\n",
        "extension regex: $ext_re"
    ) if DEBUG;

    # The 'codecs' option can provide additional mapping from filename extension
    # to codec for any that Badger::Codecs can't grok automagically
    my $codecs = $class->hash_vars(
        CODECS => $config->{ codecs }
    );

    my $data = $config->{ data } || { };

    $self->{ data       } = $data;
    $self->{ extensions } = $exts;
    $self->{ match_ext  } = $ext_re;
    $self->{ codecs     } = $codecs;
    $self->{ encoding   } = $encoding;
    $self->{ filespec   } = $filespec;
    $self->{ quiet      } = $config->{ quiet    } || FALSE;
    $self->{ dir_tree   } = $config->{ dir_tree } // TRUE;
    $self->{ stat_ttl   } = $config->{ stat_ttl } // $data->{ stat_ttl } // $STAT_TTL;
    $self->{ not_found  } = { };

    # Add any item schemas
    $self->items( $config->{ schemas } )
        if $config->{ schemas };

    # Configuration file allows further data items (and schemas) to be defined
    $self->init_file( $config->{ file } )
        if $config->{ file };

    return $self;
}

sub init_file {
    my ($self, $file) = @_;
    my $data = $self->get($file);

    if ($data) {
        # must copy data so as not to damage cached version
        $data = { %$data };

        $self->debug(
            "config file data from $file: ",
            $self->dump_data($data)
        ) if DEBUG;

        # file can contain 'items' or 'schemas' (I don't love this, but it'll do for now)
        $self->items(
            delete $data->{ items   },
            delete $data->{ schemas }
        );

        # anything else is config data
        extend($self->{ data }, $data);

        $self->debug("merged data: ", $self->dump_data($self->{ data })) if DEBUG;
    }
    elsif (! $self->{ quiet }) {
        return $self->no_config_file($file);
    }

    return $self;
}

sub no_config_file {
    shift->warn_msg( no_config_file => @_ );
}


#-----------------------------------------------------------------------------
# Redefine head() method in Badger::Config to hook into fetch() to load data
#-----------------------------------------------------------------------------

sub head {
    my ($self, $name) = @_;
    return $self->{ data }->{ $name }
        // $self->fetch($name);
}

sub tail {
    my ($self, $name, $data) = @_;
    return $data;
}


#-----------------------------------------------------------------------------
# Filesystem-specific fetch methods
#-----------------------------------------------------------------------------

sub fetch {
    my ($self, $uri) = @_;

    return if $self->previously_not_found($uri);

    $self->debug("fetch($uri)") if DEBUG or DEBUG_FETCH;

    my $file = $self->config_file($uri);
    my $dir  = $self->dir($uri);
    my $fok  = $file && $file->exists;
    my $dok  = $dir  && $dir->exists;

    if ($dok) {
        $self->debug("Found directory for $uri, loading tree") if DEBUG or DEBUG_FETCH;
        return $self->config_tree($uri, $file, $dir);
    }

    if ($fok) {
        $self->debug("Found file for $uri, loading file data => ", $file->absolute) if DEBUG or DEBUG_FETCH;
        my $data = $file->try->data;
        return $self->error_msg( load_fail => $file => $@ ) if $@;
        return $self->tail(
            $uri, $data,
            $self->item_schema_from_data(
                $uri, $data
            )
        );
    }

    $self->debug("No file or directory found for $uri") if DEBUG or DEBUG_FETCH;
    $self->{ not_found }->{ $uri } = time();
    return undef;
}

sub previously_not_found {
    my ($self, $uri) = @_;
    my $sttl = $self->{ stat_ttl } || return 0;
    my $when = $self->{ not_found }->{ $uri } || return 0;
    # we maintain the "not_found" status until stat_ttl seconds have elapsed
    if (time < $when + $sttl) {
        $self->debug("$uri NOT FOUND at $when") if DEBUG; # or DEBUG_FETCH;
        return 1
    }
    else {
        return 0;
    }
}

#-----------------------------------------------------------------------------
# Tree walking
#-----------------------------------------------------------------------------

sub config_tree {
    my $self    = shift;
    my $name    = shift;
    my $file    = shift || $self->config_file($name);
    my $dir     = shift || $self->dir($name);
    my $do_tree = $self->{ dir_tree };
    my $data    = undef; #{ };
    my ($file_data, $binder, $more);

    unless ($file && $file->exists || $dir->exists) {
        return $self->decline_msg( not_found => 'file or directory' => $name );
    }

    # start by looking for a data file
    if ($file && $file->exists) {
        $file_data = $file->try->data;
        return $self->error_msg( load_fail => $file => $@ ) if $@;
        $self->debug("Read metadata from file '$file':", $self->dump_data($file_data)) if DEBUG;
    }

    # fetch a schema for this data item constructed from the default schema
    # specification, any named schema for this item, any arguments, then any
    # local schema defined in the data file
    my $schema = $self->item_schema_from_data($name, $file_data);

    $self->debug(
        "combined schema for $name: ",
        $self->dump_data($schema)
    ) if DEBUG;

    if ($more = $schema->{ tree_type }) {
        $self->debug("schema.tree_type: $more") if DEBUG;
        if ($more eq NONE) {
            $self->debug("schema rules indicate we shouldn't descend into the tree") if DEBUG;
            $do_tree = FALSE;
        }
        elsif ($binder = $self->tree_binder($more)) {
            $self->debug("schema rules indicate a $more tree tree") if DEBUG;
            $do_tree = TRUE;
        }
        else {
            return $self->error_msg( invalid => tree_type => $more );
        }
    }

    if ($do_tree) {
        # merge file data using binder
        $data   ||= { };
        $binder ||= $self->tree_binder('nest');
        $binder->($self, $data, [ ], $file_data, $schema);

        if ($dir->exists) {
            # create a virtual file system rooted on the metadata directory
            # so that all file paths are resolved relative to it
            my $vfs = VFS->new( root => $dir );
            $self->debug("Reading metadata from dir: ", $dir->name) if DEBUG;
            $self->scan_config_dir($vfs->root, $data, [ ], $schema, $binder);
        }
    }
    else {
        $data = $file_data;
    }

    $self->debug("$name config: ", $self->dump_data($data)) if DEBUG;

    return $self->tail(
        $name, $data, $schema
    );
}

sub scan_config_dir {
    my ($self, $dir, $data, $path, $schema, $binder) = @_;
    my $files  = $dir->files;
    my $dirs   = $dir->dirs;
    $path   ||= [ ];
    $binder ||= $self->tree_binder;

    $self->debug(
        "scan_config_dir($dir, $data, ",
        $self->dump_data_inline($path), ", ",
        $self->dump_data_inline($schema), ", ",
        $binder, ")"
    ) if DEBUG;

    $data ||= { };

    foreach my $file (@$files) {
        next unless $file->name =~ $self->{ match_ext };
        $self->debug("found file: ", $file->name, ' at ', $file->path) if DEBUG;
        $self->scan_config_file($file, $data, $path, $schema, $binder);
    }
    foreach my $subdir (@$dirs) {
        $self->debug("found dir: ", $subdir->name, ' at ', $subdir->path) if DEBUG;
        # if we don't have a data binder then we need to create a sub-hash
        my $name = $subdir->name;
        #my $more = $binder ? $data : ($data->{ $name } = { });
        push(@$path, $name);
        #$self->scan_config_dir($subdir, $more, $path, $schema, $binder);
        $self->scan_config_dir($subdir, $data, $path, $schema, $binder);
        pop(@$path);
    }
}

sub scan_config_file {
    my ($self, $file, $data, $path, $schema, $binder) = @_;
    my $base = $file->basename;
    my $ext  = $file->extension;

    $self->debug(
        "scan_config_file($file, $data, ",
        $self->dump_data_inline($path), ", ",
        $self->dump_data_inline($schema), ", ",
        $binder, ")"
    ) if DEBUG;

    # set the codec to match the extension (or any additional mapping)
    # and set the data encoding
    $file->codec( $self->codec($ext) );
    $file->encoding( $self->{ encoding } );

    my $meta = $file->try->data;
    return $self->error_msg( load_fail => $file => $@ ) if $@;

    $self->debug("Metadata: ", $self->dump_data($meta)) if DEBUG;

    if ($binder) {
        $path ||= [ ];
        push(@$path, $base);
        $binder->($self, $data, $path, $meta, $schema);
        pop(@$path);
    }
    else {
        $base =~ s[^/][];
        $data->{ $base } = $meta;
    }
}


#-----------------------------------------------------------------------------
# Binder methods for combining multiple data sources (e.g. files in sub-
# directories) into a single tree.
#-----------------------------------------------------------------------------

sub tree_binder {
    my $self = shift;
    my $name = shift
        || $self->{ tree_type }
        || return $self->error_msg( missing => 'tree_type' );

    return $self->can("${name}_tree_binder")
        || return $self->decline_msg( invalid => binder => $name );
}

sub nest_tree_binder {
    my ($self, $parent, $path, $child, $schema) = @_;
    my $data = $parent;
    my $uri  = join('/', @$path);
    my @bits = @$path;
    my $last = pop @bits;

    $self->debug("Adding [$uri] as ", $self->dump_data($child))if DEBUG;

    foreach my $key (@bits) {
        $data = $data->{ $key } ||= { };
    }

    if ($last) {
        my $tail = $data->{ $last };

        if ($tail) {
            my $tref = ref $tail  || SCALAR;
            my $cref = ref $child || SCALAR;

            if ($tref eq HASH && $cref eq HASH) {
                $self->debug("Merging into $last") if DEBUG;
                @$tail{ keys %$child } = values %$tail;
            }
            else {
                return $self->error_msg( merge_mismatch => $uri, $tref, $cref );
            }
        }
        else {
            $self->debug("setting $last in data to $child") if DEBUG;
            $data->{ $last } = $child;
        }
    }
    else {
        $self->debug("No path, simple merge of child into parent") if DEBUG;
        @$data{ keys %$child } = values %$child;
    }

    $self->debug("New parent: ", $self->dump_data($parent)) if DEBUG;
}

sub flat_tree_binder {
    my ($self, $parent, $path, $child, $schema) = @_;

    while (my ($key, $value) = each %$child) {
        $parent->{ $key } = $value;
    }
}

sub join_tree_binder {
    my ($self, $parent, $path, $child, $schema) = @_;
    my $joint = $schema->{ tree_joint } || $self->{ tree_joint };
    my $base  = join($joint, @$path);

    $self->debug(
        "join_binder path is set: ",
        $self->dump_data($path),
        "\nnew base is $base"
    ) if DEBUG;

    # Similar to the above but this joins items with underscores
    # e.g. an entry "foo" in site/bar.yaml will become "bar_foo"
    while (my ($key, $value) = each %$child) {
        if ($key =~ s/^\///) {
            # if the child item has a leading '/' then we want to put it in
            # the root so we leave $key unchanged
        }
        elsif (length $base) {
            # otherwise the $key is appended onto $base
            $key = join($joint, $base, $key);
        }
        $parent->{ $key } = $value;
    }
}

sub uri_tree_binder {
    my ($self, $parent, $path, $child, $schema) = @_;
    my $opt  = $schema->{ uri_paths } || $self->{ uri_paths };
    my $base = join_uri(@$path);

    $self->debug("uri_paths option: $opt") if DEBUG;

    $self->debug(
        "uri_binder path is set: ",
        $self->dump_data($path),
        "\nnew base is $base"
    ) if DEBUG;

    # This resolves base items as URIs relative to the parent
    # e.g. an entry "foo" in the site/bar.yaml file will be stored in the parent
    # site as "bar/foo", but an entry "/bam" will be stored as "/bam" because
    # it's an absolute URI rather than a relative one (relative to the $base)
    while (my ($key, $value) = each %$child) {
        my $uri = $base ? resolve_uri($base, $key) : $key;
        if ($opt) {
            $uri = $self->fix_uri_path($uri, $opt);
        }
        $parent->{ $uri } = $value;
        $self->debug(
            "loaded metadata for [$base] + [$key] = [$uri]"
        ) if DEBUG;
    }
}

sub fix_uri_path {
    my ($self, $uri, $option) = @_;

    $option ||= $self->{ uri_paths } || return $uri;

    if ($option eq 'absolute') {
        $self->debug("setting absolute URI path") if DEBUG;
        $uri = "/$uri" unless $uri =~ /^\//;
    }
    elsif ($option eq 'relative') {
        $self->debug("setting relative URI path") if DEBUG;
        $uri =~ s/^\///;
    }
    else {
        return $self->error_msg( invalid => 'uri_paths option' => $option );
    }

    return $uri;
}

#-----------------------------------------------------------------------------
# Internal methods
#-----------------------------------------------------------------------------

sub config_file {
    my ($self, $name) = @_;

    return  $self->{ config_file }->{ $name }
        ||= $self->find_config_file($name);
}

sub config_file_data {
    my $self = shift;
    my $file = $self->config_file(@_) || return;
    my $data = $file->try->data;
    return $self->error_msg( load_fail => $file => $@ ) if $@;
    return $data;
}

sub config_filespec {
    my $self     = shift;
    my $defaults = $self->{ filespec };

    return @_
        ? extend({ }, $defaults, @_)
        : { %$defaults };
}

sub find_config_file {
    my ($self, $name) = @_;
    my $root = $self->root;
    my $exts = $self->extensions;

    foreach my $ext (@$exts) {
        my $path = $name.DOT.$ext;
        my $file = $self->file($path);
        if ($file->exists) {
            $file->codec($self->codec($ext));
            return $file;
        }
    }
    return $self->decline_msg(
        not_found => file => $name
    );
}

sub write_config_file {
    my ($self, $name, $data) = @_;
    my $root = $self->root;
    my $exts = $self->extensions;
    my $ext  = $exts->[0];
    my $path = $name.DOT.$ext;
    my $file = $self->file($path);

    $file->codec($self->codec($ext));
    $file->data($data);
    return $file;
}


sub codec {
    my ($self, $name) = @_;
    return $self->codecs->{ $name }
        || $name;
}


#-----------------------------------------------------------------------------
# item schema management
#-----------------------------------------------------------------------------

sub items {
    return extend(
        shift->{ item },
        @_
    );
}

sub item {
    my ($self, $name) = @_;

    $self->debug_data("looking for $name in items: ", $self->{ item }) if DEBUG;

    return  $self->{ item }->{ $name }
        ||= $self->lookup_item($name);
}

sub lookup_item {
    # hook for subclasses
    return undef;
}

sub item_schema {
    my ($self, $name, $schema) = @_;
    my $data = $self->item($name);

    if (DEBUG) {
        $self->debug_data("$name item schema data: ", $data);
        $self->debug_data("$name file schema: ", $schema);
    }

    if ($schema) {
        $data = extend({ }, $data, $schema);
    }

    # the schema we got may have been for a parent via lookup_item.
    $self->{ item }->{ $name } = $data;
    $self->debug_data("set new item $name data", $data) if DEBUG;

    return $data;
}

sub item_schema_from_data {
    my ($self, $name, $data) = @_;
    my $more;

    if ($data && ref $data eq HASH) {
        # In the event that someone needs to store a 'schema' item in the *real*
        # configuration data, we look for '_schema_' first and delete that,
        # leaving 'schema' untouched
        $more = delete $data->{_schema_}
             || delete $data->{ schema };
    }
    return$self->item_schema($name, $more);
}



sub has_item {
    my $self = shift->prototype;
    my $name = shift;
    my $item = $self->{ item }->{ $name };

    # This is all the same as in the base class up to the final test which
    # looks for $self->config_file($name) as a last-ditch attempt

    if (defined $item) {
        # A 1/0 entry in the item tells us if an item categorically does or
        # doesn't exist in the config data set (or allowable set - it might
        # be a valid configuration option that simply hasn't been set yet)
        return $item;
    }
    else {
        # Otherwise the existence (or not) of an item in the data set is
        # enough to satisfy us one way or another
        return 1
            if exists $self->{ data }->{ $name };

        # Special case for B::C::Filesystem which looks to see if there's a
        # matching config file.  We cache the existence in $self->{ item }
        # so we know if it's there (or not) for next time
        return $self->{ item }->{ $name }
            =  $self->config_file($name);
    }
}


1;

__END__