File Coverage

blib/lib/YAML/Active.pm

Criterion	Covered	Total	%
statement	82	118	69.4
branch	23	54	42.5
condition	2	12	16.6
subroutine	24	31	77.4
pod	15	15	100.0
total	146	230	63.4

use 5.008;
use strict;
use warnings;

package YAML::Active;
our $VERSION = '1.100810';
# ABSTRACT: Combine data and logic in YAML
use YAML::XS ();    # no imports, we'll define our own Load() and LoadFile()
use Exporter qw(import);
our %EXPORT_TAGS = (
    load   => [qw{Load Load_inactive Reload LoadFile}],
    dump   => [qw{Dump}],
    active => [qw{node_activate array_activate hash_activate}],
    assert => [qw{assert_arrayref assert_hashref}],
    null   => [qw{yaml_NULL NULL}],
);
our @EXPORT_OK = @{ $EXPORT_TAGS{all} = [ map { @$_ } values %EXPORT_TAGS ] };
use constant NULL => 'YAML::Active::NULL';

sub should_process_node_in_phase {
    my ($node, $phase) = @_;

    if (defined $phase) {
        return 0
          unless exists $node->{_phase} && $phase eq $node->{_phase};
    } else {
        return 0 if exists $node->{_phase};
    }
    return 1;
}

sub array_activate ($$) {
    my ($node, $phase) = @_;

    #my @result;
    #my @node = @$node;
    #for my $index (0..$#node) {
    #    my $activated = node_activate($node[$index], $phase);
    #    next if ref($activated) eq NULL;
    #    push @result, $activated;
    #}
    #\@result;
    [   grep { ref ne NULL }
        map { node_activate($_, $phase) } @$node
    ];
}

sub hash_activate ($$) {
    my ($node, $phase) = @_;
    return unless should_process_node_in_phase($node, $phase);
    return {
        map {
            my $val = node_activate($node->{$_}, $phase);
            ref $val eq NULL ? () : ($_ => $val)
          } keys %$node
    };
}

sub node_activate ($$) {
    my ($node, $phase) = @_;
    return array_activate($node, $phase) if ref $node eq 'ARRAY';
    return hash_activate($node, $phase) if ref $node eq 'HASH';

    # FIXME:
    # don't just do
    #
    #   return array_activate($node, $phase)
    #
    # because of the following situation:
    #
    #   x: &REF
    #    foo: 1
    #   y: *REF
    #
    # $data->{y} comes out of YAML itself as a proper reference, but when we
    # just replace $data->{x}, the value of $data->{y} still points to the old
    # "{ foo => 1 }" hash ref and so gets replaced independently as well. This
    # means we end up not with a reference but with two reference, each
    # pointing to the same cloned hash.
    #     if (ref $node eq 'ARRAY') {
    #         my $result = array_activate($node, $phase);
    #         if (UNIVERSAL::isa($result, 'ARRAY')) {
    #             @$node = @$result;
    #             return $node;
    #         } else {
    #             return $result;
    #         }
    #     } elsif (ref $node eq 'HASH') {
    #         my $result = hash_activate($node, $phase);
    #         if (UNIVERSAL::isa($result, 'HASH')) {
    #             %$node = %$result;
    #             return $node;
    #         } else {
    #             return $result;
    #         }
    #     }
    if (my $class = ref $node) {
        if (!$class->can('yaml_activate')
            && index($class, 'YAML::Active') != -1) {
            eval "require $class";
            die $@ if $@;
        }
        if ($node->can('yaml_activate')) {
            return $node->yaml_activate($phase);
        } else {

            # it's a blessed reference, but it can't yaml_activate, so dig
            # deeper
            my $activated =
                UNIVERSAL::isa($node, 'ARRAY') ? array_activate($node, $phase)
              : UNIVERSAL::isa($node, 'HASH') ? hash_activate($node, $phase)
              :                                 $node;
            return bless $activated, ref $node;

            #             if (UNIVERSAL::isa($node, 'ARRAY')) {
            #                 my $result = array_activate($node, $phase);
            #                 if (UNIVERSAL::isa($result, 'ARRAY')) {
            #                     # the blessing stays the same
            #                     @$node = @$result;
            #                     return $node;
            #                 } else {
            #                     return bless $result, ref $node;
            #                 }
            #             } elsif (UNIVERSAL::isa($node, 'HASH')) {
            #                 my $result = hash_activate($node, $phase);
            #                 if (UNIVERSAL::isa($result, 'HASH')) {
            #                     # the blessing stays the same
            #                     %$node = %$result;
            #                     return $node;
            #                 } else {
            #                     return bless $result, ref $node;
            #                 }
            #             }
            #
            #             return $node;
        }
    }
    return $node;
}

# pass through
sub Load_inactive {
    my $node = shift;
    YAML::XS::Load($node);
}

