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

package Badger::Workspace;

use Badger::Class
    version     => 0.01,
    debug       => 0,
    base        => 'Badger::Workplace',
    import      => 'class',
    utils       => 'params self_params Filter',
    accessors   => 'config_dir',
    constants   => 'ARRAY HASH SLASH DELIMITER NONE BLANK',
    constant    => {
        # configuration directory and file
        CONFIG_MODULE  => 'Badger::Config::Filesystem',
        CONFIG_DIR     => 'config',
        CONFIG_FILE    => 'workspace',
        DIRS           => 'dirs',
        SHARE          => 'share',      # parent to child
        INHERIT        => 'inherit',    # child from parent
        MERGE          => 'merge',      # child from parent with merging
    };


#-----------------------------------------------------------------------------
# Initialisation methods
#-----------------------------------------------------------------------------

sub init {
    my ($self, $config) = @_;
    $self->init_workplace($config);
    $self->init_workspace($config);
    return $self;
}

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

    # Initialise any parent connection and bootstrap the configuration manager
    $self->init_parent($config);
    $self->init_config($config);

    # Everything after this point reads configuration values from the config
    # object which includes $config above and also allows local configuration
    # files to provide further configuration data.
    $self->init_dirs;

    return $self;
}

sub init_parent {
    my ($self, $config) = @_;
    $self->{ parent } = delete $config->{ parent };
    #$self->attach(delete $config->{ parent });
    return $self;
}

sub init_config {
    my ($self, $config) = @_;
    my $conf_mod  = (
            delete $config->{ config_module }
        ||  $self->CONFIG_MODULE
    );
    my $conf_dir  = $self->dir(
            delete $config->{ config_dir       }
        ||  delete $config->{ config_directory }
        ||  $self->CONFIG_DIR
    );
    my $conf_file = (
            delete $config->{ config_file }
        ||  $self->CONFIG_FILE
    );
    my $parent  = $self->parent;
    my $pconfig = $parent && $parent->config;
    my $schemas = $self->class->hash_vars(
        SCHEMAS => $config->{ schemas }
    );

    #$self->debug("parent config: ", $self->dump_data($pconfig));

    # load the configuration module
    class($conf_mod)->load;

    # config directory
    $self->{ config_dir } = $conf_dir;

    # config directory manager
    $self->{ config } = $conf_mod->new(
        uri       => $self->config_uri,
        parent    => $pconfig,
        data      => $config,
        directory => $conf_dir,
        file      => $conf_file,
        quiet     => $config->{ quiet },
        schemas   => $schemas,
    );

    return $self;
}

sub init_inheritance_NOT_USED {
    my $self = shift;
    # Nope, I'm going to keep this simple for now.
    #$self->init_filter(SHARE);
    #$self->init_filter(INHERIT);
    #$self->init_filter(MERGE);
    return $self;
}

sub init_filter_NOT_USED {
    my ($self, $name) = @_;
    my $config = $self->config($name);

    if (! ref $config) {
        # $config can be a single word like 'all' or 'none', or a shorthand
        # specification string, e.g. foo +bar -baz
        $config = {
            accept => $config
        };
    }
    elsif (ref $config ne HASH) {
        # $config can be a reference to a list of items to include
        $config = {
            include => $config
        };
    }
    # otherwise $config must be a HASH ref

    $self->debug(
        "$self->{ uri } $name filter spec: ",
        $self->dump_data($config),
    ) if DEBUG;

    $self->{ $name } = Filter($config);

    $self->debug("$self $name filter: ", $self->{ $name }) if DEBUG;

    return $self;
}


sub init_dirs {
    my $self = shift;
    my $dirs = $self->config(DIRS) || return;
    $self->dirs($dirs);
    return $self;
}



#-----------------------------------------------------------------------------
# Delegate method to fetch config data from the config object
#-----------------------------------------------------------------------------

sub config {
    my $self   = shift;
    my $config = $self->{ config };
    return $config unless @_;
    return $config->get(@_)
        // $self->parent_config(@_);
}

sub parent_config {
    my $self   = shift;
    my $parent = $self->{ parent } || return;
    return $parent->config(@_);
}

sub config_uri {
    shift->uri;
}

sub share_config_NOT_USED {
    my $self   = shift;

    if ($self->can_share(@_)) {
        $self->debug("$self->{ uri } can share $_[0]") if DEBUG;
        return $self->config(@_);
    }
    elsif (DEBUG) {
        $self->debug("$self->{ uri } cannot share $_[0]");
    }
    return undef;
}

sub inherit_config_NOT_USED {
    my $self   = shift;
    my $parent = $self->{ parent } || return undef;

    if ($self->can_inherit(@_)) {
        $self->debug("$self->{ uri } can inherit $_[0]") if DEBUG;
        return $parent->share_config(@_);
    }
    elsif (DEBUG) {
        $self->debug("$self->{ uri } cannot inherit $_[0]");
    }
    return undef;
}

