view release on metacpan or  search on metacpan

lib/Badger/Config/Filesystem.pm  view on Meta::CPAN

}

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 {

lib/Badger/Config/Filesystem.pm  view on Meta::CPAN

    $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);