sub Load {
    my ($node, $phase) = @_;
    node_activate(YAML::XS::Load($node), $phase)

      #my $x = node_activate(Load_inactive($node), $phase);
      #use Data::Dumper; print Dumper $x;
      #if (ref $x->{setup} eq 'HASH') {
      #    printf "foo [%s]\n", $x->{setup}{foo};
      #    printf "bar [%s]\n", $x->{setup}{bar};
      #}
      #$x;
}

sub Reload {
    my ($node, $phase) = @_;
    Load(Dump($node), $phase);
}

sub LoadFile {
    my ($node, $phase) = @_;
    node_activate(YAML::XS::LoadFile($node), $phase);
}

sub assert_arrayref {
    return if UNIVERSAL::isa($_[0], 'ARRAY');
    die sprintf "%s expects an array ref", (caller)[0];
}

sub assert_hashref {
    return if UNIVERSAL::isa($_[0], 'HASH');
    die sprintf "%s expects a hash ref", (caller)[0];
}
sub yaml_NULL { bless {}, NULL }

# end of activation-related code
# start of dump-related code
sub Dump {
    my ($node, %args) = @_;
    local $YAML::XS::ForceBlock =
      exists $args{ForceBlock} ? $args{ForceBlock} : 1;
    my $dump = YAML::XS::Dump(node_dump($node));
    our %prepare_dump;
    $_->can('finish_dump') && $_->finish_dump for keys %prepare_dump;
    $dump;
}

sub node_dump ($) {
    my $node = shift;
    return array_dump($node) if ref $node eq 'ARRAY';
    return hash_dump($node)  if ref $node eq 'HASH';
    if (my $class = ref $node) {
        if (!$node->can('yaml_dump')) {
            eval "require $class";
            die $@ if $@;
        }
        if ($node->can('prepare_dump')) {
            our %prepare_dump;
            $prepare_dump{ ref $node } ||= $node->prepare_dump;
        }
        return $node->can('yaml_dump') ? $node->yaml_dump : $node;
    }
    return $node;
}

sub array_dump ($) {
    my $node = shift;
    [   grep { ref ne NULL }
        map { node_dump($_) } @$node
    ];
}

sub hash_dump ($) {
    my $node = shift;
    return {
        map {
            my $val = node_dump($node->{$_});
            ref $val eq NULL ? () : ($_ => $val)
          } keys %$node
    };
}

package YAML::Active::Concat;
our $VERSION = '1.100810';
YAML::Active->import(':all');

sub yaml_activate {
    my ($self, $phase) = @_;
    assert_arrayref($self);
    return join '' => @{ array_activate($self, $phase) };
}

package YAML::Active::Eval;
our $VERSION = '1.100810';
YAML::Active->import(':all');

sub yaml_activate {
    my ($self, $phase) = @_;
    assert_hashref($self);
    my $code_ref = eval node_activate($self->{code}, $phase);
    return $code_ref->();
}

package YAML::Active::Include;
our $VERSION = '1.100810';
YAML::Active->import(':all');

sub yaml_activate {
    my ($self, $phase) = @_;
    assert_hashref($self);
    return LoadFile(node_activate($self->{filename}, $phase));
}
sub YAML::Active::PID::yaml_activate { $$ }

package YAML::Active::Shuffle;
our $VERSION = '1.100810';
YAML::Active->import(':all');

sub yaml_activate {
    my ($self, $phase) = @_;
    assert_arrayref($self);
    return [ sort { 1 - int rand 3 } @{ array_activate($self, $phase) } ];
}

# example of a side-effect-only plugin
package YAML::Active::Print;
our $VERSION = '1.100810';
YAML::Active->import(':all');

sub yaml_activate {
    my ($self, $phase) = @_;
    assert_arrayref($self);
    my $result = array_activate($self, $phase);
    print @$result;
    return yaml_NULL();
}

package YAML::Active::ValueMutator;
our $VERSION = '1.100810';
YAML::Active->import(':all');
sub mutate_value { $_[1] }

sub yaml_activate {
    my ($self, $phase) = @_;
    if (UNIVERSAL::isa($self, 'ARRAY')) {
        return [ map { ref($_) ? $_ : $self->mutate_value($_) }
              @{ array_activate($self, $phase) } ];
    } elsif (UNIVERSAL::isa($self, 'HASH')) {
        my $h = hash_activate($self, $phase);
        $_ = $self->mutate_value($_) for grep { !ref } values %$h;
        return $h;
    }
    return $self;    # shouldn't get here
}

package YAML::Active::uc;
our $VERSION = '1.100810';
our @ISA = 'YAML::Active::ValueMutator';
sub mutate_value { uc $_[1] }

package YAML::Active::lc;
our $VERSION = '1.100810';
our @ISA = 'YAML::Active::ValueMutator';
sub mutate_value { lc $_[1] }
1;


__END__