File Coverage

scripts/jsonvalidate
Criterion Covered Total %
statement 143 298 47.9
branch 48 152 31.5
condition 10 74 13.5
subroutine 19 33 57.5
pod n/a
total 220 557 39.5


line stmt bran cond sub pod time code
1             #!/usr/bin/env perl
2             ##----------------------------------------------------------------------------
3             ## JSON Schema Validator - ~/lib/App/jsonvalidate.pm
4             ## Version v0.2.0
5             ## Copyright(c) 2025 DEGUEST Pte. Ltd.
6             ## Author: Jacques Deguest <jack@deguest.jp>
7             ## Created 2025/11/10
8             ## Modified 2025/11/18
9             ## All rights reserved
10             ##
11             ## This program is free software; you can redistribute it and/or modify it
12             ## under the same terms as Perl itself.
13             ##----------------------------------------------------------------------------
14 1     1   3927 use v5.16.0;
  1         2  
15 1     1   3 use strict;
  1         1  
  1         23  
16 1     1   3 use warnings;
  1         1  
  1         36  
17 1     1   447 use utf8;
  1         266  
  1         5  
18 1     1   410 use open ':std' => ':utf8';
  1         1145  
  1         5  
19 1         109 use vars qw(
20             $VERSION $DEBUG $VERBOSE $LOG_LEVEL $PROG_NAME
21             $opt $opts $out $err
22 1     1   117 );
  1         1  
23 1     1   1346 use Module::Generic::File qw( file cwd stdout stderr );
  1         361083  
  1         20  
24 1     1   1290 use Getopt::Class;
  1         693554  
  1         15  
25 1     1   935 use JSON ();
  1         8242  
  1         32  
26 1     1   1149 use JSON::Schema::Validate;
  1         27039  
  1         67  
27 1     1   11 use Module::Generic::File qw( file );
  1         1  
  1         13  
28 1     1   780 use Pod::Usage;
  1         45255  
  1         177  
29 1     1   604 use Term::ANSIColor::Simple;
  1         1183  
  1         267573  
30 1         90863 our $VERSION = 'v0.2.0';
31              
32 1         5 our $LOG_LEVEL = 0;
33 1         2 our $DEBUG = 0;
34 1         50 our $VERBOSE = 0;
35 1         10 our $PROG_NAME = file(__FILE__)->basename( '.pl' );
36              
37 1         182015 $SIG{INT} = $SIG{TERM} = \&_signal_handler;
38              
39 1         11738 our $out = stdout( binmode => 'utf-8', autoflush => 1 );
40 1         5665 our $err = stderr( binmode => 'utf-8', autoflush => 1 );
41 1         1894 @ARGV = map( Encode::decode_utf8( $_ ), @ARGV );
42              
43             # NOTE: options dictionary
44             # In this dictionary, the tokens are written in underscore, and are automatically converted to dash to serve as option
45             # Example: content_checks -> content-checks
46             # Any option aliases follow the same logic.
47             # The values are available under the token name, notwithstanding any alias.
48             # Example:
49             # jsonvalidate --content-checks
50             # leads to
51             # $opts->{content_checks} having a true value
52             my $dict =
53             {
54             allow_file_refs => { type => 'boolean', default => 1 },
55             compile => { type => 'boolean', default => 0 },
56             content_checks => { type => 'boolean', default => 0 },
57             ecma => { type => 'string', default => 'auto' },
58             emit_js => { type => 'boolean', default => 0 },
59             errors_only => { type => 'boolean', default => 0 },
60             extensions => { type => 'boolean', default => 0 },
61             ignore_vocab => { type => 'boolean', alias => [qw( ignore_unknown_required_vocab )], default => 0 },
62             # Array object (Module::Generic::Array) of file objects (Module::Generic::File)
63             instance => { type => 'file-array', alias => [qw(i)] },
64             # Should we print out the result as JSON data?
65             json => { type => 'boolean', default => 0 },
66             jsonl => { type => 'boolean', default => 0 },
67             max_errors => { type => 'integer', default => 200 },
68             normalize => { type => 'boolean', alias => [qw( normalise )], default => 1 },
69             register_formats => { type => 'boolean', default => 0 },
70             remote_refs => { type => 'boolean', alias => [qw( allow_http )], default => 0 },
71             # Array object (Module::Generic::Array) of file objects (Module::Generic::File)
72             schema => { type => 'file-array', alias => [qw(s)], required => 1 },
73             # base directory for file refs; this make this option value a Module::Generic::File object
74             schema_base => { type => 'file' },
75             trace => { type => 'boolean', default => 0 },
76             trace_limit => { type => 'integer', default => 0 },
77             trace_sample => { type => 'integer', default => 0 },
78             unique_keys => { type => 'boolean', default => 0 },
79              
80             # Generic options
81             debug => { type => 'integer', alias => [qw(d)], default => \$DEBUG },
82 0     0   0 help => { type => 'code', alias => [qw(?)], code => sub{ pod2usage( -exitstatus => 1, -verbose => 99, -sections => [qw( NAME SYNOPSIS DESCRIPTION OPTIONS AUTHOR COPYRIGHT )] ); }, action => 1 },
83             log_level => { type => 'integer', default => \$LOG_LEVEL },
84 0     0   0 man => { type => 'code', code => sub{ pod2usage( -exitstatus => 0, -verbose => 2 ); }, action => 1 },
85             quiet => { type => 'boolean', default => 0 },
86             verbose => { type => 'integer', default => \$VERBOSE },
87 1     0   226 v => { type => 'code', code => sub{ $out->print( $VERSION, "\n" ); exit(0) }, action => 1 },
  0         0  
  0         0  
88             };
89              
90 1   50     39 our $opt = Getopt::Class->new({ dictionary => $dict }) ||
91             die( "Error instantiating Getopt::Class object: ", Getopt::Class->error, "\n" );
92 1     0   13973 $opt->usage( sub{ pod2usage(2) } );
  0         0  