sub can_share_NOT_USED {
    shift->can_filter(SHARE, @_);
}

sub can_inherit_NOT_USED {
    shift->can_filter(INHERIT, @_);
}

sub can_filter_NOT_USED {
    my ($self, $type, $name) = @_;
    my $filter = $self->{ $type } || return;
    $self->debug("$self filter for [$type] is $filter") if DEBUG;
    return $filter->item_accepted($name);
}

sub write_config_file {
    shift->config->write_config_file(@_);
}

#-----------------------------------------------------------------------------
# A 'dirs' config file can provide mappings for local workspace directories in
# case that they're not 1:1, e.g. images => resource/images
#-----------------------------------------------------------------------------

sub dir {
    my $self = shift;

    return @_
        ? $self->resolve_dir(@_)
        : $self->root;
}

sub dirs {
    my $self = shift;
    my $dirs = $self->{ dirs } ||= { };

    if (@_) {
        # resolve all new directories relative to workspace directory
        my $root  = $self->root;
        my $addin = params(@_);

        while (my ($key, $value) = each %$addin) {
            my $subdir = $root->dir($value);
            # I think for now we're just going to store the directory...
            $dirs->{ $key } = $subdir;
            # ...it's becoming really difficult to work with inheritance because
            # child workspaces must always have all directories specifed by a
            # parent
            #if ($subdir->exists) {
            #    $dirs->{ $key } = $subdir;
            #}
            #else {
            #    return $self->error_msg(
            #        invalid => "directory for $key" => $value
            #    );
            #}
        }
        $self->debug(
            "set dirs: ",
            $self->dump_data($dirs)
        ) if DEBUG;
    }

    return $dirs;
}

sub resolve_dir {
    my ($self, @path) = @_;
    my $dirs = $self->dirs;
    my $path = join(SLASH, @path);
    my @pair = split(SLASH, $path, 2);
    my $head = $pair[0];
    my $tail = $pair[1];
    my $alias;

    $self->debug_data( dirs => $dirs ) if DEBUG;

    $self->debug(
        "[HEAD:$head] [TAIL:", $tail // BLANK, "]"
    ) if DEBUG;

    # the first element of a directory path can be an alias defined in dirs
    if ($alias = $dirs->{ $head }) {
        $self->debug(
            "resolve_dir($path) => [HEAD:$head=$alias] + [TAIL:",
            $tail // BLANK, "]"
        ) if DEBUG;
        return defined($tail)
            ? $alias->dir($tail)
            : $alias;
    }

    $self->debug(
        "resolving: ", $self->dump_data(\@path)
    ) if DEBUG;

    return $self->root->dir(@path);
}

sub file {
    my ($self, @path) = @_;
    my $opts = @path && ref $path[-1] eq 'HASH' ? pop(@path) : { };
    my $path = join(SLASH, @path);
    my @bits = split(SLASH, $path);
    my $file = pop(@bits);

    if (@bits) {
        return $self->dir(@bits)->file($file, $opts);
    }
    else {
        return $self->dir->file($file, $opts);
    }
}



#-----------------------------------------------------------------------------
# Workspaces can be attached to parent workspaces.
#-----------------------------------------------------------------------------

sub attach {
    my ($self, $parent) = @_;
    $self->{ parent } = $parent;
}

sub detach {
    my $self = shift;
    delete $self->{ parent };
}

sub parent {
    my $self = shift;
    my $n    = shift || 0;
    my $rent = $self->{ parent } || return;
    return $n
        ? $rent->parent(--$n)
        : $rent;
}

sub ancestors {
    my $self = shift;
    my $list = shift || [ ];
    push(@$list, $self);
    return $self->{ parent }
        ?  $self->{ parent }->ancestors($list)
        :  $list;
}

sub heritage {
    my $self = shift;
    my $ancs = $self->ancestors;
    return [ reverse @$ancs ];
}

#-----------------------------------------------------------------------------
# Methods to create a sub-workspace attached to the current one
#-----------------------------------------------------------------------------

sub subspace {
    my ($self, $params) = self_params(@_);
    my $class = $self->subspace_module($params);

    $params->{ parent } = $self;

    if ($DEBUG) {
        $self->debug("subspace() class: $class");
        $self->debug("subspace() params: ", $self->dump_data($params));
    }

    class($class)->load->instance($params);
}

sub subspace_module {
    my ($self, $params) = self_params(@_);
    return ref $self || $self;
}


#-----------------------------------------------------------------------------
# Cleanup methods
#-----------------------------------------------------------------------------

sub destroy {
    my $self = shift;
    $self->detach;
}

sub DESTROY {
    shift->destroy;
}

1;

__END__