home *** CD-ROM | disk | FTP | other *** search
/ DOS/V Power Report 2000 April / VPR0004A.BIN / OLS / HTMLLINT / htmllint.lzh / htmllint.cgi < prev    next >
Text File  |  2000-01-04  |  30KB  |  975 lines
  1. #!/usr/local/bin/perl
  2.  
  3. # CGI script for Another HTML-lint gateway ###################
  4.  
  5. require 5.004;
  6.  
  7. $PROGNAME = 'Another HTML-lint';
  8.  
  9. $VERSION = '0.89';
  10.  
  11. $myADDRESS = 'k16@chiba.email.ne.jp';
  12.  
  13. $version = <<EndOfVersion;
  14.   Another HTML-lint gateway script ver$VERSION
  15.     Copyright (c) 1997-2000 by ISHINO Keiichiro <$myADDRESS>.
  16.     All rights reserved.
  17. EndOfVersion
  18.  
  19. use File::Basename;
  20. use File::Find;
  21. $CGI_NAME = &basename($0);
  22. $LINT_NAME = 'htmllint.pm';
  23.  
  24. $WIN = $^O =~ /Win32/oi;
  25. $MAC = $^O =~ /MacOS/oi;
  26. #$OS2 = UNSUPPORTED;
  27. $UNIX = !($WIN || $MAC || $OS2);
  28.  
  29. require 'htmllint.env';
  30. require $LINT_NAME;
  31.  
  32. if ($ENV{'QUERY_STRING'} eq '' && @ARGV) {
  33.   # 非 CGI インタフェース
  34.   my $arg = shift;
  35.   if ($arg eq '-vv') {
  36.     print "$CGI_NAME $VERSION / $LINT_NAME $htmllint::VERSION";
  37.   } else {
  38.     print $version;
  39.   }
  40.   exit;
  41. }
  42.  
  43. require 'common.rul';
  44. require CGI; CGI->import(qw(:cgi-lib));
  45. $CGIVer = "CGI $CGI::VERSION";
  46. if ($Jcode = (!$NOUSEJCODE && eval('require Jcode'))) {
  47.   $JcodeVer = "Jcode $Jcode::VERSION";
  48.   *Jgetcode = \&Jcode::getcode;
  49.   *Jconvert = \&Jcode::convert;
  50. } else {
  51.   require 'jcode.pl';
  52.   $JcodeVer = "jcode.pl $jcode::version";
  53.   *Jgetcode = \&jcode::getcode;
  54.   *Jconvert = sub { &jcode::to($_[1], $_[0], $_[2]); };
  55. }
  56.  
  57. $msgCantLint = '申し訳ありません。ただいま調整中です。もうしばらくしてから再チェックしてください。';
  58. $msgInURL   = '指定されたURL (';
  59. $msgNoHTML  = ') は HTML ではありません。';
  60. $msgBadResp = ') は HTTPレスポンスヘッダに問題があります。';
  61. $msgInHTML  = '指定されたHTML (';
  62. $msgCantGet = ') を取得することができませんでした。';
  63. $msgNoData  = '入力されたデータはありませんでした。';
  64. $myCODE = &Jgetcode(\$msgCantLint); # euc または sjis
  65.  
  66. &ReadParse(); # GET/POST データを %in に読む
  67. &ShortName;
  68.  
  69. # 出力する漢字コードの選択
  70. &DetectCode($in{'CharCode'} or $KANJICODE) or &DetectCode('JIS');
  71. $| = 1;
  72.  
  73. # ビジーチェック
  74. if (defined(&BusyCheck)) {
  75.   my $msg = &BusyCheck;
  76.   &ErrorExit($msg) if $msg;
  77. }
  78.  
  79. $URL = $RURL = ($in{'Method'} !~ /^Data$/oi)?
  80.                 &AbsoluteURL($ENV{'HTTP_REFERER'}, $in{'URL'}): '';
  81.  
  82. # チェックオプションを得る
  83. &GetOptions;
  84. push @OPT, '-banner', '-score', '-w', 'long';
  85. #push @OPT, '-r', $RULEDIR if $RULEDIR;
  86.  
  87. # HTML をローカルに得る
  88. $HTML = $TMPDIR.'htmllint'.$$.'.html';
  89. if ($UNIX) {
  90.   $SIG{'INT'} = $SIG{'QUIT'} = $SIG{'TERM'} = $SIG{'PIPE'} = sub {
  91.     &Unlink;
  92.     &Exit;
  93.   }
  94. }
  95. if ($URL ne '') {
  96.   if ($GETLOCALFILE) {
  97.     if ($URL =~ m#^file:///?(.*)#oi) {
  98.       ($LOCALFILE = $1) =~ s/^(\w)\|(.*)/$1:$2/o;
  99.     } elsif ($WIN && $URL =~ /^\w:/o) {
  100.       $LOCALFILE = $URL;
  101.     }
  102.   }
  103.   if (defined($LOCALFILE)) {
  104.     # ローカルファイルを取得
  105.     $HTML = $RURL = $LOCALFILE;
  106.     if ($MAC) {
  107.       $HTML =~ s#/#:#og;
  108.       $HTML = ($HTML =~ m#^:(.*)#)? $1: ':'.$HTML;
  109.     }
  110.     # %XX のデコードを行なう
  111.     $HTML =~ s/\%([0-9A-Fa-f][0-9A-Fa-f])/pack('C', hex($1))/oge;
  112.   } else {
  113.     my $host = (&ParseURL($URL))[1];
  114.     if (@EXCEPTDOMAINS) {
  115.       # 除外ドメインのチェック
  116.       my $ok = 1;
  117.       foreach (@EXCEPTDOMAINS) {
  118.         if (&CheckDomain($host, $_)) {
  119.           $ok = 0;
  120.           foreach (@PERMITDOMAINS) {
  121.             if (&CheckDomain($host, $_)) {
  122.               # 非除外
  123.               $ok = 1;
  124.               last;
  125.             }
  126.           }
  127.           last;
  128.         }
  129.       }
  130.       &ErrorExit($msgInHTML.&HrefURL($URL).$msgCantGet) unless $ok;
  131.     }
  132.     if (@EXCEPTSCORES) {
  133.       # 得点記録除外ドメインのチェック
  134.       foreach (@EXCEPTSCORES) {
  135.         if (&CheckDomain($host, $_)) {
  136.           $SCOREFILE = $STATFILE = '';
  137.           last;
  138.         }
  139.       }
  140.     }
  141.     # HTML を読み込んで改行を変換してテンポラリに書く
  142.     if (!$NOUSELWP &&
  143.         eval('require LWP::UserAgent') && eval('require HTTP::Request')) {
  144.       # original code by KUSANO Takayuki (AE5T-KSN@asahi-net.or.jp)
  145.       $URLGETVer = "LWP $LWP::VERSION";
  146.       # Create a user agent object
  147.       $LWPUA = new LWP::UserAgent;
  148.       my $uagent = "Another HTML-lint/$VERSION +".$LWPUA->agent;
  149.       $LWPUA->agent($uagent);
  150.       $LWPUA->timeout($TIMEOUT) if $TIMEOUT > 0;
  151.       $LWPUA->max_size($MAXHTMLSIZE*1024) if $MAXHTMLSIZE > 0;
  152.       $LWPUA->proxy('http', "http://$HTTP_PROXY/") if $HTTP_PROXY;
  153.       $LWPUA->no_proxy(@HTTP_NOPROXY) if @HTTP_NOPROXY;
  154.       # Create a request
  155.       my $req = new HTTP::Request GET => $URL;
  156.       # Pass request to the user agent and get a response back
  157.       my $res = $LWPUA->request($req, $HTML);
  158.       # Check the outcome of the response
  159.       if ($res->is_success()) {
  160.         $RURL = $res->request->url();
  161.         $RESULT = $res->headers_as_string();
  162.         my $warning = $res->header('Client-Warning');
  163.         if ($warning ne '') {
  164.           &Unlink;
  165.           $warning = qq|(<code>$warning</code>)|;
  166.           &ErrorExit($msgInURL.&HrefURL($URL).$msgBadResp.$warning);
  167.         }
  168.         $CTYPE = $res->header('Content-Type');
  169.         unless ($CTYPE =~ m#\btext/html\b#oi) {
  170.           &Unlink;
  171.           $CTYPE = qq|(<code>$CTYPE</code>)| if $CTYPE ne '';
  172.           &ErrorExit($msgInURL.&HrefURL($URL).$msgNoHTML.$CTYPE);
  173.         }
  174.         ($CTYPE) = $CTYPE =~ /charset\s*=\s*([^\s;,]+)/oi;
  175.         my $lang = $res->header('Content-Language');
  176.         push @OPT, '-lang', $lang if $lang ne '';
  177.       } else {
  178.         ($STAT = '<br>'.$res->status_line()) =~ s/\s*\(\@INC contains:.+//o;
  179.         &Unlink;
  180.       }
  181.       if ($CTYPE ne '') {
  182.         push @OPT, '-charset', $CTYPE;
  183.         $CTYPE = ($Jcode && lc($CTYPE) eq 'utf-8')? 'utf8': undef;
  184.       }
  185.     } elsif (eval("require 'httpreq.pl'")) {
  186.       $URLGETVer = "httpreq.pl $httpreq::VERSION";
  187.       $httpreq::http_proxy = $HTTP_PROXY if $HTTP_PROXY;
  188.       $httpreq::user_agent = "Another HTML-lint/$VERSION +$httpreq::httpreq";
  189.       $httpreq::timeout = $TIMEOUT if $TIMEOUT > 0;
  190.       $httpreq::maxsize = $MAXHTMLSIZE*1024 if $MAXHTMLSIZE > 0;
  191.       $httpreq::http_proxy = $HTTP_PROXY if $HTTP_PROXY;
  192.       @httpreq::http_noproxy = @HTTP_NOPROXY if @HTTP_NOPROXY;
  193.       ($STAT, $RURL, $RESULT) = &httpreq::get($URL, $HTML);
  194.       if ($STAT >= 200 && $STAT < 300) {
  195.         ($CTYPE) = $RESULT =~ /Content-Type:\s*([^\r\n]+)/oi;
  196.         unless ($CTYPE =~ m#\btext/html\b#oi) {
  197.           &Unlink;
  198.           &ErrorExit($msgInURL.&HrefURL($URL)."$msgNoHTML(<code>$CTYPE</code>)");
  199.         }
  200.         ($CTYPE) = $CTYPE =~ /charset\s*=\s*([^\s;,]+)/oi;
  201.         my ($lang) = $RESULT =~ /Content-Language:\s*([^\s\r\n]+)/oi;
  202.         push @OPT, '-lang', $lang if $lang ne '';
  203.       } else {
  204.         &Unlink;
  205.       }
  206.     }
  207.     push @OPT, '-nolo', '-base', $URL;
  208.   }
  209.   push @OPT, '-usec';
  210. } else {
  211.   # TEXTEREA の内容をテンポラリに書く
  212.   open(HTML, ">$HTML");
  213.   print HTML $in{'Data'};
  214.   close(HTML);
  215.   push @OPT, '-ignc';
  216. }
  217. push @OPT, '-stat', $STATFILE if $STATFILE && $in{'Stat'};
  218.  
  219. if (!(-e $HTML) || (-z $HTML)) {
  220.   # テンポラリファイルがうまくできていない
  221.   my $japURL = (&Jgetcode(\$URL) =~ /^(jis|euc|sjis)$/)?
  222.                'URLに日本語などのASCII以外の文字を使うことはできません。': '';
  223.   &Unlink;
  224.   &EscapeRef(\$STAT);
  225.   &ErrorExit(($URL ne '')? $msgInHTML.&HrefURL($URL).$msgCantGet.$japURL.$STAT:
  226.                            $msgNoData);
  227. }
  228.  
  229. $LYNX = '' if !$in{'LynxView'} || $MAC;
  230. $LYNX =~ s/^\s+//o;
  231. if (!$in{'NoCheck'} || $LYNX eq '') {
  232.   push @OPT, '--', $HTML;
  233.   # 結果用PIPEファイルを作る
  234.   my $PIPE = $TMPDIR.'htmllint'.$$.'.result';
  235.   open(PIPE, ">$PIPE");
  236.   my $oldfh = select PIPE;
  237.   # さあ行け！
  238.   &htmllint::HTMLlint(@OPT);
  239.   &DetectCode($TXTCODE) if $in{'CharCode'} eq '' || uc($in{'CharCode'}) eq 'AUTO';
  240.   select $oldfh;
  241.   # 結果を読み込む
  242.   $header = $footer = '';
  243. # close(PIPE);
  244.   open(PIPE, "<$PIPE");
  245.   while (<PIPE>) {
  246.     local $RESULT;
  247.     chomp($RESULT = $_);
  248.     &EscapeRef(\$RESULT);
  249.     if ($RESULT =~ /^\d+: /o) {
  250.       push(@line, $RESULT);
  251.     } else {
  252.       if ($header) { $footer = $RESULT; }
  253.       else         { $header = $RESULT; }
  254.     }
  255.   }
  256.   close(PIPE);
  257.   unlink($PIPE);
  258.   ($WARNS) = $footer =~ /^(\d+)/o;
  259.   ($SCORE) = $footer =~ / (-?\d+)(.*)/o;
  260.   ($KIND, $TAGS) = $2 =~ / (\d+)\D+ (\d+)/o;
  261.   ($RULE)  = $header =~ /\Qを\E (.+) \Qとして\E/o;
  262.   if ($RULE eq '' || $SCORE eq '') {
  263.     &Unlink;
  264.     &ErrorExit("$msgCantLint<br>$header");
  265.   }
  266.   $counter = $SCOREFILE? &LogScore: 0;
  267.  
  268.   # 結果の表示
  269.   ($img, $alt) = (!$WARNS && $SCORE >= 100)? ('verygood', 'たいへんよくできました'):
  270.                             ($SCORE >=  80)? ('good',     'よくできました'):
  271.                             ($SCORE >=  35)? ('normal',   'ふつうです'):
  272.                                              ('fight',    'がんばりましょう');
  273.   $img .= '.gif';
  274.   if ($in{'Image'} ne '') {
  275.     &Unlink;
  276.     if ($COUNTER && uc($in{'Image'}) eq 'SCORE') {
  277.       $SCORE = sprintf("%0$in{'md'}d", $SCORE) if $in{'md'};
  278.       $query = "lit=$SCORE";
  279.       foreach ('dd', 'tr', 'pad', 'ft', 'frgb', 'trgb', 'srgb', 'prgb',
  280.                'chcolor', 'negate', 'degrees', 'rotate') {
  281.         $query .= "&$_=$in{$_}" if $in{$_};
  282.       }
  283.       $ENV{'QUERY_STRING'} = $query;
  284. #     $ENV{'HTTP_REFERER'} = $ENV{'REMOTE_ADDR'};
  285.       $ENV{'HTTP_REFERER'} = 'http://'.$ENV{'HTTP_HOST'}.$ENV{'HTTP_URI'};
  286.       $ENV{'REQUEST_METHOD'} = 'GET';
  287.       exec $COUNTER;
  288.     } else {
  289.       $img = $IMGDIR.'ahl-'.$img;
  290.       if (open(IMG, "<$img")) {
  291.         binmode(IMG);
  292. #       $len = (stat(IMG))[7];
  293.         $len = -s IMG;
  294.         sysread(IMG, $buff, $len);
  295.         close(IMG);
  296.         print qq|Content-type: image/gif\n|,
  297.               qq|Content-length: $len\n\n|,
  298.               $buff;
  299.       }
  300.     }
  301.   } else {
  302.     &PrintHTMLHeader("Check result of $PROGNAME");
  303. #   $useimage = $ENV{'HTTP_ACCEPT'} =~ m#image/gif#o;
  304.     $useimage = 1;
  305.     &Jprint(qq|<a href="https://sw.vector.co.jp/swreg/step1.info?srno=SR011941&site=v&sid=335404740" class="image"><img src="$IMGROOT$img" alt="$alt" width="68" height="68" align="right" border="0"></a>|) if $useimage;
  306.     $footer =~ s#(\Q＼(^o^)／\E)#<code>$1</code>#o;
  307. #   print "$_ => '$in{$_}'<br>" foreach (keys(%in)); print "OPT = @OPT<br>";
  308.     print('<h2>');
  309.     &Jprint('チェックの結果は以下のとおりです。');
  310.     print("</h2>\n<p>\n");
  311.     &Jprint(&HrefURL($URL), ' を ') if $URL ne '';
  312.     &Jprint($RULE, ' としてチェックしました。', "<br>\n", ($TAGS ne '0')?
  313.             "$footer<br>\n": 'タグのひとつもないHTMLは採点できません。'."<br>\n");
  314.     if (!$Jcode && $in{'CharCode'} =~ /^UTF8$/oi) {
  315.       &Jprint("<br>\n".'このサーバではUTF-8は扱えません。');
  316.     }
  317.     if ($LYNX ne '') {
  318.       &Jprint(qq|<br>\n<a href="#LynxView">|.'Lynxでの見え方はこちら</a>にあります。');
  319.     }
  320.     print("</p>\n");
  321.     &PrintHTTPHeader;
  322.     print("<p>\n");
  323.     $nopenalty = 0;
  324.     $gray = '#666666';
  325.     $br = '';
  326.     $tar = $in{'OtherWindow'}? ' target="explain"': '';
  327.     foreach (sort { $a <=> $b } @line) {
  328.       /^(\d+): ([^:]+):\s*(.*)/o;
  329.       my $n = $1;
  330.       my $id = $2;
  331.       my $body = &PrintableCtrlCharacter($3);
  332.       $warn{$n}++;
  333.       print("<br>\n") if $br++;
  334.       print($in{'ViewSource'}? qq|<a href="#$n">line $n</a>: |: qq|line $n: |);
  335.       if ($whines{$id}) {
  336.         &Jprint($body);
  337.       } else {
  338.         print(qq|<font color="$gray">(|);
  339.         &Jprint($body);
  340.         print(q|)</font>|);
  341.         $nopenalty++;
  342.       }
  343.       $n = ${$htmllint::messages{$id}}[1];
  344.       unless (defined($n)) {
  345.         $id = $htmllint::alias_messages{$id};
  346.         $n = ${$htmllint::messages{$id}}[1];
  347.       }
  348.       &Jprint(' → '.qq|<a href="$EXPLAIN#$id"$tar>|.'解説'." $n</a>");
  349.     }
  350.     print($useimage? qq|<br clear="all">\n|: "<br>\n");
  351.     &Jprint(qq|<br><font color="$gray">|.
  352.             '(グレイ)</font> のエラーは軽度のエラーで減点対象外です。') if $nopenalty;
  353.     print("</p>\n");
  354.  
  355.     if ($in{'ViewSource'}) {
  356.       &Jprint('<hr><h2>チェックしたHTMLは以下のとおりです。'."</h2>\n");
  357.       if ($RURL ne '' || $LYNX ne '') {
  358.         print('<p>');
  359.         &Jprint(&HrefURL($RURL)) if $RURL ne '';
  360.         &Jprint(' → <a href="#LynxView">Lynxでの見え方はこちら</a>') if $LYNX ne '';
  361.         print("</p>\n");
  362.       }
  363.       print("<ol>\n");
  364.       open(HTML, $HTML);
  365.       local $/ = &DetectSeparator;
  366.       my $ln = 0;
  367.       while ($RESULT = <HTML>) {
  368.         $ln = $.;
  369.         $RESULT =~ s/\s+$//g;
  370.         &ConvertAndEscape($TXTCODE);
  371.         $RESULT =~ s/  |\t/  /og;
  372. #       ($RESULT = &PrintableCtrlCharacter($RESULT)) =~ s/  |\t/  /og;
  373.         print('<li>');
  374.         if ($warn{$ln}) {
  375.           print(qq|<code><a name="$ln"><font color="red">|, $RESULT,
  376.                  q|</font></a></code>|);
  377.         } elsif ($RESULT ne '') {
  378.           print('<code>', $RESULT, '</code>');
  379.         }
  380.         print("</li>\n");
  381.       }
  382.       $ln++;
  383.       print(qq|<li><a name="$ln"><font color="$gray">[EOF]</font></a>\n|)
  384.         if $warn{$ln};
  385.       print("</ol>\n");
  386.       close(HTML);
  387.     }
  388.  
  389.     if ($LYNX ne '') {
  390.       # Lynx も見たければ実行する
  391.       print('<hr>');
  392.       &LynxView;
  393.     } elsif ($in{'LynxView'}) {
  394.       &Jprint('<hr><h2>このサーバではLynxはサポートされていません。</h2>'."\n");
  395.     }
  396.     &Unlink;
  397.     &PrintHTMLFooter(1);
  398.   }
  399. } else {
  400.   # Lynx の表示だけ見る
  401.   &PrintHTMLHeader("Lynx View by $PROGNAME");
  402.   &LynxView;
  403.   &Unlink;
  404.   &PrintHTMLFooter(0);
  405. }
  406. &Exit;
  407.  
  408. sub PrintHTTPHeader
  409. {
  410.   if ($URL ne '' && $in{'HTTPHeader'}) {
  411.     print('<blockquote>');
  412.     if ($RESULT ne '') {
  413.       $RESULT =~ s/(\r?\n)+$//o;
  414.       &ConvertAndEscape($CTYPE);
  415.       print('<pre>', $RESULT, '</pre>');
  416.     } else {
  417.       &Jprint('このサーバの設定ではHTTPヘッダを得られません。');
  418.     }
  419.     print("</blockquote>\n");
  420.   }
  421. }
  422.  
  423. sub LynxView
  424. {
  425.   my $opt;
  426.   if ($LYNX =~ /^(\S+)\s+(.*)/o) {
  427.     $LYNX = $1;
  428.     $opt = $2;
  429.   }
  430.   $opt = '-dump -nolist' if $opt eq '';
  431.   $RESULT = `$LYNX $opt $HTML`;
  432.   &ConvertAndEscape();
  433.   $LYNXVER = `$LYNX -version`;
  434.   $LYNXVER =~ s#\n#<br>\n#og;
  435.   $LYNXVER =~ s# (http:\S+) # <a href="$1">$1</a> #og;
  436.   &Jprint('<h2><a name="LynxView">Lynxでの見え方は以下のとおりです。</a>');
  437.   print(qq|</h2>\n<div class="lynx"><pre>\n|, $RESULT, "</pre></div>\n",
  438.           q|<blockquote><hr class="none">|, $LYNXVER, "</blockquote>\n");
  439. }
  440.  
  441. sub Jprint
  442. {
  443.   foreach (@_) { print &Jconvert($_, $outCODE, $myCODE); }
  444. }
  445.  
  446. sub DetectSeparator
  447. {
  448.   my $sep = "\n";
  449.   my $buff;
  450.   read(HTML, $buff, 1024);
  451.   if ($buff !~ /\x0D\x0A/o) {
  452.     $sep = "\x0A" if $buff =~ /\x0A/o;
  453.     $sep = "\x0D" if $buff =~ /\x0D/o;
  454.   }
  455.   seek(HTML, 0, 0);
  456.   $sep;
  457. }
  458.  
  459. sub DetectCode
  460. {
  461.   my $ccode = uc(shift);
  462.   if ($ccode eq 'EUC') {
  463.     $outCODE = 'euc';
  464.     $CHARSET = 'EUC-JP';
  465.   } elsif ($ccode eq 'SJIS') {
  466.     $outCODE = 'sjis';
  467.     $CHARSET = 'Shift_JIS';
  468.   } elsif ($ccode eq 'JIS') {
  469.     $outCODE = 'jis';
  470.     $CHARSET = 'ISO-2022-JP';
  471.   } elsif ($Jcode && $ccode eq 'UTF8') {
  472.     $outCODE = 'utf8';
  473.     $CHARSET = 'UTF-8';
  474.   } else {
  475.     return 0;
  476.   }
  477.   1;
  478. }
  479.  
  480. # テンポラリファイルを消す
  481. sub Unlink
  482. {
  483.   unlink($HTML) unless defined($LOCALFILE);
  484. }
  485.  
  486. # IPを得る
  487. sub GetIP
  488. {
  489.   my $host = shift;
  490.   $host =~ s#^//##o;
  491.   my (@addr) = (gethostbyname($host))[4];
  492.   my (@ip) = unpack('C4', $addr[0]);
  493.   ((((($ip[0]<<8)+$ip[1])<<8)+$ip[2])<<8)+$ip[3];
  494. }
  495.  
  496. # ドメイン名が指定のものか調べる
  497. sub CheckDomain
  498. { # original code by HOSOKAWA Tatsumi (hosokawa@ntc.keio.ac.jp)
  499.   my ($host, $domain) = @_;
  500.   if ($domain =~ m#^(\d+\.\d+\.\d+\.\d+)(?:/(\d+))?(?:([*!])(.+))?$#) {
  501.     my $rule   = $4;
  502.     my $cond   = $3;
  503.     my $mask   = $2;
  504.     my $domip  = &GetIP($1);
  505.     my $hostip = &GetIP($host);
  506.     return 0 if $rule && $cond eq (&CheckDomain($ENV{'REMOTE_ADDR'}, $rule)? '!': '*');
  507.     if (defined($mask)) {
  508.       $mask = ~((1<<(32-$mask))-1);
  509.     } else {
  510.       $mask = ~0;
  511.       foreach (0xFFFFFFFF, 0xFFFFFF, 0xFFFF, 0xFF) {
  512.         unless ($domip & $_) {
  513.           $mask = ~$_;
  514.           last;
  515.         }
  516.       }
  517.     }
  518.     return 1 if ($hostip & $mask) == ($domip & $mask);
  519.   } else {
  520.     $domain =~ s/\./\\\./og;
  521.     if ($host =~ m#(^//|\.)$domain$#) {
  522.       # 指定ドメイン名で終わるホスト
  523.       return 1;
  524.     }
  525.   }
  526.   0;
  527. }
  528.  
  529. # URL を分解する (http のみ)
  530. sub ParseURL
  531. {
  532.   my $url = shift;
  533.   $url =~ s/^\s*//o;
  534.   my $proto = ($url =~ s@^(\w*:)@@o)?   lc($1): '';
  535.   my $host  = ($url =~ s@^(//[\w\-.]*)@@o)? $1: '';
  536.   my $port  = ($url =~ s@^(:\d*)@@o)?       $1: '';
  537.   my $path  = '';
  538.   my $file  = ($url =~ s@([^#]*)@@o)?       $1: '';
  539.   ($path, $file) = ($1, $2) if $file =~ m@^(/(?:[^/]*/)*)([^/]*)$@o;
  540.   ($proto eq ':' || $host eq '//' || $port eq ':')?
  541.     undef: ($proto, $host, $port, $path, $file);
  542. }
  543.  
  544. # URL を絶対パスにする (http のみ)
  545. sub AbsoluteURL
  546. {
  547.   my ($base, $url) = @_;
  548.   my ($bproto, $bhost, $bport, $bpath, $bfile) = &ParseURL($base);
  549.   my ($uproto, $uhost, $uport, $upath, $ufile) = &ParseURL($url);
  550.   &NormalizeURL(
  551.     (!($url ne '' && $upath eq '' && $ufile eq '') &&
  552.      (($uproto eq '' || $uproto =~ /^http/oi) && $bproto =~ /^http/oi))?
  553.         (($uproto ne '')? $uproto: $bproto).
  554.         (($uhost  ne '')? $uhost.$uport: $bhost.$bport).
  555.         (($upath  ne '')? $upath.$ufile: ($bpath.
  556.         (($ufile  ne '')? $ufile: $bfile))): $url);
  557. }
  558.  
  559. # URL 中の . を解決する
  560. sub NormalizeURL
  561. {
  562.   my @files;
  563.   my ($domain, $filespec) = ('', shift);
  564.   if ($filespec =~ m#^(\w+://(?:[^/]+))(.*)$#o) {
  565.     ($domain, $filespec) = ($1, $2);
  566.   }
  567.   foreach (split(m#/+#, $filespec, -1)) {
  568.     next if $_ eq '.';
  569.     if ($_ eq '..' && @files) {
  570.       my $parent = pop(@files);
  571.       next if $parent ne '' && $parent ne $_;
  572.       push(@files, $parent);
  573.     }
  574.     push(@files, $_);
  575.   }
  576.   $domain.join('/', @files);
  577. }
  578.  
  579. # URL へのリンク参照を求める
  580. sub HrefURL
  581. {
  582.   my $url = shift;
  583.   &EscapeRef(\$url);
  584.   $url =~ m#^\w+://#o? qq|<a href="$url">$url</a>|: $url;
  585. }
  586.  
  587. # URL が存在するか調べステータスを返す (http のみ)
  588. # 戻り値は (stat, url, content-type, content-length) の配列
  589. sub AskHTML
  590. {
  591.   my $stat = 200;
  592.   my ($rurl, $type, $length, $header);
  593.   my $TIMEOUT = $in{'TimeOut'}+0;
  594.   if ($TIMEOUT > 0.0) {
  595.     $TIMEOUT = 60 if $TIMEOUT > 60.0;
  596.     my $url = &AbsoluteURL;
  597.     if ($LWPUA) {
  598.       $LWPUA->timeout($TIMEOUT);
  599.       my $req = new HTTP::Request HEAD => $url;
  600.       my $res = $LWPUA->request($req);
  601.       $stat = $res->code();
  602.       if ($in{'CheckGET'} && $stat >= 400) {
  603.         $req = new HTTP::Request GET => $url;
  604.         $res = $LWPUA->request($req);
  605.         $stat = $res->code();
  606.       }
  607.       $rurl   = $res->request->url();
  608.       $type   = $res->header('Content-Type');
  609.       $length = $res->header('Content-Length');
  610.     } else {
  611.       $httpreq::timeout = $TIMEOUT;
  612.       ($stat, $rurl, $header) = &httpreq::head($url);
  613.       if ($in{'CheckGET'} && $stat >= 400) {
  614.         ($stat, $rurl, $header) = &httpreq::get($url);
  615.       }
  616.       ($header =~ /(?:^|\n)Content-Type:\s*(.+)\n/omi)   and $type   = $1;
  617.       ($header =~ /(?:^|\n)Content-Length:\s*(.+)\n/omi) and $length = $1;
  618.     }
  619.   }
  620.   [$stat, $rurl, $type, $length];
  621. }
  622.  
  623. # コード変換して実体参照にエスケープする
  624. sub ConvertAndEscape
  625. {
  626.   $icode = shift;
  627.   if ($outCODE eq 'jis') {
  628.     &Jconvert(\$RESULT, $myCODE, $icode);
  629.     &EscapeRef(\$RESULT);
  630.     &Jconvert(\$RESULT, $outCODE, $myCODE);
  631.   } else {
  632.     &Jconvert(\$RESULT, $outCODE, $icode);
  633.     &EscapeRef(\$RESULT);
  634.   }
  635. }
  636.  
  637. # 実体参照にエスケープする
  638. sub EscapeRef
  639. {
  640.   $str = shift;
  641.   $$str =~ s/&/&/og;
  642.   $$str =~ s/</</og;
  643.   $$str =~ s/>/>/og;
  644.   $$str =~ s/"/"/og;
  645. }
  646.  
  647. # 制御文字を印字可能に変換する
  648. sub PrintableCtrlCharacter
  649. {
  650.   my $str = shift;
  651.   $str =~ s#([\x00-\x08\x0B\x0C\x0E-\x1F])#'<i>^'.pack('C',unpack('C',$1)+0x40).'</i>'#eog;
  652.   $str;
  653. }
  654.  
  655. # エラー出力して終了する
  656. sub ErrorExit
  657. {
  658.   my (@msgs) = @_;
  659.   &PrintHTMLHeader("$PROGNAME error!");
  660.   &Jprint(qq|<h2>$PROGNAME error!</h2>\n|);
  661.   while (@msgs) {
  662.     print('<p>');
  663.     &Jprint(shift(@msgs));
  664.     print("</p>\n");
  665.   }
  666.   &PrintHTTPHeader if $RESULT ne '';
  667.   &PrintHTMLFooter(0);
  668.   &Exit;
  669. }
  670.  
  671. sub Exit
  672. {
  673.   # 消されていないテンポラリの始末をする
  674.   $File::Find::prune = 1;
  675.   &find(\&CleanupTmp, $TMPDIR? $TMPDIR: '.');
  676.   exit;
  677. }
  678.  
  679. sub CleanupTmp
  680. {
  681.   if (!-d && /^htmllint-?\d+\.(html|result)$/o && (stat($_))[9] < time-24*60*60) {
  682.     # 24時間以前のファイルを消す
  683.     unlink($_);
  684.   }
  685. }
  686.  
  687. # HTML ヘッダ部分を出力する (PrintHeaderという関数は cgi-lib に既存)
  688. sub PrintHTMLHeader {
  689.   my ($title) = @_;
  690.   print(qq|Content-Type: text/html; charset=$CHARSET\x0D\x0A\x0D\x0A|,
  691.         <<EndOfHTMLHeader);
  692. <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
  693. <html lang="ja"><head>
  694. <meta http-equiv="Content-Type" content="text/html; charset=$CHARSET">
  695. <link rev="made" href="mailto:$myADDRESS">
  696. <link rel="stylesheet" type="text/css" href="${HTMLDIR}htmllint.css">
  697. <link rel="contents" href="./index.html">
  698. <title>$title</title>
  699. </head>
  700. <body bgcolor="#FFFFF0" text="#000000" link="#0000FF" vlink="#663399" alink="#FF0000">
  701. <div align="center">
  702. [<a href="./index.html">about</a>]
  703. [<a href="./sitemap.html">sitemap</a>]
  704. [<a href="./htmllint.html">gateway</a>]
  705. [<a href="./htmllintl.html">lite</a>]
  706. [<a href="./htmllinte.html">dyn</a>]
  707. </div><hr>
  708. EndOfHTMLHeader
  709. }
  710.  
  711. # HTML フッタ部分を出力する
  712. sub PrintHTMLFooter
  713. {
  714.   my $cntstr;
  715.   if (shift) {
  716.     $cntstr = ($counter? "-- #$counter": '').' -- cost '.(time - $^T).' sec';
  717.     $cntstr .= " -- $LINTER run" if $LINTER > 1;
  718.     $cntstr .= ' --<br>';
  719.   }
  720.   $JcodeVer .= ' NoXS' if $Jcode && defined($Jcode::Unicode::NoXS::VERSION);
  721.   print(<<EndOfHTMLFooter);
  722. <hr><div align="center">
  723. <address>${cntstr}This page was generated by $CGI_NAME $VERSION / $LINT_NAME $htmllint::VERSION<br>
  724. $URLGETVer / $CGIVer / $JcodeVer<br>
  725. 1997-2000 (c) by <a href="mailto:k16\@chiba.email.ne.jp">k16\@chiba.email.ne.jp</a> / PostPet: k16pet\@kinchan.com</address></div>
  726. <hr><div align=center>
  727. [<a href="./index.html">about</a>]
  728. [<a href="./sitemap.html">sitemap</a>]
  729. [<a href="./htmllint.html">gateway</a>]
  730. [<a href="./htmllintl.html">lite</a>]
  731. [<a href="./htmllinte.html">dyn</a>]
  732. </div>
  733. </body>
  734. </html>
  735. EndOfHTMLFooter
  736. }
  737.  
  738. # 得点の記録
  739. sub LogScore
  740. {
  741.   my $rule = $RULE;
  742.   foreach (keys(%doctypes)) {
  743.     if (${$doctypes{$_}}{'guide'} eq $rule) {
  744.       $rule = $_;
  745.       last;
  746.     }
  747.   }
  748.   my $cnt = 0;
  749.   my $file = $SCOREFILE;
  750.   my $url = $URL;
  751.   $url =~ s/ /%20/og;
  752.   $url = '<TEXTAREA>' if $url eq '';
  753.   my ($sec, $min, $hour, $mday, $mon, $year) = localtime(time);
  754.   my $post = sprintf('%04d%02d', 1900+$year, 1+$mon);
  755.   $file =~ s/#/$post/g;
  756.   my $existfile = -e $file;
  757.   if (open(LOGF, ($existfile? '>>': '>').$file)) {
  758.     flock(LOGF, 2) if $UNIX;
  759.     if ($SCORECOUNTER) {
  760.       open(CNTF, $SCORECOUNTER);
  761.       $cnt = <CNTF>+1;
  762.       if (open(CNTF, ">$SCORECOUNTER")) {
  763.         print CNTF "$cnt\n";
  764.       }
  765.       close(CNTF);
  766.       chmod 0766, $SCORECOUNTER;
  767.     }
  768.     $WARNS = 0 unless $WARNS;
  769.     my $rhost = ($ENV{'REMOTE_HOST'} or $ENV{'REMOTE_ADDR'});
  770.     print LOGF sprintf('%04d/%02d/%02d %02d:%02d:%02d',
  771.                        1900+$year, 1+$mon, $mday, $hour, $min, $sec),
  772.                " $rhost $url ",
  773.                ($TAGS ne '0')? "$SCORE/$WARNS/$TAGS/$KIND": "//$TAGS/$KIND",
  774.                " $rule\n";
  775. #   flock(LOGF, 8) if $UNIX;
  776.     close(LOGF);
  777.     chmod 0766, $file;
  778.   }
  779.   $cnt;
  780. }
  781.  
  782. # 警告情報を収集する (htmllint.pm が呼ぶ)
  783. sub PushStat
  784. {
  785.   my $name = shift;
  786.   push(@{'stat'.$name}, shift);
  787. }
  788.  
  789. # 警告の統計を取る (htmllint.pm が呼ぶ)
  790. sub TakeStatistics
  791. {
  792.   my $stat = shift;
  793.   if ($stat ne '') {
  794.     local ($statstart, $statsample, $seensample, *STAT);
  795.     my @lt = localtime;
  796.     my $suffix = sprintf('%04d%02d', $lt[5]+1900, $lt[4]+1);
  797.     $stat =~ s/#/$suffix/g;
  798.     if ($stat ne $stdio) {
  799.       if (-e $stat) {
  800.         open(STAT, "+<$stat") || return;
  801.         flock(STAT, 2) if $UNIX;
  802.         # 排他制御が起こったときSTATの内容は古いのでもう一度オープンし直す
  803.         open(STAT, "+<$stat") || return;
  804.         flock(STAT, 2) if $UNIX;
  805.         local $err = 0;
  806.         local $SIG{__WARN__} = sub { $err++; }; # 次の do のエラーをトラップ
  807.         do $stat;
  808.         if (!defined($statstart) && !$err) {
  809.           # 何らかの理由で読み込みに失敗した ($stat が破損しているときは修復する)
  810. #         flock(STAT, 8) if $UNIX;
  811.           close(STAT);
  812.           return;
  813.         }
  814.         seek(STAT, 0, 0);
  815.       } else {
  816.         open(STAT, ">$stat") || return;
  817.         flock(STAT, 2) if $UNIX;
  818.       }
  819.     } else {
  820.       *STAT = *STDOUT;
  821.     }
  822.     foreach (keys(%whinesStat)) { $statistics{$_} += $whinesStat{$_}; }
  823.     undef %whinesStat;
  824.     foreach (keys(%seenTagsStat)) { $statSeenTags{$_} += $seenTagsStat{$_}; }
  825.     undef %seenTagsStat;
  826.     foreach (keys(%seenTagsKind)) { $statKindTags{$_} += $seenTagsKind{$_}; }
  827.     undef %seenTagsKind;
  828.     foreach (keys(%seenMultiBody)) { $statMultiBody{$_} += $seenMultiBody{$_}; }
  829.     undef %seenMultiBody;
  830.     $statcurrent = sprintf('%4d/%02d/%02d %02d:%02d:%02d',
  831.                            $lt[5]+1900, $lt[4]+1, $lt[3], $lt[2], $lt[1], $lt[0]);
  832.     $statstart = $statcurrent unless defined($statstart);
  833.     print STAT '$statstart   = \'', $statstart,   "';\n",
  834.                '$statcurrent = \'', $statcurrent, "';\n",
  835.                '$statsample = ',  ++$statsample,   ";\n",
  836.                '$seensample = ',  ++$seensample,   ";\n";
  837.     &PrintStatArray('statistics',
  838.                     'statUnknownDoctype',
  839.                     'statOnceOnly',
  840.                     'statOnceOnlyGroup',
  841.                     'statUnclosedElement',
  842.                     'statExcludedElement',
  843.                     'statOmitEndTag',
  844.                     'statDeprecatedElement',
  845.                     'statDeprecatedTag',
  846.                     'statDeprecatedAttr',
  847.                     'statElementOverlap',
  848.                     'statMustFollow',
  849.                     'statEmptyContainer',
  850.                     'statIllegalClosing',
  851.                     'statRequired',
  852.                     'statRequiredAttr',
  853.                     'statRequiredValue',
  854.                     'statUnknownElement',
  855.                     'statUnknownAttribute',
  856.                     'statUnexpectedPCDATA',
  857.                     'statOmitAttributeName',
  858.                     'statMinimizedAttribute',
  859.                     'statHereAnchor',
  860.                     'statNoRegCharset',
  861.                     'statNoTextHtml',
  862.                     'statUnknownProtocol',
  863.                     'statIllegalFormatURL',
  864.                     'statBadJISX0208',
  865.                     'statExcludedURLRef',
  866.                     'statSeenTags',
  867.                     'statKindTags',
  868.                     'statMultiBody');
  869.     if ($stat ne $stdio) {
  870.       truncate(STAT, tell(STAT));
  871. #     flock(STAT, 8) if $UNIX;
  872.       close(STAT);
  873.       chmod 0766, $stat;
  874.     }
  875.   }
  876. }
  877.  
  878. sub PrintStatArray
  879. {
  880.   foreach $name (@_) {
  881.     my $esc;
  882.     if ($name ne 'statistics') {
  883.       foreach (@$name) { $$name{$_}++; }
  884.       undef @$name;
  885.     }
  886.     if (%$name) {
  887.       print STAT "\%$name = (\n";
  888.       foreach (sort {$$name{$b} <=> $$name{$a} || $a cmp $b} keys(%$name)) {
  889.         $esc = $_;
  890.         $esc =~ s/[\x00-\x1F]/ /og; # 暫定
  891.         $esc =~ s/\\/\\\\/og;
  892.         $esc =~ s/'/\\'/og;
  893. #       $esc =~ s/\n//o;
  894.         print STAT "  '$esc' => $$name{$_},\n";
  895.       }
  896.       print STAT ");\n";
  897.     }
  898.     undef %$name;
  899.   }
  900. }
  901.  
  902. # 短縮問い合わせデータの調整
  903. sub ShortName
  904. {
  905.   foreach (split(/[&;]/, $in{'keywords'})) { $in{$_} = 'on'; }
  906.   foreach (keys(%in)) { $in{$_} = 'on' if $in{$_} eq ''; }
  907.   my %shortNames = (
  908.     Method          => 'M',
  909. #   URL             => '',
  910. #   Data            => '',
  911.     CharCode        => 'C',
  912.     NoWarnings      => 'N',
  913.     ViewSource      => 'V',
  914.     LynxView        => 'L',
  915. #   HTTPHead        => '',
  916.     OtherWindow     => 'O',
  917. #   NoCheck         => '',
  918.     IgnoreDOCTYPE   => 'I',
  919.     HTMLVersion     => 'H',
  920.     Pedantic        => 'P',
  921.     NoReligious     => 'R',
  922.     NoAccessibility => 'A',
  923.     TimeOut         => 'T',
  924. #   CheckGET        => '';
  925. #   CheckList       => '',
  926.     Enable          => 'E',
  927.     Disable         => 'D',
  928. #   LimitWhines     => '',
  929.   );
  930.   foreach (keys(%shortNames)) { $in{$_} = $in{$shortNames{$_}} if !defined($in{$_}); }
  931. }
  932.  
  933. # チェックオプションを得る
  934. sub GetOptions
  935. {
  936.   my $x = 'html20';
  937.   foreach (keys(%doctypes)) {
  938.     if ($in{'HTMLVersion'} =~ /^(${$doctypes{$_}}{'name'})$/i) {
  939.       $x = $_;
  940.       last;
  941.     }
  942.   }
  943.   push @OPT, '-x', $x,
  944.              $in{'IgnoreDOCTYPE'}?   '-ignd':  '-used',
  945.              $in{'NoWarnings'}?      '-nowar': '-war',
  946.              $in{'NoReligious'}?     '-norel': '-rel',
  947.              $in{'NoAccessibility'}? '-noacc': '-acc';
  948.   push @OPT, '-limit', $in{'LimitWhines'} if $in{'LimitWhines'} > 0;
  949.   my (@warnings, @enable, @disable);
  950.   &htmllint::ListWarnings(\@warnings);
  951.   foreach (@warnings) {
  952.     if (/^(\S+)\s+(\S+)\s+(ENABLED|DISABLED)\s+(\S+)(?:\s+(\S+)\s+(\S+))?/) {
  953.       my ($id, $sh, $ed, $n, $swa, $wna) = ($1, $2, $3, $4, $5, $6);
  954.       $whines{$id}  = $n;
  955.       $whines{$swa} = $wna if $swa;
  956.       next if $id eq 'over-limit-whines';
  957.       $sh = $id if $sh eq '-';
  958.       if ($in{$id}) { push(@enable,  $sh) if $ed =~ /^D/o; }
  959.       else          { push(@disable, $sh) if $ed =~ /^E/o; }
  960.     }
  961.   }
  962.   if ($in{'Pedantic'}) {
  963.     push @OPT, '-ped';
  964.   } else {
  965.     push @OPT, '-noped';
  966.     if ($in{'CheckList'}) {
  967.       push @OPT, '-e', join(',', @enable)  if @enable;
  968.       push @OPT, '-d', join(',', @disable) if @disable;
  969.     } else {
  970.       push @OPT, '-e', $in{'Enable'}  if $in{'Enable'}  ne '';
  971.       push @OPT, '-d', $in{'Disable'} if $in{'Disable'} ne '';
  972.     }
  973.   }
  974. }
  975.