view release on metacpan or  search on metacpan

lib/JSON/SchemaValidator.pm  view on Meta::CPAN

    ^
        [0-9]{4}\-[0-9]{2}\-[0-9]{2}T[0-9]{2}
        :
        [0-9]{2}:[0-9]{2}
        (?:\.[0-9]{1,6})?
        (?:
            Z
            |
            [-+][0-9]{2}:[0-9]{2}
        )
    $
/ix;

my $HOSTNAME_RE = qr/
    (?:
        (?:[a-z0-9]|[a-z0-9][a-z0-9\-]*[a-z0-9])\.
    )*
    (?:[a-z0-9]|[a-z0-9][a-z0-9\-]*[a-z0-9])
/ix;

my $EMAIL_RE = qr/
    [a-z0-9\._\%\+!\$\&\*=\^\|\~#%\{\}\/\-]+
    \@
    $HOSTNAME_RE
/ix;

sub new {
    my $class = shift;
    my (%params) = @_;

    my $self = {};
    bless $self, $class;

    $self->{formats} = {
        hostname => sub {
            my ($hostname) = @_;

            return 0 if length $hostname > 255;

            return 0 unless $hostname =~ qr/^$HOSTNAME_RE$/;

            return 0 if grep { length > 63 } split /\./, $hostname;

            return 1;
        },
        email => sub {
            my ($email) = @_;

            return 0 unless $email =~ m/^$EMAIL_RE$/;

            my ($username, $hostname) = split /@/, $email;

            return 0 if length $hostname > 255;
            return 0 if grep { length > 63 } split /\./, $hostname;

            return 1;
        },
        ipv4 => sub {
            my ($ipv4) = @_;

            my @parts = split m/\./, $ipv4;

            return unless @parts > 0 && @parts < 5;

            for my $part (@parts) {
                return unless $part =~ m/^[0-9]+$/ && $part >= 0 && $part < 256;
            }

            return unless $parts[-1] > 0;

            return 1;
        },
        ipv6 => sub {
            my ($ipv6) = @_;

            my @parts = split m/\:/, $ipv6;

            return unless @parts > 0 && @parts < 9;

            for my $part (@parts) {
                next if $part eq '';

                return unless $part =~ m/^[0-9a-f]{1,4}$/i;
            }

            return 1;
        },
        'date-time' => sub {
            my ($date_time) = @_;

            return unless $date_time =~ $DATETIME_RE;

            $date_time =~ s{\.[0-9]*}{};
            $date_time =~ s{Z$}{+00:00}i;
            $date_time =~ s{:([0-9]+)$}{$1}i;

            return unless eval { Time::Piece->strptime(uc($date_time), '%Y-%m-%dT%T%z') };

            return 1;
        }
    };
    $self->{fetcher} = $params{fetcher};

    return $self;
}

sub formats { shift->{formats} }

sub validate {
    my $self = shift;
    my ($json, $schema) = @_;

    $schema = Storable::dclone($schema);

    my $context = {
        root    => $schema,
        ids     => {},
        pointer => '#',
    };

    $self->_collect_ids($context, $schema);

    my $result = $self->_validate($context, $json, $schema);

    return $result;
}

sub _collect_ids {
    my $self = shift;
    my ($context, $schema) = @_;

    if (_is_object($schema)) {
        my $new_context = {%$context};

        if ($schema->{id} && _is_string($schema->{id})) {
            my $base_url = $context->{base_url};