File Coverage

blib/lib/Net/Amazon/MechanicalTurk/DataStructure.pm

Criterion	Covered	Total	%
statement	6	127	4.7
branch	0	68	0.0
condition	0	33	0.0
subroutine	2	15	13.3
pod	0	8	0.0
total	8	251	3.1

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;