qpdf/libtests/qtest/json_parse.test

#!/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
    "decimal point after minus",# 41
    "e after minus",            # 42
    "missing digit after e",    # 43
    "missing digit after e+/-", # 44
    "tab char in string",       # 45
    "cr char in string",        # 46
    "lf char in string",        # 47
    "bs char in string",        # 48
    );

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));
}