File Coverage

blib/lib/Banal/Utils/Data.pm

Criterion	Covered	Total	%
statement	30	155	19.3
branch	0	80	0.0
condition	0	38	0.0
subroutine	10	16	62.5
pod	3	3	100.0
total	43	292	14.7

#===============================================
package Banal::Utils::Data;

use 5.006;
use utf8;
use strict;
use warnings;
no  warnings qw(uninitialized);

require Exporter;

our @ISA 		= qw(Exporter);
our @EXPORT_OK 	= qw(   banal_get_data
						flatten_complex_data_to_list
						flatten_complex_data_to_list_with_options
					);
use Carp;
use Data::Dumper;
use Banal::Utils::String 	qw(trim);
use Banal::Utils::Array 	qw(array1_starts_with_array2);




##############################################################################"
# PUBLIC (exportable) FUNCTIONS
##############################################################################"


#----------------------------------
# Function, not a method!
#----------------------------------
sub banal_get_data {
	my $args								= {@_};
	my $opts								= $args->{options} || {};
	my $search_upwards_while_not_defined	= $opts->{search_upwards_while_not_defined};



	# This is where the MAGIC happens. For a full list of options, see the function "normalize_data_root_and_keys()".
	my ($root, @keys) 						= _normalize_data_root_and_keys (@_);

	# The data root should have been defined by now.
	return unless ($root);

	# All this for nothing?
	return $root if (scalar(@keys)  < 1);

	# The reason for the below loop is to allow outer level 'variables' to be used when the variable is not defined at the proper (inner) level.
	# Very handy for CONFIGURATION handling scenarios.
	my $key		= pop @keys;
	while (scalar(@keys) >= 0) {
		my $value= _banal_basic_get_data_via_key_list(data=>$root, keys=>[@keys, $key]);
		return $value if defined($value);

		# Continue searching upwards if we are allowed to do so. Return otherwise.
		return unless $search_upwards_while_not_defined;

		pop @keys;
	}
	return;
}



#-----------------------------------------------
# FUNCTION (not a method).
#-----------------------------------------------
sub flatten_complex_data_to_list {
	return flatten_complex_data_to_list_with_options (data=>[@_], on_ArrayRef=>'flatten',  on_HashRef=>'flatten', on_ScalarRef=>'flatten');
}


#-----------------------------------------------
# FUNCTION (not a method).
#-----------------------------------------------
sub flatten_complex_data_to_list_with_options {
	my $opts 			= {@_};
	my $data			= $opts->{data};
	my $on_ArrayRef		= $opts->{on_ArrayRef}	|| 'flatten';
	my $on_HashRef		= $opts->{on_HashRef}	|| 'flatten';
	my $on_ScalarRef	= $opts->{on_ScalarRef}	|| 'flatten';
	my @list			= ();

	foreach my $datum (@$data) {
		if 		((reftype($datum) eq 'ARRAY') 	&& ($on_ArrayRef 	=~ /^flatten|dereference$/io)){
				push @list, flatten_complex_data_to_list_with_options(data=>$datum);
				next;
		}elsif ((reftype($datum) eq 'HASH') 	&& ($on_HashRef 	=~ /^flatten|dereference$/io)){
				push @list, flatten_complex_data_to_list_with_options(data=>[%$datum]);
				next;
		}elsif 	((reftype($datum) eq 'SCALAR') 	&& ($on_ScalarRef 	=~ /^flatten|dereference$/io)){
				push @list, flatten_complex_data_to_list_with_options(data=>[$$datum]);;
				next;

		}else {
				push @list, $datum;
				next;
		}

	}
	return @list;
}


#*******************************************************************
# PRIVATE (non-exported) FUNCTIONS
#*******************************************************************

#----------------------------------
sub _is_absolute_data_key_reference {
	return ((scalar(@_)  > 0) && !$_[0]);
}

