[Bps-public-commit] r15795 - in Data-Hierarchy/trunk: .
clkao at bestpractical.com
clkao at bestpractical.com
Mon Sep 8 06:50:53 EDT 2008
Author: clkao
Date: Mon Sep 8 06:50:52 2008
New Revision: 15795
Added:
Data-Hierarchy/trunk/CHANGES
Data-Hierarchy/trunk/Hierarchy.pm (contents, props changed)
Data-Hierarchy/trunk/MANIFEST
Data-Hierarchy/trunk/META.yml
Data-Hierarchy/trunk/Makefile.PL
Data-Hierarchy/trunk/README
Data-Hierarchy/trunk/t/
Data-Hierarchy/trunk/t/1basic.t
Modified:
Data-Hierarchy/trunk/ (props changed)
Log:
r35234 at mtl (orig r169): clkao | 2004-09-11 06:33:48 +0800
import D::H 0.18
Added: Data-Hierarchy/trunk/CHANGES
==============================================================================
--- (empty file)
+++ Data-Hierarchy/trunk/CHANGES Mon Sep 8 06:50:52 2008
@@ -0,0 +1,34 @@
+[Changes for 0.18 - May 29, 2004]
+
+* Fix - find sticky values was not working.
+
+[Changes for 0.17 - Mar 18, 2004]
+
+* New - store_override for overriding existing values on the entry.
+
+[Changes for 0.16 - Mar 17, 2004]
+
+* Fix - get_descenents is unhappy with older versions of Data::Hierarchy.
+
+[Changes for 0.15 - Mar 8, 2004]
+
+* New - properties beginning with '.' are now sticky to the entry.
+* New - merge function to merge two Data::Hierarchy objects.
+
+[Changes for 0.13 - Nov 4, 2003]
+
+* New - get_single and store_single.
+* Fix - get_* now return cloned hash to avoid being modified directly.
+
+[Changes for 0.12 - Oct 6, 2003]
+
+* New - Find descendents with a rule.
+* Fix - cleanup useless entries after store and store_recursively
+
+[Changes for 0.11 - Sep 26, 2003]
+
+* Fix an obvious edge case.
+
+[Changes for 0.10 - Sep 26, 2003]
+
+Initial release.
Added: Data-Hierarchy/trunk/Hierarchy.pm
==============================================================================
--- (empty file)
+++ Data-Hierarchy/trunk/Hierarchy.pm Mon Sep 8 06:50:52 2008
@@ -0,0 +1,234 @@
+package Data::Hierarchy;
+$VERSION = '0.18';
+use strict;
+use Clone qw(clone);
+
+=head1 NAME
+
+Data::Hierarchy - Handle data in a hierarchical structure
+
+=head1 SYNOPSIS
+
+ my $tree = Data::Hierarchy->new();
+ $tree->store ('/', {access => 'all'});
+ $tree->store ('/private', {access => 'auth',
+ '.sticky' => '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_recursively ('/', {access => 'all'});
+
+ my $hashref = $tree->dump;
+
+=head1 DESCRIPTION
+
+Data::Hierarchy provides a simple interface for manipulating
+inheritable data attached to a hierarchical environment (like
+filesystem).
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->{sep} ||= '/';
+ $self->{hash} = shift || {};
+ $self->{sticky} = {};
+ return $self;
+}
+
+sub store_single {
+ my ($self, $key, $value) = @_;
+ $key =~ s/$self->{sep}$//;
+ $self->{hash}{$key} = $value;
+}
+
+sub _store {
+ my ($self, $key, $value) = @_;
+
+ $key =~ s/$self->{sep}$//;
+
+ my $oldvalue = $self->{hash}{$key} if exists $self->{hash}{$key};
+ my $hash = {%{$oldvalue||{}}, %$value};
+ for (keys %$hash) {
+ if (substr ($_, 0, 1) eq '.') {
+ defined $hash->{$_} ?
+ $self->{sticky}{$key}{$_} = $hash->{$_} :
+ delete $self->{sticky}{$key}{$_};
+ delete $hash->{$_};
+ }
+ else {
+ delete $hash->{$_}
+ unless defined $hash->{$_};
+ }
+ }
+
+ $self->{hash}{$key} = $hash;
+ delete $self->{hash}{$key} unless %{$self->{hash}{$key}};
+ delete $self->{sticky}{$key} unless keys %{$self->{sticky}{$key}};
+}
+
+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);
+ }
+}
+
+sub _descendents {
+ my ($self, $hash, $key) = @_;
+ return sort grep {$key.$self->{sep} eq substr($_.$self->{sep}, 0,
+ length($key)+1)}
+ keys %$hash;
+}
+
+sub descendents {
+ my ($self, $key) = @_;
+ use Carp;
+ my $both = {%{$self->{hash}}, %{$self->{sticky} || {}}};
+ return sort grep {$key.$self->{sep} eq substr($_.$self->{sep}, 0,
+ length($key)+1)}
+ keys %$both;
+}
+
+sub _store_recursively {
+ my ($self, $key, $value, $hash) = @_;
+
+ $key =~ s/$self->{sep}$//;
+ my @datapoints = $self->_descendents ($hash, $key);
+
+ for (@datapoints) {
+ my $vhash = $hash->{$_};
+ delete $vhash->{$_} for keys %$value;
+ delete $hash->{$_} unless %{$hash->{$_}};
+ }
+}
+
+sub store {
+ my ($self, $key, $value) = @_;
+
+ my $ovalue = $self->get ($key);
+ for (keys %$value) {
+ next unless defined $value->{$_};
+ delete $value->{$_}
+ if exists $ovalue->{$_} && $ovalue->{$_} eq $value->{$_};
+ }
+ return unless keys %$value;
+ $self->_store_recursively ($key, $value, $self->{hash});
+ $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->{$_};
+ }
+ }
+ }
+ return unless keys %$value;
+ $self->_store ($key, $value);
+}
+
+sub store_recursively {
+ my ($self, $key, $value) = @_;
+
+ $self->_store_recursively ($key, $value, $self->{hash});
+ $self->_store_recursively ($key, $value, $self->{sticky});
+ $self->_store ($key, $value);
+}
+
+sub find {
+ my ($self, $key, $value) = @_;
+ $key =~ s/$self->{sep}$//;
+ my @items;
+ my @datapoints = $self->descendents($key);
+
+ for my $entry (@datapoints) {
+ my $matched = 1;
+ for (keys %$value) {
+ my $lookat = substr ($_, 0, 1) eq '.' ?
+ $self->{sticky}{$entry} : $self->{hash}{$entry};
+ $matched = 0
+ unless exists $lookat->{$_}
+ && $lookat->{$_} =~ m/$value->{$_}/;
+ last unless $matched;
+ }
+ push @items, $entry
+ if $matched;
+ }
+ return @items;
+}
+
+sub get_single {
+ my ($self, $key) = @_;
+ return clone ($self->{hash}{$key} || {});
+}
+
+sub get {
+ my ($self, $key, $rdonly) = @_;
+ use Carp;
+ confess unless $key;
+ $key =~ s/$self->{sep}$//;
+ my $value = {};
+ # XXX: could build cached pointer for fast traversal
+ my @datapoints = sort grep {$_.$self->{sep} eq substr($key.$self->{sep}, 0,
+ length($_)+1)}
+ keys %{$self->{hash}};
+
+ 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}
+ }
+ return wantarray ? ($value, @datapoints) : $value;
+}
+
+sub dump {
+ my ($self) = @_;
+ return $self->{hash};
+}
+
+1;
+
+=head1 AUTHORS
+
+Chia-liang Kao E<lt>clkao at clkao.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2003 by Chia-liang Kao E<lt>clkao at clkao.orgE<gt>.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
Added: Data-Hierarchy/trunk/MANIFEST
==============================================================================
--- (empty file)
+++ Data-Hierarchy/trunk/MANIFEST Mon Sep 8 06:50:52 2008
@@ -0,0 +1,7 @@
+MANIFEST
+CHANGES
+README
+Makefile.PL
+Hierarchy.pm
+t/1basic.t
+META.yml Module meta-data (added by MakeMaker)
Added: Data-Hierarchy/trunk/META.yml
==============================================================================
--- (empty file)
+++ Data-Hierarchy/trunk/META.yml Mon Sep 8 06:50:52 2008
@@ -0,0 +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.18
+version_from: Hierarchy.pm
+installdirs: site
+requires:
+ Clone: 0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: Data-Hierarchy/trunk/Makefile.PL
==============================================================================
--- (empty file)
+++ Data-Hierarchy/trunk/Makefile.PL Mon Sep 8 06:50:52 2008
@@ -0,0 +1,18 @@
+#!/usr/bin/perl
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ AUTHOR => 'Chia-liang Kao (clkao at clkao.org)',
+ ABSTRACT => 'Handle inheritable attributes in a hierarchical environment.',
+ NAME => 'Data::Hierarchy',
+ VERSION_FROM => 'Hierarchy.pm',
+ DISTNAME => 'Data-Hierarchy',
+ PREREQ_PM => {
+ 'Clone' => '0',
+ },
+ dist => {
+ COMPRESS => 'gzip -9',
+ SUFFIX => '.gz',
+ },
+);
+
Added: Data-Hierarchy/trunk/README
==============================================================================
--- (empty file)
+++ Data-Hierarchy/trunk/README Mon Sep 8 06:50:52 2008
@@ -0,0 +1,24 @@
+This is the README file for Data::Hierarchy, a module that handles
+data in hierarchical structure.
+
+* Installation
+
+Data::Hierarchy uses the stanard perl module install process:
+
+% perl Makefile.PL
+% make
+# make install
+
+* Latest version
+
+The latest Data::Hierarchy could be found on cpan or at:
+http://svn.elixus.org/svnweb/repos/browse/member/clkao/Data-Hierarchy/
+
+* Copyright
+
+Copyright 2003-2004 by Chia-liang Kao clkao at clkao.org.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See <http://www.perl.com/perl/misc/Artistic.html>.
Added: Data-Hierarchy/trunk/t/1basic.t
==============================================================================
--- (empty file)
+++ Data-Hierarchy/trunk/t/1basic.t Mon Sep 8 06:50:52 2008
@@ -0,0 +1,59 @@
+#!/usr/bin/perl
+use Test::More qw(no_plan);
+use strict;
+BEGIN {
+use_ok 'Data::Hierarchy';
+}
+
+my $tree = Data::Hierarchy->new();
+$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'}});
+
+ok (eq_hash (scalar $tree->get ('/private/somewhere/deep'), {access => 'auth',
+ 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 (($tree->get ('/private/somewhere/deep'))[-1], '/private');
+is (($tree->get ('/public'))[-1], '');
+
+ok (eq_array ([$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'});
+
+is_deeply ([$tree->get ('/private/fnord/somewhere/deep')],
+ [{access => 'all',
+ otherinfo => 'fnord',
+ type => 'null', }, '','/private/fnord']);
+
+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->merge ($tree, '/private');
+
+ok (eq_hash (scalar $tree2->get ('/private/fnord'), {access => 'all',
+ otherinfo => 'fnord',
+ '.sticky' => 'this is private fnord',
+ type => 'null'}));
More information about the Bps-public-commit
mailing list