File Coverage

lib/PHP/Decode/Array.pm

Criterion	Covered	Total	%
statement	135	150	90.0
branch	58	70	82.8
condition	33	42	78.5
subroutine	20	21	95.2
pod	11	16	68.7
total	257	299	85.9

#
# PHP arrays - a php array is an ordered map.
# http://www.php.net/manual/en/language.types.array.php
#
package PHP::Decode::Array;

use strict;
use warnings;
use Tie::IxHash;
use Exporter qw(import);
our @EXPORT_OK = qw(is_int_index);
our %EXPORT_TAGS = (all => \@EXPORT_OK);

our $VERSION = '0.15';

my $arridx = 1;
our $arrpfx = '#arr';
our $class_strmap; # client might override $PHP::Decode::Array::class_strmap = \%strmap;

sub new_name {
	my $name = "$arrpfx$arridx";
	$arridx++;
	return $name;
}

sub is_int_index {
	my ($k) = @_;

	if ($k =~ /^\-?\d+$/) {
		return 1;
	}
	return 0;
}

sub _ordered_map {
	my ($self) = @_;

	# preserve the order of inserted keys
	# https://perldoc.perl.org/perlfaq4#How-can-I-make-my-hash-remember-the-order-I-put-elements-into-it?
	# https://metacpan.org/pod/Tie::IxHash
	#
	tie my %map, "Tie::IxHash";

	# convert existing consecutive numeric map to ordered map
	#
	if (exists $self->{map}) {
		foreach my $k (sort { $a <=> $b } keys %{$self->{map}}) {
			$map{$k} = $self->{map}{$k};
		}
	}
	return \%map;
}

sub new {
	my ($class, %args) = @_;

	# $self->{map} is created on demand and converted to ordered map
	# if required. A native perl hashmap is much faster.
	#
	my $self = bless {
                %args,
		name => new_name(),
		idx => undef,
		pos => 0,
	}, $class;
	$self->{strmap} = $class_strmap unless exists $self->{strmap};

	if (defined $self->{strmap}) {
		$self->{strmap}{$self->{name}} = $self; # register name
	}
	return $self;
}

