commit perl-Data-Hierarchy

Hello community, here is the log from the commit of package perl-Data-Hierarchy checked in at Mon Sep 18 13:13:40 CEST 2006. -------- --- perl-Data-Hierarchy/perl-Data-Hierarchy.changes 2006-01-25 21:39:37.000000000 +0100 +++ perl-Data-Hierarchy/perl-Data-Hierarchy.changes 2006-09-18 12:58:43.000000000 +0200 @@ -1,0 +2,8 @@ +Mon Sep 18 04:22:26 CEST 2006 - lmuelle@suse.de + +- Update to version 0.31. + - Fix a test assuming hash key orders. + - Big rewrite, simplifying the API and documenting everything. + - Added to_relative (to help with SVK floating checkouts). + +------------------------------------------------------------------- Old: ---- Data-Hierarchy-0.21.tar.gz New: ---- Data-Hierarchy-0.31.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ perl-Data-Hierarchy.spec ++++++ --- /var/tmp/diff_new_pack.6Y6Hvd/_old 2006-09-18 13:09:03.000000000 +0200 +++ /var/tmp/diff_new_pack.6Y6Hvd/_new 2006-09-18 13:09:04.000000000 +0200 @@ -1,11 +1,11 @@ # -# spec file for package perl-Data-Hierarchy (Version 0.21) +# spec file for package perl-Data-Hierarchy (Version 0.31) # -# Copyright (c) 2005 SUSE LINUX Products GmbH, Nuernberg, Germany. +# Copyright (c) 2006 SUSE LINUX Products GmbH, Nuernberg, Germany. # This file and all modifications and additions to the pristine # package are under the same license as the package itself. # -# Please submit bugfixes or comments via http://www.suse.de/feedback/ +# Please submit bugfixes or comments via http://bugs.opensuse.org/ # # norootforbuild @@ -17,8 +17,8 @@ Requires: perl = %{perl_version} Autoreqprov: on Summary: Handle data in a hierarchical structure -Version: 0.21 -Release: 2 +Version: 0.31 +Release: 1 Source: http://cpan.org/modules/by-module/Data/Data-Hierarchy-%{version}.tar.gz BuildRoot: %{_tmppath}/%{name}-%{version}-build @@ -57,6 +57,11 @@ /var/adm/perl-modules/%{name} %changelog -n perl-Data-Hierarchy +* Mon Sep 18 2006 - lmuelle@suse.de +- Update to version 0.31. +- Fix a test assuming hash key orders. +- Big rewrite, simplifying the API and documenting everything. +- Added to_relative (to help with SVK floating checkouts). * Wed Jan 25 2006 - mls@suse.de - converted neededforbuild to BuildRequires * Wed Feb 16 2005 - schwab@suse.de ++++++ Data-Hierarchy-0.21.tar.gz -> Data-Hierarchy-0.31.tar.gz ++++++ diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/Data-Hierarchy-0.21/CHANGES new/Data-Hierarchy-0.31/CHANGES --- old/Data-Hierarchy-0.21/CHANGES 2004-11-10 14:46:04.000000000 +0100 +++ new/Data-Hierarchy-0.31/CHANGES 2006-09-07 22:21:05.000000000 +0200 @@ -1,3 +1,13 @@ +[Changes for 0.31 - Sep 7, 2006] + +* Fix a test assuming hash key orders. + +[Changes for 0.30 - Jul 25, 2006] + +* Big rewrite, simplifying the API and documenting everything. + +* Added to_relative (to help with SVK floating checkouts). + [Changes for 0.21 - Nov 10, 2004] * fix store_recursively for empty key, which should find diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/Data-Hierarchy-0.21/Hierarchy.pm new/Data-Hierarchy-0.31/Hierarchy.pm --- old/Data-Hierarchy-0.21/Hierarchy.pm 2004-11-10 14:39:29.000000000 +0100 +++ new/Data-Hierarchy-0.31/Hierarchy.pm 2006-09-07 22:20:39.000000000 +0200 @@ -1,7 +1,8 @@ package Data::Hierarchy; -$VERSION = '0.21'; +$VERSION = '0.31'; use strict; -use Clone qw(clone); +use Storable qw(dclone); +# XXX consider using Moose =head1 NAME @@ -12,7 +13,7 @@ my $tree = Data::Hierarchy->new(); $tree->store ('/', {access => 'all'}); $tree->store ('/private', {access => 'auth', - '.sticky' => 'this is private}); + '.note' => 'this is private}); $info = $tree->get ('/private/somewhere/deep'); @@ -22,232 +23,537 @@ my @items = $tree->find ('/', {access => qr/.*/}); # override all children - $tree->store_recursively ('/', {access => 'all'}); - - my $hashref = $tree->dump; + $tree->store ('/', {'.note' => undef}, {override_sticky_descendents => 1}); =head1 DESCRIPTION -Data::Hierarchy provides a simple interface for manipulating +LData::Hierarchy provides a simple interface for manipulating inheritable data attached to a hierarchical environment (like -filesystem). +a filesystem). + +One use of LData::Hierarchy is to allow an application to annotate +paths in a real filesystem in a single compact data +structure. However, the hierarchy does not actually need to correspond +to an actual filesystem. + +Paths in a hierarchy are referred to in a Unix-like syntax; C<"/"> is +the root "directory". (You can specify a different separator character +than the slash when you construct a Data::Hierarchy object.) With the +exception of the root path, paths should never contain trailing +slashes. You can associate properties, which are arbitrary name/value +pairs, with any path. (Properties cannot contain the undefined value.) +By default, properties are inherited by child +paths: thus, if you store some data at C: + + $tree->store('/some/path', {color => 'red'}); + +you can fetch it again at a C: + + print $tree->get('/some/path/below/that')->{'color'}; + # prints red + +On the other hand, properties whose names begin with dots are +uninherited, or "sticky": + + $tree->store('/some/path', {'.color' => 'blue'}); + print $tree->get('/some/path')->{'.color'}; # prints blue + print $tree->get('/some/path/below/that')->{'.color'}; # undefined + +Note that you do not need to (and in fact, cannot) explicitly add +"files" or "directories" to the hierarchy; you simply add and delete +properties to paths. + +=cut + +=head1 CONSTRUCTOR + +Creates a new hierarchy object. Takes the following options: + +=over + +=item sep + +The string used as a separator between path levels. Defaults to '/'. + +=back =cut sub new { my $class = shift; - # allow shorthand of ->new({...}) to mean ->new(hash => {...}) - unshift @_, 'hash' if @_ % 2; - - my $self = bless {@_}, $class; - $self->{sep} ||= '/'; - $self->{hash} ||= {}; - $self->{sticky} ||= {}; + my %args = ( + sep => '/', + @_); + + my $self = bless {}, $class; + $self->{sep} = $args{sep}; + $self->{hash} = {}; + $self->{sticky} = {}; return $self; } -sub key_safe { - if (length ($_[1]) > 1 and rindex($_[1], $_[0]->{sep}) == length ($_[1])) { - require Carp; - Carp::confess('key unsafe'); - } - $_[1] =~ s/\Q$_[0]->{sep}\E+$//; +=head1 METHODS + +=head2 Instance Methods + +=over + +=cut + +=item C + +Given a path and a hash reference of properties, stores the properties +at the path. + +Unless the C option is given with a false value, +it eliminates any non-sticky property in a descendent of C<$path> with +the same name. + +If the C option is given with a true +value, it eliminates any sticky property in a descendent of C<$path> +with the same name. override it. + +A value of undef removes that value; note, though, that +if an ancestor of C<$path> defines that property, the ancestor's value +will be inherited there; that is, with: + + $t->store('/a', {k => 'top'}); + $t->store('/a/b', {k => 'bottom'}); + $t->store('/a/b', {k => undef}); + print $t->get('/a/b')->{'k'}; + +it will print 'top'. + +=cut + +sub store { + my $self = shift; + $self->_store_no_cleanup(@_); + $self->_remove_redundant_properties_and_undefs; +} + +# 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); +} + +=item C + +Given a path, looks up all of the properteies (sticky and not) and +returns them in a hash reference. The values are clones, unless you +pass a true value for C<$dont_clone>. + +If called in list context, returns that hash reference followed by all +of the ancestral paths of C<$path> which contain non-sticky properties +(possibly including itself). + +=cut + +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; +} + +=item C + +Given a path and a hash reference of name/regular expression pairs, +returns a list of all paths which are descendents of C<$path> +(including itself) and define B<at that path itself> (not inherited) +all of the properties in the hash with values matching the given +regular expressions. (You may want to use C to merely see if +it has any value defined there.) Properties can be sticky or not. + +=cut + +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; +} + +=item C + +Given a second LData::Hierarchy object and a path, copies all the +properties from the other object at C<$path> or below into the +corresponding paths in the object this method is invoked on. All +properties from the object this is invoked on at C<$path> or below are +erased first. + +=cut + +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); + 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; +} + +=item C + +Given a path which B<every> element of the hierarchy must be contained +in, returns a special Data::Hierarchy::Relative object which +represents the hierarchy relative that path. The B<only> thing you can +do with a Data::Hierarchy::Relative object is call +C on it, which returns a new +LData::Hierarchy object at that base path. For example, if +everything in the hierarchy is rooted at C and it +needs to be moved to C, you can do + + $hierarchy = $hierarchy->to_relative('/home/super_project')->to_absolute('/home/awesome_project'); + +(Data::Hierarchy::Relative objects may be a more convenient +serialization format than Data::Hierarchy objects, if they are +tracking the state of some relocatable resource.) + +=cut + +sub to_relative { + my $self = shift; + my $base_path = shift; + + return Data::Hierarchy::Relative->new($base_path, %$self); } -sub store_single { - my ($self, $key, $value) = @_; - $self->key_safe ($key); - $self->{hash}{$key} = $value; +# 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, $key, $value) = @_; - $self->key_safe ($key); + my ($self, $path, $new_props) = @_; - my $oldvalue = $self->{hash}{$key} if exists $self->{hash}{$key}; - my $hash = {%{$oldvalue||{}}, %$value}; - for (keys %$hash) { + my $old_props = $self->{hash}{$path} if exists $self->{hash}{$path}; + my $merged_props = {%{$old_props||{}}, %$new_props}; + for (keys %$merged_props) { if (index($_, '.') == 0) { - defined $hash->{$_} ? - $self->{sticky}{$key}{$_} = $hash->{$_} : - delete $self->{sticky}{$key}{$_}; - delete $hash->{$_}; + defined $merged_props->{$_} ? + $self->{sticky}{$path}{$_} = $merged_props->{$_} : + delete $self->{sticky}{$path}{$_}; + delete $merged_props->{$_}; } else { - delete $hash->{$_} - unless defined $hash->{$_}; + delete $merged_props->{$_} + unless defined $merged_props->{$_}; } } - $self->{hash}{$key} = $hash; - delete $self->{hash}{$key} unless %{$self->{hash}{$key}}; - delete $self->{sticky}{$key} unless keys %{$self->{sticky}{$key}}; + $self->{hash}{$path} = $merged_props; } -sub merge { - my ($self, $other, $path) = @_; - my %datapoints = map {$_ => 1} ($self->descendents ($path), - $other->descendents ($path)); - for my $key (reverse sort keys %datapoints) { - my $value = $self->get ($key); - my $nvalue = $other->get ($key); - for (keys %$value) { - $nvalue->{$_} = undef - unless defined $nvalue->{$_}; - } - $self->store ($key, $nvalue); - } +# 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) = @_; + + # XXX: could build cached pointer for fast traversal + return sort grep {index($path.$self->{sep}, $_.$self->{sep}) == 0} + keys %$hash; } +# 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, $key) = @_; + my ($self, $hash, $path) = @_; # If finding for everything, don't bother grepping - return sort keys %$hash unless length($key); + return sort keys %$hash unless length($path); - return sort grep {index($_.$self->{sep}, $key.$self->{sep}) == 0} + return sort grep {index($_.$self->{sep}, $path.$self->{sep}) == 0} keys %$hash; } -sub descendents { - my ($self, $key) = @_; - my $both = {%{$self->{hash}}, %{$self->{sticky} || {}}}; +# 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); - # If finding for everything, don't bother grepping - return sort keys %$both unless length($key); + my $both = {%{$self->{hash}}, %{$self->{sticky} || {}}}; - return sort grep {index($_.$self->{sep}, $key.$self->{sep}) == 0} - keys %$both; + return $self->_descendents($both, $path); } -# empty the overridden values on descendents for hash -sub _store_recursively { - my ($self, $key, $value, $hash) = @_; +# 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.) - $self->key_safe ($key); - my @datapoints = $self->_descendents ($hash, $key); +sub _remove_matching_properties_recursively { + my ($self, $path, $remove_props, $hash) = @_; - for (@datapoints) { - my $vhash = $hash->{$_}; - delete $vhash->{$_} for keys %$value; - delete $hash->{$_} unless %{$hash->{$_}}; + my @datapoints = $self->_descendents ($hash, $path); + + for my $datapoint (@datapoints) { + delete $hash->{$datapoint}{$_} for keys %$remove_props; + delete $hash->{$datapoint} unless %{$hash->{$datapoint}}; } } -# use store_fast to avoid trimming duplicated value with ancestors -sub store_fast { +# 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; - $self->store (@_, 1); + 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); } -sub store { - my ($self, $key, $value, $fast) = @_; +# Internal method. +# +# Cleans up the hash and sticky by removing redundant properties, +# undef properties, and empty property hashes. - unless ($fast) { - my $ovalue = $self->get ($key); - for (keys %$value) { - next unless defined $value->{$_}; - delete $value->{$_} - if exists $ovalue->{$_} && $ovalue->{$_} eq $value->{$_}; - } +sub _remove_redundant_properties_and_undefs { + my $self = 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}}) { + 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); + + 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} }; } - return unless keys %$value; - $self->_store_recursively ($key, $value, $self->{hash}) - unless $fast; - $self->_store ($key, $value); -} - -sub store_override { - my ($self, $key, $value) = @_; - - my ($ovalue, @datapoints) = $self->get ($key); - for (keys %$value) { - next unless defined $value->{$_}; - if (exists $ovalue->{$_} && $ovalue->{$_} eq $value->{$_}) { - # if the parent has the property already - if ($#datapoints > 0 && exists $self->{hash}{$datapoints[-1]}{$_}) { - $value->{$_} = undef; - } - else { - delete $value->{$_}; - } - } + + 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} }; } - return unless keys %$value; - $self->_store ($key, $value); } -# Useful for removing sticky properties. -sub store_recursively { - my ($self, $key, $value) = @_; +# These are for backwards compatibility only. - $self->_store_recursively ($key, $value, $self->{hash}); - $self->_store_recursively ($key, $value, $self->{sticky}); - $self->_store ($key, $value); -} +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}); } -sub find { - my ($self, $key, $value) = @_; - $self->key_safe ($key); - my @items; - my @datapoints = $self->descendents($key); +package Data::Hierarchy::Relative; - for my $entry (@datapoints) { - my $matched = 1; - for (keys %$value) { - my $lookat = (index($_, '.') == 0) ? - $self->{sticky}{$entry} : $self->{hash}{$entry}; - $matched = 0 - unless exists $lookat->{$_} - && $lookat->{$_} =~ m/$value->{$_}/; - last unless $matched; - } - push @items, $entry - if $matched; +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 @items; -} -sub get_single { - my ($self, $key) = @_; - return clone ($self->{hash}{$key} || {}); + return $self; } -sub get { - my ($self, $key, $rdonly) = @_; - $self->key_safe ($key); - my $value = {}; - # XXX: could build cached pointer for fast traversal - my @datapoints = sort grep {index($key.$self->{sep}, $_.$self->{sep}) == 0} - keys %{$self->{hash}}; +sub to_absolute { + my $self = shift; + my $base_path = shift; - for (@datapoints) { - my $newv = $self->{hash}{$_}; - $newv = clone $newv unless $rdonly; - $value = {%$value, %$newv}; - } - if (exists $self->{sticky}{$key}) { - my $newv = $self->{sticky}{$key}; - $newv = clone $newv unless $rdonly; - $value = {%$value, %$newv} + 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; } - return wantarray ? ($value, @datapoints) : $value; -} -sub dump { - my ($self) = @_; - return $self->{hash}; + bless $tree, 'Data::Hierarchy'; + + return $tree; } 1; +=back + =head1 AUTHORS Chia-liang Kao E<lt>clkao@clkao.orgE<gt> +David Glasser E<lt>glasser@mit.eduE<gt> =head1 COPYRIGHT -Copyright 2003 by Chia-liang Kao E<lt>clkao@clkao.orgE<gt>. +Copyright 2003-2006 by Chia-liang Kao E<lt>clkao@clkao.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/Data-Hierarchy-0.21/MANIFEST new/Data-Hierarchy-0.31/MANIFEST --- old/Data-Hierarchy-0.21/MANIFEST 2004-09-11 00:37:32.000000000 +0200 +++ new/Data-Hierarchy-0.31/MANIFEST 2006-07-21 14:59:48.000000000 +0200 @@ -1,7 +1,11 @@ -MANIFEST CHANGES -README -Makefile.PL Hierarchy.pm +Makefile.PL +MANIFEST +META.yml Module meta-data (added by MakeMaker) +README t/1basic.t -META.yml Module meta-data (added by MakeMaker) +t/2basic-with-sep.t +t/3store-vs-store_recursively.t +t/4merge.t +t/5relative.t diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/Data-Hierarchy-0.21/META.yml new/Data-Hierarchy-0.31/META.yml --- old/Data-Hierarchy-0.21/META.yml 2004-11-10 14:46:14.000000000 +0100 +++ new/Data-Hierarchy-0.31/META.yml 2006-09-07 22:21:20.000000000 +0200 @@ -1,11 +1,11 @@ # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Data-Hierarchy -version: 0.21 +version: 0.31 version_from: Hierarchy.pm installdirs: site requires: - Clone: 0 + Test::Exception: 0 distribution_type: module -generated_by: ExtUtils::MakeMaker version 6.21 +generated_by: ExtUtils::MakeMaker version 6.30 diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/Data-Hierarchy-0.21/Makefile.PL new/Data-Hierarchy-0.31/Makefile.PL --- old/Data-Hierarchy-0.21/Makefile.PL 2004-09-11 00:37:32.000000000 +0200 +++ new/Data-Hierarchy-0.31/Makefile.PL 2006-07-21 15:00:20.000000000 +0200 @@ -8,7 +8,7 @@ VERSION_FROM => 'Hierarchy.pm', DISTNAME => 'Data-Hierarchy', PREREQ_PM => { - 'Clone' => '0', + Test::Exception => '0', }, dist => { COMPRESS => 'gzip -9', diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/Data-Hierarchy-0.21/README new/Data-Hierarchy-0.31/README --- old/Data-Hierarchy-0.21/README 2004-09-11 00:37:32.000000000 +0200 +++ new/Data-Hierarchy-0.31/README 2006-07-21 14:59:59.000000000 +0200 @@ -12,11 +12,11 @@ * Latest version The latest Data::Hierarchy could be found on cpan or at: -http://svn.elixus.org/svnweb/repos/browse/member/clkao/Data-Hierarchy/ +http://svn.clkao.org/svnweb/member/browse/clkao/modules/Data-Hierarchy/ * Copyright -Copyright 2003-2004 by Chia-liang Kao clkao@clkao.org. +Copyright 2003-2006 by Chia-liang Kao clkao@clkao.org. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/Data-Hierarchy-0.21/t/1basic.t new/Data-Hierarchy-0.31/t/1basic.t --- old/Data-Hierarchy-0.21/t/1basic.t 2004-09-11 00:37:32.000000000 +0200 +++ new/Data-Hierarchy-0.31/t/1basic.t 2006-07-25 21:48:50.000000000 +0200 @@ -1,6 +1,7 @@ #!/usr/bin/perl -use Test::More qw(no_plan); +use Test::More tests => 16; use strict; +use warnings; BEGIN { use_ok 'Data::Hierarchy'; } @@ -12,35 +13,55 @@ '.sticky' => 'this is private fnord'}); $tree->store ('/blahblah', {access => {fnord => 'bzz'}}); -ok (eq_hash (scalar $tree->get ('/private/somewhere/deep'), {access => 'auth', - type => 'pam'})); +# Tree is: +# / [access: all] +# /private [access: auth, type: pam] +# /private/fnord [otherinfo: fnord, .sticky: this is private fnord] +# /blahblah [access: {fnord => bzz}] + +is_deeply (scalar $tree->get ('/private/somewhere/deep'), {access => 'auth', + type => 'pam'}); + +is_deeply (scalar $tree->get ('/private'), {access => 'auth', + type => 'pam'}); + +is_deeply (scalar $tree->get ('/private/fnord'), {access => 'auth', + otherinfo => 'fnord', + '.sticky' => 'this is private fnord', + type => 'pam'}); + +is_deeply (scalar $tree->get ('/private/fnord/blah'), {access => 'auth', + otherinfo => 'fnord', + type => 'pam'}); -ok (eq_hash (scalar $tree->get ('/private'), {access => 'auth', - type => 'pam'})); - -ok (eq_hash (scalar $tree->get ('/private/fnord'), {access => 'auth', - otherinfo => 'fnord', - '.sticky' => 'this is private fnord', - type => 'pam'})); - -ok (eq_hash (scalar $tree->get ('/private/fnord/blah'), {access => 'auth', - otherinfo => 'fnord', - type => 'pam'})); - -ok (eq_hash (scalar $tree->get ('/private/fnordofu'), {access => 'auth', - type => 'pam'})); +is_deeply (scalar $tree->get ('/private/fnordofu'), {access => 'auth', + type => 'pam'}); is (($tree->get ('/private/somewhere/deep'))[-1], '/private'); is (($tree->get ('/public'))[-1], ''); -ok (eq_array ([$tree->find ('/', {access => qr/.*/})], - ['','/blahblah','/private'])); +is_deeply ([$tree->find ('/', {access => qr/.*/})], + ['','/blahblah','/private']); $tree->store ('/private', {type => undef}); -ok (eq_hash (scalar $tree->get ('/private'), { access => 'auth' })); - -$tree->store_recursively ('/', {access => 'all', type => 'null'}); +# Tree is: +# / [access: all] +# /private [access: auth] +# /private/fnord [otherinfo: fnord, .sticky: this is private fnord] +# /blahblah [access: {fnord => bzz}] + +is_deeply (scalar $tree->get ('/private'), { access => 'auth' }); +is_deeply (scalar $tree->get ('/private/nothing'), { access => 'auth' }); +is_deeply (scalar $tree->get ('/private/fnord'), { access => 'auth', + otherinfo => 'fnord', + '.sticky' => 'this is private fnord' }); + +$tree->store ('/', {access => 'all', type => 'null'}, {override_sticky_descendents => 1}); + +# Tree is: +# / [access: all, type: null] +# /private/fnord [otherinfo: fnord, .sticky: this is private fnord] is_deeply ([$tree->get ('/private/fnord/somewhere/deep')], [{access => 'all', @@ -49,11 +70,27 @@ my $tree2 = Data::Hierarchy->new(); $tree2->store ('/private/blah', {access => 'no', type => 'pam', giggle => 'haha'}); -$tree2->store_recursively ('/private', {access => 'auth', type => 'pam', blah => 'fnord'}); +$tree2->store ('/private', {access => 'auth', type => 'pam', blah => 'fnord'}, {override_sticky_descendents => 1}); + +# Tree2 is: +# /private [access: auth, type: pam, blah: fnord] +# /private/blah [giggle: haha] + +is_deeply (scalar $tree2->get ('/private/blah'), { access => 'auth', + type => 'pam', + blah => 'fnord', + giggle => 'haha'}); $tree2->merge ($tree, '/private'); -ok (eq_hash (scalar $tree2->get ('/private/fnord'), {access => 'all', - otherinfo => 'fnord', - '.sticky' => 'this is private fnord', - type => 'null'})); +# Tree2 is: +# /private [access: all, type: null] +# /private/fnord [otherinfo: fnord, .sticky: this is private fnord] + +is_deeply (scalar $tree2->get ('/private/fnord'), {access => 'all', + otherinfo => 'fnord', + '.sticky' => 'this is private fnord', + type => 'null'}); + +is_deeply (scalar $tree2->get ('/private/blah'), { access => 'all', + type => 'null'}); diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/Data-Hierarchy-0.21/t/2basic-with-sep.t new/Data-Hierarchy-0.31/t/2basic-with-sep.t --- old/Data-Hierarchy-0.21/t/2basic-with-sep.t 1970-01-01 01:00:00.000000000 +0100 +++ new/Data-Hierarchy-0.31/t/2basic-with-sep.t 2006-07-25 21:48:50.000000000 +0200 @@ -0,0 +1,98 @@ +#!/usr/bin/perl +use Test::More tests => 16; +use strict; +use warnings; +BEGIN { +use_ok 'Data::Hierarchy'; +} + +my $tree = Data::Hierarchy->new(sep => '\\'); +$tree->store ('\\', {access => 'all'}); +$tree->store ('\\private', {access => 'auth', type => 'pam'}); +$tree->store ('\\private\\fnord', {otherinfo => 'fnord', + '.sticky' => 'this is private fnord'}); +$tree->store ('\\blahblah', {access => {fnord => 'bzz'}}); + +# Tree is: +# / [access: all] +# /private [access: auth, type: pam] +# /private/fnord [otherinfo: fnord, .sticky: this is private fnord] +# /blahblah [access: {fnord => bzz}] + +is_deeply (scalar $tree->get ('\\private\\somewhere\\deep'), {access => 'auth', + type => 'pam'}); + +is_deeply (scalar $tree->get ('\\private'), {access => 'auth', + type => 'pam'}); + +is_deeply (scalar $tree->get ('\\private\\fnord'), {access => 'auth', + otherinfo => 'fnord', + '.sticky' => 'this is private fnord', + type => 'pam'}); + +is_deeply (scalar $tree->get ('\\private\\fnord\\blah'), {access => 'auth', + otherinfo => 'fnord', + type => 'pam'}); + +is_deeply (scalar $tree->get ('\\private\\fnordofu'), {access => 'auth', + type => 'pam'}); + +is (($tree->get ('\\private\\somewhere\\deep'))[-1], '\\private'); +is (($tree->get ('\\public'))[-1], ''); + +is_deeply ([$tree->find ('\\', {access => qr/.*/})], + ['','\\blahblah','\\private']); + +$tree->store ('\\private', {type => undef}); + +# Tree is: +# / [access: all] +# /private [access: auth] +# /private/fnord [otherinfo: fnord, .sticky: this is private fnord] +# /blahblah [access: {fnord => bzz}] + +is_deeply (scalar $tree->get ('\\private'), { access => 'auth' }); +is_deeply (scalar $tree->get ('\\private\\nothing'), { access => 'auth' }); +is_deeply (scalar $tree->get ('\\private\\fnord'), { access => 'auth', + otherinfo => 'fnord', + '.sticky' => 'this is private fnord' }); + +$tree->store ('\\', {access => 'all', type => 'null'}, {override_sticky_descendents => 1}); + +# Tree is: +# / [access: all, type: null] +# /private/fnord [otherinfo: fnord, .sticky: this is private fnord] + +is_deeply ([$tree->get ('\\private\\fnord\\somewhere\\deep')], + [{access => 'all', + otherinfo => 'fnord', + type => 'null', }, '','\\private\\fnord']); + +my $tree2 = Data::Hierarchy->new(sep => '\\'); +$tree2->store ('\\private\\blah', {access => 'no', type => 'pam', giggle => 'haha'}); +$tree2->store ('\\private', {access => 'auth', type => 'pam', blah => 'fnord'}, {override_sticky_descendents => 1}); + +# Tree2 is: +# /private [access: auth, type: pam, blah: fnord] +# /private/blah [giggle: haha] + +is_deeply (scalar $tree2->get ('\\private\\blah'), { access => 'auth', + type => 'pam', + blah => 'fnord', + giggle => 'haha'}); + +$tree2->merge ($tree, '\\private'); + +# Tree2 is: +# /private [access: all, type: null] +# /private/fnord [otherinfo: fnord, .sticky: this is private fnord] + +is_deeply (scalar $tree2->get ('\\private\\fnord'), {access => 'all', + otherinfo => 'fnord', + '.sticky' => 'this is private fnord', + type => 'null'}); + +# the next test fails: correctly? + +is_deeply (scalar $tree2->get ('\\private\\blah'), { access => 'all', + type => 'null'}); diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/Data-Hierarchy-0.21/t/3store-vs-store_recursively.t new/Data-Hierarchy-0.31/t/3store-vs-store_recursively.t --- old/Data-Hierarchy-0.21/t/3store-vs-store_recursively.t 1970-01-01 01:00:00.000000000 +0100 +++ new/Data-Hierarchy-0.31/t/3store-vs-store_recursively.t 2006-07-25 21:48:50.000000000 +0200 @@ -0,0 +1,205 @@ +#!/usr/bin/perl +use Test::More tests => 57; +use strict; +use warnings; +BEGIN { +use_ok 'Data::Hierarchy'; +} + +# my belief: +# store (non-fast) recurses on entries that are actually changing the value +# store_fast never recurses +# store_recursively always does +# +# note that a store_recursively of a sticky property DELETES it from +# nodes underneath (whether or not your are changing it, etc) + +my $TREE; + +sub reset_tree { + $TREE = Data::Hierarchy->new; + + $TREE->store('/foo', {a => 1, '.k' => 10}); + $TREE->store('/foo/bar', {a => 2, '.k' => 20}); +} + +sub test_foo_and_bar { + my($foo, $foo_bar) = @_; + local $Test::Builder::Level = $Test::Builder::Level + 1; # report failures at call site + is_deeply [$TREE->get('/foo')], $foo; + is_deeply [$TREE->get('/foo/bar')], $foo_bar; +} + +reset_tree(); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo', {a => 3}); +test_foo_and_bar + [{a => 3, '.k' => 10}, '/foo'], + [{a => 3, '.k' => 20}, '/foo']; + +reset_tree(); +$TREE->store('/foo', {a => 1}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 1, '.k' => 20}, '/foo']; + +reset_tree(); +$TREE->store('/foo', {a => 1}, {override_sticky_descendents => 1}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 1, '.k' => 20}, '/foo']; + +reset_tree(); +$TREE->store('/foo', {a => 3}, {override_sticky_descendents => 1}); +test_foo_and_bar + [{a => 3, '.k' => 10}, '/foo'], + [{a => 3, '.k' => 20}, '/foo']; + +reset_tree(); +$TREE->store('/foo', {a => 1}, {override_descendents => 0}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo', {a => 3}, {override_descendents => 0}); +test_foo_and_bar + [{a => 3, '.k' => 10}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo', {a => undef}); +test_foo_and_bar + [{'.k' => 10}], + [{'.k' => 20}]; + +reset_tree(); +$TREE->store('/foo', {a => undef}, {override_descendents => 0}); +test_foo_and_bar + [{'.k' => 10}], + [{a => 2, '.k' => 20}, '/foo/bar']; + +reset_tree(); +$TREE->store('/foo', {a => undef}, {override_sticky_descendents => 1}); +test_foo_and_bar + [{'.k' => 10}], + [{'.k' => 20}]; + +# now start testing sticky + +reset_tree(); +$TREE->store('/foo', {'.k' => 30}); +test_foo_and_bar + [{a => 1, '.k' => 30}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo', {'.k' => 10}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo', {'.k' => 10}, {override_sticky_descendents => 1}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 2}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo', {'.k' => 30}, {override_sticky_descendents => 1}); +test_foo_and_bar + [{a => 1, '.k' => 30}, '/foo'], + [{a => 2}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo', {'.k' => 10}, {override_descendents => 0}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo', {'.k' => 30}, {override_descendents => 0}); +test_foo_and_bar + [{a => 1, '.k' => 30}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + + +reset_tree(); +$TREE->store('/foo', {'.k' => undef}); +test_foo_and_bar + [{a => 1}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo', {'.k' => undef}, {override_sticky_descendents => 1}); +test_foo_and_bar + [{a => 1}, '/foo'], + [{a => 2}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo', {'.k' => undef}, {override_descendents => 0}); +test_foo_and_bar + [{a => 1}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + + + +# now testing assigns to /foo/bar (with store_override too) + +reset_tree(); +$TREE->store('/foo/bar', {a => 2}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo/bar', {a => 1}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 1, '.k' => 20}, '/foo']; + +reset_tree(); +$TREE->store('/foo/bar', {a => 3}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 3, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo/bar', {a => 2}, {override_descendents => 0}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo/bar', {a => 1}, {override_descendents => 0}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 1, '.k' => 20}, '/foo']; + +reset_tree(); +$TREE->store('/foo/bar', {a => 3}, {override_descendents => 0}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 3, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo/bar', {a => 2}, {override_sticky_descendents => 1}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 2, '.k' => 20}, '/foo', '/foo/bar']; + +reset_tree(); +$TREE->store('/foo/bar', {a => 1}, {override_sticky_descendents => 1}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 1, '.k' => 20}, '/foo']; + +reset_tree(); +$TREE->store('/foo/bar', {a => 3}, {override_sticky_descendents => 1}); +test_foo_and_bar + [{a => 1, '.k' => 10}, '/foo'], + [{a => 3, '.k' => 20}, '/foo', '/foo/bar']; diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/Data-Hierarchy-0.21/t/4merge.t new/Data-Hierarchy-0.31/t/4merge.t --- old/Data-Hierarchy-0.21/t/4merge.t 1970-01-01 01:00:00.000000000 +0100 +++ new/Data-Hierarchy-0.31/t/4merge.t 2006-07-21 14:59:48.000000000 +0200 @@ -0,0 +1,22 @@ +#!/usr/bin/perl +use Test::More tests => 3; +use strict; +use warnings; +BEGIN { +use_ok 'Data::Hierarchy'; +} + +my $t1 = Data::Hierarchy->new; +$t1->store('/foo', { A => 1 }); + +my $t2 = Data::Hierarchy->new; +$t2->store('/foo', { A => 3 }); +$t2->store('/foo/bar', { A => 4 }); + +$t1->merge($t2, '/foo'); + +is_deeply (scalar $t1->get('/foo'), { A => 3 }); + +is_deeply (scalar $t1->get('/foo/bar'), { A => 4 }); + + diff -urN --exclude=CVS --exclude=.cvsignore --exclude=.svn --exclude=.svnignore old/Data-Hierarchy-0.21/t/5relative.t new/Data-Hierarchy-0.31/t/5relative.t --- old/Data-Hierarchy-0.21/t/5relative.t 1970-01-01 01:00:00.000000000 +0100 +++ new/Data-Hierarchy-0.31/t/5relative.t 2006-09-07 22:20:25.000000000 +0200 @@ -0,0 +1,23 @@ +#!/usr/bin/perl +use Test::More tests => 4; +use Test::Exception; + +use strict; +use warnings; +BEGIN { +use_ok 'Data::Hierarchy'; +} + +my $t = Data::Hierarchy->new; +$t->store('/foo', { A => 1 }); +$t->store('/foo/bar', { A => 3 }); +$t->store('/foo/bar/baz', { A => 4 }); + +my $rel = $t->to_relative('/foo'); + +my $tnew = $rel->to_absolute('/beep'); + +is($tnew->get('/beep')->{A}, 1); +is($tnew->get('/beep/bar/baz')->{A}, 4); + +throws_ok { $t->to_relative('/fo') } qr!/foo is not a child of /fo!; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Remember to have fun... --------------------------------------------------------------------- To unsubscribe, e-mail: opensuse-commit+unsubscribe@opensuse.org For additional commands, e-mail: opensuse-commit+help@opensuse.org