2
1
mirror of https://github.com/qpdf/qpdf.git synced 2024-12-23 11:28:56 +00:00
qpdf/libtests/qtest/json_parse.test
2022-05-20 10:13:15 -04:00

157 lines
4.4 KiB
Perl

#!/usr/bin/env perl
require 5.008;
use warnings;
use strict;
use File::Copy;
use File::Compare;
chdir("json_parse") or die "chdir testdir failed: $!\n";
require TestDriver;
my $td = new TestDriver('json_parse');
my $json_mod = 0;
if ($^O ne 'msys')
{
# Emperical evidence and considerable debugging reveals that in
# some versions of perl (e.g. the one with git bash on the GitHub
# actions Windows 2022 build environment), using the JSON module
# defeats the functionality of binmode when writing test output
# files, thus invalidating NORMALIZE_NEWLINES. This causes test
# failures and spurious upadtes to save files in CI on MSVC.
eval {
require JSON;
$json_mod = 1;
};
if ($@)
{
$td->emphasize("JSON.pm not found -- using stored actual outputs");
}
}
cleanup();
my $good = 11;
for (my $i = 1; $i <= $good; ++$i)
{
my $n = sprintf("%02d", $i);
unlink "out.json";
my $r = system("json_parse good-$n.json > out.json 2>&1");
if ($td->runtest("json_parse accepted $n",
{$td->STRING => "$r\n"},
{$td->STRING => "0\n"},
$td->NORMALIZE_NEWLINES))
{
if ($json_mod)
{
if ($td->runtest("check output $n",
{$td->STRING => normalize_json("out.json")},
{$td->STRING => normalize_json("good-$n.json")},
$td->NORMALIZE_NEWLINES))
{
if (compare("out.json", "save-$n.json"))
{
copy("out.json", "save-$n.json");
$td->emphasize("updated save-$n.json from out.json");
}
}
}
else
{
$td->runtest("check output $n against saved",
{$td->FILE => "out.json"},
{$td->FILE => "save-$n.json"},
$td->NORMALIZE_NEWLINES);
}
}
else
{
$td->runtest("skip checking output $n",
{$td->FILE => "out.json"},
{$td->STRING => ""});
}
$td->runtest("good $n reactor",
{$td->COMMAND => "json_parse good-$n.json --react"},
{$td->FILE => "good-$n-react.out", $td->EXIT_STATUS => 0},
$td->NORMALIZE_NEWLINES);
}
my @bad = (
"junk after string", # 1
"junk after array", # 2
"junk after dictionary", # 3
"bad number", # 4
"invalid keyword", # 5
"missing colon", # 6
"missing comma in dict", # 7
"missing comma in array", # 8
"dict key not string", # 9
"unexpected } in array", # 10
"unexpected } at top", # 11
"unexpected } in dict", # 12
"unexpected ] in dict", # 13
"unexpected ] at top", # 14
"unexpected :", # 15
"unexpected ,", # 16
"premature end array", # 17
"null character", # 18
"unexpected character", # 19
"point in exponent", # 20
"duplicate point", # 21
"duplicate e", # 22
"stray +", # 23
"bad character in number", # 24
"bad character in keyword", # 25
"bad backslash character", # 26
"unterminated string", # 27
"unterminated after \\", # 28
"leading +", # 29
"decimal with no digits", # 30
"minus with no digits", # 31
"leading zero", # 32
"leading zero negative", # 33
"premature end after u", # 34
"bad hex digit", # 35
"parser depth exceeded", # 36
"stray low surrogate", # 37
"high high surrogate", # 38
"dangling high surrogate", # 39
"duplicate dictionary key", # 40
);
my $i = 0;
foreach my $d (@bad)
{
++$i;
my $n = sprintf("%02d", $i);
$td->runtest("$n: $d",
{$td->COMMAND => "json_parse bad-$n.json"},
{$td->FILE => "bad-$n.out", $td->EXIT_STATUS => 2},
$td->NORMALIZE_NEWLINES);
}
cleanup();
$td->report((3 * $good) + scalar(@bad));
sub cleanup
{
unlink "out.json";
}
sub normalize_json
{
my $file = shift;
open(F, "<$file") or die "can't open $file: $file: $!\n";
$/ = undef;
my $encoded = scalar(<F>);
close(F);
my $j = JSON->new->allow_nonref;
$j->canonical();
$j->utf8->pretty->encode($j->utf8->decode($encoded));
}