Config::Tree::Base - Base class for Config::Tree classes

 # Moose-speak
 extends 'Config::Tree::Base';

package Config::Tree::Base;

use Moose;

use Data::Schema;

has name => (is => 'rw');

has ro => (is => 'ro', default => 1);
has modified => (is => 'rw', default => 0);
has when_invalid => (is => 'rw', default => 'die');
has validator => (is => 'rw', default => sub { Data::Schema->new() } );
has cwd => (is => 'rw', default => '/');
has dirstack => (is => 'rw', default => sub { [] });

has schema => (is => 'rw');

has include_path_re => (is => 'rw');
has exclude_path_re => (is => 'rw');

sub get_tree_for {
    my ($self, $wanted_path) = @_;

    # default implementation
    my ($tree, $mtime) = $self->_get_tree;
    $self->_validate_tree($tree, '/');
    ('/', $tree, $mtime);
}

sub _validate_tree {
    my ($self, $tree, $path) = @_;
    return 1 unless $self->schema && $tree;
    #use Data::Dumper; $Data::Dumper::Terse=1; print "_validate_tree: tree=".Dumper($tree).", schema=".Dumper($self->schema)."\n";
    my $res = $self->validator->validate($tree, $self->schema);
    return 1 if $res->{success};
    if ($self->when_invalid eq 'quiet') {
        return 0;
    } else {
        my $msg = $self->_format_validation_error($res, $path);
        if ($self->when_invalid eq 'warn') {
            warn $msg;
        } else {
            #print $msg;
            die $msg;
        }
    }
}

sub save {
    my ($self) = @_;
    die "save: config is read only!" if $self->ro;
    return unless $self->modified;
    $self->_save;
    $self->modified(0);
}

sub getcwd {
    my ($self) = @_;
    $self->cwd;
}

sub pushd {
    my ($self, $new_dir) = @_;
    push @{ $self->dirstack }, $self->cwd;
    $self->cd($new_dir) if defined($new_dir);
}

sub popd {
    my ($self) = @_;
    my $p = pop @{ $self->dirstack };
    die "popd: too many pops" unless defined($p);
    $self->cwd($p);
}

sub cd {
    my ($self, $path) = @_;
    die "cd: path must be speficied" unless $path;
    $self->cwd($self->normalize_path($path));
}

sub normalize_path {
    my ($self, $path) = @_;
    die "normalize_path: path must be string" if ref($path);

    my @p1;
    push @p1, (grep {length} split m!/+!, $self->cwd) unless $path =~ m!^/!;
    push @p1, (grep {length} split m!/+!, $path);
    my @p2;
    # eliminate .. and .
    for (@p1) {
        if ($_ eq '..') { pop @p2 } elsif ($_ eq '.') {} else { push @p2, $_ }
    }
    "/" . join("/", @p2);
}

sub get {
    my ($self, $path) = @_;
    my @res = $self->_get_with_key($path);
    return unless @res;
    die "BUG: _get_with_key doesn't return a 2-element list" unless @res == 2;
    $res[1];
}

# instead of just returning $val, returns a list ($key, $val) where $key is the
# key of the last branch (which might contain prefix).

sub _get_with_key {
    my ($self, $path) = @_;
    $path = $self->normalize_path($path);
    return if $self->path_is_excluded($path);
    my ($tree_path, $tree, $mtime) = $self->get_tree_for($path);
    return unless defined($tree);
    die "get: cannot get config tree for `$path`, got `$tree_path`" unless index($path, $tree_path) == 0;
    my $curpath = $tree_path eq '/' ? '' : $tree_path;
    my $key = "";
    for (grep {length} split m!/+!, substr($path, length($tree_path))) {
        $curpath .= "/$_";
        #use Data::Dumper; print "get($path): $curpath: tree=",Dumper($tree),"\n";
        return if $self->path_is_excluded($curpath);
        if (ref($tree) eq 'HASH') {
            for my $prefix ("", "*", "-", "+", ".", "^", "!") {
                $key = "$prefix$_";
                last if defined($tree->{$key});
            }
            $tree = $tree->{$key};
        } elsif (ref($tree) eq 'ARRAY' && /^\d+$/) {
            $key = $_;
            $tree = $tree->[$_];
        } else {
            return;
        }
    }
    ($key, $tree);
    # XXX clone?
}

sub path_is_excluded {
    my ($self, $p) = @_;
    if ($self->include_path_re && $p !~ $self->include_path_re) {
        #print "$p is not included (".$self->include_path_re.")\n";
        return 1;
    }
    if ($self->exclude_path_re && $p =~ $self->exclude_path_re) {
        #print "$p is excluded (".$self->exclude_path_re.")\n";
        return 1;
    }
    0;
}

sub _set_or_unset_in_tree {
    my ($self, $tree, $path, $is_set, $val) = @_;

    my @path = grep {length} split m!/+!, $self->normalize_path($path);
    die "_set_in_tree: cannot set value for /" unless @path;
    my $n = pop @path;
    my $supertree;
    #print "set($path): ";
    for (my $i=0; $i<@path; $i++) {
        #print " >> $path[$i] ";
        if (ref($tree) eq 'HASH') {
            $supertree = $tree;
            $tree = $tree->{$path[$i]};
        } elsif (ref($tree) eq 'ARRAY' && /^\d+$/) {
            $supertree = $tree;
            $tree = $tree->[$path[$i]];
        } else {
            $tree = {};
            if (ref($supertree) eq 'ARRAY') {
                $supertree->[$path[$i-1]] = { $path[$i] => $tree };
            } else {
                $supertree->{$path[$i-1]} = { $path[$i] => $tree };
            }
        }
    }
    #print "\n";
    my $oldval;
    if (ref($tree) eq 'HASH') {
        $oldval = $tree->{$n};
        if ($is_set) { $tree->{$n} = $val } else { delete $tree->{$n} }
    } elsif (ref($tree) eq 'ARRAY' && $n =~ /^\d+$/) {
        $oldval = $tree->[$n];
        if ($is_set) { $tree->[$n] = $val } else { splice @{ $tree }, $n, 1 }
    } else {
        die "BUG: _set_in_tree: can't set /".join("/", @path, $n).": nonexisting hash/array";
    }
    $oldval;
}

sub _set_or_unset {
    my ($self, $path, $is_set, $val) = @_;
    die "_set_or_unset: config is read-only!" if $self->ro;

    # default implementation: modify retrieved tree (from _get_tree) directly
    my ($tree, $mtime) = $self->_get_tree;
    return unless defined($tree);
    my $oldval = $self->_set_or_unset_in_tree($tree, $path, $is_set, $val);
    $self->modified(1);
    $oldval;
}

sub set {
    my ($self, $path, $val) = @_;
    $self->_set_or_unset($path, 1, $val);
}

sub unset {
    my ($self, $path) = @_;
    $self->_set_or_unset($path, 0);
}

__PACKAGE__->meta->make_immutable;
1;