view release on metacpan or  search on metacpan

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

            $self->_validate_schema( $obj->{else}, 0, "$path/else", undef );
        }
    }
}

sub _validate_composition_array {
    my ( $self, $arr, $keyword, $path ) = @_;

    if ( ref($arr) ne 'ARRAY' ) {
        $self->_add_error( SCHEMA_COMPOSITION_NOT_ARRAY,
            "$keyword must be an array", $path );
        return;
    }

    if ( @$arr == 0 ) {
        $self->_add_error( SCHEMA_COMPOSITION_EMPTY,
            "$keyword array cannot be empty", $path );
        return;
    }

    for my $i ( 0 .. $#$arr ) {
        my $schema = $arr->[$i];
        if ( ref($schema) ne 'HASH' ) {
            $self->_add_error(
                SCHEMA_KEYWORD_INVALID_TYPE,
                "$keyword\[$i] must be a schema object",
                "$path\[$i]"
            );
        }
        else {
            $self->_validate_schema( $schema, 0, "$path\[$i]", undef );
        }
    }
}

sub _check_json_pointer {
    my ( $self, $pointer, $doc, $path ) = @_;

    if ( !defined $pointer || ref($pointer) ) {
        $self->_add_error( SCHEMA_KEYWORD_INVALID_TYPE,
            '$root must be a string', $path );
        return;
    }

    # Validate the pointer resolves
    my $target = $self->_resolve_json_pointer( $pointer, $doc );
    if ( !defined $target ) {
        $self->_add_error( SCHEMA_REF_NOT_FOUND,
            "\$root target does not exist: $pointer", $path );
    }
}

sub _resolve_json_pointer {
    my ( $self, $pointer, $doc ) = @_;

    # Handle # prefix
    $pointer =~ s/^#//;

    return $doc if $pointer eq '' || $pointer eq '/';

    my @segments = split m{/}, $pointer;
    shift @segments if @segments && $segments[0] eq '';

    my $current = $doc;

    for my $segment (@segments) {

        # Unescape JSON Pointer tokens
        $segment =~ s/~1/\//g;
        $segment =~ s/~0/~/g;

        if ( ref($current) eq 'HASH' ) {
            return undef unless exists $current->{$segment};
            $current = $current->{$segment};
        }
        elsif ( ref($current) eq 'ARRAY' ) {
            return undef unless $segment =~ /^\d+$/;
            my $idx = int($segment);
            return undef if $idx >= @$current;
            $current = $current->[$idx];
        }
        else {
            return undef;
        }
    }

    return $current;
}

sub _validate_namespace {
    my ( $self, $definitions, $path ) = @_;

    for my $name ( keys %$definitions ) {
        my $def      = $definitions->{$name};
        my $def_path = "$path/$name";

        # Validate identifier
        my $id_regex =
          $self->{allow_dollar} ? $IDENTIFIER_DOLLAR_REGEX : $IDENTIFIER_REGEX;
        if ( $name !~ $id_regex ) {
            $self->_add_error( SCHEMA_NAME_INVALID,
                "Definition name '$name' must be a valid identifier",
                $def_path );
        }

        if ( ref($def) ne 'HASH' ) {
            $self->_add_error( SCHEMA_INVALID_TYPE,
                'Definition must be an object', $def_path );
            next;
        }

        # Check for nested definitions (namespace)
        if (   !exists $def->{type}
            && !exists $def->{'$ref'}
            && !$self->_has_composition_keywords($def) )
        {
            # Could be a namespace with nested definitions
            my $has_nested = 0;
            for my $key ( keys %$def ) {
                if (
                    ref( $def->{$key} ) eq 'HASH'