File Coverage

blib/lib/YAML/PP/Schema/Perl.pm

Criterion	Covered	Total	%
statement	319	328	97.2
branch	88	100	88.0
condition	12	18	66.6
subroutine	63	63	100.0
pod	13	13	100.0
total	495	522	94.8

use strict;
use warnings;
package YAML::PP::Schema::Perl;

our $VERSION = '0.036_001'; # TRIAL VERSION

use Scalar::Util qw/ blessed reftype /;

my $qr_prefix;
# workaround to avoid growing regexes when repeatedly loading and dumping
# e.g. (?^:(?^:regex))
{
    $qr_prefix = qr{\(\?-xism\:};
    if ($] >= 5.014) {
        $qr_prefix = qr{\(\?\^(?:[uadl])?\:};
    }
}

sub new {
    my ($class, %args) = @_;
    my $tags = $args{tags} || [];
    my $loadcode = $args{loadcode} || 0;
    my $dumpcode = $args{dumpcode};
    $dumpcode = 1 unless defined $dumpcode;
    my $classes = $args{classes};

    my $self = bless {
        tags => $tags,
        loadcode => $loadcode,
        dumpcode => $dumpcode,
        classes => $classes,
    }, $class;
}

sub register {
    my ($self, %args) = @_;
    my $schema = $args{schema};

    my $tags;
    my $loadcode = 0;
    my $dumpcode = 1;
    my $classes;
    if (blessed($self)) {
        $tags = $self->{tags};
        @$tags = ('!perl') unless @$tags;
        $loadcode = $self->{loadcode};
        $dumpcode = $self->{dumpcode};
        $classes = $self->{classes};
    }
    else {
        my $options = $args{options};
        my $tagtype = '!perl';
        for my $option (@$options) {
            if ($option =~ m/^tags?=(.+)$/) {
                $tagtype = $1;
            }
            elsif ($option eq '+loadcode') {
                $loadcode = 1;
            }
            elsif ($option eq '-dumpcode') {
                $dumpcode = 0;
            }
        }
        $tags = [split m/\+/, $tagtype];
    }


    my $perl_tag;
    my %tagtypes;
    my @perl_tags;
    for my $type (@$tags) {
        if ($type eq '!perl') {
            $perl_tag ||= $type;
            push @perl_tags, '!perl';
        }
        elsif ($type eq '!!perl') {
            $perl_tag ||= 'tag:yaml.org,2002:perl';
            push @perl_tags, 'tag:yaml.org,2002:perl';
        }
        else {
            die "Invalid tagtype '$type'";
        }
        $tagtypes{ $type } = 1;
    }

    my $perl_regex = '!perl';
    if ($tagtypes{'!perl'} and $tagtypes{'!!perl'}) {
        $perl_regex = '(?:tag:yaml\\.org,2002:|!)perl';
    }
    elsif ($tagtypes{'!perl'}) {
        $perl_regex = '!perl';
    }
    elsif ($tagtypes{'!!perl'}) {
        $perl_regex = 'tag:yaml\\.org,2002:perl';
    }

    my $class_regex = qr{.+};
    my $no_objects = 0;
    if ($classes) {
        if (@$classes) {
            $class_regex = '(' . join( '|', map "\Q$_\E", @$classes ) . ')';
        }
        else {
            $no_objects = 1;
            $class_regex = '';
        }
    }

    # Code
    if ($loadcode) {
        my $load_code = sub {
            my ($constructor, $event) = @_;
            return $self->evaluate_code($event->{value});
        };
        my $load_code_blessed = sub {
            my ($constructor, $event) = @_;
            my $class = $event->{tag};
            $class =~ s{^$perl_regex/code:}{};
            my $sub = $self->evaluate_code($event->{value});
            return $self->object($sub, $class);
        };
        $schema->add_resolver(
            tag => "$_/code",
            match => [ all => $load_code],
            implicit => 0,
        ) for @perl_tags;
        $schema->add_resolver(
            tag => qr{^$perl_regex/code:$class_regex$},
            match => [ all => $load_code_blessed ],
            implicit => 0,
        );
        $schema->add_resolver(
            tag => qr{^$perl_regex/code:.+},
            match => [ all => $load_code ],
            implicit => 0,
        ) if $no_objects;
    }
    else {
        my $loadcode_dummy = sub { return sub {} };
        my $loadcode_blessed_dummy = sub {
            my ($constructor, $event) = @_;
            my $class = $event->{tag};
            $class =~ s{^$perl_regex/code:}{};
            return $self->object(sub {}, $class);
        };
        $schema->add_resolver(
            tag => "$_/code",
            match => [ all => $loadcode_dummy ],
            implicit => 0,
        ) for @perl_tags;
        $schema->add_resolver(
            tag => qr{^$perl_regex/code:$class_regex$},
            match => [ all => $loadcode_blessed_dummy ],
            implicit => 0,
        );
        $schema->add_resolver(
            tag => qr{^$perl_regex/code:.+},
            match => [ all => $loadcode_dummy ],
            implicit => 0,
        ) if $no_objects;
    }

    # Glob
    my $load_glob = sub {
        my $value = undef;
        return \$value;
    };
    my $load_glob_blessed = sub {
        my ($constructor, $event) = @_;
        my $class = $event->{tag};
        $class =~ s{^$perl_regex/glob:}{};
        my $value = undef;
        return $self->object(\$value, $class);
    };

    $schema->add_mapping_resolver(
        tag => "$_/glob",
        on_create => $load_glob,
        on_data => sub {
            my ($constructor, $ref, $list) = @_;
            $$ref = $self->construct_glob($list);
        },
    ) for @perl_tags;
    if ($no_objects) {
        $schema->add_mapping_resolver(
            tag => qr{^$perl_regex/glob:.+$},
            on_create => $load_glob,
            on_data => sub {
                my ($constructor, $ref, $list) = @_;
                $$ref = $self->construct_glob($list);
            },
        );
    }
    else {
        $schema->add_mapping_resolver(
            tag => qr{^$perl_regex/glob:$class_regex$},
            on_create => $load_glob_blessed,
            on_data => sub {
                my ($constructor, $ref, $list) = @_;
                $$$ref = $self->construct_glob($list);
            },
        );
    }

    # Regex
    my $load_regex = sub {
        my ($constructor, $event) = @_;
        return $self->construct_regex($event->{value});
    };
    my $load_regex_blessed = sub {
        my ($constructor, $event) = @_;
        my $class = $event->{tag};
        $class =~ s{^$perl_regex/regexp:}{};
        my $qr = $self->construct_regex($event->{value});
        return $self->object($qr, $class);
    };
    $schema->add_resolver(
        tag => "$_/regexp",
        match => [ all => $load_regex ],
        implicit => 0,
    ) for @perl_tags;
    $schema->add_resolver(
        tag => qr{^$perl_regex/regexp:$class_regex$},
        match => [ all => $load_regex_blessed ],
        implicit => 0,
    );
    $schema->add_resolver(
        tag => qr{^$perl_regex/regexp:$class_regex$},
        match => [ all => $load_regex ],
        implicit => 0,
    ) if $no_objects;

    my $load_sequence = sub { return [] };
    my $load_sequence_blessed = sub {
        my ($constructor, $event) = @_;
        my $class = $event->{tag};
        $class =~ s{^$perl_regex/array:}{};
        return $self->object([], $class);
    };
    $schema->add_sequence_resolver(
        tag => "$_/array",
        on_create => $load_sequence,
    ) for @perl_tags;
    $schema->add_sequence_resolver(
        tag => qr{^$perl_regex/array:$class_regex$},
        on_create => $load_sequence_blessed,
    );
    $schema->add_sequence_resolver(
        tag => qr{^$perl_regex/array:.+$},
        on_create => $load_sequence,
    ) if $no_objects;

    my $load_mapping = sub { return {} };
    my $load_mapping_blessed = sub {
        my ($constructor, $event) = @_;
        my $class = $event->{tag};
        $class =~ s{^$perl_regex/hash:}{};
        return $self->object({}, $class);
    };
    $schema->add_mapping_resolver(
        tag => "$_/hash",
        on_create => $load_mapping,
    ) for @perl_tags;
    $schema->add_mapping_resolver(
        tag => qr{^$perl_regex/hash:$class_regex$},
        on_create => $load_mapping_blessed,
    );
    $schema->add_mapping_resolver(
        tag => qr{^$perl_regex/hash:.+$},
        on_create => $load_mapping,
    ) if $no_objects;

    # Ref
    my $load_ref = sub {
        my $value = undef;
        return \$value;
    };
    my $load_ref_blessed = sub {
        my ($constructor, $event) = @_;
        my $class = $event->{tag};
        $class =~ s{^$perl_regex/ref:}{};
        my $value = undef;
        return $self->object(\$value, $class);
    };
    $schema->add_mapping_resolver(
        tag => "$_/ref",
        on_create => $load_ref,
        on_data => sub {
            my ($constructor, $ref, $list) = @_;
            $$$ref = $self->construct_ref($list);
        },
    ) for @perl_tags;
    $schema->add_mapping_resolver(
        tag => qr{^$perl_regex/ref:$class_regex$},
        on_create => $load_ref_blessed,
        on_data => sub {
            my ($constructor, $ref, $list) = @_;
            $$$ref = $self->construct_ref($list);
        },
    );
    $schema->add_mapping_resolver(
        tag => qr{^$perl_regex/ref:.+$},
        on_create => $load_ref,
        on_data => sub {
            my ($constructor, $ref, $list) = @_;
            $$$ref = $self->construct_ref($list);
        },
    ) if $no_objects;

    # Scalar ref
    my $load_scalar_ref = sub {
        my $value = undef;
        return \$value;
    };
    my $load_scalar_ref_blessed = sub {
        my ($constructor, $event) = @_;
        my $class = $event->{tag};
        $class =~ s{^$perl_regex/scalar:}{};
        my $value = undef;
        return $self->object(\$value, $class);
    };
    $schema->add_mapping_resolver(
        tag => "$_/scalar",
        on_create => $load_scalar_ref,
        on_data => sub {
            my ($constructor, $ref, $list) = @_;
            $$$ref = $self->construct_scalar($list);
        },
    ) for @perl_tags;
    $schema->add_mapping_resolver(
        tag => qr{^$perl_regex/scalar:$class_regex$},
        on_create => $load_scalar_ref_blessed,
        on_data => sub {
            my ($constructor, $ref, $list) = @_;
            $$$ref = $self->construct_scalar($list);
        },
    );
    $schema->add_mapping_resolver(
        tag => qr{^$perl_regex/scalar:.+$},
        on_create => $load_scalar_ref,
        on_data => sub {
            my ($constructor, $ref, $list) = @_;
            $$$ref = $self->construct_scalar($list);
        },
    ) if $no_objects;

    $schema->add_representer(
        scalarref => 1,
        code => sub {
            my ($rep, $node) = @_;
            $node->{tag} = $perl_tag . "/scalar";
            $node->{data} = $self->represent_scalar($node->{value});
        },
    );
    $schema->add_representer(
        refref => 1,
        code => sub {
            my ($rep, $node) = @_;
            $node->{tag} = $perl_tag . "/ref";
            $node->{data} = $self->represent_ref($node->{value});
        },
    );
    $schema->add_representer(
        coderef => 1,
        code => sub {
            my ($rep, $node) = @_;
            $node->{tag} = $perl_tag . "/code";
            $node->{data} = $dumpcode ? $self->represent_code($node->{value}) : '{ "DUMMY" }';
        },
    );
    $schema->add_representer(
        glob => 1,
        code => sub {
            my ($rep, $node) = @_;
            $node->{tag} = $perl_tag . "/glob";
            $node->{data} = $self->represent_glob($node->{value});
        },
    );

    $schema->add_representer(
        class_matches => 1,
        code => sub {
            my ($rep, $node) = @_;
            my $blessed = blessed $node->{value};
            my $tag_blessed = ":$blessed";
            if ($blessed !~ m/^$class_regex$/) {
                $tag_blessed = '';
            }
            $node->{tag} = sprintf "$perl_tag/%s%s",
                lc($node->{reftype}), $tag_blessed;
            if ($node->{reftype} eq 'HASH') {
                $node->{data} = $node->{value};
            }
            elsif ($node->{reftype} eq 'ARRAY') {
                $node->{data} = $node->{value};
            }

            # Fun with regexes in perl versions!
            elsif ($node->{reftype} eq 'REGEXP') {
                if ($blessed eq 'Regexp') {
                    $node->{tag} = $perl_tag . "/regexp";
                }
                $node->{data} = $self->represent_regex($node->{value});
            }
            elsif ($node->{reftype} eq 'SCALAR') {

                # in perl <= 5.10 regex reftype(regex) was SCALAR
                if ($blessed eq 'Regexp') {
                    $node->{tag} = $perl_tag . '/regexp';
                    $node->{data} = $self->represent_regex($node->{value});
                }

                # In perl <= 5.10 there seemed to be no better pure perl
                # way to detect a blessed regex?
                elsif (
                    $] <= 5.010001
                    and not defined ${ $node->{value} }
                    and $node->{value} =~ m/^\(\?/
                ) {
                    $node->{tag} = $perl_tag . '/regexp' . $tag_blessed;
                    $node->{data} = $self->represent_regex($node->{value});
                }
                else {
                    # phew, just a simple scalarref
                    $node->{data} = $self->represent_scalar($node->{value});
                }
            }
            elsif ($node->{reftype} eq 'REF') {
                $node->{data} = $self->represent_ref($node->{value});
            }

            elsif ($node->{reftype} eq 'CODE') {
                $node->{data} = $dumpcode ? $self->represent_code($node->{value}) : '{ "DUMMY" }';
            }
            elsif ($node->{reftype} eq 'GLOB') {
                $node->{data} = $self->represent_glob($node->{value});
            }
            else {
                die "Reftype '$node->{reftype}' not implemented";
            }

            return 1;
        },
    );
    return;
}

sub evaluate_code {
    my ($self, $code) = @_;
    unless ($code =~ m/^ \s* \{ .* \} \s* \z/xs) {
        die "Malformed code";
    }
    $code = "sub $code";
    my $sub = eval $code;
    if ($@) {
        die "Couldn't eval code: $@>>$code<<";
    }
    return $sub;
}

sub construct_regex {
    my ($self, $regex) = @_;
    if ($regex =~ m/^$qr_prefix(.*)\)\z/s) {
        $regex = $1;
    }
    my $qr = qr{$regex};
    return $qr;
}

