package Net::Amazon::MechanicalTurk::DataStructure; use strict; use warnings; our $VERSION = '1.00'; sub wrap { my ($class, $data) = @_; visit($data, sub { my ($key, $value, $nodes) = @_; if (ref($value)) { bless($value, $class); } }); } sub fromProperties { # Assume static call if 1st arg is not this class shift if ($#_ >= 0 and $_[0] eq "Net::Amazon::MechanicalTurk::DataStructure"); my $data = {}; my $props = shift; while (my ($fullKey,$value) = each %$props) { my $nodeRef = \$data; foreach my $key (split(/\./, $fullKey)) { if (UNIVERSAL::isa(${$nodeRef}, "HASH")) { $nodeRef = \${$nodeRef}->{$key}; } elsif (UNIVERSAL::isa(${$nodeRef}, "ARRAY")) { if ($key !~ /^\d+$/ or $key < 1) { Carp::croak("Can't convert key $fullKey to data structure."); } $nodeRef = \${$nodeRef}->[$key-1]; } elsif ($key =~ /^\d+$/) { ${$nodeRef} = []; $nodeRef = \${$nodeRef}->[$key-1]; } else { ${$nodeRef} = {}; $nodeRef = \${$nodeRef}->{$key}; } } ${$nodeRef} = $value; } return $data; } sub toProperties { # Assume static call if 1st arg is not this class shift if ($#_ >= 0 and $_[0] eq "Net::Amazon::MechanicalTurk::DataStructure"); my $self = shift; my $props = {}; eachFlattenedProperty($self, sub { my ($key, $value) = @_; $props->{$key} = $value; }); return $props; } sub eachFlattenedProperty { # Assume static call if 1st arg is not this class shift if ($#_ >= 0 and $_[0] eq "Net::Amazon::MechanicalTurk::DataStructure"); my ($self, $block) = @_; return unless defined($self); _eachFlattenedProperty(undef, $self, 0, $block); } sub _eachFlattenedProperty { my ($key, $value, $parentIsHash, $block) = @_; if (UNIVERSAL::isa($value, "ARRAY")) { for (my $i=0; $i<=$#{$value}; $i++) { _eachFlattenedProperty($key.".".($i+1), $value->[$i], 0, $block); } } elsif (UNIVERSAL::isa($value, "HASH")) { while (my ($subKey,$subValue) = each %$value) { my $newKey = $subKey; if (defined($key)) { $newKey = ($parentIsHash) ? "${key}.1.${subKey}" : "${key}.${subKey}"; } _eachFlattenedProperty($newKey, $subValue, 1, $block); } } else { $block->($key, $value); } } sub visit { # Assume static call if 1st arg is not this class shift if ($#_ >= 0 and $_[0] eq "Net::Amazon::MechanicalTurk::DataStructure"); my ($self, $block, $orderKeys) = @_; _visit(undef, $self, [], $block, $orderKeys); } sub _visit { my ($key, $value, $nodes, $block, $orderKeys) = @_; return unless defined($value); $block->($key, $value, $nodes); push(@$nodes, $value); if (UNIVERSAL::isa($value, "HASH")) { if ($orderKeys) { foreach my $k (sort keys %$value) { _visit($k, $value->{$k}, $nodes, $block, $orderKeys); } } else { while (my ($k,$v) = each %{$value}) { _visit($k, $v, $nodes, $block, $orderKeys); } } } elsif (UNIVERSAL::isa($value, "ARRAY")) { for (my $i=0; $i<=$#{$value}; $i++) { _visit($i, $value->[$i], $nodes, $block, $orderKeys); } } pop(@$nodes); } sub toString { # Assume static call if 1st arg is not this class shift if ($#_ >= 0 and $_[0] eq "Net::Amazon::MechanicalTurk::DataStructure"); my $self = shift; my $message = "<<" . ref($self) . ">>"; visit($self, sub { my ($key, $value, $nodes) = @_; if (!defined($key)) { return; } if (!UNIVERSAL::isa($value, "ARRAY") && !UNIVERSAL::isa($value, "HASH")) { $message .= "\n" . (" " x ($#{$nodes}*2)) . "[$key]" . " " . $value; } else { $message .= "\n" . (" " x ($#{$nodes}*2)) . "[$key]"; } }, 1); return $message; } sub getFirst { # Assume static call if 1st arg is not this class shift if ($#_ >= 0 and $_[0] eq "Net::Amazon::MechanicalTurk::DataStructure"); my $self = shift; my $result = get($self, @_); if (UNIVERSAL::isa($result, "ARRAY")) { return ($#{$result} >= 0) ? $result->[0] : undef; } else { return $result; } } sub get { # Assume static call if 1st arg is not this class shift if ($#_ >= 0 and $_[0] eq "Net::Amazon::MechanicalTurk::DataStructure"); my $self = shift; my @matches; if ($#_ == 0) { if (UNIVERSAL::isa($_[0], "ARRAY")) { @matches = @$_[0]; } else { @matches = split /\./, $_[0]; } } else { @matches = @_; } my $node = $self; my $i = 0; while ($i <= $#matches) { my $match = $matches[$i]; if (UNIVERSAL::isa($node, "ARRAY")) { # numeric indices are 1 based if ($match =~ /^\d+$/) { if ($match < 1 or $match > ($#{$node}+1)) { return undef; } $node = $node->[$match-1]; $i++; } elsif ($#{$node} >= 0) { $node = $node->[0]; } else { return undef; } } elsif (UNIVERSAL::isa($node, "HASH")) { if (!exists $node->{$match}) { if ($match =~ /^\d+$/ and $match == 1) { # handle case where data structure has # a hash containing a hash # but get supplied an index of 1 # family.1.kid.1 # { family => { kid => ['k1', 'k2' ] } # allows get to read properties produced # by toProperties $i++; } else { return undef; } } else { $node = $node->{$match}; $i++; } } else { return undef; } } return $node; } return 1;