Data::Hierarchy - Handle data in a hierarchical structure

    my $tree = Data::Hierarchy->new();
    $tree->store ('/', {access => 'all'});
    $tree->store ('/private', {access => 'auth',
                               '.note' => 'this is private});

    $info = $tree->get ('/private/somewhere/deep');

    # return actual data points in list context
    ($info, @fromwhere) = $tree->get ('/private/somewhere/deep');

    my @items = $tree->find ('/', {access => qr/.*/});

    # override all children
    $tree->store ('/', {'.note' => undef}, {override_sticky_descendents => 1});

    $tree->store('/some/path', {color => 'red'});

    print $tree->get('/some/path/below/that')->{'color'};
    # prints red

    $tree->store('/some/path', {'.color' => 'blue'});
    print $tree->get('/some/path')->{'.color'};            # prints blue
    print $tree->get('/some/path/below/that')->{'.color'}; # undefined

package Data::Hierarchy;
$VERSION = '0.34';
use strict;
use Storable qw(dclone);
# XXX consider using Moose

sub new {
    my $class = shift;
    my %args = (
                sep => '/',
                @_);

    my $self = bless {}, $class;
    $self->{sep} = $args{sep};
    $self->{hash} = {};
    $self->{sticky} = {};
    return $self;
}

sub store {
    my $self = shift;
    $self->_store_no_cleanup(@_);
    $self->_remove_redundant_properties_and_undefs($_[0]);
}

# Internal method.
#
# Does everything that store does, except for the cleanup at the
# end (appropriate for use in e.g. merge, which calls this a bunch of
# times and then does cleanup at the end).

sub _store_no_cleanup {
    my $self = shift;
    my $path = shift;
    my $props = shift;
    my $opts = shift || {};

    $self->_path_safe ($path);

    my %args = (
               override_descendents => 1,
               override_sticky_descendents => 0,
                %$opts);

    $self->_remove_matching_properties_recursively($path, $props, $self->{hash})
      if $args{override_descendents};
    $self->_remove_matching_properties_recursively($path, $props, $self->{sticky})
      if $args{override_sticky_descendents};
    $self->_store ($path, $props);
}

sub get {
    my ($self, $path, $dont_clone) = @_;
    $self->_path_safe ($path);
    my $value = {};

    my @datapoints = $self->_ancestors($self->{hash}, $path);

    for (@datapoints) {
	my $newv = $self->{hash}{$_};
	$newv = dclone $newv unless $dont_clone;
	$value = {%$value, %$newv};
    }
    if (exists $self->{sticky}{$path}) {
	my $newv = $self->{sticky}{$path};
	$newv = dclone $newv unless $dont_clone;
	$value = {%$value, %$newv}
    }
    return wantarray ? ($value, @datapoints) : $value;
}

sub find {
    my ($self, $path, $prop_regexps) = @_;
    $self->_path_safe ($path);
    my @items;
    my @datapoints = $self->_all_descendents($path);

    for my $subpath (@datapoints) {
	my $matched = 1;
	for (keys %$prop_regexps) {
	    my $lookat = (index($_, '.') == 0) ?
		$self->{sticky}{$subpath} : $self->{hash}{$subpath};
	    $matched = 0
		unless exists $lookat->{$_}
			&& $lookat->{$_} =~ m/$prop_regexps->{$_}/;
	    last unless $matched;
	}
	push @items, $subpath
	    if $matched;
    }
    return @items;
}

sub merge {
    my ($self, $other, $path) = @_;
    $self->_path_safe ($path);

    my %datapoints = map {$_ => 1} ($self->_all_descendents ($path),
				    $other->_all_descendents ($path));
    for my $datapoint (sort keys %datapoints) {
	my $my_props = $self->get ($datapoint, 1);
	my $other_props = $other->get ($datapoint);
	for (keys %$my_props) {
	    $other_props->{$_} = undef
		unless defined $other_props->{$_};
	}
	$self->_store_no_cleanup ($datapoint, $other_props);
    }

    $self->_remove_redundant_properties_and_undefs;
}

sub to_relative {
    my $self = shift;
    my $base_path = shift;

    return Data::Hierarchy::Relative->new($base_path, %$self);
}

# Internal method.
#
# Dies if the given path has a trailing slash and is not the root.  If it is root,
# destructively changes the path given as argument to the empty string.

sub _path_safe {
    # Have to do this explicitly on the elements of @_ in order to be destructive
    if ($_[1] eq $_[0]->{sep}) {
        $_[1] = '';
        return;
    }

    my $self = shift;
    my $path = shift;

    my $location_of_last_separator = rindex($path, $self->{sep});
    return if $location_of_last_separator == -1;

    my $potential_location_of_trailing_separator = (length $path) - (length $self->{sep});

    return unless $location_of_last_separator == $potential_location_of_trailing_separator;

    require Carp;
    Carp::confess('non-root path has a trailing slash!');
}

# Internal method.
#
# Actually does property updates (to hash or sticky, depending on name).

sub _store {
    my ($self, $path, $new_props) = @_;

    my $old_props = exists $self->{hash}{$path} ? $self->{hash}{$path} : undef;
    my $merged_props = {%{$old_props||{}}, %$new_props};
    for (keys %$merged_props) {
	if (index($_, '.') == 0) {
	    defined $merged_props->{$_} ?
		$self->{sticky}{$path}{$_} = $merged_props->{$_} :
		delete $self->{sticky}{$path}{$_};
	    delete $merged_props->{$_};
	}
	else {
	    delete $merged_props->{$_}
		unless defined $merged_props->{$_};
	}
    }

    $self->{hash}{$path} = $merged_props;
}

# Internal method.
#
# Given a hash (probably $self->{hash}, $self->{sticky}, or their union),
# returns a sorted list of the paths with data that are ancestors of the given
# path (including it itself).

sub _ancestors {
    my ($self, $hash, $path) = @_;

    my @ancestors;
    push @ancestors, '' if exists $hash->{''};

    # Special case the root.
    return @ancestors if $path eq '';

    my @parts = split m{\Q$self->{sep}}, $path;
    # Remove empty string at the front.
    my $current = '';
    unless (length $parts[0]) {
	shift @parts;
	$current .= $self->{sep};
    }

    for my $part (@parts) {
        $current .= $part;
        push @ancestors, $current if exists $hash->{$current};
        $current .= $self->{sep};
    }

    # XXX: could build cached pointer for fast traversal
    return @ancestors;
}

# Internal method.
#
# Given a hash (probably $self->{hash}, $self->{sticky}, or their union),
# returns a sorted list of the paths with data that are descendents of the given
# path (including it itself).

sub _descendents {
    my ($self, $hash, $path) = @_;

    # If finding for everything, don't bother grepping
    return sort keys %$hash unless length($path);

    return sort grep {index($_.$self->{sep}, $path.$self->{sep}) == 0}
	keys %$hash;
}

# Internal method.
#
# Returns a sorted list of all of the paths which currently have any
# properties (sticky or not) that are descendents of the given path
# (including it itself).
#
# (Note that an arg of "/f" can return entries "/f" and "/f/g" but not
# "/foo".)

sub _all_descendents {
    my ($self, $path) = @_;
    $self->_path_safe ($path);

    my $both = {%{$self->{hash}}, %{$self->{sticky} || {}}};

    return $self->_descendents($both, $path);
}

# Internal method.
#
# Given a path, a hash reference of properties, and a hash reference
# (presumably {hash} or {sticky}), removes all properties from the
# hash at the path or its descendents with the same name as a name in
# the given property hash. (The values in the property hash are
# ignored.)

sub _remove_matching_properties_recursively {
    my ($self, $path, $remove_props, $hash) = @_;

    my @datapoints = $self->_descendents ($hash, $path);

    for my $datapoint (@datapoints) {
	delete $hash->{$datapoint}{$_} for keys %$remove_props;
	delete $hash->{$datapoint} unless %{$hash->{$datapoint}};
    }
}

# Internal method.
#
# Returns the parent of a path; this is a purely textual operation, and is not necessarily a datapoint.
# Do not pass in the root.

sub _parent {
    my $self = shift;
    my $path = shift;

    return if $path eq q{} or $path eq $self->{sep};

    # For example, say $path is "/foo/bar/baz";
    # then $last_separator is 8.
    my $last_separator = rindex($path, $self->{sep});

    # This happens if a path is passed in without a leading
    # slash. This is really a bug, but old version of
    # SVK::Editor::Status did this, and we might as well make it not
    # throw unintialized value errors, since it works otherwise. At
    # some point in the future this should be changed to a plain
    # "return" or an exception.
    return '' if $last_separator == -1;

    return substr($path, 0, $last_separator);
}

# Internal method.
#
# Cleans up the hash and sticky by removing redundant properties,
# undef properties, and empty property hashes.

sub _remove_redundant_properties_and_undefs {
    my $self = shift;
    my $prefix = shift;
    # This is not necessarily the most efficient way to implement this
    # cleanup, but that can be fixed later.

    # By sorting the keys, we guarantee that we never get to a path
    # before we've dealt with all of its ancestors.
    for my $path (sort keys %{$self->{hash}}) {
        next if $prefix && index($prefix.$self->{sep}, $path.$self->{sep}) != 0;
        my $props = $self->{hash}{$path};

        # First check for undefs.
        for my $name (keys %$props) {
            if (not defined $props->{$name}) {
                delete $props->{$name};
            }
        }

        # Now check for redundancy.

        # The root can't be redundant.
        if (length $path) {
            my $parent = $self->_parent($path);

            my $parent_props = $self->get($parent, 1);

            for my $name (keys %$props) {
                # We've already dealt with undefs in $props, so we
                # don't need to check that for defined.
                if (defined $parent_props->{$name} and
                    $props->{$name} eq $parent_props->{$name}) {
                    delete $props->{$name};
                }
            }
        }

        # Clean up empty property hashes.
        delete $self->{hash}{$path} unless %{ $self->{hash}{$path} };
    }

    for my $path (sort keys %{$self->{sticky}}) {
        # We only have to remove undefs from sticky, since there is no
        # inheritance.
        my $props = $self->{sticky}{$path};

        for my $name (keys %$props) {
            if (not defined $props->{$name}) {
                delete $props->{$name};
            }
        }

        # Clean up empty property hashes.
        delete $self->{sticky}{$path} unless %{ $self->{sticky}{$path} };
    }
}

# These are for backwards compatibility only.

sub store_recursively { my $self = shift; $self->store(@_, {override_sticky_descendents => 1}); }
sub store_fast        { my $self = shift; $self->store(@_, {override_descendents => 0}); }
sub store_override    { my $self = shift; $self->store(@_, {override_descendents => 0}); }

package Data::Hierarchy::Relative;

sub new {
    my $class = shift;
    my $base_path = shift;

    my %args = @_;

    my $self = bless { sep => $args{sep} }, $class;

    my $base_length = length $base_path;

    for my $item (qw/hash sticky/) {
        my $original = $args{$item};
        my $result = {};

        for my $path (sort keys %$original) {
            unless ($path eq $base_path or index($path, $base_path . $self->{sep}) == 0) {
                require Carp;
                Carp::confess("$path is not a child of $base_path");
            }
            my $relative_path = substr($path, $base_length);
            $result->{$relative_path} = $original->{$path};
        }

        $self->{$item} = $result;
    }

    return $self;
}

sub to_absolute {
    my $self = shift;
    my $base_path = shift;

    my $tree = { sep => $self->{sep} };

    for my $item (qw/hash sticky/) {
        my $original = $self->{$item};
        my $result = {};

        for my $path (keys %$original) {
            $result->{$base_path . $path} = $original->{$path};
        }

        $tree->{$item} = $result;
    }

    bless $tree, 'Data::Hierarchy';

    return $tree;
}

1;