sub construct_glob {
    my ($self, $list) = @_;
    if (@$list % 2) {
        die "Unexpected data in perl/glob construction";
    }
    my %globdata = @$list;
    my $name = delete $globdata{NAME} or die "Missing NAME in perl/glob";
    my $pkg = delete $globdata{PACKAGE};
    $pkg = 'main' unless defined $pkg;
    my @allowed = qw(SCALAR ARRAY HASH CODE IO);
    delete @globdata{ @allowed };
    if (my @keys = keys %globdata) {
        die "Unexpected keys in perl/glob: @keys";
    }
    no strict 'refs';
    return *{"${pkg}::$name"};
}

sub construct_scalar {
    my ($self, $list) = @_;
    if (@$list != 2) {
        die "Unexpected data in perl/scalar construction";
    }
    my ($key, $value) = @$list;
    unless ($key eq '=') {
        die "Unexpected data in perl/scalar construction";
    }
    return $value;
}

sub construct_ref {
    &construct_scalar;
}

sub represent_scalar {
    my ($self, $value) = @_;
    return { '=' => $$value };
}

sub represent_ref {
    &represent_scalar;
}

sub represent_code {
    my ($self, $code) = @_;
    require B::Deparse;
    my $deparse = B::Deparse->new("-p", "-sC");
    return $deparse->coderef2text($code);
}


my @stats = qw/ device inode mode links uid gid rdev size
    atime mtime ctime blksize blocks /;
sub represent_glob {
    my ($self, $glob) = @_;
    my %glob;
    for my $type (qw/ PACKAGE NAME SCALAR ARRAY HASH CODE IO /) {
        my $value = *{ $glob }{ $type };
        if ($type eq 'SCALAR') {
            $value = $$value;
        }
        elsif ($type eq 'IO') {
            if (defined $value) {
                undef $value;
                $value->{stat} = {};
                if ($value->{fileno} = fileno(*{ $glob })) {
                    @{ $value->{stat} }{ @stats } = stat(*{ $glob });
                    $value->{tell} = tell *{ $glob };
                }
            }
        }
        $glob{ $type } = $value if defined $value;
    }
    return \%glob;
}

sub represent_regex {
    my ($self, $regex) = @_;
    $regex = "$regex";
    if ($regex =~ m/^$qr_prefix(.*)\)\z/s) {
        $regex = $1;
    }
    return $regex;
}

sub object {
    my ($self, $data, $class) = @_;
    return bless $data, $class;
}

1;

__END__