Perl JSON validator

Schema.pm

package JSON::Schema;

use strict;
use warnings;

use Scalar::Util qw(looks_like_number);
use Exporter;

# inherit this package
our @ISA = qw(Exporter);

# exportable subroutines
our @EXPORT_OK = qw(callback optional null number boolean string object array);

# json types
# ----------
# * Null
# * Number
# * Boolean
# * String
# * Object
# * Array

use constant {
    TYPE_NULL    => 0,
    TYPE_NUMBER  => 1,
    TYPE_BOOLEAN => 2,
    TYPE_STRING  => 3,
    TYPE_OBJECT  => 4,
    TYPE_ARRAY   => 5
};

sub callback {
    my ($chk, $obj) = @_;
    $obj->{chk} = $chk;
    return $obj;
}

sub optional {
    my $obj = shift;
    $obj->{optional} = 1;
    return $obj;
}

sub null {
    return {k => TYPE_NULL};
}

sub number {
    return {k => TYPE_NUMBER};
}

sub boolean {
    return {k => TYPE_BOOLEAN};
}

sub string {
    return {k => TYPE_STRING};
}

sub object {
    my $fields = shift;
    return {k => TYPE_OBJECT, fields => $fields};
}

sub array {
    my $type = shift;
    return {k => TYPE_ARRAY, type => $type};
}

sub _new_ref {
    my ($class, $schema) = @_;
    if (ref($schema) eq $class) {
        return $schema;
    }
    return new($class, $schema);
}

sub new {
    my ($class, $schema) = @_;
    my $k = $schema->{k};
    if ($k == TYPE_OBJECT) {
        my $fields = $schema->{fields};
        foreach my $f (keys %$fields) {
            $fields->{$f} = _new_ref($class, $fields->{$f});
        }
    } elsif ($k == TYPE_ARRAY) {
        $schema->{type} = _new_ref($class, $schema->{type});
    }
    return bless $schema, $class;
}

sub valid {
    my ($self, $json) = @_;
    my $k = $self->{k};
    if ($k == TYPE_NULL) {
        if (defined($json)) {
            return 0;
        }
        return 1;
    } elsif ($k == TYPE_NUMBER) {
        if (!defined($json)) {
            return 0;
        }
        if (looks_like_number($json)) {
            my $chk = $self->{chk};
            if (defined($chk)) {
                return $chk->($json);
            }
            return 1;
        }
        return 0;
    } elsif ($k == TYPE_BOOLEAN) {
        if (!defined($json)) {
            return 0;
        }
        if ($json == 0 || $json == 1) {
            my $chk = $self->{chk};
            if (defined($chk)) {
                return $chk->($json);
            }
            return 1;
        }
        return 0;
    } elsif ($k == TYPE_STRING) {
        if (!defined($json)) {
            return 0;
        }
        if (ref($json) eq '') {
            my $chk = $self->{chk};
            if (defined($chk)) {
                return $chk->($json);
            }
            return 1;
        }
        return 0;
    } elsif ($k == TYPE_OBJECT) {
        if (!defined($json)) {
            return 0;
        }
        if (ref($json) ne 'HASH') {
            return 0;
        }
        my $fields = $self->{fields};
FIELD:
        foreach my $f (keys %$fields) {
            if (!defined($json->{$f})) {
                next FIELD if $fields->{$f}->{optional};
                return 0;
            }
            if (!$fields->{$f}->valid($json->{$f})) {
                return 0;
            }
        }
        my $chk = $self->{chk};
        if (defined($chk)) {
            return $chk->($json);
        }
        return 1;
    } elsif ($k == TYPE_ARRAY) {
        if (!defined($json)) {
            return 0;
        }
        if (ref($json) ne 'ARRAY') {
            return 0;
        }
        foreach my $elem (@$json) {
            if (!$self->{type}->valid($elem)) {
                return 0;
            }
        }
        my $chk = $self->{chk};
        if (defined($chk)) {
            return $chk->($json);
        }
        return 1;
    } else {
        return 0;
    }
}

1;

test.pl

use strict;
use warnings;

use lib './';

use JSON;
use JSON::Schema qw(array object callback number optional);
use Data::Dumper;

sub bounds {
    my $n = shift;
    return $n >= 0 && $n <= 100;
}

my $schema = new JSON::Schema(
    object {
        points => array object {
            x => callback(\&bounds, number),
            y => callback(\&bounds, number),
            z => callback(\&bounds, optional(number))
        }
    }
);
my $obj = decode_json $ARGV[0];
print Dumper($schema, $obj);

print "in" if !$schema->valid($obj);
print "valid object\n";