view release on metacpan or  search on metacpan

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

use strict;
use warnings;
package YAML::PP::Schema;
use B;
use Module::Load qw//;

our $VERSION = 'v0.40.0'; # VERSION

use YAML::PP::Common qw/ YAML_PLAIN_SCALAR_STYLE /;

use Carp qw/ croak /;
use Scalar::Util qw/ blessed /;

sub new {
    my ($class, %args) = @_;

    my $yaml_version = delete $args{yaml_version};
    my $bool = delete $args{boolean};
    $bool = 'perl' unless defined $bool;
    if (keys %args) {
        die "Unexpected arguments: " . join ', ', sort keys %args;
    }
    my $true;
    my $false;
    my @bool_class;
    my @bools = split m/,/, $bool;
    for my $b (@bools) {
        if ($b eq '*') {
            push @bool_class, ('boolean', 'JSON::PP::Boolean');
            last;
        }
        elsif ($b eq 'JSON::PP') {
            require JSON::PP;
            $true ||= \&_bool_jsonpp_true;
            $false ||= \&_bool_jsonpp_false;
            push @bool_class, 'JSON::PP::Boolean';
        }
        elsif ($b eq 'boolean') {
            require boolean;
            $true ||= \&_bool_booleanpm_true;
            $false ||= \&_bool_booleanpm_false;
            push @bool_class, 'boolean';
        }
        elsif ($b eq 'perl' or $b eq 'perl_experimental') {
            push @bool_class, 'perl';
        }
        else {
            die "Invalid value for 'boolean': '$b'. Allowed: ('perl', 'boolean', 'JSON::PP')";
        }
    }
    # Ensure booleans are resolved
    $true ||= \&_bool_perl_true;
    $false ||= \&_bool_perl_false;

    my %representers = (
        'undef' => undef,
        flags => [],
        equals => {},
        regex => [],
        class_equals => {},
        class_matches => [],
        class_isa => [],
        scalarref => undef,
        refref => undef,
        coderef => undef,
        glob => undef,
        tied_equals => {},
        bool => undef,
    );
    my $self = bless {
        yaml_version => $yaml_version,
        resolvers => {},
        representers => \%representers,
        true => $true,
        false => $false,
        bool_class => \@bool_class,
    }, $class;
    return $self;
}

sub resolvers { return $_[0]->{resolvers} }
sub representers { return $_[0]->{representers} }

sub true { return $_[0]->{true} }
sub false { return $_[0]->{false} }
sub bool_class { return @{ $_[0]->{bool_class} } ? $_[0]->{bool_class} : undef }