93 1   50     1099 our $opts = $opt->exec || die( "An error occurred executing Getopt::Class: ", $opt->error, "\n" );
94 1         578378 my @errors = ();
95 1         10 my $opt_errors = $opt->configure_errors;
96 1 50       1055 push( @errors, @$opt_errors ) if( $opt_errors->length );
97 1 50       40753 if( $opts->{quiet} )
98             {
99 0         0 $DEBUG = $VERBOSE = 0;
100             }
101              
102             # NOTE: SIGDIE
103             local $SIG{__DIE__} = sub
104             {
105 0     0   0 my $trace = $opt->_get_stack_trace;
106 0         0 my $stack_trace = join( "\n ", split( /\n/, $trace->as_string ) );
107 0         0 $err->print( "Error: ", @_, "\n", $stack_trace );
108 0         0 &_cleanup_and_exit(1);
109 1         2791 };
110             # NOTE: SIGWARN
111             local $SIG{__WARN__} = sub
112             {
113 0 0   0   0 $out->print( "Perl warning only: ", @_, "\n" ) if( $LOG_LEVEL >= 5 );
114 1         10 };
115              
116             # Unless the log level has been set directly with a command line option
117 1 50       9 unless( $LOG_LEVEL )
118             {
119 1 50       4 $LOG_LEVEL = 1 if( $VERBOSE );
120 1 50       3 $LOG_LEVEL = ( 1 + $DEBUG ) if( $DEBUG );
121             }
122              
123             # NOTE: Find out what action to take
124             # Right now, there is only 'validate' by default, but this design allows us to have other commands supported in the future.
125 1         8 my $action_found = '';
126 1         31 my @actions = grep{ exists( $dict->{ $_ }->{action} ) } keys( %$opts );
  46         850  
