use strict; use warnings; use JSON; use File::Find qw(finddepth); use Encode qw(decode); #### START OF GLOBAL VARS my $fh; # Output file handle my $imgDirectory = 'C:/Users/Owner/My Website/img/covers'; my $respJsonData; my @unknownIDs = (); my @unknownFields = (); my @mismatchedTags = (); my @missingFields = (); my @emptyFieldsByType = (); my @emptyFieldsByWork = (); #### END OF GLOBAL VARS #### START OF MAIN PROGRAM #### # For each .json.txt file, analyze it. Then make your report. my $gameJsonData = loadJson("../IFIndexer/gamejson.txt"); my @files = <./json/*.json.txt>; foreach my $file (@files) { if ($file =~ /index\.json\.txt$/) { # skip for now. } else { $respJsonData = loadJson($file); analyzeJson($file); } } makeQCPage(); #### END OF MAIN PROGRAM #### sub loadJson { my $inname = $_[0]; my $jsondata = ''; open(my $jinfh, "<", $inname) || die("can't open $inname: $!"); print "*** reading $inname ... "; while ( <$jinfh> ) { $jsondata .= $_; } close $jinfh; print "DONE!\n"; print "*** parsing $inname ... "; $jsondata =~ s/^\x{ef}\x{bb}\x{bf}//; # decode_json doesn't like these leading bytes, the "Byte Order Mark" aka BOM. my $hashref = decode_json $jsondata; print "DONE!\n"; return $hashref; } sub analyzeJson { my $fname = $_[0]; $fname =~ /json\/(.*?)\.json/; my $type = $1; testUnknownIDs( $type ); testUnknownFields( $type ); testFields( $type ); # Missing, Empty # testTodoFields(); # testMismatchedHtmlTags(); # testMissingImages(); } sub testUnknownIDs { my $type = $_[0]; foreach my $k (keys %{$respJsonData}) { if (!exists($gameJsonData->{'games'}{$k})) { push @unknownIDs, "$type :: $k"; } } } sub testUnknownFields { my $type = $_[0]; foreach my $k (keys %{$respJsonData}) { my $v = $respJsonData->{$k}; foreach my $f (keys %{$v}) { if ($f !~ /^(title|sfx|year|things|notes|x)$/) { push @unknownFields, "$type :: $k : $f"; } } if (exists($v->{'things'})) { foreach my $th (@{$v->{'things'}}) { foreach my $tk (keys %{$th}) { if ($tk !~ /^(name|type|loc|desc)$/) { push @unknownFields, "$type :: $k : things[].$tk"; } } }} } } sub testFields { my $type = $_[0]; foreach my $k (keys %{$respJsonData}) { my $v = $respJsonData->{$k}; if (!exists($v->{'title'})) { push @missingFields, "$type :: $k : title"; } elsif ($v->{'title'} eq '') { push @emptyFieldsByType, "$type :: $k : title"; push @emptyFieldsByWork, "$k :: $type : title"; } if (!exists($v->{'things'})) { push @missingFields, "$type :: $k : things"; } else { my $n = 0; foreach my $th (@{$v->{'things'}}) { # CAREFUL. Don't over-report a missing/empty thing. if (!exists($th->{'name'})) { push @missingFields, "$type :: $k : things[$n].name"; } elsif ($th->{'name'} eq '') { push @emptyFieldsByType, "$type :: $k : things[$n].name"; push @emptyFieldsByWork, "$k :: $type : things[$n].name"; } elsif (!exists($th->{'type'})) { push @missingFields, "$type :: $k : things[$n].type"; } elsif ($th->{'type'} eq '') { push @emptyFieldsByType, "$type :: $k : things[$n].type"; push @emptyFieldsByWork, "$k :: $type : things[$n].type"; } elsif (!exists($th->{'loc'})) { push @missingFields, "$type :: $k : things[$n].loc"; } elsif ($th->{'loc'} eq '') { push @emptyFieldsByType, "$type :: $k : things[$n].loc"; push @emptyFieldsByWork, "$k :: $type : things[$n].loc"; } elsif (!exists($th->{'desc'})) { push @missingFields, "$type :: $k : things[$n].desc"; } elsif ($th->{'desc'} eq '') { push @emptyFieldsByType, "$type :: $k : things[$n].desc"; push @emptyFieldsByWork, "$k :: $type : things[$n].desc"; } $n++; } } } } sub testMismatchedTags { my $type = $_[0]; my @tags = ('b', 'div', 'em', 'i', 'ins', 'li', 'p', 'pre', 'span', 'ul', 'var'); foreach my $k (keys %{$respJsonData}) { my $v = $respJsonData->{$k}; if (exists($v->{'things'})) { foreach my $th (@{$v->{'things'}}) { if (exists($th->{'desc'})) { foreach my $t (@tags) { my $nleft = 0; my $nright = 0; while ($v =~ /<$t\b.*?>/gs) { $nleft++; } while ($v =~ /<\/$t>/gs) { $nright++; } if ($nleft != $nright) { my $err = "Unbalanced <$t> tag in desc field."; push @mismatchedTags, "$type :: $k : $err"; } }} }} } } sub makeQCPage { open($fh, ">:encoding(UTF-8)", "qc.html"); print $fh "\n\n\n"; print $fh "\n"; print $fh "\n"; print $fh "Thinger Quality Control\n"; print $fh "\n\n"; print $fh "\n