# return number if key contains numeric value.
#
sub get_index {
	my ($self, $k) = @_;
	my $k0 = $k;

	# float keys are truncated to int,
	# http://php.net/manual/en/language.types.array.php
	# (but only int-strings are converted to int-key)
	#
	if (defined $self->{strmap} && exists $self->{strmap}{$k}) {
		$k = $self->{strmap}{$k};
	}
	if (($k0 =~ /^#str\d+$/) && ($k =~ /^\-?(\d|[1-9]\d+)$/)) {
		$k = int($k);
	} elsif (($k0 !~ /^#str\d+$/) && (ref($k) eq '') && ($k =~ /^\-?(\d|[1-9]\d+|\d+\.\d*|\d*\.\d+)([eE][+-]?\d+)?$/)) {
		$k = int($k);
	} else {
		$k = $k0;
	}
	return $k;
}

sub set {
	my ($self, $k, $v) = @_;

	# without key use the increment of the largest previously used int key
	#
	if (defined $k) {
		$k = $self->get_index($k);
		if (is_int_index($k)) {
			if (!defined $self->{idx} || ($k >= $self->{idx})) {
				$self->{idx} = $k+1;
			}
		} else {
			$self->{non_numeric} = 1;
		}
		if (!exists $self->{map} || !exists $self->{ordered}) {
			$self->{map} = $self->_ordered_map();
			$self->{ordered} = 1;
		}
	} else {
		# use faster unordered map as long as no explicit key is used.
		#
		$self->{map} = {} unless exists $self->{map};
		$self->{idx} = 0 unless defined $self->{idx};
		$k = $self->{idx};
		$self->{idx} += 1;
	}
	if (defined $self->{strmap} && (ref($v) eq ref($self))) {
		$self->{map}{$k} = $v->{name};
	} else {
		$self->{map}{$k} = $v;
	}
	#printf ">> setarr: %s{%s} = %s\n", $self->{name}, $k, $v if $opt{v};
	return $self;
}

sub get {
	my ($self, $k) = @_;

	if (exists $self->{map}) {
		$k = $self->get_index($k);

		if (exists $self->{map}{$k}) {
			return $self->{map}{$k};
		}
	}
	return;
}

sub copy {
	my ($self, $keys) = @_;

	# TODO: #arr$x.$y sub-name here?
	#
	my $c = PHP::Decode::Array->new(strmap => $self->{strmap});

	if (exists $self->{map}) {
		if (exists $self->{ordered} || defined $keys) {
			$c->{map} = $c->_ordered_map();
			$c->{ordered} = 1;
		} else {
			$c->{map} = {};
		}
		unless (defined $keys) {
			$keys = [keys %{$self->{map}}]; # default: all keys
		}
		foreach my $k (@$keys) {
			my $v0 = $self->{map}{$k};
			my $v = $v0;

			if (defined $v && defined $self->{strmap} && exists $self->{strmap}{$v}) {
				$v = $self->{strmap}{$v};
			}
			if (defined $v && (ref($v) eq ref($self))) {
				my $subarray = $v->copy();
				if (defined $self->{strmap}) {
					$c->{map}{$k} = $subarray->{name};
				} else {
					$c->{map}{$k} = $subarray;
				}
			} else {
				$c->{map}{$k} = $v0;
			}
		}
		$c->{idx} = $self->{idx};
		$c->{pos} = $self->{pos};
		$c->{non_mumeric} = 1 if exists $self->{non_numeric};
	}
	return $c;
}

sub delete {
	my ($self, $k) = @_;

	if (exists $self->{map}) {
		# after deletion key order has to be preserved
		#
		unless (exists $self->{ordered}) {
			$self->{map} = $self->_ordered_map();
			$self->{ordered} = 1;
		}
		return delete $self->{map}{$k};
	}
	return;
}

sub val {
	my ($self, $k) = @_;
	exists $self->{map}{$k} || die "assert: bad key $k passed to array->val()";
	return $self->{map}{$k}; # for get_keys lookup
}

sub get_keys {
	my ($self) = @_;

	if (exists $self->{map}) {
		my @keys;
		if (exists $self->{ordered}) {
			# insertion order is preserved by Tie::IxHash
			#
			@keys = keys %{$self->{map}};
		} else {
			@keys = sort { $a <=> $b } keys %{$self->{map}};
		}
		return \@keys;
	}
	return [];
}

sub get_keys_sorted {
	my ($self) = @_;
	my @keys;

	# sort non-hash arrays by index
	#
	if (exists $self->{map}) {
		if (exists $self->{non_numeric}) {
			@keys = sort keys %{$self->{map}};
		} else {
			@keys = sort { $a <=> $b } keys %{$self->{map}};
		}
		return \@keys;
	}
	return [];
}

sub get_pos {
	my ($self) = @_;

	return $self->{pos};
}

sub set_pos {
	my ($self, $pos) = @_;

	$self->{pos} = $pos;
	return;
}

sub is_numerical {
	my ($self) = @_;

	if (exists $self->{non_numeric}) {
		return 0;
	}
	return 1;
}

sub empty {
	my ($self) = @_;

	return (keys %{$self->{map}} == 0);
}

sub to_str {
	my ($self) = @_;
	my $keys = $self->get_keys();
	my $str = '(';

	foreach my $k (@$keys) {
		my $v = $self->{map}{$k};

		if (defined $v && defined $self->{strmap} && exists $self->{strmap}{$v}) {
			$v = $self->{strmap}{$v};
		}
		$str .= ', ' if ($str ne '(');
		if (defined $v && (ref($v) eq ref($self))) {
			$str .= $v->to_str();
		} else {
			if (is_int_index($k)) {
				$str .= "$k => '$v'";
			} else {
				$str .= "'$k' => '$v'";
			}
		}
	}
	$str .= ')';
	return $str;
}

1;

__END__