File Coverage

blib/script/pkwalify

Criterion	Covered	Total	%
statement	67	104	64.4
branch	26	46	56.5
condition	10	18	55.5
subroutine	6	9	66.6
pod			n/a
total	109	177	61.5

#!/usr/local/bin/perl -w
# -*- mode: cperl; coding: latin-2 -*-

#
# Author: Slaven Rezic
#
# Copyright (C) 2006,2007,2008,2009,2015 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: [e-mail]
# WWW:  http://www.rezic.de/eserte/
#

use strict;
use vars qw($VERSION);
$VERSION = '1.13';

use Kwalify;
use Getopt::Long;

my $schema_file;
my $parse_mod;
my $silent;
my $show_version;
GetOptions("f=s"       => \$schema_file,
	   "m|module=s" => \$parse_mod,
	   "s|silent"  => \$silent,
	   "v|version" => \$show_version,
	   "h|help"    => sub { print usage(); exit 0 },
	  )
    or die usage();

if ($show_version) {
    version();
    exit;
}

if (!defined $schema_file) {
    die usage("-f option is mandatory");
}

my $data_file = shift @ARGV;
if (!defined $data_file) {
    die usage("datafile is mandatory");
}

my(@schema) = read_file($schema_file);
if (@schema != 1) {
    print "<$schema_file> does not contain exactly one schema, cannot handle this.";
    exit 1;
}
my $schema = $schema[0];
my(@data)   = read_file($data_file);

my $errors = 0;
my $document_index = 0;
for my $data (@data) {
    my $document_label = $data_file . '#' . $document_index;
    eval { Kwalify::validate($schema, $data) };
    if ($@) {
	print "$document_label: INVALID\n$@\n";
	$errors++;
    } else {
	if (!$silent) {
	    print "$document_label: valid.\n";
	}
    }
    $document_index++;
}

exit $errors;

sub read_file {
    my $file = shift;

    my @try_order;
    if (defined $parse_mod) {
	@try_order = ($parse_mod);
    } elsif ($file =~ m{\.json$}i) {
	@try_order = ('JSON::XS', 'JSON', 'YAML::Syck', 'YAML', 'YAML::XS');
    } else { # yaml or don't know
	@try_order = ('YAML::Syck', 'YAML', 'YAML::XS', 'JSON::XS', 'JSON');
    }

    my @errors;
    for my $try (@try_order) {
	if      ($try eq 'YAML::Syck' && eval { require YAML::Syck; 1 }) {
	    my @data = eval { YAML::Syck::LoadFile($file) };
	    return @data if !$@;
	    push @errors, $@;
	} elsif ($try eq 'YAML::XS'   && eval { require YAML::XS; 1 }) {
	    my @data = eval { YAML::XS::LoadFile($file) };
	    return @data if !$@;
	    push @errors, $@;
	} elsif ($try eq 'YAML'       && eval { require YAML; 1 }) {
	    my @data = eval { YAML::LoadFile($file) };
	    return @data if !$@;
	    push @errors, $@;
	} elsif ($try eq 'JSON::XS'   && eval { require JSON::XS; 1 }) {
	    my @data = eval { JSON::XS::decode_json(slurp_file($file)) };
	    return @data if !$@;
	    push @errors, $@;
	} elsif ($try eq 'JSON'       && eval { require JSON; 1 }) {
	    my $data = eval {
		my $json = slurp_file($file);
		if (defined &JSON::from_json) {
		    JSON::from_json($json, {utf8 => 1});
		} else { # old style
		    JSON::jsonToObj($json);
		}
	    };
	    return ($data) if $data && !$@;
	    push @errors, $@;
	} else {
	    push @errors, "Unsupported module $try";
	}
    }
    if (!@errors) {
	die "Cannot parse <$file>. Try to install a YAML and/or JSON parsing module first.\n";
    } else {
	die "Cannot parse <$file>. Cumulated errors:\n" . join("\n", @errors) . "\n";
    }
}

sub slurp_file {
    my $file = shift;
    open FH, "< $file"
	or die "Can't open <$file>: $!";
    local $/ = undef;
    my $json = ;
    close FH;
    $json;
}

sub usage {
    my($msg) = @_;
    if (defined $msg) {
	$msg .= "\n";
    } else {
	$msg = "";
    }
    <
${msg}usage: $0 [-v] [-s] [-m parse-mod] -f schema.yml data.yml
       $0 -f schema.json data.json
EOF
}

sub version {
    print <
pkwalify $VERSION
Kwalify.pm $Kwalify::VERSION
perl $]
EOF
}

__END__