\"\" Thinger Quality Control

\n\n"; print $fh "

"; print $fh "Unknown IDs"; print $fh " • Unknown Fields"; print $fh " • Mismatched Tags"; print $fh " • Missing Fields"; print $fh " • Empty Fields by Type"; print $fh " • Empty Fields by Work"; print $fh "

\n\n"; reportUnknownIDs(); reportUnknownFields(); reportMismatchedTags(); reportMissingFields(); reportEmptyFields(); doFooter(); print $fh "\n\n"; close $fh; } sub reportUnknownIDs { print $fh "

Unknown IDs

\n\n"; print $fh "

Either the things file is using the wrong ID, or the work needs to be added to the games file.

\n"; print $fh "\n\n"; } sub reportUnknownFields { print $fh "

Unknown Fields

\n\n\n\n"; } sub reportMissingFields { print $fh "

Missing Fields

\n\n\n\n"; } sub reportEmptyFields { my $cur; my $last; my %counts; %counts = (); foreach my $r (@emptyFieldsByType) { $r =~ /^(.*?)\s\:/; my $cur = $1; if (exists($counts{$cur})) { $counts{$cur}++; } else { $counts{$cur} = 1; } } $last = ''; print $fh "

Empty Fields by Type

\n\n\n \n" if $last ne ''; print $fh "
  • \n $cur (" . $counts{$cur} . ")\n \n
  • \n" if $last ne ''; print $fh "\n\n"; $last = ''; print $fh "

    Empty Fields by Work

    \n\n\n" if $last ne ''; print $fh "
  • $cur\n \n" if $last ne ''; print $fh "\n\n"; } sub reportMismatchedTags { print $fh "

    Mismatched Tags

    \n\n\n\n"; } # Want to make sure every
  • tag is balanced with a
  • tag and so on, # in any particular response field. sub collectUnbalancedTagProblems { my ($id, $k, $v, $records) = @_; my @tags = ('b', 'div', 'em', 'i', 'ins', 'li', 'p', 'pre', 'span', 'ul', 'var'); foreach my $t (@tags) { my $nleft = 0; my $nright = 0; while ($v =~ /<$t\b.*?>/gs) { $nleft++; } while ($v =~ /<\/$t>/gs) { $nright++; } if ($nleft != $nright) { my $p = "Unbalanced <$t> tag in \"$k\" field."; push @{$records}, { 'sort' => "$id $p", 'id' => $id, 'problem' => $p }; } } } sub imageExists { my $id = $_[0]; if (-e "$imgDirectory/$id.png") { return 1; } elsif (-e "$imgDirectory/$id.jpg") { return 1; } elsif (-e "$imgDirectory/$id.gif") { return 1; } else { return 0; } } sub hasCoverTag { my $id = $_[0]; if (!exists($gameJsonData->{'games'}{$id})) { return 0; } if (!exists($gameJsonData->{'games'}{$id}{'tags'})) { return 0; } foreach my $tag (@{$gameJsonData->{'games'}{$id}{'tags'}}) { if ($tag eq 'cover') { return 1; } } return 0; } sub getCurrentYear { my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); return 1900 + $year; } sub isEnglish { # return 1 if there's an English version of the work; otherwise, return 0. my $gVersions = $_[0]; foreach my $ver (@{$gVersions}) { if (exists($ver->{'lang'}) and ($ver->{'lang'} =~ /^en/)) { return 1; } } return 0; } sub reportField { my ($fldname, $records) = @_; if (scalar(@{$records}) == 0) { print $fh "

    No \"$fldname\" fields found.

    \n"; } else { print $fh "\n\n"; } } sub doFooter { my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); my $dd = substr('0' . $mday,-2); my $mmm = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec')[$mon]; my $yyyy = 1900 + $year; print $fh "\n"; }