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