Import of original from CPAN

darcs-hash:20070826024820-f4041-398ec2fd305416e5da8a1ff7524a7fefd671a842.gz

Makefile.PL

@@ -0,0 +1,10 @@
+use inc::Module::Install;
+
+name            'Data-Path';
+perl_version    '5.006';
+
+all_from        'lib/Data/Path';
+
+build_requires  'Test::More' => '0.7';
+
+WriteAl;

README

@@ -0,0 +1,24 @@
+Data-Path version 1.0
+=====================
+
+INSTALLATION
+
+To install this module type the following:
+
+   perl Makefile.PL
+   make
+   make test
+   make install
+
+COPYRIGHT AND LICENCE
+
+Put the correct copyright and licence information here.
+
+Copyright (C) 2006 by Marco Schrieck
+Copyright (C) 2007 by Jeremfy Wall
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.4 or,
+at your option, any later version of Perl 5 you may have available.
+
+

lib/Data/Path.pm

@@ -0,0 +1,207 @@
+package Data::Path;
+
+use 5.006001;
+use strict;
+use warnings;
+
+our $VERSION = '1.0';
+
+sub new {
+	my ($class,$data,$callback)=@_;
+	$callback||={};
+	my $self=
+		{ data     => $data 
+
+		# set call backs to default if not given
+		, callback => 
+			{ key_does_not_exist            => $callback->{key_does_not_exist} ||
+				sub {
+					my ($data, $key, $index, $value, $rest )=@_;
+					die "key $key does not exists\n";
+				}
+
+			, index_does_not_exist         => $callback->{index_does_not_exist} ||
+				sub {
+					my ($data, $key, $index, $value, $rest )=@_;
+					die "key $key\[$index\] does not exists\n";
+				}
+
+			, retrieve_index_from_non_array => $callback->{retrieve_index_from_non_array} ||
+				sub {
+					my ($data, $key, $index, $value, $rest )=@_;
+					die "trie to retrieve an index $index from a no array value (in key $key)\n";
+				}
+
+			, retrieve_key_from_non_hash    => $callback->{retrieve_key_from_non_hash} ||
+				sub {
+					my ($data, $key, $index, $value, $rest )=@_;
+					die "trie to retrieve a key from a no hash value (in key $key)\n";
+				}
+			}
+
+		};
+	return bless $self,$class;
+}
+
+sub get {
+	my ($self,$rkey,$data)=@_;
+
+	# set data to
+	$data||=$self->{data};
+
+	# get key till / or [
+	my $key = $1 if ( $rkey =~ s/^\/([^\/|\[]+)//o );
+	
+	# check index for index
+	my $index = $1 if ( $rkey =~ s/^\[(\d+)\]//o );
+
+	# set rest
+	my $rest  = $rkey;
+
+	# get key from data
+	my $value = $data->{$key};
+
+	# die if key does not exists and something after that is requested 
+	$self->{callback}->{key_does_not_exist}->($data, $key, $index, $value, $rest) 
+		if not exists $data->{$key} and $rest;
+
+	# check index 
+	if (defined $index) {
+
+		# die if index does not exists and something after that is requested 
+		$self->{callback}->{index_does_not_exist}->($data, $key, $index, $value, $rest) 
+			if not exists $value->[$index] and $rest;
+
+		if ( ref $value eq 'ARRAY' ) {
+			$value=$value->[$index];
+		} else {
+			$self->{callback}->{retrieve_index_from_non_array}->($data, $key, $index, $value, $rest);
+		}
+	}
+
+	# check if last element is reached
+	if ($rest) {
+		if ( ref $value eq 'HASH' ) {
+			$value=$self->get($rest,$value);
+		} else {
+			$self->{callback}->{retrieve_key_from_non_hash}->($data, $key, $index, $value, $rest);
+		}
+	}
+
+	return $value;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Data::Path - Perl extension for XPath like accessing from complex data structs
+
+=head1 SYNOPSIS
+
+  use Data::Path;
+
+  my $hashdata={
+  	result => {
+		msg => 
+			[ { text => 'msg0' }
+			, { text => 'msg1' }
+			, { text => 'msg2' }
+			]
+	}
+  }
+  
+  my $hpath=Data::Path->new($hashdata);
+  my $value= $hpath->get('/result/msg[1]/text');
+
+  print "OK" if $value eq 'msg1';
+
+
+  my $hpath=Data::Path->new($hashdata,$callback);
+
+  my $hpath=Data::Path->new
+  	($hashdata,
+	{ key_does_not_exist => sub { die index not found } 
+  	);
+
+=head1 DESCRIPTION
+
+XPath like access to get values from a complex data structs.
+
+key_does_not_exist / index_does_not_exist are only called if it was not the last part of the path.
+If the last part of path is not exists undef is returned.
+
+=head2 CALLBACKs
+
+The default callbacks but you can overwrite this.
+
+	{ key_does_not_exist            =>
+		sub {
+			my ($data, $key, $index, $value, $rest )=@_;
+			die "key $key does not exists\n";
+		}
+
+	, index_does_not_exist         =>
+		sub {
+			my ($data, $key, $index, $value, $rest )=@_;
+			die "key $key\[$index\] does not exists\n";
+		}
+
+	, retrieve_index_from_non_array =>
+		sub {
+			my ($data, $key, $index, $value, $rest )=@_;
+			die "trie to retrieve an index $index from a no array value (in key $key)\n";
+		}
+
+	, retrieve_key_from_non_hash    =>
+		sub {
+			my ($data, $key, $index, $value, $rest )=@_;
+			die "trie to retrieve a key from a no hash value (in key $key)\n";
+		}
+	}
+
+	
+=head2 EXMAPLE overwrite callback
+
+  my $hpath=Data::Path->new
+  	($hashdata,
+	{ key_does_not_exist   => sub { die key not found } 
+	{ index_does_not_exist => sub { die index not found } 
+  	);
+
+
+=head2 EXPORT
+
+None by default.
+
+=head1 SEE ALSO
+
+	XPath
+ 
+=head1 TODO
+
+Slices of data through /foo[*]/bar syntax. eg. retrieve all the bar keys from each element of the foo
+array.
+
+allow accessing the results of coderefs eg. /foo()/bar retreive the result of the foo coderef/method
+of the object
+
+=head1 AUTHOR
+
+Marco Schrieck, E<lt>marco.schrieck@gmx.deE<gt>
+
+Jeremy Wall L<< jeremy@marzhillstudios.com >>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006 by Marco Schrieck
+Copyright (C) 2007 by Jeremy Wall
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.4 or,
+at your option, any later version of Perl 5 you may have available.
+
+
+=cut

t/Data-Path.t

@@ -0,0 +1,89 @@
+
+use Test::More tests => 15;
+BEGIN {
+    use lib qw(lib);
+    use_ok('Data::Path')
+};
+
+
+my $hash=
+    { scalar => 'scalar_value'
+    , array  =>
+        [ qw( array_value0 array_value1 array_value2 array_value3)
+        ]
+    , hash   =>
+        {  hash1 => 'hash_value1'
+        ,  hash2 => 'hash_value2'
+        }
+    , complex =>
+        { level2 =>
+            [ { level3_0 =>
+                [ 'level4_0'
+                , { level4_1 => { level5 => 'huhu' }
+                  }
+				, 'level4_2'
+                ]
+              }
+            ]
+        }
+
+    };
+
+my $a=Data::Path->new($hash);
+
+ok ( $a );
+
+my $v='';
+
+$v=$a->get('/scalar');
+ok ( $v eq 'scalar_value' , " value=$v");
+
+$v=$a->get('/array[0]');
+ok ( $v eq 'array_value0' , " value=$v");
+
+$v=$a->get('/hash/hash1');
+ok ( $v eq 'hash_value1'  , " value=$v");
+
+$v=$a->get('/complex/level2[0]/level3_0[0]');
+ok ( $v eq 'level4_0'     , " value=$v");
+
+$v=$a->get('/complex/level2[0]/level3_0[2]');
+ok ( $v eq 'level4_2'     , " value=$v");
+
+$v=$a->get('/complex/level2[0]/level3_0[1]/level4_1/level5');
+ok ( $v eq 'huhu' ," value=$v");
+
+eval {
+	$a->get('/complex/level2[99]/level3_0[1]/level4_1/level5');
+};
+ok ( $@ =~/does not exists/  ," check error_msg = $@");
+
+eval {
+	$a->get('/complex/level2[0]/level3_1[1]/level4_1/level5');
+};
+ok ( $@ =~/does not exists/  ," check error_msg = $@");
+
+$v=$a->get('/complex/level2[0]/level3_0[1]/level4_1/level5_not_exists') || 'UNDEF';
+ok ( $v eq 'UNDEF' ," value=$v");
+
+$v=$a->get('/complex/level2[0]/level3_0[99]') || 'UNDEF';
+ok ( $v eq 'UNDEF' ," value=$v");
+
+$v=$a->get('/complex/level2[0]/level3_0[2]') || 'UNDEF';
+ok ( $v eq 'level4_2' ," value=$v");
+
+
+my $b=Data::Path->new($hash,
+	{ 'key_does_not_exist'=>sub{ die 'callback_error_key' } 
+	, 'index_does_not_exist'=>sub{ die 'callback_error_index' } 
+	} );
+eval {
+	$b->get('/complex/home/');
+};
+ok ( $@ =~/callback_error_key/  ," check error_msg = $@");
+
+eval {
+	$b->get('/complex/level2[99]/level3_0');
+};
+ok ( $@ =~/callback_error_index/  ," check error_msg = $@");
+