common/scripts/gblint.pl

   1 #!/usr/bin/perl -Tw
   2 #
   3 # Each new section id requires adding it to the list (e.g. improved
   4 # disciplines).
   5 #
   6 ###############################################################################
   7 use strict;
   8
   9 my $endOfDTD = 0;
  10
  11 my %sectionDocLookup = (
  12   '_unknown' => '_unknown',
  13   'toc'      => 'toc',
  14   'title'    => 'title',
  15   'dedicate' => 'dedicate',
  16   'acknwldg' => 'acknwldg',
  17   'credits'  => 'acknwldg',
  18   'coming'   => 'coming',
  19   'tssf'     => 'tssf',
  20   'gamerulz' => 'gamerulz',
  21   'discplnz' => 'discplnz',
  22   'camflage' => 'discplnz',
  23   'hunting'  => 'discplnz',
  24   'sixthsns' => 'discplnz',
  25   'tracking' => 'discplnz',
  26   'healing'  => 'discplnz',
  27   'wepnskll' => 'discplnz',
  28   'mndshld'  => 'discplnz',
  29   'mndblst'  => 'discplnz',
  30   'anmlknsp' => 'discplnz',
  31   'mindomtr' => 'discplnz',
  32   'mksumary' => 'discplnz',
  33   'anmlctrl' => 'discplnz',
  34   'curing'   => 'discplnz',
  35   'invsblty' => 'discplnz',
  36   'psisurge' => 'discplnz',
  37   'psiscrn'  => 'discplnz',
  38   'dvnation' => 'discplnz',
  39   'wpnmstry' => 'discplnz',
  40   'anmlmstr' => 'discplnz',
  41   'deliver'  => 'discplnz',
  42   'assimila' => 'discplnz',
  43   'hntmstry' => 'discplnz',
  44   'pthmnshp' => 'discplnz',
  45   'kaisurge' => 'discplnz',
  46   'kaiscrn'  => 'discplnz',
  47   'nexus'    => 'discplnz',
  48   'gnosis'   => 'discplnz',
  49   'magi'     => 'discplnz',
  50   'kalchemy' => 'discplnz',
  51   'powers'   => 'powers',
  52   'lessmcks' => 'powers',
  53   'alchemy'  => 'powers',
  54   'sorcery'  => 'powers',
  55   'enchant'  => 'powers',
  56   'elementl' => 'powers',
  57   'prophecy' => 'powers',
  58   'psycmncy' => 'powers',
  59   'evcation' => 'powers',
  60   'highmcks' => 'powers',
  61   'thamtrgy' => 'powers',
  62   'telergy'  => 'powers',
  63   'physirgy' => 'powers',
  64   'theurgy'  => 'powers',
  65   'visionry' => 'powers',
  66   'necrmncy' => 'powers',
  67   'staff'    => 'powers',
  68   'moonston' => 'powers',
  69   'equipmnt' => 'equipmnt',
  70   'howcarry' => 'equipmnt',
  71   'howmuch'  => 'equipmnt',
  72   'howuse'   => 'equipmnt',
  73   'cmbtrulz' => 'cmbtrulz',
  74   'evasion'  => 'cmbtrulz',
  75   'lorecrcl' => 'lorecrcl',
  76   'lcbonus'  => 'lorecrcl',
  77   'levels'   => 'levels',
  78   'primate'  => 'levels',
  79   'tutelary' => 'levels',
  80   'mentora'  => 'levels',
  81   'scion'    => 'levels',
  82   'archmstr' => 'levels',
  83   'prncpln'  => 'levels',
  84   'imprvdsc' => 'imprvdsc',
  85   'guardian' => 'imprvdsc',
  86   'sunkght'  => 'imprvdsc',
  87   'sunlord'  => 'imprvdsc',
  88   'kaiwisdm' => 'kaiwisdm',
  89   'sage'     => 'sage',
  90   'numbered' => 'numbered',
  91   'passing'  => 'passing',
  92   'part1'    => 'part1',
  93   'part2'    => 'part2',
  94   'map'      => 'map',
  95   'action'   => 'action',
  96   'crsumary' => 'crsumary',
  97   'smevazn'  => 'crsumary',
  98   'crtable'  => 'crtable',
  99   'random'   => 'random',
 100   'errata'   => 'errata',
 101   'errintro' => 'errata',
 102   'errerr'   => 'errata',
 103   'footnotz' => 'footnotz',
 104   'illstrat' => 'illstrat',
 105   'primill'  => 'illstrat',
 106   'secill'   => 'illstrat',
 107   'license'  => 'license',
 108   'lic-pre'  => 'license',
 109   'lic-1'    => 'license',
 110   'lic-1-0'  => 'license',
 111   'lic-1-1'  => 'license',
 112   'lic-1-2'  => 'license',
 113   'lic-1-3'  => 'license',
 114   'lic-1-4'  => 'license',
 115   'lic-1-5'  => 'license',
 116   'lic-1-6'  => 'license',
 117   'lic-1-7'  => 'license',
 118   'lic-2'    => 'license',
 119   'lic-2-0'  => 'license',
 120   'lic-2-1'  => 'license',
 121   'lic-2-2'  => 'license',
 122   'lic-2-3'  => 'license',
 123   'lic-2-4'  => 'license',
 124   'lic-2-5'  => 'license',
 125   'lic-3'    => 'license',
 126   'lic-3-0'  => 'license',
 127   'lic-3-1'  => 'license',
 128   'lic-4'    => 'license',
 129   'lic-4-0'  => 'license',
 130   'lic-5'    => 'license',
 131   'lic-5-0'  => 'license',
 132   'lic-6'    => 'license',
 133   'lic-6-0'  => 'license',
 134   'lic-6-1'  => 'license',
 135 );
 136
 137 my $errorCount = 0;
 138 my $maxErrorCount = 0;
 139 my $skipLines = 0;
 140 my $initials = "??";
 141 my $useCorr = 0;
 142 my $checkNonASCII = 1;
 143 my $language = 'en';
 144
 145 while( $#ARGV > -1 && $ARGV[ 0 ] =~ /^-/ ) {
 146   if( $ARGV[ 0 ] eq "-e" && $#ARGV > 0 ) {
 147     shift @ARGV;
 148     $maxErrorCount = shift @ARGV;
 149   }
 150   elsif( $ARGV[ 0 ] eq "-s" && $#ARGV > 0 ) {
 151     shift @ARGV;
 152     $skipLines = shift @ARGV;
 153   }
 154   elsif( $ARGV[ 0 ] eq "-i" && $#ARGV > 0 ) {
 155     shift @ARGV;
 156     $initials = shift @ARGV;
 157   }
 158   elsif( $ARGV[ 0 ] eq "--use-corr" ) {
 159     shift @ARGV;
 160     $useCorr = 1;
 161   }
 162   elsif( $ARGV[ 0 ] eq '--skip-ASCII-check' ) {
 163     shift @ARGV;
 164     $checkNonASCII = 0;
 165   }
 166   elsif( $ARGV[ 0 ] eq '--language' ) {
 167     shift @ARGV;
 168     $language = shift @ARGV;
 169   }
 170 }
 171
 172 my $lineNumber = 1;
 173 my $currentSection = "_unknown";
 174
 175 while( my $line = <> ) {
 176   my @section = ( $line =~ /<section[^>]+id="([^"]*)"/g );
 177   if( $#section > 0 ) { die( "Multiple sections begin at line $lineNumber\n" ); }
 178   elsif( $#section == 0 ) {
 179     if( $section[ 0 ] =~ /^sect[[:digit:]]+$/ ) {
 180       $currentSection = $section[ 0 ];
 181     }
 182     else {
 183       $currentSection = $sectionDocLookup{$section[ 0 ]};
 184     }
 185   }
 186
 187   if( $skipLines >= $lineNumber ) {
 188     ++$lineNumber;
 189     next;
 190   }
 191
 192   ##### Unescaped Characters
 193   if( $line =~ /[\200-\377]/ ) {
 194     if( $line =~ /\221/ ) { &printError( "ne", $currentSection, $lineNumber, "unescaped left single quotation mark(s)", "\221", "<quote>...</quote> or <ch.apos/>" ); }
 195     if( $line =~ /\222/ ) { &printError( "ne", $currentSection, $lineNumber, "unescaped right single quotation mark(s)", "\222", "<quote>...</quote> or <ch.apos/>" ); }
 196     if( $line =~ /\223/ ) { &printError( "ne", $currentSection, $lineNumber, "unescaped left double quotation mark(s)", "\223", "<quote>...</quote>" ); }
 197     if( $line =~ /\224/ ) { &printError( "ne", $currentSection, $lineNumber, "unescaped right double quotation mark(s)", "\224", "<quote>...</quote>" ); }
 198     if( $line =~ /\226/ ) { &printError( "ne", $currentSection, $lineNumber, "unescaped endash(es)", "\226", "<ch.endash/>" ); }
 199     if( $line =~ /\227/ ) { &printError( "ne", $currentSection, $lineNumber, "unescaped emdash(es)", "\227", "<ch.emdash/>" ); }
 200 #    if( $checkNonASCII && $line =~ /(.{0,4}?)?([\x80-\xff])(.{0,4})?/ ) {
 201 #      &printError( "ne", $currentSection, $lineNumber, "unescaped non-ASCII character(s) in \"${1}[[HERE]]${3}\"; first found only", "$2" );
 202 #    }
 203     if( $line =~ /(.{0,4}?)?([\x80-\x9f])(.{0,4})?/ ) {
 204       &printError( "ne", $currentSection, $lineNumber, "unsafe non-ASCII character(s) in \"${1}[[HERE]]${3}\"; first found only", "$2" );
 205     }
 206 }
 207   if( $line =~ /'/ ) { &printError( "ne", $currentSection, $lineNumber, "unescaped apostrophe(s)", "'", "<ch.apos/> or <quote>...</quote>" ); }
 208   if( $line =~ /`/ ) { &printError( "ne", $currentSection, $lineNumber, "backtick(s)", "`", "<ch.apos/> or <quote>...</quote>" ); }
 209
 210   # tab
 211
 212   if( $line =~ /\t/ ) { &printError( "ne", $currentSection, $lineNumber, "TAB character found; convert to equivalent SPACEs" ); }
 213
 214   # ampersand
 215   if( $line =~ /\&\s/ ) { &printError( "ne", $currentSection, $lineNumber, "possible malformed ampersand or escape sequence", "&", "<ch.ampersand/>" ); }
 216
 217   # emdash
 218   if( $line =~ /\s-\s/ ) { &printError( "ne", $currentSection, $lineNumber, "probable malformed emdash", " - ", "<ch.emdash/>" ); }
 219   if( $line =~ /(?<!\!)--(?!>)/ ) { &printError( "ne", $currentSection, $lineNumber, "probable malformed emdash", "--", "<ch.emdash/>" ); }
 220
 221   # endash
 222   if( $line =~ /([0-9])-([0-9]+)(?![^<]+>)/ ) { &printError( "ne", $currentSection, $lineNumber, "possible malformed endash", "$1-$2", "$1<ch.endash/>$2" ); }
 223
 224   # ellipsis
 225   if( $line =~ /(\.\s*\.(\s*\.)?)/ ) { &printError( "ne", $currentSection, $lineNumber, "possible malformed ellipsis", "$1", "<ch.ellips/> or <ch.lellips/>" ); }
 226   if( $line =~ m{([[:space:]]<ch\.ellips/>)} || $line =~ m{(<ch\.ellips/>[[:space:]])} ) { &printError( "ne", $currentSection, $lineNumber, "<ch.ellips/> with extraneous surrounding space", "$1", "<ch.ellips/>" ); }
 227   if( $line =~ m{([^>])(<ch\.lellips/>)} ) { &printError( "ne", $currentSection, $lineNumber, "possible <ch.lellips/> used in place of <ch.ellips/>", "$1$2", "$1<ch.ellips/>" ); }
 228   if( $line =~ m{(><ch\.ellips/>)} ) { &printError( "ne", $currentSection, $lineNumber, "possible <ch.ellips/> used in place of <ch.lellips/>", "$1", "><ch.lellips/>" ); }
 229
 230   # thinspace
 231   if( $line =~ m{(</?quote>)\1} ) { &printError( "ne", $currentSection, $lineNumber, "probable candidate for thinspace", "$1$1", "$1<ch.thinspace/>$1" ); }
 232   if( $line =~ m{(<quote>)(<ch.apos/>)} || $line =~ m{(<ch.apos/>)(</quote>)} ) { &printError( "ne", $currentSection, $lineNumber, "probable canidate for thinspace", "$1$2", "$1<ch.thinspace/>$2" ); }
 233
 234   # blankline
 235   if( $line =~ /(__+)/ ) { &printError( "ne", $currentSection, $lineNumber, "probable candidate for blankline", "$1", "<ch.blankline/>" ); }
 236
 237   # percent
 238   #  It should be safe to assume that there will be a "]>" at the end of
 239   #  internal DTD subset. Previous to the end of the internal DTD subset
 240   #  "%" has special meaning and shouldn't be detected.
 241   if( $line =~ /]>/ ) { $endOfDTD = 1; }
 242   if( $endOfDTD && $line =~ /\%/ ) { &printError( "ne", $currentSection, $lineNumber, "possible candidate for percent", "\%", "<ch.percent/>" ); }
 243
 244   ##### OCR Errors
 245
 246   if( $line !~ m{^[[:space:]]*</((p)|(choice))>} && $line =~ m{(([^.?!:);>]</((p)|(choice)))>)} ) { &printError( "??", $currentSection, $lineNumber, "possible missing punctuation", "$1" ); }
 247   if( $line =~ /((?<![iIeE]\.[eg])[.?!]\s+[a-z])/ ) { &printError( "??", $currentSection, $lineNumber, "possible bad initial capitalization", "$1" ); }
 248   if( $line =~ /([a-zA-Z][0-9][a-zA-Z])/ ) { &printError( "??", $currentSection, $lineNumber, "probable replacement of number for letter", "$1" ); }
 249   if( $line =~ />[^<]*-[[:space:]]/ ) { &printError( "??", $currentSection, $lineNumber, "possible retained end-of-line hyphen(s)" ); }
 250
 251   ##### Obsolete Markup
 252
 253   if( $line =~ /\&lsquot;/ ) { &printError( "ne", $currentSection, $lineNumber, "probable obsolete markup", "\&lsquot;", "<quote>" ); }
 254   if( $line =~ /\&rsquot;/ ) { &printError( "ne", $currentSection, $lineNumber, "probable obsolete markup", "\&rsquot;", "</quote>" ); }
 255   if( $line =~ /\&ldquot;/ ) { &printError( "ne", $currentSection, $lineNumber, "probable obsolete markup", "\&ldquot;", "<quote>" ); }
 256   if( $line =~ /\&rdquot;/ ) { &printError( "ne", $currentSection, $lineNumber, "probable obsolete markup", "\&rdquot;", "</quote>" ); }
 257   if( $line =~ /\&quot;/ ) { &printError( "ne", $currentSection, $lineNumber, "possible obsolete markup", "\&quot;", "<quote> or </quote>" ); }
 258   if( $line =~ /(\&link.[^;]+;)/ && ($1 ne '&link.staff.contact;') && ($1 ne '&link.project.website;')) { &printError( "ne", $currentSection, $lineNumber, "possibe obsolete markup", "$1", "use <bookref.../> instead" ); }
 259   if( $line =~ /\&([^[:space:]]+);/ ) {
 260     unless( $1 =~ /^(?:link|inclusion)/ ) {
 261       &printError( "ne", $currentSection, $lineNumber, "possible obsolete markup", "\&$1\;", "<ch.$1/>" );
 262     }
 263   }
 264   if( $line =~ /(<a([^>]*) class="footnote"(.*?)>)/ )  { &printError( "ne", $currentSection, $lineNumber, "obsolete markup", "$1", "<footref$2$3>" ); }
 265
 266   ##### Character Attributes
 267   # The following test uses negative lookback (?<! ... )
 268   if( $line =~ /[^>]((?<!CLOSE\s)COMBAT\s+SKILL)/ || $line =~ /((?<!CLOSE\s)COMBAT\s+SKILL)[^<]/ ) {
 269     &printError( "ne", $currentSection, $lineNumber, "possible missing markup", "$1", "<typ class=\"attribute\">$1</typ>" );
 270   }
 271   if( $line =~ /[^>](CLOSE\sCOMBAT\sSKILL)/ || $line =~ /(CLOSE\s+COMBAT\s+SKILL)[^<]/ ) {
 272     &printError( "ne", $currentSection, $lineNumber, "possible missing markup", "$1", "<typ class=\"attribute\">$1</typ>" );
 273   }
 274   if( $line =~ /[^>](ENDURANCE)/ || $line =~ /(ENDURANCE)[^<]/ ) {
 275     &printError( "ne", $currentSection, $lineNumber, "possible missing markup", "ENDURANCE", "<typ class=\"attribute\">ENDURANCE</typ>" );
 276   }
 277   if( $line =~ /[^>](WILLPOWER)/ || $line =~ /(WILLPOWER)[^<]/ ) {
 278     &printError( "ne", $currentSection, $lineNumber, "possible missing markup", "WILLPOWER", "<typ class=\"attribute\">WILLPOWER</typ>" );
 279   }
 280
 281   ##### Links
 282   if( $line =~ /[^>](random[[:space:]]+number[[:space:]]+table)/i ) {
 283     &printError( "ne", $currentSection, $lineNumber, "possible missing markup", "$1", "<a idref=\"random\">$1</a>" );
 284   }
 285   if( $line =~ /[^>](action[[:space:]]+charts?)/i ) {
 286     &printError( "ne", $currentSection, $lineNumber, "possible missing markup", "$1", "<a idref=\"action\">$1</a>" );
 287   }
 288
 289   ##### Others
 290   if( $line =~ m{<!--(?!/?ERRTAG)} ) { &printError( "ne", $currentSection, $lineNumber, "XML comment found (check for editor comments)" ); }
 291   if( $line =~ /([[:upper:]]{5,})/ &&
 292       $` !~ /<signpost>$/ &&
 293       (($language eq 'en' &&
 294         $1 ne "ENDURANCE" &&
 295         $1 ne "COMBAT" &&
 296         $1 ne "WILLPOWER" &&
 297         $1 ne "HAVOC" &&
 298         $1 ne "CLOSE") ||
 299        ($language eq 'es' &&
 300         $1 ne 'DESTREZA' &&
 301         $1 ne 'RESISTENCIA')) &&
 302         $1 ne "DOCTYPE" &&
 303         $1 ne "ENTITY" &&
 304         $1 ne "XVIII" &&
 305         $1 ne "ERRTAG" )
 306       { &printError( "ne", $currentSection, $lineNumber, "possible <signpost> needed", "$1", "<signpost>$1</signpost>" ); }
 307
 308   #####
 309   ++$lineNumber;
 310 }
 311
 312 unless( $endOfDTD || $skipLines > 0 ) { print "End of document reached without finding end of internal DTD subset \"]>\".\n"; }
 313
 314 ################################################################################
 315
 316 sub printError {
 317   my ($type, $section, $line, $message, $original, $corrected) = @_;
 318   my $report = "";
 319
 320   if( $useCorr ) {
 321     $report = "($type) $section: ";
 322     if( defined $original ) { $report .= "$original "; }
 323     if( defined $corrected ) { $report .= "-> $corrected "; }
 324     $report .= "[$initials: $message <line $line>]\n";
 325   }
 326   else {
 327     $report = "line $line ($section): $message";
 328     if( defined $original ) { $report .= " \"$original\""; }
 329     if( defined $corrected ) { $report .= " ($corrected)"; }
 330     $report .= "\n";
 331   }
 332
 333   print $report;
 334
 335   ++$errorCount;
 336   if( $maxErrorCount > 0 && $errorCount > $maxErrorCount ) { die "Maximum number of errors ($maxErrorCount) exceeded. Quitting.\n"; }
 337 }