127 1         24 foreach my $action ( @actions )
128             {
129 3         61 $action =~ tr/-/_/;
130 3 50       17 next if( ref( $opts->{ $action } ) eq 'CODE' );
131 0 0 0     0 if( $opts->{ $action } && $action_found && $action_found ne $action )
    0 0        
      0        
132             {
133 0         0 push( @errors, "You have opted for \"$action\", but \"$action_found\" is already selected." );
134             }
135             elsif( $opts->{ $action } && !length( $action_found ) )
136             {
137 0         0 $action_found = $action;
138 0 0       0 die( "Unable to find a subroutne for '$action'" ) if( !main->can( $action ) );
139             }
140             }
141              
142 1 50       57 if( !$action_found )
143             {
144             # pod2usage( -exitval => 2, -message => "No action was selected" );
145 1         5 $action_found = 'validate';
146             }
147              
148 1 50       4 if( @errors )
149             {
150 0         0 my $error = join( "\n", map{ "\t* $_" } @errors );
  0         0  
151 0         0 substr( $error, 0, 0, "\n\tThe following arguments are mandatory and missing.\n" );
152 0 0       0 if( !$opts->{quiet} )
153             {
154 0         0 $err->print( <<EOT );
155             $error
156             Please, use option '-h' or '--help' to find out and properly call
157             this program in interactive mode:
158              
159             $PROG_NAME -h
160             EOT
161             }
162 0         0 exit(1);
163             }
164              
165             my $coderef = ( exists( $dict->{ $action_found }->{code} ) && ref( $dict->{ $action_found }->{code} ) eq 'CODE' )
166             ? $dict->{ $action_found }->{code}
167 1 50 33     40 : main->can( $action_found );
168 1 50       5 if( !defined( $coderef ) )
169             {
170 0         0 die( "There is no sub for action \"$action_found\"\n" );
171             }
172             # exit( $coderef->() ? 0 : 1 );
173 1 50       19 &_cleanup_and_exit( $coderef->() ? 0 : 1 );
174              
175             sub bailout
176             {
177 0     0   0 my $err = join( '', @_ );
178 0         0 _message( '<red>', $err, '</>' );
179 0         0 die( $err );
180             }
181              
182             sub validate
183             {
184 1     1   10 my $schema = $opts->{schema};
185 1         31 my $instance = $opts->{instance};
186 1         120 my $json = JSON->new->utf8->canonical;
187             # Load schemas (one or many)
188 1         3 my @schemas;
189 1         10 foreach my $sf ( @$schema )
190             {
191 1 50       15 if( !$sf->exists )
    50          
192             {
193 0         0 bailout( "The schema file $sf does not exist." );
194             }
195             elsif( $sf->is_empty )
196             {
197 0         0 _message( 1, "Warning: the schema file <orange>$sf</> is empty." );
198 0         0 next;
199             }
200 1         45428 _message( 2, "Loading schema data from file <green>$sf</>" );
201 1         18 my $data = $sf->load_json;
202 1 50       14345 if( !$data )
203             {
204 0         0 _message( 1, "Failed to load JSON data from schema file \"<green>$sf</>\": ", $sf->error );
205 0         0 next;
206             }
207 1         35 _message( 4, "<green>", length( $data ), "</> bytes of JSON data loaded from <green>$sf</>" );
208 1         5 push( @schemas, $data );
209             }
210              
211             # Determine base dir for file resolution
212             # Since all the schema files are Module::Generic::File objects, it returns an object
213 1         15 my $root_schema_path = _first_existing_path( @$schema );
214             # If 'schema_base' is provided, it would be a Module::Generic::File object
215 1 50 33     85 if( !defined( $opts->{schema_base} ) && defined( $root_schema_path ) )
216             {
217 0         0 _message( 5, "No <green>schema_base</> value provided, deriving it from <green>$root_schema_path</>" );
218             # Set 'schema_base' to the parent directory of the first schema file found.
219 0         0 $opts->{schema_base} = $root_schema_path->parent;
220 0         0 _message( 5, "<green>schema_base</> is now set to <green>$opts->{schema_base}</>" );
221             }
222              
223 1 50       42 if( $opts->{extensions} )
224             {
225 0         0 $opts->{unique_keys} = $opts->{extensions};
226             }
227              
228             # Build the validator from the FIRST schema (root)
229             my %ctor =
230             (
231             compile => $opts->{compile} ? 1 : 0,
232             content_assert => $opts->{content_checks} ? 1 : 0,
233             extensions => $opts->{extensions} ? 1 : 0,
234             ignore_unknown_required_vocab => $opts->{ignore_vocab} ? 1 : 0,
235             max_errors => $opts->{max_errors},
236             normalize_instance => $opts->{normalize} ? 1 : 0,
237             trace => $opts->{trace} ? 1 : 0,
238             trace_limit => $opts->{trace_limit},
239             trace_sample => $opts->{trace_sample},
240 1 50       51 unique_keys => $opts->{unique_keys} ? 1 : 0,
    50          
    50          
    50          
    50          
    50          
    50          
241             );
242 1         301 local $JSON::Schema::Validate::DEBUG = $opts->{debug};
243 1         52 my $js = JSON::Schema::Validate->new( $schemas[0], %ctor );
244             # Register built-in formats if desired
245 1 50       375 if( $opts->{register_formats} )
246             {
247 0         0 _message( 5, "Registering builtin formats." );
248 0         0 $js->register_builtin_formats;
249             }
250              
251             # Content checks on?
252 1 50       65 if( $opts->{content_checks} )
253             {
254 0         0 _message( 5, "Asserting content." );
255 0         0 $js->content_checks(1);
256             }
257              
258             # Simple resolver:
259             # - file:/… or relative paths from --schema-base
260             # - http(s):// if LWP::UserAgent is available (optional)
261             # - otherwise: if the requested absolute matches any secondary schema $id, return it
262 1         32 my %by_id;
263 1         3 for my $s ( @schemas )
264             {
265 1 50 33     17 if( ref( $s ) eq 'HASH' && defined( $s->{'$id'} ) )
266             {
267 0         0 $by_id{ $s->{'$id'} } = $s;
268             }
269             }
270              
271             $js->set_resolver(sub
272             {
273 0     0   0 my( $abs_uri ) = @_;
274 0         0 my $orig_uri = $abs_uri;
275              
276             # Strip fragment for all decisions below
277 0         0 my( $doc_uri, $fragment ) = ( $abs_uri =~ /^([^#]+)(#.*)?$/ );
278 0   0     0 $doc_uri //= $abs_uri;
279 0   0     0 my $has_fragment = defined( $fragment ) && length( $fragment );
280              
281             # First: exact $id match from any schema we were given on the command line
282 0 0 0     0 if( exists( $by_id{ $abs_uri } ) || exists( $by_id{ $doc_uri } ) )
283             {
284 0   0     0 my $schema = $by_id{ $abs_uri } // $by_id{ $doc_uri };
285 0 0       0 _message( 6, "Resolver: found pre-loaded schema for ", $by_id{ $abs_uri } ? $abs_uri : $doc_uri );
286 0         0 return( $schema );
287             }
288              
289             # Optional: allow relative/local file refs (very common and safe)
290 0 0 0     0 if( $opts->{allow_file_refs} && defined( $opts->{schema_base} ) )
291             {
292             # If it's not a proper scheme, treat as relative path
293 0 0       0 if( $doc_uri !~ /^[a-zA-Z][a-zA-Z0-9+.-]*:/ )
    0          
294             {
295 0         0 my $path = file( $doc_uri, base_dir => $opts->{schema_base} );
296 0 0       0 if( $path->exists )
297             {
298 0         0 _message( 6, "Resolver: loading local file $path for $doc_uri" );
299 0         0 return( $path->load_json );
300             }
301             }
302             # Also support explicit file:// URIs
303             elsif( $doc_uri =~ m{^file://}i )
304             {
305 0         0 my $path = file( $doc_uri );
306 0 0       0 if( $path->exists )
307             {
308 0         0 _message( 6, "Resolver: loading file:// URI $path" );
309 0         0 return( $path->load_json );
310             }
311             }
312             }
313              
314             # Only if user explicitly asked for remote fetching
315             # Can also be called as --allow_http. It is aliased to --remote_refs
316 0 0       0 if( $doc_uri =~ m{^https?://}i )
317             {
318             # The specs say that, if there is a fragment, we should always fetch the remote document.
319 0   0     0 my $should_fetch = $has_fragment || $opts->{remote_refs};
320 0 0       0 if( $should_fetch )
321             {
322 0   0     0 _message( 5, "Resolver: fetching remote document $doc_uri (fragment=$has_fragment, remote-refs=", ( $opts->{remote_refs} // 0 ), ")" );
323 0         0 my $doc = _fetch_http_json( $doc_uri, $json );
324 0 0       0 return( $doc ) if( defined( $doc ) );
325             }
326             else
327             {
328 0         0 _message( 4, "Resolver: refusing to fetch remote $doc_uri (no fragment and --remote-refs not used)" );
329 0         0 return;
330             }
331             }
332              
333 0         0 my $path = file( $doc_uri );
334             # 4. Last resort: maybe it's a bare filename without base?
335 0 0 0     0 if( $path->exists && $path->is_file )
336             {
337 0         0 _message( 6, "Resolver: fallback loading bare path $path" );
338 0         0 return( $path->load_json );
339             }
340              
341             # Fail loudly with helpful message
342 0         0 bailout( <<EOF );
343             Cannot resolve \$ref "$orig_uri"
344              
345             Document URI: $doc_uri
346             Fragment : $fragment
347              
348             This is probably a fictional/internal \$id (very common and correct!).
349              
350             The validator will NOT auto-fetch such URIs by default (security + correctness).
351              
352             This looks like a reference to a remote document with a JSON Pointer fragment.
353             Such references MUST be retrieved (per JSON Schema spec).
354              
355             Solutions:
356             • Pass --remote-refs to allow HTTP(S) fetching
357             • Provide the referenced schema via additional --schema arguments
358             • Rewrite the schema to use relative references + --schema-base
359             EOF
360 1         21 });
361              
362             # Optional: capture $comment into trace (no-op handler by default)
363 1     0   27 $js->set_comment_handler(sub{});
364              
365             # Validate instances
366 1         13 my $total_ok = 0;
367 1         3 my $total_fail = 0;
368 1         3 my $run_idx = 0;
369              
370 1 50       19 if( $opts->{instance}->is_empty )
371             {
372 0 0       0 if( $opts->{jsonl} )
373             {
374 0         0 _message( 5, "No JSON data file was provided, reading from STDIN line by line." );
375 0         0 while( defined( my $line = <STDIN> ) )
376             {
377 0 0       0 next if $line =~ /\A\s*\z/;
378 0         0 my $data = _decode_json_or_die( $line, $json, "STDIN: line $.: " );
379 0         0 _run_one( $js, $data, \$total_ok, \$total_fail, ++$run_idx, $json );
380             }
381             }
382             else
383             {
384 0         0 _message( 5, "No JSON data file was provided, reading from STDIN all in one go." );
385 0         0 my $data = &_get_stdin();
386 0         0 _run_one( $js, $data, \$total_ok, \$total_fail, ++$run_idx, $json );
387             }
388             }
389             else
390             {
391 1         49 for my $inst_file ( @{$opts->{instance}} )
  1         4  
392             {
393 1         27 _message( 5, "Processing JSON data file <green>$inst_file</>" );
394 1 50       5 if( !$inst_file->exists )
    50          
395             {
396 0         0 bailout( "The instance file \"$inst_file\" does not exist." );
397             }
398             elsif( $inst_file->is_empty )
399             {
400 0         0 _message( 1, "The instance file \"$inst_file\" is empty." );
401 0         0 next;
402             }
403 1         45090 my $raw = $inst_file->load( binmode => 'raw' );
404 1 50       11833 if( !defined( $raw ) )
405             {
406 0         0 _message( 1, "The instance file \"$inst_file\" content could not be retrieved: ", $inst_file->error );
407 0         0 next;
408             }
409            
410 1 50       14 if( $opts->{jsonl} )
411             {
412 1         57 _message( 5, "Processing the file <green>$inst_file</> data line-by-line." );
413 1         3 my $ln = 0;
414 1         6 for my $line ( split( /\n/, $raw, -1 ) )
415             {
416 5         10 ++$ln;
417 5 100       30 next if( $line =~ /\A\s*\z/ );
418 4         23 my $data = _decode_json_or_die( $line, $json, "$inst_file:$ln: " );
419 4         23 _run_one( $js, $data, \$total_ok, \$total_fail, ++$run_idx, $json );
420             }
421             }
422             else
423             {
424 0         0 _message( 5, "Processing the file <green>$inst_file</> data all in one go." );
425 0         0 my $data = _decode_json_or_die( $raw, $json, "$inst_file: " );
426 0         0 _run_data_maybe_array( $js, $data, \$total_ok, \$total_fail, \$run_idx, $json );
427             }
428             }
429             }
430              
431 1 50 33     10 if( $opts->{emit_js} )
    50          
432             {
433 0 0       0 my $js_code = $js->compile_js( $opts->{ecma} ? ( ecma => $opts->{ecma} ) : () );
434 0         0 my $source = join( ', ', map{ $_->basename } @{$opts->{schema}} );
  0         0  
  0         0  
435 0         0 require DateTime;
436 0         0 my $now = DateTime->now->iso8601;
437 0         0 $out->print( <<HEADER );
438             // =============================================================================
439             // JSON Schema Validator — Client-Side (Compiled from Perl)
440             // =============================================================================
441             // Schema : $source
442             // Generated: $now
443             // Validator: JSON::Schema::Validate $JSON::Schema::Validate::VERSION (Perl)
444             // Module : $INC{'JSON/Schema/Validate.pm'}
445             // Compiler : jsonvalidate --emit-js
446             // =============================================================================
447              
448             HEADER
449 0         0 $out->print( $js_code );
450 0 0       0 return( $total_fail ? 0 : 1 );
451             }
452             # Summary & exit code
453             elsif( !$opts->{quiet} && !$opts->{json} )
454             {
455 0         0 $out->print( "Summary: OK=$total_ok FAIL=$total_fail\n" );
456             }
457             # Return 0 on failure, and 1 on success
458 1 50       110 _message( 5, "<red>$total_fail</> total fail. Returning ", ( $total_fail ? 0 : 1 ) );
459 1 50       79 return( $total_fail ? 0 : 1 );
460             }
461              
462             sub _cleanup_and_exit
463             {
464 1     1   3 my $exit = shift( @_ );
465 1 50 50     14 $exit = 0 if( !length( $exit // '' ) || $exit !~ /^\d+$/ );
      33        
466 1         185 exit( $exit );
467             }
468              
469             sub _decode_json_or_die
470             {
471 4     4   97 my( $raw, $json, $label ) = @_;
472 4         6 my $data;
473 4         8 local $@;
474             eval
475             {
476 4         32 $data = $json->decode( $raw );
477 4         14 1;
478             }
479             or do
480 4 50       8 {
481 0         0 bailout( "Failed to decode JSON ($label): $@" );
482             };
483 4         10 return( $data );
484             }
485              
486             sub _fetch_http_json
487             {
488 0     0   0 my( $url, $json ) = @_;
489              
490 0         0 local $@;
491             eval
492             {
493 0         0 require LWP::UserAgent;
494 0         0 require HTTP::Request;
495 0         0 my $ua = LWP::UserAgent->new( timeout => 10 );
496 0         0 my $res = $ua->get( $url );
497 0 0       0 if( $res->is_success )
498             {
499 0         0 return( _decode_json_or_die( $res->decoded_content, $json, "$url: " ) );
500             }
501 0         0 bailout( "HTTP $url failed: " . $res->status_line );
502             }
503             or do
504 0 0       0 {
505             # No LWP or fetch failed; return undef so caller can try alternatives or die.
506 0         0 return;
507             };
508             }
509              
510             sub _first_existing_path
511             {
512 1     1   3 for my $p ( @_ )
513             {
514 1 50 33     13 return( $p ) if( defined( $p ) && $p->exists );
515             }
516 0         0 return;
517             }
518              
519             # Get the JSON data from STDIN
520             sub _get_stdin
521             {
522 0 0   0   0 $out->print( "Enter the JSON data below and type ctrl-D when finished:\n" ) if( &_is_tty );
523 0         0 my $json = '';
524 0         0 $json .= $_ while( <STDIN> );
525 0         0 $json =~ s/(\r?\n)+$//gs;
526 0         0 _message( 4, "JSON received is '$json'" );
527 0         0 return( $json );
528             }
529              
530             # Taken from ExtUtils::MakeMaker
531             sub _is_tty
532             {
533 0   0 0   0 return( -t( STDIN ) && ( -t( STDOUT ) || !( -f STDOUT || -c STDOUT ) ) );
534             }
535              
536             sub _message
537             {
538 5     5   131 my $required_level;
539 5 50       46 if( $_[0] =~ /^\d{1,2}$/ )
540             {
541 5         17 $required_level = shift( @_ );
542             }
543             else
544             {
545 0         0 $required_level = 0;
546             }
547 5 50 33     31 return if( !$LOG_LEVEL || $LOG_LEVEL < $required_level );
548 0 0       0 my $msg = join( '', map( ref( $_ ) eq 'CODE' ? $_->() : $_, @_ ) );
549 0 0       0 if( index( $msg, '</>' ) != -1 )
550             {
551 0         0 $msg =~ s
552             {
553             <([^\>]+)>(.*?)<\/>
554             }
555             {
556 0         0 my $colour = $1;
557 0         0 my $txt = $2;
558 0         0 my $obj = color( $txt );
559 0   0     0 my $code = $obj->can( $colour ) ||
560             die( "Colour '$colour' is unsupported by Term::ANSIColor::Simple" );
561 0         0 $code->( $obj );
562             }gexs;
563             }
564 0         0 my $frame = 0;
565 0   0     0 my $sub_pack = (caller(1))[3] || '';
566 0         0 my( $pkg, $file, $line ) = caller( $frame );
567 0   0     0 my $sub = ( caller( $frame + 1 ) )[3] // '';
568 0         0 my $sub2;
569 0 0       0 if( length( $sub ) )
570             {
571 0         0 $sub2 = substr( $sub, rindex( $sub, '::' ) + 2 );
572             }
573             else
574             {
575 0         0 $sub2 = 'main';
576             }
577 0         0 return( $err->print( "${pkg}::${sub2}() [$line]: $msg\n" ) );
578             }
579              
580             sub _run_data_maybe_array
581             {
582 0     0   0 my( $js, $data, $ok_ref, $fail_ref, $idx_ref, $json ) = @_;
583              
584 0 0       0 if( ref( $data ) eq 'ARRAY' )
585             {
586 0         0 for my $elem ( @$data )
587             {
588 0         0 _run_one( $js, $elem, $ok_ref, $fail_ref, ++$$idx_ref, $json );
589             }
590             }
591             else
592             {
593 0         0 _run_one( $js, $data, $ok_ref, $fail_ref, ++$$idx_ref, $json );
594             }
595             }
596              
597             sub _run_one
598             {
599 4     4   12 my( $js, $data, $ok_ref, $fail_ref, $idx, $json ) = @_;
600              
601 4         82 my $ok = $js->validate( $data );
602              
603 4 50       3983 if( $opts->{json} )
604             {
605 4 100       185 if( $ok )
606             {
607 2         22 $out->print( $json->encode({ index => $idx, ok => JSON::true }), "\n" );
608             }
609             else
610             {
611             my @errs = map
612             {
613             {
614 3         81 path => $_->path,
615             message => $_->message,
616             keyword => $_->keyword,
617             schema_ptr => $_->schema_pointer,
618             }
619 2 50       4 } @{$js->errors || []};
  2         15  
620              
621 2         127 $out->print( $json->encode({
622             index => $idx,
623             ok => JSON::false,
624             errors => \@errs,
625             }), "\n" );
626             }
627             }
628             else
629             {
630 0 0       0 if( $ok )
631             {
632 0 0 0     0 if( !$opts->{quiet} && !$opts->{errors_only} && !$opts->{emit_js} )
      0        
633             {
634 0         0 $err->print( "Record #$idx OK\n" );
635             }
636             }
637             else
638             {
639 0         0 $$fail_ref++;
640 0         0 my $errs = $js->errors;
641 0 0       0 if( !$opts->{quiet} )
642             {
643 0         0 $err->print( "Record #$idx FAILED\n" );
644             # $out->printf( " %s: %s\n", $err->path, $err->message );
645             # Maybe, we should display the full list?
646             # for my $e ( @{$js->errors || []} )
647             # {
648             # $out->printf( " - %s: %s\n", $e->path, $e->message );
649             # }
650 0         0 for my $error ( @$errs )
651             {
652             # If $err is a JSON::Schema::Validate::Error object, this calls as_string()
653 0         0 $err->print( " $error\n" );
654             }
655             }
656             }
657             }
658              
659 4 100       331 $$ok_ref++ if( $ok );
660             }
661              
662             # Signal handler for SIG TERM or INT; we exit 1
663             sub _signal_handler
664             {
665 0     0     my( $sig ) = @_;
666 0           &_message( "Caught a $sig signal, terminating process $$" );
667 0 0         if( uc( $sig ) eq 'TERM' )
668             {
669 0           &_cleanup_and_exit(0);
670             }
671             else
672             {
673 0           &_cleanup_and_exit(1);
674             }
675             }
676              
677             # NOTE: POD
678             __END__
679              
680             =encoding utf-8
681              
682             =pod
683              
684             =head1 NAME
685              
686             jsonvalidate - Validate JSON instances against a JSON Schema (Draft 2020-12)
687              
688             =head1 SYNOPSIS
689              
690             jsonvalidate --schema schema.json --instance data.json
691             jsonvalidate -s schema.json -i instances.array.json
692             jsonvalidate -s schema.json -i - < data.jsonl --jsonl --json
693             jsonvalidate -s root.json -s subdefs.json -i items.ndjson --jsonl --compile --register-formats
694              
695             =head1 DESCRIPTION
696              
697             A lean CLI powered by L<JSON::Schema::Validate>. It supports arrays of instances, JSON Lines, local file C<$ref>, optional HTTP(S) fetch for C<$ref> (when L<LWP::UserAgent> is available), and useful output modes.
698              
699             =head1 OPTIONS
700              
701             =head2 Selection
702              
703             =over 4
704              
705             =item B<--schema>, B<-s> FILE1, FILE2, FILE3, etc...
706              
707             Root schema; additional C<--schema> files are made available to the resolver, such as when their C<C<'$id'>> is referenced.
708              
709             =item B<--instance>, B<-i> FILE1, FILE2, FILE3, etc...
710              
711             Instances to validate. Use C<-> for STDIN. An instance may be a single object, a single array (each element validated), or JSON Lines with C<--jsonl>.
712              
713             Not that you can either use C<-> (STDIN), or one or more files, but you cannot mix both.
714              
715             =item B<--jsonl>
716              
717             Treat each line as an instance (NDJSON).
718              
719             =back
720              
721             =head2 Output
722              
723             =over 4
724              
725             =item B<--quiet>, B<-q>
726              
727             Suppress per-record output; still returns non-zero exit on failures.
728              
729             =item B<--errors-only>
730              
731             Only print failed records (ignored when C<--json> is used).
732              
733             =item B<--json>
734              
735             Emit JSON objects (one per instance) with C<{ index, ok, errors[] }>.
736              
737             =back
738              
739             =head2 Behavior
740              
741             =over 4
742              
743             =item B<--allow-file-refs>
744              
745             Enabled by default.
746              
747             When enabled, perform resolution of relative or file:// references.
748              
749             =item B<--allow-http>
750              
751             Disabled by default.
752              
753             This is an alias for B<--remote-refs>
754              
755             =item B<--compile> / B<--no-compile>
756              
757             Enable compiled fast-path for repeated validation.
758              
759             =item B<--content-checks>
760              
761             Enable C<contentEncoding>, C<contentMediaType>, C<contentSchema>. Registers a basic C<application/json> validator/decoder.
762              
763             =item B<--extensions>
764              
765             Enables non-standard extensions. Right now this includes C<uniqueKeys>
766              
767             =item B<--ignore-unknown-required-vocab>
768              
769             Ignore unknown vocabularies listed in schema C<C<'$vocabulary'>> I<required>.
770              
771             =item B<--register-formats>
772              
773             Register built-in C<format> validators (date, email, hostname, ip, uri, uuid, JSON Pointer, regex, etc.).
774              
775             =item B<--max-errors N>
776              
777             Maximum recorded errors per validation (default 200).
778              
779             =item B<--normalize> / B<--no-normalize>
780              
781             Round-trip instances through L<JSON> to enforce strict JSON typing (default on).
782              
783             =item B<--remote-refs>
784              
785             Allow fetching of http:// and https:// $ref URIs.
786              
787             By default this is OFF — fictional $id values like
788             "https://schemas.example.com/..." will NOT be fetched.
789              
790             This is the modern, safe default (prevents SSRF, accidental traffic).
791              
792             =item B<--schema-base DIR>
793              
794             A base directory to resolve relative file C<$ref> (defaults to the directory of the first C<--schema>).
795              
796             =item B<--trace>
797              
798             Record lightweight trace; cap with C<--trace-limit>; sample with C<--trace-sample>.
799              
800             =item B<--trace-limit N>
801              
802             Max number of trace entries per validation (0 = unlimited).
803              
804             =item B<--trace-sample P>
805              
806             Sampling percentage for trace events.
807              
808             =item B<--unique-keys> / B<--no-unique-keys>
809              
810             Enables the non-standard extension C<uniqueKeys>
811              
812             =back
813              
814             =head1 EXIT CODES
815              
816             =over 4
817              
818             =item * C<0>
819              
820             All instances validated.
821              
822             =item * C<1>
823              
824             At least one instance failed.
825              
826             =item * C<2>
827              
828             Usage error.
829              
830             =back
831              
832             =head1 SEE ALSO
833              
834             L<JSON::Schema::Validate>, L<JSON>
835              
836             =head1 AUTHOR
837              
838             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
839              
840             =head1 COPYRIGHT
841              
842             Copyright(c) 2025 DEGUEST Pte. Ltd.
843              
844             All rights reserved
845              
846             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
847              
848             =cut