home *** CD-ROM | disk | FTP | other *** search
/ DOS/V Power Report 2001 December (DVD) / VPR0112A.ISO / OLS / HTMLLINT / htmllint.lzh / parsedtd.pl < prev    next >
Perl Script  |  2001-03-20  |  33KB  |  1,150 lines
  1. #!/usr/local/bin/perl
  2.  
  3. # Simple DTD Parser for HTML ##########################
  4.  
  5. # HTML の DTD を読んで、HTML-lint が使用する情報を出力する。
  6. # この出力をそのまま使用してもよいが、たいていは、Perl の正規表現を利用した値に
  7. # 加工したり、DTD 中のコメントを反映させたりしてから使用する。
  8. # HTML-lint で使用するこれらの情報は、wilbur.rul 等ファイル名が固定されているので
  9. # 必要ならば調整する必要がある。
  10.  
  11. # history : 0.00 1997/06/06 着手
  12. #           0.10 1997/06/23 最初のリリース
  13. #           0.11 1997/06/29 細かいバグ修正
  14. #           0.12 1997/07/01 %tagsAttributes は不要
  15. #           0.13 1997/07/08 Cougar
  16. #           0.14 1997/07/11 %includeTags が出力されていなかった
  17. #           0.15 1997/07/26 Arena
  18. #           0.16 1997/08/18 %tagsAttributes 復活、(%REF) がうまく展開されていない
  19. #           0.17 1997/08/20 ATTLIST が空のときの処理
  20. #           0.18 1997/08/21 別の特定 DTD の参照処理
  21. #           0.19 1997/09/05 最後に 1; 出力
  22. #           0.20 1997/10/02 Cougar 09/17
  23. #           0.21 1998/02/03 HTML4.0 Frameset
  24. #           0.22 1998/02/24 Mozilla 3.0/4.0
  25. #           0.23 1998/03/07 Deprecated な要素の抽出 / 変数名変更
  26. #           0.24 1998/03/20 %attrValues のキー区切りを / に変更
  27. #           0.25 1998/07/07 &Doctype
  28. #           0.26 1999/05/01 ISO15445 のための調整
  29. #           0.27 1999/07/29 IE5 は属性名に下線を使っている
  30. #           0.28 1999/09/11 HTML 4.01 / -i
  31. #           0.29 1999/10/28 IE50 XMLNS:namespace
  32. #           0.30 1999/11/01 %attrValues 廃止、%tagsAttributes に統合
  33. #           0.31 2000/01/30 XHTML 1.0
  34. #           0.32 2000/03/26 XHTML 1.1
  35. #           0.33 2000/12/20 <? ... ?> 無視
  36. #           0.34 2000/12/25 属性値をDTDどおりに出力
  37. #           0.35 2001/01/13 (A+,B)+
  38. #           0.36 2001/02/24 (A*|B*|C*) != (A|B|C)*
  39. #           0.37 2001/03/13 binmode STDOUT
  40. $VERSION = '0.37';
  41.  
  42. # Copyright (c) 1997 ISHINO Keiichiro. All rights reserved.
  43.  
  44. require 5.000;
  45.  
  46. $dump_token  = 0;  # 読んだ全トークンを出力
  47. $dump_mark   = 0;  # 読んだマーク宣言を出力
  48. $dump_result = 1;  # 解析結果を出力
  49.  
  50. $ignore_FIXED = 0;
  51.  
  52. $html = 'HTML';
  53.  
  54. # Token Patterns
  55. $markDcl = '(<!(SGML|DOCTYPE|ELEMENT|ATTLIST|ENTITY|NOTATION|SHORTREF|USEMAP|\[|--)|<\?)';
  56. $nameChr    = '[A-Za-z0-9\.\-_:]';
  57. $nameStr    = '[A-Za-z:]'.$nameChr.'*';
  58. $digits     = '[0-9]+';
  59. $refParam   = '%'.$nameStr.';?';
  60. $entToken   = '#PCDATA|RCDATA|CDATA|EMPTY|ANY';
  61. $attToken   = '#FIXED|#REQUIRED|#CURRENT|#IMPLIED|#CONREF';
  62. $sectStatus = 'CDATA|RCDATA|IGNORE|INCLUDE|TEMP';
  63. $charData   = 'CDATA|NUMBER|NUMBERS|NAME|NAMES|NMTOKEN|NMTOKENS|NUTOKEN|NUTOKENS'.
  64.               '|ENTITY|ENTITIES|ID|IDREF|IDREFS|NOTATION';
  65. $nameSep    = '/';  # $nameChr に含まれないもの %attrValues のキー区切りでもある
  66. {
  67.   local(@tmp);
  68.   foreach (split(/\|/, $charData)) { push (@tmp, $_.'\.'); }
  69.   $refInnerParam = join('|', @tmp); # 内部的に一時使用
  70. }
  71.  
  72. # Mark Dispacher
  73. %dispatchDTD = (
  74. #   '<!SGML'     => 'SkipEndOfMark',
  75.     '<!DOCTYPE'  => 'Doctype',
  76.     '<!ELEMENT'  => 'Element',
  77.     '<!ATTLIST'  => 'Attlist',
  78.     '<!ENTITY'   => 'Entity',
  79. #   '<!NOTATION' => 'SkipEndOfMark',
  80. #   '<!SHORTREF' => 'SkipEndOfMark',
  81. #   '<!USEMAP'   => 'SkipEndOfMark',
  82.     '<!\['       => 'MarkSection',
  83.     '<!--'       => 'Comment',
  84.     '<\?'        => 'Declaration',
  85. );
  86.  
  87. # Included DTD
  88. %includedDTD = (
  89.    'ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML' => 'ISOlat1.ent',
  90.    '-//IETF//ENTITIES Added Latin 1 for HTML//EN'    => 'ISOlat1.ent',
  91.    '-//W3C//ENTITIES Latin1//EN//HTML'               => 'HTMLlat1.ent',
  92.    '-//W3C//ENTITIES Full Latin 1//EN//HTML'         => 'HTMLlat1.ent',
  93.    '-//W3C//ENTITIES Symbols//EN//HTML'              => 'HTMLsymbol.ent',
  94.    '-//W3C//ENTITIES Symbolic//EN//HTML'             => 'HTMLsymbol.ent',
  95.    '-//W3C//ENTITIES Special//EN//HTML'              => 'HTMLspecial.ent',
  96.    '-//W3C//DTD HTML 4.0 Transitional//EN'           => 'html40-loose.dtd',
  97.    '-//W3C//DTD HTML 4.01 Transitional//EN'          => 'html401-loose.dtd',
  98.    '-//W3C//ENTITIES Latin 1 for XHTML//EN'          => 'xhtml-lat1.ent',
  99.    '-//W3C//ENTITIES Symbols for XHTML//EN'          => 'xhtml-symbol.ent',
  100.    '-//W3C//ENTITIES Special for XHTML//EN'          => 'xhtml-special.ent',
  101. );
  102.  
  103. ##################################################
  104. # メインループ
  105.  
  106. if ($ARGV[0] eq '-i') {
  107.   shift;
  108.   $ignore_DEPRECATED = 1; # 強制的に Deprecated = IGNORE とする
  109. }
  110. if ($ARGV[0] ne '-d') {
  111.   # DTD から規則ファイルを作る
  112.   print "usage: parsedtd.pl [-i] dtdfile>rulefile\n",
  113.         "       parsedtd.pl -d include.rul ignore.rul\n" unless @ARGV;
  114.   while (@ARGV > 0) {
  115.     local($file) = shift(@ARGV);
  116.     if ($file eq '-') {
  117.       *DTD = *STDIN;
  118.       &GetDTD;
  119.     } else {
  120.       &ReadDTD($file, 1);
  121.     }
  122.   }
  123. } else {
  124.   # 規則ファイルから Deprecated な要素を抽出する
  125.   shift;
  126.   $loose  = shift;
  127.   $strict = shift;
  128.   if ($strict eq '') {
  129.     print "usage: deprecated.pl loose.rul strict.rul\n";
  130.     exit(0);
  131.   }
  132.   do $strict;
  133.   &ExpandInternalElementsAll;
  134.   $strictTags = join('|', $emptyTags, $pairTags);
  135.   %strictElements = %tagsElements;
  136.   %strictAttributes = %tagsAttributes;
  137. # %strictValues = %attrValues;
  138.   do $loose;
  139.   &ExpandInternalElementsAll;
  140.  
  141.   $deprecatedTags = '';
  142.   foreach (sort(split(/\|/, $emptyTags), split(/\|/, $pairTags))) {
  143.     unless (/^($strictTags)$/) {
  144.       $deprecatedTags = Join('|', $deprecatedTags, $_);
  145.     }
  146.   }
  147.   &EchoValue('deprecatedTags', $deprecatedTags);
  148.  
  149.   %deprecatedElems = ();
  150.   foreach $key (sort keys %tagsElements) {
  151.     next if $key =~ /^($deprecatedTags)$/o;
  152.     foreach (sort split(/\|/, $tagsElements{$key})) {
  153.       next if /^($deprecatedTags|CDATA|RCDATA)$/o;
  154.       $deprecatedElems{$key} = Join('|', $deprecatedElems{$key}, $_)
  155.                                       unless /^($strictElements{$key})$/;
  156.     }
  157.   }
  158.   &EchoArray('deprecatedElems', \%deprecatedElems);
  159.  
  160.   %deprecatedAttrs = ();
  161.   foreach $key (sort keys %tagsAttributes) {
  162.     next if $key =~ /^($deprecatedTags)$/o;
  163.     foreach (sort keys %{$tagsAttributes{$key}}) {
  164.       $deprecatedAttrs{$key} = Join('|', $deprecatedAttrs{$key}, $_)
  165.                                       unless $strictAttributes{$key}->{$_};
  166.     }
  167.   }
  168.   &EchoArray('deprecatedAttrs', \%deprecatedAttrs);
  169.  
  170.   %deprecatedVals = ();
  171.   foreach $key (sort keys %tagsAttributes) {
  172.     next if $key =~ /^($deprecatedTags)$/o;
  173.     foreach $attr (keys %{$tagsAttributes{$key}}) {
  174.       next if $attr =~ /^($deprecatedAttrs{$key})$/;
  175.       my $val = $tagsAttributes{$key}->{$attr};
  176.       next if $val =~ /^%/o;
  177.       my $strict = $strictAttributes{$key}->{$attr};
  178.       foreach (sort split(/\|/, $val)) {
  179.         $deprecatedVals{$key}->{$attr} = Join('|', $deprecatedVals{$key}->{$attr}, $_)
  180.                                                                  unless /^($strict)$/;
  181.       }
  182.     }
  183.   }
  184.   &EchoArrayArray('deprecatedVals', \%deprecatedVals);
  185. }
  186. exit(0);
  187.  
  188. ##################################################
  189. # DTD を読む。
  190.  
  191. sub ReadDTD
  192. {
  193.   local($file, $die) = @_;
  194.   if ($file ne '') {
  195.     local(*DTD);
  196.     my $ln = $.+0;
  197.     warn "$ln: Open '$file'\n";
  198.     if (open(DTD, "<$file")) {
  199.       &GetDTD;
  200.       close DTD;
  201.       warn "$ln: Close '$file'\n";
  202.     } elsif ($die) {
  203.       die qq|Can't open "$file".\n|;
  204.     } else {
  205. #     warn qq|Can't open "$file".\n|;
  206.       print qq|# Can't open "$file".\n|;
  207.     }
  208.   }
  209. }
  210.  
  211. sub GetDTD
  212. {
  213.   $enterDTD++;
  214.   TOKEN:
  215.   while (&GetToken(-1)) {
  216.     foreach $mark (keys(%dispatchDTD)) {
  217.       if ($token =~ /^$mark$/) {
  218.         die $@ unless eval('&'.$dispatchDTD{$mark});
  219.         next TOKEN;
  220.       }
  221.     }
  222.     if ($token =~ /^$refParam$/o) {
  223.       my $ref = &ExtendRefParam($token);
  224.       my $inc = $includedDTD{$ref};
  225.       &ReadDTD($inc? $inc: $ref);
  226.       next TOKEN;
  227.     }
  228.     warn "$.: Unsupported mark declaration '$token'\n";
  229.     &SkipEndOfMark;
  230.   }
  231.   $enterDTD--;
  232.   &EchoResults if $dump_result && !$enterDTD;
  233. }
  234.  
  235. ##################################################
  236. # 結果の出力
  237.  
  238. sub EchoResults
  239. {
  240.   binmode STDOUT;
  241.   print "#======= ELEMENTS =======\n";
  242.   {
  243.     local(@empty, @pair, @ostart, @oend, @cdata);
  244.     local(%onceonly, %required);
  245.     local(%exclude, %include);
  246.     local(@model0, %model1, @model2, %modelx);
  247.     foreach $name (sort(keys(%elements))) {
  248.       local($value) = $elements{$name};
  249.       if (substr($value, 2) eq 'EMPTY' && substr($value, 1, 1) eq 'O') {
  250.         push(@empty, $name);
  251.         next;
  252.       }
  253.       push(@pair,   $name) unless $name =~ /^#$digits$/o;
  254.       push(@ostart, $name) if substr($value, 0, 1) eq 'O';
  255.       push(@oend,   $name) if substr($value, 1, 1) eq 'O';
  256.       $value = substr($value, 2);
  257.       while ($value =~ /\s+(\-|\+)\((($nameChr|#|\|)+)\)/o) {
  258.         $exclude{$name} = $2 if $1 eq '-';
  259.         $include{$name} = $2 if $1 eq '+';
  260.         $value = $`.$';
  261.       }
  262.       if ($value =~ /^\((($nameChr|#|\|)+)\)(\*|\+)$/o) {
  263.         $model1{$name} = $1;
  264.         push(@model0, $name) if $3 eq '*'&& $name !~ /^#$digits$/o;
  265.       } elsif ($value =~ /^($refInnerParam)/o) {
  266.         $model1{$name} = '%'.$';
  267.         push(@model0, $name) if $value =~ /^R?CDATA/o;
  268.       } elsif ($value =~ /^(R?CDATA|ANY)$/o) {
  269.         $model1{$name} = $value;
  270.         push(@model0, $name);
  271.       } elsif ($value eq 'EMPTY') {
  272.         push(@model0, $name);
  273.       } else {
  274.         $modelx{$name} = $value;
  275.       }
  276.     }
  277.     foreach $name (keys(%modelx)) {
  278.       local($value) = $modelx{$name};
  279.       if ($value =~ /^\(([^\(\)]+)\)\*?$/o) {
  280.         $value = $1;
  281.         local($sep) = ($value =~ /(,|&|\|)/o)? $1: '&';
  282.         $sep = '\|' if $sep eq '|';
  283.         local(@tags) = split(/$sep/, $value);
  284.         local($tag, $tname);
  285.         local(@once, @twice, @req, @nseq, @seq, @val);
  286.         foreach $tag (@tags) {
  287.           if ($tag =~ /^(#?$nameChr+)(\?|\+|\*)?$/o) {
  288.             $tname = $1;
  289.             my $post = $2;
  290.             if ($tname ne '#PCDATA' && (!$post || $post eq '?')) {
  291. #             foreach (@once) {
  292. #               if ($_ eq $tname) {
  293. #                 push(@twice, $_);
  294. #                 last;
  295. #               }
  296. #             }
  297.               push(@once, $tname);
  298.             }
  299.             if ($tname ne '#PCDATA' && $sep ne '\|' && (!$post || $post eq '+')) {
  300.               push(@req,  $tname);
  301.             }
  302.             push(@nseq, $tname) if $sep eq '&';
  303.             push(@seq,  $tname) if $sep eq ',';
  304.             push(@val,  $tname);
  305.             delete $modelx{$name};
  306.           }
  307.         }
  308. #       if (@twice) {
  309. #         my $twice = &Ujoin(@twice);
  310. #         my @tmp;
  311. #         foreach (@once) {
  312. #           push(@tmp, $_) unless /^($twice)$/;
  313. #         }
  314. #         @once = @tmp;
  315. #       }
  316.         $onceonly{$name} = &Join('|', @once) if @once;
  317.         $required{$name} = &Ujoin(@req) if @req;
  318.         if ($sep eq '&') {
  319.           $model1{$name} = &Ujoin(@nseq) if @nseq;
  320.         } elsif ($sep eq ',') {
  321.           $model1{$name} = &Join('|', @seq) if @seq;
  322.           push(@model2, $name);
  323.         } else {
  324.           $model1{$name} = &Ujoin(@val) if @val;
  325.         }
  326.       }
  327.     }
  328.     foreach $name (keys(%exclude)) {
  329.       if ($model1{$name}) {
  330.         local(%tmp);
  331.         grep($tmp{$_}++, split(/\|/, $exclude{$name}));
  332.         $model1{$name} =
  333.           join('|', grep(!$tmp{$_}, split(/\|/, $model1{$name})));
  334. #       delete $exclude{$name};
  335.       }
  336.     }
  337.     foreach (keys(%include)) {
  338.       if ($model1{$_}) {
  339.         $model1{$_} .= '|'.$include{$_} if $include{$_} !~ /^($model1{$_})$/;
  340.       } else {
  341.         $model1{$_} = $include{$_};
  342.       }
  343.     }
  344.     foreach $tag (@pair, @empty) {
  345.       my $ok = 0;
  346.       foreach (keys(%model1)) {
  347.         if ($tag =~ /^($model1{$_})$/i) {
  348.           $ok = 1;
  349.           last;
  350.         }
  351.       }
  352.       if (!$ok && $tag ne $html) {
  353.         warn "warning: Unrefered element '$tag'\n";
  354. #       undef($attributes{$tag});
  355.         push(@unref, $tag);
  356.       }
  357.     }
  358.     $unrefs = &Ujoin(@unref);
  359.     # よくわからなかった要素モデルのタグ
  360.     if (scalar keys %modelx) {
  361.       foreach (keys %modelx) { warn "warning: Unknown style element '$_'\n"; }
  362.       &EchoArray('unknownStyleElements', \%modelx);
  363.     }
  364.     # 終了タグのない空タグ
  365.     &EchoValue('emptyTags', &Xjoin(@empty));
  366.     # 組みタグ
  367.     &EchoValue('pairTags', &Xjoin(@pair));
  368.     # 薦められないタグ
  369.     &EchoValue('deprecatedTags', &Xjoin(@deprecate));
  370.     # 開始タグ省略可
  371.     &EchoValue('omitStartTags', &Xjoin(@ostart));
  372.     # 終了タグ省略可
  373.     &EchoValue('omitEndTags', &Xjoin(@oend));
  374.     # 要素が空でもよいタグ
  375.     &EchoValue('maybeEmpty', &Xjoin(@model0));
  376.     # 要素中に現われなければならないタグ
  377.     &EchoArray('requiredTags', \%required);
  378.     # 要素中に１度だけ現われてよいタグ
  379.     &EchoArray('onceonlyTags', \%onceonly);
  380.     # 要素に順序どおりに書くタグ
  381.     &EchoValue('sequencialTags', &Xjoin(@model2));
  382.     # 要素に書けるタグ
  383.     &EchoArray('tagsElements', \%model1);
  384.     # 排除タグ要素
  385.     &EchoArray('excludedElems', \%exclude);
  386.     # 追加タグ要素
  387.     &EchoArray('includedElems', \%include);
  388.   }
  389.   print "#======= ATTRIBUTES =======\n";
  390.   {
  391.     local(%attrs, %avalues, %required);
  392.     foreach $name (sort(keys(%attributes))) {
  393.       local($value) = $attributes{$name};
  394.       while ($value =~ m#^([^/]+)/([^/]+)/([^/]+)/?#o) {
  395.         local($att, $val, $def) = ($1, $2, $3);
  396.         $value = $';
  397.         my $fixed = '';
  398.         if ($def eq '#FIXED') {
  399.           $value =~ m#^"([^"]*)"/?#o;
  400.           $fixed = $1;
  401. #         $fixed = uc($fixed) if $fixed =~ /^($val)$/i;
  402.           $value = $';
  403.           next if $ignore_FIXED;
  404.           next if $att =~ /^(SDAFORM|SDARULE|SDAPREF|SDASUFF|SDASUSP)$/i;
  405.         } elsif ($def eq '#REQUIRED') {
  406.           $required{$name} = &Join('&', $required{$name}, $att);
  407.         }
  408.         $attrs{$name} = &Join('|', $attrs{$name}, $att);
  409.         $val = '%'.$' if $val =~ /^($refInnerParam)/o;
  410.         $val = $1 if $val =~ /\(([^\(\)]+)\)$/o;
  411.         $val .= "=$fixed" if $fixed ne '';
  412. #       $avalues{$name.$nameSep.$att} = $val;
  413.         $avalues{$name}{$att} = $val;
  414.       }
  415.     }
  416.     # 属性一覧
  417. #   &EchoArray('tagsAttributes', \%attrs);
  418.     &EchoArrayArray('tagsAttributes', \%avalues);
  419.     # 必須属性
  420.     &EchoArray('requiredAttrs', \%required);
  421.   }
  422.   print "#======= ENTITIES =======\n";
  423.   # ﾀ体参照
  424.   &EchoArray('refEntities', \%generalEntities);
  425.   # パラメタ参照
  426.   &EchoArray('refParams', \%parameters);
  427.  
  428.   print "\n1;\n";
  429. }
  430.  
  431. sub EchoArrayArray
  432. {
  433.   my ($name, $array) = @_;
  434.   print "\%$name = (\n";
  435.   foreach $aname (sort keys %$array) {
  436.     my $maxlen;
  437.     foreach (keys %{$$array{$aname}}) {
  438.       $maxlen = length($_) if $maxlen < length($_);
  439.     }
  440.     print("  '$aname' => {\n");
  441.     foreach (sort keys %{$$array{$aname}}) {
  442.       &EchoValue($_, $$array{$aname}->{$_}, $maxlen, 4);
  443.     }
  444.     print("  },\n");
  445.   }
  446.   print ");\n";
  447. }
  448.  
  449. sub EchoArray
  450. {
  451.   local($name, $array) = @_;
  452.   local($maxlen);
  453.   foreach $aname (keys(%$array)) {
  454. #   $aname =~ s/:XMLNS:/[^:]+:.+/og;
  455. #   $aname = '[^:]+:.+' if $aname eq ':XMLNS:';
  456.     $maxlen = length($aname) if $maxlen < length($aname);
  457.   }
  458.   print "\%$name = (\n";
  459.   foreach $aname (sort(keys(%$array))) {
  460.     &EchoValue($aname, $$array{$aname}, $maxlen);
  461.   }
  462.   print ");\n";
  463. }
  464.  
  465. sub EchoValue
  466. {
  467.   local($name, $value, $offset, $offset2) = @_;
  468. # $name  =~ s/:XMLNS:/[^:]+:.+/og;
  469. # $name = '[^:]+:.+' if $name eq ':XMLNS:';
  470.   $value =~ s/:XMLNS:/[^:]+:.+/og;
  471.   local($term, $sep);
  472.   if ($offset) {
  473.     $offset -= length($name);
  474.     $offset2 = 2 unless $offset2;
  475.     $name = sprintf("%${offset2}s'%s'%${offset}s => ", '', $name, '');
  476.     $term = ',';
  477.   } else {
  478.     $name = '$'.$name.' = ';
  479.     $term = ';';
  480.   }
  481.   $sep = ($value =~ /&/o)? '&': '|';
  482.   $offset = length($name);
  483.   while (length($value) > 76-$offset) {
  484.     local($splitline) = rindex($value, $sep, 76-$offset);
  485.     last if $splitline == -1;
  486.     print $name, "'", substr($value, 0, $splitline), "'.\n";
  487.     $name =~ s/\S/ /og;
  488.     $value = substr($value, $splitline);
  489.   }
  490.   print $name, "'$value'$term\n";
  491. }
  492.  
  493. ##################################################
  494. # <!ENTITY [%] ent-name [type] "content">
  495. # <!ENTITY [%] ent-name PUBLIC "content" SYSTEM "file">
  496. # 多重定義しているときは後ろが無視される。
  497.  
  498. sub Entity
  499. {
  500.   local($param, $ename, $type, $content, $end);
  501.   $ename = &GetToken(0);
  502.   if ($param = ($ename eq '%')) {
  503.     # parameter entity
  504.     $ename = &GetToken(0);
  505.   }
  506.   die "$.: Illegal entity name $ename\n"
  507.     unless $ename =~ /^($nameStr)/o;
  508.   if (&SkipComment !~ /^("|')/o) {
  509.     $type = &GetToken(0);
  510.     die "$.: Illegal parameter entity content $content\n"
  511.       if &SkipComment !~ /^("|')/o;
  512.   }
  513.   $content = &GetToken(0);
  514.   if ($param) {
  515.     if (defined($paramEntities{$ename})) {
  516.       warn "$.: Already defined parameter entity '$ename'\n";
  517.     } else {
  518.       $paramEntities{$ename} = $content;
  519.       print "$./%ENTITY/$ename/$paramEntities{$ename}\n" if $dump_mark;
  520.       if ($type eq 'PUBLIC' && $content =~ m#^-//W3C//#) {
  521.         my $file = &GetToken(0);
  522.         if ($file ne '' && $file ne '>') {
  523.           $file = &GetToken(0) if $file eq 'SYSTEM';
  524.           unless ($file =~ m#/#) {
  525.             $paramFile{$ename} = $file;
  526.           } elsif ($file =~ m#^http://.*/([^/]+)$#) {
  527.             $paramFile{$ename} = $1;
  528.           }
  529.         } else {
  530.           &UnGetToken;
  531.         }
  532.       }
  533.     }
  534.     do { $end = &GetToken(0); } while $end ne '>';
  535.   } else {
  536.     if ($type eq '' || $type eq 'CDATA') {
  537.     } elsif ($type eq 'STARTTAG') {
  538.       $content = '<'.$content.'>' unless $content =~ /^<.+>$/o;
  539.     } elsif ($type eq 'ENDTAG') {
  540.       $content = '</'.$content.'>' unless $content =~ /^<\/.+>$/o;
  541.     } elsif ($type eq 'PUBLIC') {
  542.       $content = &GetToken(0); # 暫定
  543.     } else {
  544.       warn "$.: Unknown entity type '$type'\n";
  545.       $content = '';
  546.     }
  547.     if ($content ne '') {
  548.       if (defined($generalEntities{$ename})) {
  549.         warn "$.: Already defined general entity '$ename'\n";
  550.       } else {
  551.         $generalEntities{$ename} = $content;
  552.         print "$./ENTITY/$ename/$generalEntities{$ename}\n" if $dump_mark;
  553.       }
  554.     }
  555.     $end = &GetToken(0);
  556.   }
  557.   die "$.: Illegal entity declaration\n" if $end ne '>';
  558.   1;
  559. }
  560.  
  561. #########################################################
  562. # <!ELEMENT elem-name omit-start omit-end entity-model>
  563.  
  564. sub Element
  565. {
  566.   local($ename, $start, $end, $entity);
  567.   $ename = &GetToken(1);
  568.   die "$.: Illegal element name: $ename\n"
  569.     unless $ename =~ /^($nameStr|\(.+)$/o;
  570.   &SkipComment;
  571.   if ($line =~ /^[-O]/) {
  572.     $start = &GetToken(0);
  573.     die "$.: Illegal start omitting\n"
  574.       unless $start =~ /^[-O]$/o;
  575.     $end = &GetToken(0);
  576.     die "$.: Illegal end omitting\n"
  577.       unless $end =~ /^[-O]$/o;
  578.   } else {
  579.     $start = $end = '-';
  580.   }
  581.   $entity = &GetToken(2);
  582.   die "$.: Illegal entity model: $entity\n"
  583.     unless $entity =~ /^($entToken|($refInnerParam)$nameStr|\(.+)$/o;
  584.   if ($entity =~ /^\(/o) {
  585.     &ElementGroup($entity);
  586.     while (&GetToken(0) =~ /^(\-|\+)$/o) {
  587.       local($addsub) = $1;
  588.       die "$.:Illegal group subscription\n" unless &GetLine =~ /^\(/o;
  589.       $line = $';
  590.       $entity .= ' '.$addsub.&GetGroup(1);
  591.     }
  592.     &UnGetToken;
  593.   }
  594.   die "$.: Illegal element declaration\n" unless &GetToken(0) eq '>';
  595.   $ename  =~ s/[\(\)]//og;
  596.   $ename  =~ tr/[a-z]/[A-Z]/;
  597.   $entity =~ tr/[a-z]/[A-Z]/ unless $entity =~ /^($refInnerParam)/o;
  598.   foreach (split(/[\|,]/, $ename)) {
  599.     die "$.: Already defined element '$_'\n" if defined($elements{$_});
  600.     $elements{$_} = $start.$end.$entity;
  601.     push(@deprecate, $_) if $deprecated;
  602.   }
  603.   print "$./ELEMENT/$ename/$start/$end/$entity\n" if $dump_mark;
  604.   1;
  605. }
  606.  
  607. sub ElementGroup
  608. {
  609.   ($entity) = @_;
  610.   # (#PCDATA) --> (#PCDATA)*
  611.   $entity =~ s/^\(#PCDATA\)$/$&\*/o;
  612.   # (OPTION+) --> (OPTION)+
  613.   $entity =~ s/^\((#?$nameChr+)(\+|\*)\)$/\($1\)$2/o;
  614.   # ((...)*) --> (...)*
  615.   $entity = $1 if $entity =~ /\((\([^\(\)]+\)[\?\*\+]?)\)/o;
  616.   # (A|(B|C)|D)* --> (A|B|C|D)*
  617.   substr($entity, 1, length($1)) =~ s/[\(\)]//og
  618.     if $entity =~ /^\(([^&,\?\*\+]+)\)[\?\*\+]?$/o;
  619.   # (A+,B)+ --> (A|B)+   -- 暫定 (HTML+)
  620.   if ($entity =~ /^\((.+)\+,(.+)\)\+$/o) {
  621.     $entity = "($1|$2)+";
  622.   }
  623.   # (A|(B|C)*|D)* --> (A|B|C|D)*
  624.   if ($entity =~ /^\((.+)\)\*$/o) {
  625.     $entity = $1;
  626.     if ($entity =~ /\((.+)\)(\*|\+)/) {
  627.       substr($entity, length($`), length($&)) = $1;
  628.     }
  629.     $entity = '('.$entity.')*';
  630.   }
  631.   # (...|A*|...)* --> (...|A|...)*
  632.   if ($entity =~ /^\((.+)\)(\*|\+)$/o) {
  633.     local(@tags) = split(/\|/, $1);
  634.     local($rep) = "\\$2";
  635.     local(@tmp, $tag);
  636.     while ($tag = pop(@tags)) {
  637.       last unless $tag =~ /^(#?$nameChr+)$rep?$/o;
  638.       push(@tmp, $1);
  639.     }
  640.     $entity = '('.&Ujoin(@tmp).')'.substr($rep, 1) unless $tag;
  641.   }
  642.   # (A*|B*|C*) --> (A|B|C)*  間違いだが都合でこのように展開しておく
  643.   if ($entity =~ /^\(([^\(,&\)]+)\)$/o) {
  644.     local(@tags) = split(/\|/, $1);
  645.     local(@tmp, $tag, $rep);
  646.     if (pop(@tags) =~ /^(#?$nameChr+)(\*|\+)$/o) {
  647.       push(@tmp, $1);
  648.       $rep = "\\$2";
  649.       while ($tag = pop(@tags)) {
  650.         last unless $tag =~ /^(#?$nameChr+)$rep$/;
  651.         push(@tmp, $1);
  652.       }
  653.       $entity = '('.&Ujoin(@tmp).')'.substr($rep, 1) unless $tag;
  654.     }
  655.   }
  656.   # (A,(B),C) --> (A,#N,C)
  657.   if ($entity =~ /^\(([^\(]*\(.+\)[^\)]*)\)$/o) {
  658.     $entity = &ElementNestGroup($1);
  659.   }
  660.   $entity;
  661. }
  662.  
  663. sub ElementNestGroup
  664. {
  665.   ($entity) = @_;
  666.   local($ent, $ref);
  667.   while ($entity) {
  668.     if ($entity =~ /^[^\(\)]+/o) {
  669.       $ent .= $&;
  670.       $entity = $';
  671.     }
  672.     if ($entity =~ /^\(/o) {
  673.       local($eg) = '--'.uc(&ElementNestGroup($'));
  674.       $ref = '';
  675.       foreach (keys(%elements)) {
  676.         if (/^#\d\d\d$/o && $elements{$_} eq $eg) {
  677.           $ref = $_;
  678.           last;
  679.         }
  680.       }
  681.       if ($ref eq '') {
  682.         $ref = sprintf("#%03d", $refGroup++);
  683.         $elements{$ref} = $eg;
  684.       }
  685.       $ent .= $ref;
  686.     }
  687.     if ($entity =~ /^\)[\+\*\?]?/o) {
  688.       $ent = &ElementGroup('('.$ent.$&);
  689.       $entity = $';
  690.       if ($ent =~ /[\+\*\?]$/o) {           # 0.13
  691.         $ent = $`.'*';
  692.         $entity = $&.$entity;
  693.       }
  694.       return $ent;
  695.     }
  696.   }
  697.   &ElementGroup('('.$ent.')');
  698. }
  699.  
  700. ###################################################
  701. # <!ATTLIST elem-name attr-name values default
  702. #                     attr-name values default...>
  703.  
  704. sub Attlist
  705. {
  706.   local($ename, $aname, $values, $default, @attrs);
  707.   $ename = &GetToken(1);
  708.   die "$.: Illegal element name: $ename\n"
  709.     unless $ename =~ /^($nameStr|\(.+)$/o;
  710.   print "$./ATTRIBUTE/$ename" if $dump_mark;
  711.   for (;;) {
  712.     last if &GetToken(0) eq '>';
  713.     &UnGetToken;
  714.     $aname = &GetToken(1);
  715.     die "$.: Illegal attribute name: $aname\n"
  716.       unless $aname =~ /^($nameStr|\()$/o;
  717.     $aname =~ tr/[a-z]/[A-Z]/;
  718.     push(@attrs, $aname);
  719.     $values = &GetToken(1);
  720.     die "$.: Illegal attribute values: $values\n"
  721.       unless $aname =~ /^($digits|$nameStr|\()$/o;
  722.     if ($values !~ /^($refInnerParam)/o) {
  723.       die "$.: Illegal character data type: $values\n"
  724.         unless $values =~ /^\(/o || $values =~ /^($charData)$/o;
  725. #     $values  =~ tr/[a-z]/[A-Z]/;
  726.     }
  727.     if ($values eq 'NOTATION') {
  728.       warn "$.: Unsupported attribute style '$values'\n";
  729.       &GetToken(1);
  730.       $values = 'CDATA';
  731.     }
  732.     $values =~ s/^\(($nameStr)\)$/$1/o;
  733.     push(@attrs, $values);
  734.     ($default = &GetToken(0)) =~ s#/##og;
  735.     die "$.: Illegal default attribute: $aname\n"
  736.       unless $aname =~ /^($digits|$nameStr|$attAToken)$/o;
  737. #   $default =~ tr/[a-z]/[A-Z]/;
  738.     push(@attrs, $default);
  739.     print "/$aname/$values/$default" if $dump_mark;
  740.     warn "$.: Unsuppoertd default attribute '$aname'\n"
  741.       unless $aname =~ /^([^#]+|#FIXED|#REQUIRED|#IMPLIED)$/o;
  742.     if ($default eq '#FIXED') {
  743.       die "$.: No fixed value\n" unless &SkipComment =~ /^("|')/o;
  744.       &GetToken(0);
  745.       print "/$token" if $dump_mark;
  746.       push(@attrs, '"'.$token.'"') unless $ignore_FIXED;
  747.     }
  748.   }
  749.   print "\n" if $dump_mark;
  750.   $ename =~ s/(\(|\))//og;
  751.   foreach (split(/\|/, uc($ename))) {
  752.     if (defined($attributes{$_})) {
  753. #     die "$.: Already defined attlist '$_'\n";
  754.       $attributes{$_} = join('/', $attributes{$_}, @attrs);
  755.     } else {
  756.       $attributes{$_} = join('/', @attrs);
  757.     }
  758.   }
  759.   1;
  760. }
  761.  
  762. ##################################################
  763. # <!DOCTYPE HTML [ declaration ]>
  764.  
  765. sub Doctype
  766. {
  767.   $html = uc(&GetToken(0));
  768.   &GetLine;
  769.   if ($line =~ /^\[/o) {
  770.     $line = $';
  771.     &GetDTD;
  772.     &GetLine;
  773.     die "$.: Unterminated DOCTYPE\n" unless $line =~ /^\]>/o;
  774.     $line = $';
  775.   } else {
  776.     &SkipEndOfMark;
  777.   }
  778. }
  779.  
  780. ##################################################
  781. # <![ status [ doc-part ]]>
  782.  
  783. sub MarkSection
  784. {
  785.   local($stat, $doc, $nest);
  786.   local($deprecated) = (&SkipComment =~ /^%HTML\.Deprecated/oi);
  787.   $stat = &GetToken(0);
  788.   $stat = 'IGNORE' if $deprecated && $ignore_DEPRECATED;
  789.   die "$.: Illegal section status $stat\n" unless $stat =~ /^($sectStatus)$/o;
  790.   die "$.: Illegal section declaration $token\n" if &GetToken(0) ne '[';
  791.   $nest = 1;
  792.   while (&GetLine) {
  793.     if ($line =~ /(\[|\])/o) {
  794.       if ($1 eq '[') {
  795.         $nest++;
  796.       } elsif ($1 eq ']') {
  797.         if (!--$nest) {
  798.           $doc .= $`;
  799.           $line = $';
  800.           last;
  801.         }
  802.       }
  803.       $doc .= $`.$&;
  804.       $line = $';
  805.     } else {
  806.       $doc .= $line;
  807.       $line = '';
  808.     }
  809.   }
  810.   die "$.: Unterminated section declaration\n"
  811.     if $nest || &GetToken(0) ne ']' || &GetToken(0) ne '>';
  812.   if ($stat eq 'INCLUDE') {
  813.     # とりあえず INCLUDE だけ処理する
  814.     # しかもこれが %HTML.Deprecated ならば、特殊なマークで囲んでおく
  815.     # GetToken はこれを見て何か処理する
  816.     # ﾀ際に何かされるのは !ELEMENT のみであるから、
  817.     # !ELEMENT が直接現れないマークは処理されない
  818.     $line = ($deprecated? '{{'.$doc.'}}': $doc).$line;
  819.   }
  820.   1;
  821. }
  822.  
  823. ##################################################
  824. # <!-- ... -->
  825.  
  826. sub Comment
  827. {
  828.   local($ln) = $.;
  829.   while (&GetLine) {
  830.     if ($line =~ /----/o) {
  831.       # HTML3.0 DTD にはこのような記述があるので、とりあえず無視してみる
  832.       $line = $';
  833.       next;
  834.     }
  835.     if ($line =~ /--/o) {
  836.       $line = $';
  837.       last unless $line =~ /^>/o;
  838.       $line = $';
  839.       return 1;
  840.     }
  841.     $line = '';
  842.   }
  843.   die "$ln: Unterminated comment declaration <!--\n";
  844. }
  845.  
  846. ##################################################
  847. # <? ... ?>
  848.  
  849. sub Declaration
  850. {
  851.   local($ln) = $.;
  852.   while (&GetLine) {
  853.     if ($line =~ /\?>/o) {
  854.       $line = $';
  855.       return 1;
  856.     }
  857.     $line = '';
  858.   }
  859.   die "$ln: Unterminated declaration <?\n";
  860. }
  861.  
  862. ##################################################
  863. # マーク宣言末まで読み飛ばす。
  864.  
  865. sub SkipEndOfMark
  866. {
  867.   local($ln) = $.;
  868.   local($nest) = 0;
  869.   while (&SkipComment) {
  870.     if ($line =~ />/o) {
  871.       $line = $';
  872.       last if $nest-- == 0;
  873.     } elsif ($line =~ /</o) {
  874.       $line = $';
  875.       $nest++;
  876.     } else {
  877.       $line = '';
  878.     }
  879.   }
  880.   1;
  881. }
  882.  
  883. ##################################################
  884. # パラメータ参照を展開する。
  885.  
  886. sub ExtendRefParam
  887. {
  888.   local($param) = @_;
  889.   $param =~ /$nameStr/o; # % と ; を除く
  890.   local($name) = $&;
  891.   $param = ($paramFile{$name} or $paramEntities{$name}); # 空文字列かも知れない
  892.   die "$.: Undefined parameter entity '$param' (\%$name)\n" unless defined($param);
  893.   if ($param =~ /^($charData)$/o) {
  894.     # CDATA や NUMBER のときはﾀ体参照を残す
  895.     $parameters{$name} = $param;
  896.     $param .= '.'.$name; # 接続の '.' には注意
  897.   }
  898.   $param;
  899. }
  900.  
  901. ##################################################
  902. # 括弧で囲まれた群を読んで $token に追加する。
  903. #   &GetGroup(1) | のみの群を読む
  904. #   &GetGroup(2) フルスペックの群を読む
  905.  
  906. sub GetGroup
  907. {
  908.   local($ln) = $.;
  909.   local($connect, $repeat);
  910.   local($type) = @_; # $type = 1 or 2
  911.   if ($type == 2) {
  912.     $connect = '\||&|,';
  913.     $repeat  = '\?|\*|\+';
  914.   } else {
  915.     $connect = '\||,'; # ',' for ISO15445
  916.   }
  917.   local($token) = '(';
  918.   while (&GetLine) {
  919.     if ($line =~ /^($refParam)/o) {
  920.       local($rest) = $';
  921.       $line = &ExtendRefParam($1).' '.$rest;
  922.       next;
  923.     }
  924.     if ($line =~ /^\(/o) {
  925.       $line = $';
  926.       $token .= &GetGroup($type);
  927.     } elsif ($line =~ /^($digits|#?$nameStr)/io) {
  928.       $line = $';
  929.       $token .= $1;
  930.     } else {
  931.       die "$.: Illegal group element: $line";
  932.     }
  933.     if ($repeat && $line =~ /^($repeat)/) {
  934.       $line = $';
  935.       $token .= $1;
  936.     }
  937.     last unless &GetLine;
  938.     if ($line =~ /^\)/o) {
  939.       $token .= ')';
  940.       $line = $';
  941.       # 繰り返し指ｦ子の直前には空白がないと仮定
  942.       # これは、次に現れるかも知れない加算演算子と区別するため
  943.       if ($repeat && $line =~ /^($repeat)/) {
  944.         $line = $';
  945.         $token .= $1;
  946.       }
  947.       return $token;
  948.     }
  949.     if ($line !~ /^($connect)/) {
  950.       die "$.: Illegal grouping operator: $line";
  951.     }
  952.     $line = $';
  953.     $token .= $1;
  954.   }
  955.   die "$ln: Unterminated group\n";
  956. }
  957.  
  958. ##################################################
  959. # 文字列を読んでその中身だけを返す。
  960.  
  961. sub GetString
  962. {
  963.   local($ln) = $.;
  964.   local($quot) = @_; # $quot = " or '
  965.   local($token) = '';
  966.   while (&GetLine) {
  967.     if ($line =~ /$quot/) {
  968.       $line = $';
  969.       $token .= $`;
  970.       $token =~ s/\s/ /og;
  971.       local($str) = '';
  972.       while ($token =~ /($refParam)/o) {
  973.         # 再帰的な展開はしない
  974.         $str .= $`;
  975.         $token = &ExtendRefParam($1).$';
  976.       }
  977.       return $str.$token;
  978.     }
  979.     $token .= $line;
  980.     $line = '';
  981.   }
  982.   die "$ln: Unterminated string\n";
  983. }
  984.  
  985. ##################################################
  986. # DTD トークンを $token に得る。
  987. # $token が返る。EOF のときは空文字列。
  988. #   &GetToken(0)  (...)群を解ﾟしない
  989. #   &GetToken(1)  (..|..) のみの群を解ﾟする
  990. #   &GetToken(2)  繰り返しを含む排除以外の群を解ﾟする
  991. #   &GetToken(-1) DTDトップレベル用
  992.  
  993. sub GetToken
  994. {
  995.   local($type) = @_;
  996.   $token = '';
  997.   LINE:
  998.   while (&SkipComment) {
  999.     if ($line =~ /^{{/o) {
  1000.       $line = $';
  1001.       $deprecated++;
  1002.       next LINE;
  1003.     }
  1004.     if ($line =~ /^}}/o) {
  1005.       $line = $';
  1006.       $deprecated--;
  1007.       next LINE;
  1008.     }
  1009.     if ($type == -1) {
  1010.       if ($line =~ /^($markDcl|$refParam)/io) {
  1011.         $token = $1;
  1012.         $line = $';
  1013.       } elsif ($enterDTD == 1) {
  1014.         die "$.: Illegal line: $line";
  1015.       } else {
  1016.         $token = '';
  1017.       }
  1018.     } else {
  1019.       if ($line =~ /^($refParam)/o) {
  1020.         $line = &ExtendRefParam($1).' '.$';
  1021.         next LINE;
  1022.       }
  1023.       if ($line =~ /^($digits|#?$nameStr|\[|\]|%|\+|-|O|>)/o) {
  1024.         $line = $';
  1025.         $token = $1;
  1026.       } elsif ($line =~ /^("|')/o) {
  1027.         $line = $';
  1028.         $token = &GetString($1);
  1029.       } elsif ($type && ($line =~ /^\(/o)) {
  1030.         $line = $';
  1031.         $token = &GetGroup($type);
  1032.       } else {
  1033.         die "$.: Illegal line: $line";
  1034.       }
  1035.     }
  1036.     last;
  1037.   }
  1038.   print "$.> $token\n" if $dump_token && $token;
  1039.   $token;
  1040. }
  1041.  
  1042. ##################################################
  1043. # $token を $line に戻す。
  1044.  
  1045. sub UnGetToken
  1046. {
  1047.   $line = $token.' '.$line;
  1048. }
  1049.  
  1050. ##################################################
  1051. # コメントを読み飛ばす。$line を返す。
  1052.  
  1053. sub SkipComment
  1054. {
  1055.   LINE:
  1056.   while (&GetLine =~ /^--/o) {
  1057.     local($ln) = $.;
  1058.     $line = $';
  1059.     while (&GetLine) {
  1060.       if ($line =~ /--/o) {
  1061.         $line = $';
  1062.         next LINE;
  1063.       }
  1064.       $line = '';
  1065.     }
  1066.     die "$ln: Unterminated comment\n";
  1067.   }
  1068.   $line;
  1069. }
  1070.  
  1071. ##################################################
  1072. # 行を $line に読む。EOF なら空文字列が返る。
  1073.  
  1074. sub GetLine
  1075. {
  1076.   for (;;) {
  1077.     # 先行空白をﾌてる
  1078.     $line =~ s/^\s+//o;
  1079.     last if $line ne '';
  1080.     $line = <DTD>;
  1081.     last if $line eq '' && eof;
  1082.   }
  1083.   $line;
  1084. }
  1085.  
  1086. ##################################################
  1087. # 文字列を連結する。
  1088. # join() では空文字列も連結してしまうがこれは空文字列はﾌてる。
  1089.  
  1090. sub Join
  1091. {
  1092.   my $sep = shift;
  1093.   my $str;
  1094.   foreach (@_) {
  1095.     $str = $str? $str.$sep.$_: $_ if $_;
  1096.   }
  1097.   $str;
  1098. }
  1099.  
  1100. sub Ujoin
  1101. {
  1102.   my $str;
  1103.   foreach (@_) {
  1104.     $str = $str? $str.'|'.$_: $_ unless $_ =~ /^($str)$/;
  1105.   }
  1106.   $str;
  1107. }
  1108.  
  1109. sub Xjoin
  1110. {
  1111.   my $str;
  1112.   foreach (@_) {
  1113.     next if /^($unrefs)$/;
  1114.     $str = $str? $str.'|'.$_: $_ unless $_ =~ /^($str)$/;
  1115.   }
  1116.   $str;
  1117. }
  1118.  
  1119. ##################################################
  1120. # #NNN 形ｮの内部要素を展開する
  1121.  
  1122. sub ExpandInternalElement
  1123. {
  1124.   my $elem = shift;
  1125.   ($elem =~ /^#\d+$/o)? &ExpandInternalElements($tagsElements{$elem}): $elem;
  1126. }
  1127.  
  1128. sub ExpandInternalElements
  1129. {
  1130.   my $elem = shift;
  1131.   my $ext = '';
  1132.   while ($elem =~ /#\d+/o) {
  1133.     $elem = $';
  1134.     my $precede = $`;
  1135.     $ext .= $precede.&ExpandInternalElement($&);
  1136.   }
  1137.   $ext.$elem;
  1138. }
  1139.  
  1140. sub ExpandInternalElementsAll
  1141. {
  1142.   foreach (keys %tagsElements) {
  1143.     next if /^#/o;
  1144.     $tagsElements{$_} = &ExpandInternalElements($tagsElements{$_});
  1145.   }
  1146.   foreach (keys %tagsElements) {
  1147.     delete $tagsElements{$_} if /^#/o;
  1148.   }
  1149. }
  1150.