view release on metacpan or  search on metacpan

lib/YAML/PP/Schema/Perl.pm  view on Meta::CPAN

our $VERSION = 'v0.40.0'; # 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],