#----------------------------------
sub _normalize_data_root_and_keys {
	my $args								= {@_};
	my $keys								= $args->{keys}				|| $args->{key}				|| $args->{path} 	|| [];
	my $data								= $args->{data};
	my $context								= $args->{context}			|| [];
	my $opts								= $args->{options}			|| {};
	my $separator							= $opts->{path_separator} 	|| $opts->{separator} 		|| '/';
	my $remove_extra_separators				= defined($opts->{remove_extra_separators})				? $opts->{remove_extra_separators} 				: 1;
	my $remove_leading_separator			= defined($opts->{remove_leading_separator})			? $opts->{remove_leading_separator} 			: 0;
	my $remove_trailing_separator			= defined($opts->{remove_trailing_separator})			? $opts->{remove_trailing_separator} 			: $remove_extra_separators;
	my $remove_empty_segments				= defined($opts->{remove_empty_segments})				? $opts->{remove_empty_segments} 				: 0;
	my $try_avoiding_repeated_segments		= defined($opts->{try_avoiding_repeated_segments})		? $opts->{try_avoiding_repeated_segments} 		: 0;
	my $lc									= $opts->{lower_case} 		|| $opts->{lc}	|| 0;
	my $trim								= $opts->{trim}				|| 0;

	my $mroot								= undef;	# Yeah, 'undef' by default.
	my $relevant_keys						= [];
	my @accumulated_segs					= ();
	my $use_path_semantics;

	{
		no warnings;
		$use_path_semantics				=	(defined($opts->{path}) && (($keys eq $opts->{path}) || ($keys == $opts->{path})))	? 	1 	: $opts->{use_path_semantics};
	}

	# Flatten all context and key segments (which are potentially a mix of path segment strings)
	$keys = flatten_complex_data_to_list_with_options(data=>[$data, $context, $keys], on_HashRef=>'keep');

	# If we've got a HASH reference given as a key (or context) segment, that's our root. Otherwise, build the relevant thingy (relative to the root).
	foreach my $key (reverse @$keys) {
		if (reftype($key) eq 'HASH') {
			$mroot = $key;
			last;
		}else {
			unshift @$relevant_keys, $key;
		}
	}

	# Flatten all context and key segments (which are potentially a mix of path segment strings)
	while ( scalar(@$relevant_keys)) {
		my $key			= pop @$relevant_keys;
		my @segs		= flatten_complex_data_to_list_with_options(data=>[$key], on_HashRef=>'keep');

		# If it's an empty ARRAY, just ignore, and pass on to the next one.
		next unless (scalar(@segs));

		# Do we have much to do, anyway?
		if ($use_path_semantics)	 {
			my $path 	= join($separator, @segs);

			$path 		=~ s/${separator}+/${separator}/	if ($remove_extra_separators);
			$path 		=~ s/^${separator}// 				if ($remove_leading_separator);			# If you ask for this, you won't be able to detect absolute paths.
		  	$path 		=~ s/${separator}$//				if ($remove_trailing_separator);

			@segs 		= split /$separator/, $path;
		}

		# Lowercase and trim if required.
		@segs			= [map {lc($_)} 	@segs]	if ($lc); 		# Segments are all automatically lowercased, if asked for it.
		@segs			= [map {trim($_)} 	@segs]	if ($trim); 	# Segments are all automatically trimmed, if asked for.

		my @prepend_segs	= @segs;
		if($try_avoiding_repeated_segments) {
			@prepend_segs	= ();
			while (scalar(@segs)) {
				if (array1_starts_with_array2([@accumulated_segs], [@segs])) {
					last;
				}

				my $s = shift @segs;
				push @prepend_segs, $s;
			}
		}

		@accumulated_segs	= (@prepend_segs, @accumulated_segs);

		last if (_is_absolute_data_key_reference(@accumulated_segs));
	}


	# Remove empty segments if we are asked for  it.
	# If you ask for this, you won't be able to detect absolute paths later on (normally, we have already done the detection for you, though)
	@accumulated_segs			= grep (/^\s*$/i,	@accumulated_segs) if ($remove_empty_segments);

	# Here's a little something: We insert the root to the begining of the array.
	unshift @accumulated_segs, $mroot;

	return wantarray ? @accumulated_segs : [@accumulated_segs];
}

#----------------------------------
# Function, not a method!
# 	Allows to get a data element within a deep structure composed of possibly complex data types (HASH, ARRAY, ...)
#   Example:
#		_banal_basic_get_data_via_key_list (data=>$h, keys=>["employee[23]", "department", "name"])
#
# 	In this example, we are assuming that the initial data ($h) is a HASH that has a key called 'employee' which refers to an ARRAY of hashes, ....
#----------------------------------
sub _banal_basic_get_data_via_key_list {
	my $args				= {@_};
	my $data				= $args->{data};
	my $keys				= $args->{keys};
	my @segments			= @$keys;

  	foreach my $segment (@segments) {
	  	next unless $segment;

	  	my $element = $segment;
	  	my $index;

	    if($element =~ /^([^\[]*)\[(\d+)\]$/) {
	      $element = $1;
	      $index   = $2;
	    }
	    else {
	      $index = undef;
	    }

	  	# We're on a SCALAR. Fishy, since we have got a key segment, too.
	 	unless(reftype($data)) {
	 		return;
	 	}

	 	# We're on a SCALAR Reference. Fishy, since we have got a key segment, too.
	 	if(reftype($data) eq "SCALAR") {
	  		return;
	 	}


	 	# We're on an ARRAY.
	    if(reftype($data) eq "ARRAY") {
	    	if (defined ($index) && !defined($element)) {
	    		if(exists $data->[$index]) {
	          		$data = $data->[$index];
	          		next;
	        	}
	        	else {
	          		croak "No element with index $index!\n";
	        	}
	    	}elsif (!defined($element)) {
	    		return $data
	    	}
	      	return;
	    }


	 	# We're on a HASH.
	 	if(reftype($data) eq "HASH") {

	 		# the entire segment (even if it matches the array indexing pattern!)
	 		if (exists $data->{$segment}) {
	 			$data = $data->{$segment};		# this way, we are able to retreive weird hash values with keys that actually match our array indexing.
	      		next;
	    	}

	 		# Now, we are on the normal route.
	 		if (! exists $data->{$element}) {
	      		return;
	    	}
	    	if(reftype($data->{$element}) eq "ARRAY") {
	     		if(! defined($index) ) {
	        		#croak "$element is an array but you didn't specify an index to access it!\n";
	        		$data = $data->{$element};
	        		next;
	      		}
	      		else {
	        		if(exists $data->{$element}->[$index]) {
	          			$data = $data->{$element}->[$index];
	         			 next;
	        		}
	        		else {
	          			croak "$element doesn't have an element with index $index!\n";
	          			return;
	        		}
	      		}
	    	}
	   		 else {
	      		$data = $data->{$element};
	    	}
	 	}
	}

	return $data;
}


1;


__END__