From bd812b73579b395daecff047c664f450cb16e7a7 Mon Sep 17 00:00:00 2001 From: jeremy Date: Sat, 25 Aug 2007 21:48:20 -0500 Subject: [PATCH] Import of original from CPAN darcs-hash:20070826024820-f4041-398ec2fd305416e5da8a1ff7524a7fefd671a842.gz --- Makefile.PL | 10 +++ README | 24 ++++++ lib/Data/Path.pm | 207 +++++++++++++++++++++++++++++++++++++++++++++++ t/Data-Path.t | 89 ++++++++++++++++++++ 4 files changed, 330 insertions(+) create mode 100644 Makefile.PL create mode 100644 README create mode 100644 lib/Data/Path.pm create mode 100644 t/Data-Path.t diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..ede2aa4 --- /dev/null +++ b/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; diff --git a/README b/README new file mode 100644 index 0000000..c27cbe0 --- /dev/null +++ b/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. + + diff --git a/lib/Data/Path.pm b/lib/Data/Path.pm new file mode 100644 index 0000000..52d3017 --- /dev/null +++ b/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, Emarco.schrieck@gmx.deE + +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 diff --git a/t/Data-Path.t b/t/Data-Path.t new file mode 100644 index 0000000..74d7a5a --- /dev/null +++ b/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 = $@"); +