#!/usr/bin/perl
# CGI script for Another HTML-lint gateway
require 5.004;
$VERSION = '1.12';
$PROGNAME = 'Another HTML-lint';
=ignore
use strict;
use vars qw($VERSION $PROGNAME);
use vars qw($RULEDIR $LOGSDIR $TMPDIR $IMGDIR $TAGSLIST $HTMLDIR $GATEWAYURL $EXPLAIN $CGIROOT $IMGROOT $HTMLLINTRC $HTMLEXT $INDEXHTML @EXCEPTDOMAINS @PERMITDOMAINS $PERMITPRIVATEIP $NOUSELWP $NOUSEJCODE $MAXHTMLSIZE $TIMEOUT $HTTP_PROXY @HTTP_NOPROXY $GETLOCALFILE $KANJICODE $LYNX $W3M $SCOREFILE $SCORECOUNTER $STATFILE @EXCEPTSCORES $COUNTER $NOCOMMERCIAL $AUTOSCORE);
use vars qw($HTML $LOCALFILE $URL $RURL @OPT $RESULT $TXTCODE $STYLE $SCRIPT $RULE $FILE $PIPE $WARNS $SCORE $KIND $TAGS $STAT $LANG $outCODE $CHARSET $CTYPE $TextView $LWPUA $URLGETVer);
use vars qw(%in $stdio %doctypes $defaultrule %whines $icode $counter $err %warn %whinesStat %seenTagsStat %seenTagsKind %seenMultiBody %statistics %statSeenTags %statKindTags %statMultiBody $statstart $statsample $seensample);
=cut

my $myADDRESS = 'k16@chiba.email.ne.jp';
my $version = <<EndOfVersion;
  Another HTML-lint gateway script ver$VERSION
    Copyright (c) 1997-2003 by ISHINO Keiichiro <$myADDRESS>.
    All rights reserved.
EndOfVersion

use File::Basename;
use File::Find;
my $CGI_NAME = &basename($0);
my $LINT_NAME = 'htmllint.pm';

my $WIN = $^O =~ /Win32/oi;
my $MAC = $^O =~ /MacOS/oi;
my $OS2; #UNSUPPORTED;
my $UNIX = !($WIN || $MAC || $OS2);

require 'htmllint.env';
require $LINT_NAME;

if ($ENV{QUERY_STRING} eq '' && @ARGV) {
  # No CGI
  my $arg = shift;
  if ($arg eq '-vv') {
    print "$CGI_NAME $VERSION / $LINT_NAME $htmllint::VERSION";
  } else {
    print $version;
  }
  exit;
}

require 'common.rul';
use CGI;
$CGI::POST_MAX = $MAXHTMLSIZE*1024 if $MAXHTMLSIZE > 0;
my $CGIVer = "CGI $CGI::VERSION";
my $cgi = new CGI;
my ($Jcode, $JcodeVer);
if ($Jcode = (!$NOUSEJCODE && eval('require Jcode'))) {
  $JcodeVer = "Jcode $Jcode::VERSION";
  *Jgetcode = \&Jcode::getcode;
  *Jconvert = \&Jcode::convert;
} else {
  require 'jcode.pl';
  $JcodeVer = "jcode.pl $jcode::version";
  *Jgetcode = \&jcode::getcode;
  *Jconvert = sub { &jcode::to($_[1], $_[0], $_[2]); };
}

my $acceptMIME = '(?:text\/html|application\/xhtml\+xml)';
my $msgCantLint = '申し訳ありません。ただいま調整中です。もうしばらくしてから再チェックしてください。';
my $msgInURL   = '指定されたURL (';
my $msgNoHTML  = ') は HTML ではありません。';
my $msgBadResp = ') は HTTPレスポンスヘッダに問題があります。';
my $msgInHTML  = '指定されたHTML (';
my $msgInFile  = '指定されたファイル (';
my $msgCantGet = ') を取得することができませんでした。';
my $msgNoData  = '入力されたデータはありませんでした。';
my $msgNoFile  = 'ファイル名が指定されていません。';
my $msgCannotMkdir = ' を作成できませんでした。';
my $myCODE = &Jgetcode(\$msgCantLint); # euc または sjis
my $bannerCommercial = $NOCOMMERCIAL? '': '';
&ShortName;

# 出力する漢字コードの選択
&DetectCode($cgi->param('CharCode') or $KANJICODE) or &DetectCode('JIS');
$| = 1;

# ビジーチェック
if (defined(&BusyCheck)) {
  my $msg = &BusyCheck;
  &ErrorExit($msg) if $msg;
}

$URL = $RURL = ($cgi->param('Method') =~ /^(?:Data|File)$/oi)? '':
                &htmllint::AbsoluteURL($ENV{HTTP_REFERER}, $cgi->param('URL'));

# チェックオプションを得る
&GetOptions;
push @OPT, '-banner', '-score', '-w', 'long';
#push @OPT, '-r', $RULEDIR if $RULEDIR;

unless (-e $TMPDIR || mkdir $TMPDIR, 0777) {
  &ErrorExit($TMPDIR.$msgCannotMkdir);
}
if ($LOGSDIR ne '') {
  unless (-e $LOGSDIR || mkdir $LOGSDIR, 0777) {
    &ErrorExit($LOGSDIR.$msgCannotMkdir);
  }
} else {
  $SCOREFILE = $SCORECOUNTER = $STATFILE = '';
}

# HTML をローカルに得る
$HTML = $TMPDIR.'htmllint'.$$.'.html';
if ($UNIX) {
  $SIG{'INT'} = $SIG{'QUIT'} = $SIG{'TERM'} = $SIG{'PIPE'} = sub {
    &Unlink;
    &Exit;
  }
}
if ($URL ne '') {
  if ($GETLOCALFILE) {
    if ($URL =~ m#^file:///?(.*)#oi) {
      ($LOCALFILE = $1) =~ s/^(\w)\|(.*)/$1:$2/o;
    } elsif ($WIN && $URL =~ /^\w:/o) {
      $LOCALFILE = $URL;
    }
  }
  if (defined($LOCALFILE)) {
    # ローカルファイルを取得
    $HTML = $RURL = $LOCALFILE;
    if ($MAC) {
      $HTML =~ s#/#:#og;
      $HTML = ($HTML =~ m#^:(.*)#)? $1: ':'.$HTML;
    }
    # %XX のデコードを行なう
    $HTML =~ s/\%([0-9A-Fa-f][0-9A-Fa-f])/pack('C', hex($1))/oge;
  } else {
    my $host = (&htmllint::ParseURL($URL))[1];
    $host = $1 if $host =~ /\@(.+)$/;
    unless ($PERMITPRIVATEIP) {
      # Private IP か調べる
      &ErrorExit($msgInHTML.&HrefURL($URL).$msgCantGet) if !CheckPrivateIP($ENV{REMOTE_ADDR}) && CheckPrivateIP($host);
    }
    if (@EXCEPTDOMAINS) {
      # 除外ドメインのチェック
      my $ok = 1;
      foreach (@EXCEPTDOMAINS) {
        if (&CheckDomain($host, $_)) {
          $ok = 0;
          foreach (@PERMITDOMAINS) {
            if (&CheckDomain($host, $_)) {
              # 非除外
              $ok = 1;
              last;
            }
          }
          last;
        }
      }
      &ErrorExit($msgInHTML.&HrefURL($URL).$msgCantGet) unless $ok;
    }
    if (@EXCEPTSCORES) {
      # 得点記録除外ドメインのチェック
      foreach (@EXCEPTSCORES) {
        if (&CheckDomain($host, $_)) {
          $SCOREFILE = $STATFILE = '';
          last;
        }
      }
    }
    # HTML を読み込んで改行を変換してテンポラリに書く
    if (!$NOUSELWP &&
        eval('require LWP::UserAgent') && eval('require HTTP::Request')) {
      $URLGETVer = "LWP $LWP::VERSION";
      $LWPUA = new LWP::UserAgent;
      my $uagent = "Another_HTML-lint/$VERSION +".$LWPUA->agent;
      $LWPUA->agent($uagent);
      $LWPUA->timeout($TIMEOUT) if $TIMEOUT > 0;
      $LWPUA->max_size($MAXHTMLSIZE*1024) if $MAXHTMLSIZE > 0;
      $LWPUA->proxy('http', "http://$HTTP_PROXY/") if $HTTP_PROXY;
      $LWPUA->no_proxy(@HTTP_NOPROXY) if @HTTP_NOPROXY;
      $LWPUA->parse_head(0);
      my $req = new HTTP::Request GET => $URL;
      $req->header('Accept' => 'text/html, */*');
      if ($host =~ m#^//(.+)#o) { $req->header('Host' => $1); }
      my $res = $LWPUA->request($req, $HTML);
      if ($res->is_success()) {
        $RURL = $res->request->url();
        $RESULT = $res->headers_as_string();
        my $warning = $res->header('Client-Warning');
        if ($warning ne '') {
          &Unlink;
          $warning = qq|(<code>$warning</code>)|;
          &ErrorExit($msgInURL.&HrefURL($URL).$msgBadResp.$warning);
        }
        $CTYPE = $res->header('Content-Type');
        unless ($CTYPE =~ m#\b$acceptMIME\b#oi) {
          &Unlink;
          $CTYPE = qq|(<code>$CTYPE</code>)| if $CTYPE ne '';
          &ErrorExit($msgInURL.&HrefURL($URL).$msgNoHTML.$CTYPE);
        }
        ($CTYPE) = $CTYPE =~ /charset\s*=\s*([^\s;,]+)/oi;
        $LANG = $res->header('Content-Language');
        $STYLE = $res->header('Content-Style-Type');
        $SCRIPT = $res->header('Content-Script-Type');
      } else {
        ($STAT = "\n".$res->status_line()) =~ s/\s*\(\@INC contains:.+//o;
        &Unlink;
      }
    } elsif (eval("require 'httpreq.pl'")) {
      $URLGETVer = "httpreq.pl $httpreq::VERSION";
      $httpreq::http_proxy = $HTTP_PROXY if $HTTP_PROXY;
      $httpreq::user_agent = "Another_HTML-lint/$VERSION +$httpreq::httpreq";
      $httpreq::timeout = $TIMEOUT if $TIMEOUT > 0;
      $httpreq::maxsize = $MAXHTMLSIZE*1024 if $MAXHTMLSIZE > 0;
      $httpreq::http_proxy = $HTTP_PROXY if $HTTP_PROXY;
      @httpreq::http_noproxy = @HTTP_NOPROXY if @HTTP_NOPROXY;
      ($STAT, $RURL, $RESULT) = &httpreq::get($URL, $HTML);
      if ($STAT >= 200 && $STAT < 300) {
        ($CTYPE) = $RESULT =~ /Content-Type:\s*([^\r\n]+)/oi;
        unless ($CTYPE =~ m#\b$acceptMIME\b#oi) {
          &Unlink;
          &ErrorExit($msgInURL.&HrefURL($URL)."$msgNoHTML(<code>$CTYPE</code>)");
        }
        ($CTYPE) = $CTYPE =~ /charset\s*=\s*([^\s;,]+)/oi;
        ($LANG) = $RESULT =~ /Content-Language:\s*([^\s\r\n]+)/oi;
        ($STYLE) = $RESULT =~ /Content-Style-Type:\s*([^\s\r\n]+)/oi;
        ($SCRIPT) = $RESULT =~ /Content-Script-Type:\s*([^\s\r\n]+)/oi;
      } else {
        &Unlink;
      }
    }
    if ($CTYPE ne '') {
      push @OPT, '-charset', $CTYPE;
      $CTYPE = ($Jcode && lc($CTYPE) eq 'utf-8')? 'utf8': undef;
    }
    push @OPT, '-lang', $LANG if $LANG ne '';
    push @OPT, '-style', $STYLE if $STYLE ne '';
    push @OPT, '-script', $SCRIPT if $SCRIPT ne '';
    push @OPT, '-nolo', '-base', $URL;
  }
  push @OPT, '-usec';
} else {
  if ($cgi->param('Method') =~ /^File$/oi) {
    # ファイルアップロード
    $FILE = $cgi->param('File');
    if ($FILE eq '') { &ErrorExit($msgNoFile); }
    $HTML = $cgi->tmpFileName($FILE);
    push @OPT, '-usec';
  } else {
    # TEXTEREA の内容をテンポラリに書く
    open(HTML, ">$HTML");
    print HTML $cgi->param('Data');
    close(HTML);
    push @OPT, '-ignc';
  }
}
push @OPT, '-stat', $STATFILE if $STATFILE && $cgi->param('Stat');

if (!(-e $HTML) || (-z $HTML)) {
  # テンポラリファイルがうまくできていない
  my $japURL = (&Jgetcode(\$URL) =~ /^(jis|euc|sjis)$/)? 'URLに日本語などのASCII以外の文字を使うことはできません。': '';
  &Unlink;
  &EscapeRef(\$STAT);
  &EscapeRef(\$FILE);
  &ErrorExit(($URL ne '')?  $msgInHTML.&HrefURL($URL).$msgCantGet.$japURL.$STAT:
             ($FILE ne '')? $msgInFile.$FILE.$msgCantGet: $msgNoData);
}

$TextView = lc($cgi->param('LynxView')? 'lynx': $cgi->param('TextView'));
$TextView = '' if $TextView ne 'lynx' && $TextView ne 'w3m';
if ($TextView ne 'lynx' || $MAC) { $LYNX = ''; } else { $LYNX =~ s/^\s+//o; }
if ($TextView ne 'w3m'  || $MAC) { $W3M  = ''; } else { $W3M  =~ s/^\s+//o; }
if (!$cgi->param('NoCheck') || ($LYNX eq '' && $W3M eq '')) {
  push @OPT, '--', $HTML;
  # 結果用PIPEファイルを作る
  $PIPE = $TMPDIR.'htmllint'.$$.'.result';
  open(PIPE, ">$PIPE");
  my $oldfh = select PIPE;
  # さあ行け！
  &htmllint::HTMLlint(@OPT);
  &DetectCode($TXTCODE)
    if $cgi->param('CharCode') eq '' || uc($cgi->param('CharCode')) eq 'AUTO';
  select $oldfh;
  # 結果を読み込む
  my $header;
  my $footer;
# close(PIPE);
  open(PIPE, "<$PIPE");
  my @line;
  while (<PIPE>) {
    local $RESULT;
    chomp($RESULT = $_);
    &EscapeRef(\$RESULT);
    if ($RESULT =~ /^\d+: /o) {
      push(@line, $RESULT);
    } else {
      if ($header) { $footer = $RESULT; } else { $header = $RESULT; }
    }
  }
  close(PIPE);
  unlink($PIPE);
  ($WARNS) = $footer =~ /^(\d+)/o;
  ($SCORE) = $footer =~ / (-?\d+)(.*)/o;
  ($KIND, $TAGS) = $2 =~ / (\d+)\D+ (\d+)/o;
  ($RULE)  = $header =~ /\Qを\E (.+) \Qとして\E/o;
  if ($RULE eq '' || $SCORE eq '') {
    &Unlink;
    &ErrorExit("$msgCantLint<br>$header");
  }
  $counter = $SCOREFILE? &LogScore: 0;
  # 結果の表示
  my ($img, $alt) = (!$WARNS && $SCORE >= 100)? ('verygood', 'たいへんよくできました'):
                               ($SCORE >=  80)? ('good',     'よくできました'):
                               ($SCORE >=  35)? ('normal',   'ふつうです'):
                                                ('fight',    'がんばりましょう');
  $img .= '.gif';
  if ($cgi->param('Image') ne '') {
    &Unlink;
    if ($AUTOSCORE) {
      if ($COUNTER && uc($cgi->param('Image')) eq 'SCORE') {
        $SCORE = sprintf("%0$in{'md'}d", $SCORE) if $cgi->param('md');
        my $query = "lit=$SCORE";
        foreach ('dd', 'tr', 'pad', 'ft', 'frgb', 'trgb', 'srgb', 'prgb', 'chcolor', 'negate', 'degrees', 'rotate') {
          $query .= "&$_=".$cgi->param($_) if $cgi->param($_);
        }
        $ENV{QUERY_STRING} = $query;
#       $ENV{HTTP_REFERER} = $ENV{REMOTE_ADDR};
        $ENV{HTTP_REFERER} = 'http://'.$ENV{HTTP_HOST}.$ENV{HTTP_URI};
        $ENV{REQUEST_METHOD} = 'GET';
        exec $COUNTER;
      } else {
        $img = $IMGDIR.'ahl-'.$img;
        if (open(IMG, "<$img")) {
          binmode(IMG);
          my $len = -s IMG;
          my $buff;
          sysread(IMG, $buff, $len);
          close(IMG);
          print qq|Content-type: image/gif\n|, qq|Content-length: $len\n\n|, $buff;
        }
      }
    }
  } else {
    &PrintHTMLHeader("Check result of $PROGNAME");
#   my $useimage = $ENV{HTTP_ACCEPT} =~ m#image/gif#o;
    my $useimage = 1;
    &Jprint(qq|<a href="https://sw.vector.co.jp/swreg/step1.info?srno=SR011941&amp;site=v&amp;sid=335404740" class="image"><img src="$IMGROOT$img" alt="$alt" width="68" height="68" align="right" border="0"></a>|) if $useimage;
    $footer =~ s#(\Q＼(^o^)／\E)#<code>$1</code>#o;
    print('<h2>');
    &Jprint('チェックの結果は以下のとおりです。');
    print("</h2>\n<p>\n");
    if ($FILE ne '') {
      &EscapeRef(\$FILE);
      &Jprint($FILE.' を ');
    } elsif ($URL ne '') {
      &Jprint(&HrefURL($URL).' を ');
    }
    &Jprint($RULE.' としてチェックしました。'."<br>\n", ($TAGS ne '0')?
            "$footer<br>\n": 'タグのひとつもないHTMLは採点できません。'."<br>\n");
    if (!$Jcode && $cgi->param('CharCode') =~ /^UTF8$/oi) {
      &Jprint("<br>\n".'このサーバではUTF-8は扱えません。');
    }
    if ($LYNX ne '' || $W3M ne '') {
      &Jprint(qq|<br>\n<a href="#${TextView}View">${TextView}|.'での見え方はこちら</a>にあります。');
    }
    print("</p>\n");
    &PrintHTTPHeader;
    my $gray = '#666666';
    if (@line) {
      my $br = '';
      my $tar = $cgi->param('OtherWindow')? ' target="explain"': '';
      &Jprint('<p>先頭の数字はエラーのおおまかな重要度を 0〜9 で示しています(減点数ではありません)。少ない数字は軽く、9 になるほど致命的です。');
      foreach (@line) {
        /^(\d+): ([^:]+):\s*(.*)/o;
        my $id = $2;
        unless ($whines{$id}) {
          &Jprint('0 は減点対象外のごく軽度のエラーで '.qq|<font color="$gray">|.
                  '(グレイのかっこつき)</font> でメッセージされています。');
          last;
        }
      }
      print("</p><p>\n");
      foreach (sort { $a <=> $b } @line) {
        /^(\d+): ([^:]+):\s*(.*)/o;
        my $n = $1;
        my $id = $2;
        my $body = &PrintableCtrlCharacter($3);
        $warn{$n}++;
        print("<br>\n") if $br++;
        print("$whines{$id}: ");
        print($cgi->param('ViewSource')? qq|<a href="#$n">line $n</a>: |: qq|line $n: |);
        if ($whines{$id}) {
          &Jprint($body);
        } else {
          print(qq|<font color="$gray">(|);
          &Jprint($body);
          print(q|)</font>|);
        }
        $n = ${$htmllint::messages{$id}}[1];
        unless (defined($n)) {
          $id = $htmllint::alias_messages{$id};
          $n = ${$htmllint::messages{$id}}[1];
        }
        &Jprint(' → '.qq|<a href="$EXPLAIN#$id"$tar>|.'解説'." $n</a>");
      }
      print("</p>\n");
    }
#   print(qq|<br clear="all">\n|) if $useimage;

    if ($cgi->param('ViewSource')) {
      &Jprint('<hr><h2>チェックしたHTMLは以下のとおりです。'."</h2>\n");
      if ($RURL ne '' || $LYNX ne '' || $W3M ne '') {
        print('<p>');
        &Jprint(&HrefURL($RURL)) if $RURL ne '';
        if ($LYNX ne '' || $W3M ne '') {
          &Jprint(qq| → <a href="#${TextView}View">${TextView}での見え方はこちら</a>|);
        }
        print("</p>\n");
      }
      print("<ol>\n");
      open(HTML, $HTML);
      local $/ = &DetectSeparator;
      my $ln = 0;
      while ($RESULT = <HTML>) {
        $ln = $.;
        $RESULT =~ s/\s+$//g;
        &ConvertAndEscape($TXTCODE);
        $RESULT =~ s/  |\t/&nbsp;&nbsp;/og;
#       ($RESULT = &PrintableCtrlCharacter($RESULT)) =~ s/  |\t/&nbsp;&nbsp;/og;
        print('<li>');
        if ($warn{$ln}) {
          print(qq|<code><a name="$ln"><font color="red">|, $RESULT, q|</font></a></code>|);
        } elsif ($RESULT ne '') {
          print('<code>', $RESULT, '</code>');
        }
        print("</li>\n");
      }
      $ln++;
      print(qq|<li><a name="$ln"><font color="$gray">[EOF]</font></a>\n|)
        if $warn{$ln};
      print("</ol>\n");
      close(HTML);
    }

    if ($TextView) {
      print('<hr>');
      my $view;
      if ($LYNX ne '') {
        # Lynx も見たければ実行する
        $view = &LynxView;
      } elsif ($W3M ne '') {
        # w3m も見たければ実行する
        $view = &W3mView;
      }
      &Jprint('<h2>このサーバでは', $TextView, 'はサポートされていません。</h2>'."\n")
        unless $view;
    }
    &Unlink;
    &PrintHTMLFooter(1);
  }
} else {
  &PrintHTMLHeader("$TextView View by $PROGNAME");
  if ($LYNX ne '') {
    # Lynx の表示だけ見る
    &LynxView;
  } elsif ($W3M ne '') {
    # w3m の表示だけ見る
    &W3mView;
  }
  &Unlink;
  &PrintHTMLFooter(0);
}
&Exit;

sub PrintHTTPHeader
{
  if ($URL ne '' && $cgi->param('HTTPHeader')) {
    print('<blockquote>');
    if ($RESULT ne '') {
      $RESULT =~ s/(\r?\n)+$//o;
      &ConvertAndEscape($CTYPE);
      print('<pre>', $RESULT, '</pre>');
    } else {
      &Jprint('このサーバの設定ではHTTPヘッダを得られません。');
    }
    print("</blockquote>\n");
  }
}

sub LynxView
{
  &TextView($LYNX, '-dump -nolist -force_html');
}
sub W3mView
{
  my $opt = '-dump -T text/html -M '.(($myCODE eq 'euc')? '-e': '-s');
  &TextView($W3M, $opt);
}
sub TextView
{
  my $opt;
  my ($prog, $defopt) = @_;
  if ($prog =~ /^(\S+)\s+(.*)/o) {
    $prog = $1;
    $opt = $2;
  }
  my $ver;
  if ($TextView eq 'lynx') {
    $ver = `$prog -version`;
    $ver =~ s#\n#<br>\n#og;
    $ver =~ s# (http:\S+) # <a href="$1">$1</a> #og;
    return 0 if $ver eq '';
  }
  $opt = $defopt if $opt eq '';
  $RESULT = `$prog $opt $HTML`;
  &ConvertAndEscape(&Jgetcode(\$RESULT));
  &Jprint(qq|<h2><a name="${TextView}View">$TextView|, 'での見え方は以下のとおりです。</a>');
  print(qq|</h2>\n<div class="lynx"><pre class="lynx">\n|, $RESULT, "</pre></div>\n");
  print(q|<blockquote><hr class="none">|, $ver, "</blockquote>\n") if $ver;
  1;
}

sub Jprint
{
  foreach (@_) { print &Jconvert($_, $outCODE, $myCODE); }
}

sub DetectSeparator
{
  my $sep = "\n";
  my $buff;
  read(HTML, $buff, 1024);
  if ($buff !~ /\x0D\x0A/o) {
    $sep = "\x0A" if $buff =~ /\x0A/o;
    $sep = "\x0D" if $buff =~ /\x0D/o;
  }
  seek(HTML, 0, 0);
  $sep;
}

sub DetectCode
{
  my $ccode = uc(shift);
  if ($ccode eq 'EUC') {
    $outCODE = 'euc';
    $CHARSET = 'EUC-JP';
  } elsif ($ccode eq 'SJIS') {
    $outCODE = 'sjis';
    $CHARSET = 'Shift_JIS';
  } elsif ($ccode eq 'JIS') {
    $outCODE = 'jis';
    $CHARSET = 'ISO-2022-JP';
  } elsif ($Jcode && $ccode eq 'UTF8') {
    $outCODE = 'utf8';
    $CHARSET = 'UTF-8';
  } else {
    return 0;
  }
  1;
}

# テンポラリファイルを消す
sub Unlink
{
  unlink($HTML) if !defined($LOCALFILE);
}

# IPを得る
sub GetIP
{
  my $host = shift;
  $host =~ s#^//##o;
  my @ip;
  if ($host =~ m#^(\d+)\.(\d+)\.(\d+)\.(\d+)$#) {
    @ip = ($1,$2,$3,$4);
  } else {
    my (@addr) = (gethostbyname($host))[4];
    @ip = unpack('C4', $addr[0]);
  }
  ((((($ip[0]<<8)+$ip[1])<<8)+$ip[2])<<8)+$ip[3];
}

# Private IP か調べる
sub CheckPrivateIP
{
  my $host = shift;
  if ($host =~ m#^(?://)?(\d+)\.(\d+)\.(\d+)\.(\d+)$#) {
    # RFC1918に示されるのは以下
    #  10.0.0.0〜10.255.255.255
    #  172.16.0.0〜172.31.255.255
    #  192.168.0.0〜192.168.255.255
    ($1==10) || ($1==172 && $2>=16 && $2<32) || ($1==192 && $2==168) ||
    ($1==127 && $2==0 && $3==0); # 127.0.0.1 なども利用されている
  } else { 0 }
}

# ドメイン名が指定のものか調べる
sub CheckDomain
{
  my ($host, $domain) = @_;
  if ($domain =~ m#^(\d+\.\d+\.\d+\.\d+)(?:/(\d+))?(?:([*!])(.+))?$#) {
    my $rule   = $4;
    my $cond   = $3;
    my $mask   = $2;
    my $domip  = &GetIP($1);
    my $hostip = &GetIP($host);
    return 0 if $rule && $cond eq (&CheckDomain($ENV{REMOTE_ADDR}, $rule)? '!': '*');
    if (defined($mask)) {
      $mask = ~((1<<(32-$mask))-1);
    } else {
      $mask = ~0;
      foreach (0xFFFFFFFF, 0xFFFFFF, 0xFFFF, 0xFF) {
        unless ($domip & $_) {
          $mask = ~$_;
          last;
        }
      }
    }
    return 1 if ($hostip & $mask) == ($domip & $mask);
  } else {
    $domain =~ s/\./\\\./og;
    if ($host =~ m#(^//|\.)$domain$#) {
      # 指定ドメイン名で終わるホスト
      return 1;
    }
  }
  0;
}

# URL へのリンク参照を求める
sub HrefURL
{
  my $url = shift;
  &EscapeRef(\$url);
  $url =~ m#^\w+://#o? qq|<a href="$url">$url</a>|: $url;
}

# URL が存在するか調べステータスを返す (http のみ)
# 戻り値は (stat, url, content-type, content-length, msg) の配列
sub AskHTML
{
  my $stat = 200;
  my ($rurl, $type, $length, $header, $msg);
  my $TIMEOUT = $cgi->param('TimeOut')+0;
  if ($TIMEOUT > 0.0) {
    $TIMEOUT = 60 if $TIMEOUT > 60.0;
    my $url = &htmllint::AbsoluteURL;
    if ($LWPUA) {
      $LWPUA->timeout($TIMEOUT);
      my $req = new HTTP::Request HEAD => $url;
      my $res = $LWPUA->request($req);
      $stat = $res->code();
      if ($cgi->param('CheckGET') && $stat >= 400) {
        $req = new HTTP::Request GET => $url;
        $res = $LWPUA->request($req);
        $stat = $res->code();
      }
      $rurl = $res->request->url();
      $type = $res->header('Content-Type');
      $length = $res->header('Content-Length');
      $msg = $res->message();
      $msg =~s /,\s*<HTML> chunk \d+.+$//;
    } else {
      $httpreq::timeout = $TIMEOUT;
      ($stat, $rurl, $header) = &httpreq::head($url);
      if ($cgi->param('CheckGET') && $stat >= 400) {
        ($stat, $rurl, $header) = &httpreq::get($url);
      }
      ($header =~ /(?:^|\n)Content-Type:\s*(.+)\n/omi)   and $type   = $1;
      ($header =~ /(?:^|\n)Content-Length:\s*(.+)\n/omi) and $length = $1;
    }
  }
  [$stat, $rurl, $type, $length, $msg];
}

# コード変換して実体参照にエスケープする
sub ConvertAndEscape
{
  $icode = shift;
  if ($outCODE eq 'jis') {
    &Jconvert(\$RESULT, $myCODE, $icode);
    &EscapeRef(\$RESULT);
    &Jconvert(\$RESULT, $outCODE, $myCODE);
  } else {
    &Jconvert(\$RESULT, $outCODE, $icode);
    &EscapeRef(\$RESULT);
  }
}

# 実体参照にエスケープする
sub EscapeRef
{
  my $str = shift;
  $$str =~ s/&/&amp;/og;
  $$str =~ s/</&lt;/og;
  $$str =~ s/>/&gt;/og;
  $$str =~ s/"/&quot;/og;
  $$str =~ s/\n/<br>/og;
}

# 制御文字を印字可能に変換する
sub PrintableCtrlCharacter
{
  my $str = shift;
  $str =~ s#([\x00-\x08\x0B\x0C\x0E-\x1F])#'<i>^'.pack('C',unpack('C',$1)+0x40).'</i>'#eog;
  $str;
}

# エラー出力して終了する
sub ErrorExit
{
  my (@msgs) = @_;
  &PrintHTMLHeader("$PROGNAME error!");
  &Jprint(qq|<h2>$PROGNAME error!</h2>\n|);
  while (@msgs) {
    print('<p>');
    &Jprint(shift(@msgs));
    print("</p>\n");
  }
  &PrintHTTPHeader if $RESULT ne '';
  &PrintHTMLFooter(0);
  &Exit;
}

sub Exit
{
  # 消されていないテンポラリの始末をする
  &find(\&CleanupTmp, $TMPDIR? $TMPDIR: '.');
  exit;
}

sub CleanupTmp
{
  if (-d) {
    $File::Find::prune = 1 if $_ ne '.';
  } elsif (/^htmllint-?\d+\.(html|result)$/o && (stat($_))[9] < time-24*60*60) {
    # 24時間以前のファイルを消す
    unlink($_);
  }
}

# HTML ヘッダ部分を出力する (PrintHeaderという関数は cgi-lib に既存)
sub PrintHTMLHeader {
  my ($title) = @_;
  my $brclear = $bannerCommercial? '<br clear="all">': '';
  print(qq|Content-Type: text/html; charset=$CHARSET\x0D\x0A\x0D\x0A|,
        <<EndOfHTMLHeader);
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html lang="ja"><head>
<meta http-equiv="Content-Type" content="text/html; charset=$CHARSET">
<link rev="made" href="mailto:$myADDRESS">
<link rel="stylesheet" type="text/css" href="${HTMLDIR}htmllint.css">
<link rel="contents" href="${HTMLDIR}index.html">
<title>$title</title>
</head>
<body bgcolor="#E4EDE3" text="#000000" link="#0000FF" vlink="#663399" alink="#FF0000">
<div align="center" class="nav">$bannerCommercial
[<a href="${HTMLDIR}index.html">about</a>]
[<a href="${HTMLDIR}sitemap.html">sitemap</a>]
[<a href="${HTMLDIR}htmllint.html">gateway</a>]
[<a href="${HTMLDIR}htmllintl.html">lite</a>]
[<a href="${HTMLDIR}htmllinte.html">dyn</a>]$brclear
</div><hr>
EndOfHTMLHeader
}

# HTML フッタ部分を出力する
sub PrintHTMLFooter
{
  my $cntstr;
  if (shift) {
    $cntstr = ($counter? "-- #$counter": '').' -- cost '.(time - $^T).' sec';
#   $cntstr .= " -- $LINTER run" if $LINTER > 1;
    $cntstr .= ' --<br>';
  }
  $JcodeVer .= ' NoXS' if $Jcode && defined($Jcode::Unicode::NoXS::VERSION);
  my $vers = join(' / ', $CGIVer, $JcodeVer);
  $vers = join(' / ', $URLGETVer, $vers) if $URLGETVer;
  print(<<EndOfHTMLFooter);
<hr><div align="center">
<address>${cntstr}This page was generated by $CGI_NAME $VERSION / $LINT_NAME $htmllint::VERSION<br>
$vers<br>
1997-2003 (c) by <a href="mailto:k16\@chiba.email.ne.jp">k16\@chiba.email.ne.jp</a></address></div>
<hr><div align="center" class="nav">$bannerCommercial
[<a href="${HTMLDIR}index.html">about</a>]
[<a href="${HTMLDIR}sitemap.html">sitemap</a>]
[<a href="${HTMLDIR}htmllint.html">gateway</a>]
[<a href="${HTMLDIR}htmllintl.html">lite</a>]
[<a href="${HTMLDIR}htmllinte.html">dyn</a>]
</div>
</body>
</html>
EndOfHTMLFooter
}

# 得点の記録
sub LogScore
{
  my $rule = $RULE;
  foreach (keys(%doctypes)) {
    if (${$doctypes{$_}}{'guide'} eq $rule) {
      $rule = $_;
      last;
    }
  }
  my $cnt = 0;
  my $file = $SCOREFILE;
  my $url = ($FILE or $URL);
  $url =~ s/ /%20/og;
  $url = '<TEXTAREA>' if $url eq '';
  my ($sec, $min, $hour, $mday, $mon, $year) = localtime(time);
  my $post = sprintf('%04d%02d', 1900+$year, 1+$mon);
  $file =~ s/#/$post/g;
  my $existfile = -e $file;
  if (open(LOGF, ($existfile? '>>': '>').$file)) {
    flock(LOGF, 2) if $UNIX;
    if ($SCORECOUNTER) {
      open(CNTF, $SCORECOUNTER);
      $cnt = <CNTF>+1;
      if (open(CNTF, ">$SCORECOUNTER")) {
        print CNTF "$cnt\n";
      }
      close(CNTF);
      chmod 0766, $SCORECOUNTER;
    }
    $WARNS = 0 unless $WARNS;
    my $rhost = ($ENV{REMOTE_HOST} or $ENV{REMOTE_ADDR});
    print LOGF sprintf('%04d/%02d/%02d %02d:%02d:%02d', 1900+$year, 1+$mon, $mday, $hour, $min, $sec),
      " $rhost $url ", ($TAGS ne '0')? "$SCORE/$WARNS/$TAGS/$KIND": "//$TAGS/$KIND", " $rule\n";
#   flock(LOGF, 8) if $UNIX;
    close(LOGF);
    chmod 0766, $file;
  }
  $cnt;
}

# 警告情報を収集する (htmllint.pm が呼ぶ)
sub PushStat
{
  my $name = shift;
  push(@{'stat'.$name}, shift);
}

# 警告の統計を取る (htmllint.pm が呼ぶ)
sub TakeStatistics
{
  my $stat = shift;
  if ($stat ne '') {
    local ($statstart, $statsample, $seensample, *STAT);
    my @lt = localtime;
    my $suffix = sprintf('%04d%02d', $lt[5]+1900, $lt[4]+1);
    $stat =~ s/#/$suffix/g;
    if ($stat ne $stdio) {
      if (-e $stat) {
        open(STAT, "+<$stat") || return;
        flock(STAT, 2) if $UNIX;
        # 排他制御が起こったときSTATの内容は古いのでもう一度オープンし直す
        open(STAT, "+<$stat") || return;
        flock(STAT, 2) if $UNIX;
        local $err = 0;
        local $SIG{__WARN__} = sub { $err++; }; # 次の do のエラーをトラップ
        do $stat;
        if (!defined($statstart) && !$err) {
          # 何らかの理由で読み込みに失敗した ($stat が破損しているときは修復する)
#         flock(STAT, 8) if $UNIX;
          close(STAT);
          return;
        }
        seek(STAT, 0, 0);
      } else {
        open(STAT, ">$stat") || return;
        flock(STAT, 2) if $UNIX;
      }
    } else {
      *STAT = *STDOUT;
    }
    foreach (keys(%whinesStat)) { $statistics{$_} += $whinesStat{$_}; }
    undef %whinesStat;
    foreach (keys(%seenTagsStat)) { $statSeenTags{$_} += $seenTagsStat{$_}; }
    undef %seenTagsStat;
    foreach (keys(%seenTagsKind)) { $statKindTags{$_} += $seenTagsKind{$_}; }
    undef %seenTagsKind;
    foreach (keys(%seenMultiBody)) { $statMultiBody{$_} += $seenMultiBody{$_}; }
    undef %seenMultiBody;
    my $statcurrent = sprintf('%4d/%02d/%02d %02d:%02d:%02d',
      $lt[5]+1900, $lt[4]+1, $lt[3], $lt[2], $lt[1], $lt[0]);
    my $statstart = $statcurrent unless defined($statstart);
    print STAT
      '$statstart   = \'', $statstart,   "';\n",
      '$statcurrent = \'', $statcurrent, "';\n",
      '$statsample = ',  ++$statsample,   ";\n",
      '$seensample = ',  ++$seensample,   ";\n";
    &PrintStatArray('statistics',
      'statOnceOnly',
      'statOnceOnlyGroup',
      'statUnclosedElement',
      'statExcludedElement',
      'statOmitEndTag',
      'statDeprecatedElement',
      'statDeprecatedTag',
      'statDeprecatedAttr',
      'statMustFollow',
      'statEmptyContainer',
      'statIllegalClosing',
      'statRequired',
      'statRequiredAttr',
      'statRequiredValue',
      'statUnknownElement',
      'statUnknownAttribute',
      'statUnexpectedPCDATA',
      'statOmitAttributeName',
      'statMinimizedAttribute',
      'statHereAnchor',
      'statNoRegCharset',
      'statNoTextHtml',
      'statUnknownProtocol',
      'statBadJISX0208',
      'statExcludedURLRef',
      'statSeenTags',
      'statKindTags',
      'statMultiBody');
    if ($stat ne $stdio) {
      truncate(STAT, tell(STAT));
#     flock(STAT, 8) if $UNIX;
      close(STAT);
      chmod 0766, $stat;
    }
  }
}

sub PrintStatArray
{
  foreach my $name (@_) {
    my $esc;
    if ($name ne 'statistics') {
      foreach (@$name) { $$name{$_}++; }
      undef @$name;
    }
    if (%$name) {
      print STAT "\%$name = (\n";
      foreach (sort {$$name{$b} <=> $$name{$a} || $a cmp $b} keys(%$name)) {
        $esc = $_;
        $esc =~ s/[\x00-\x1F]/ /og; # 暫定
        $esc =~ s/\\/\\\\/og;
        $esc =~ s/'/\\'/og;
        print STAT "  '$esc' => $$name{$_},\n";
      }
      print STAT ");\n";
    }
    undef %$name;
  }
}

# 短縮問い合わせデータの調整
sub ShortName
{
  foreach (split(/[&;]/, $cgi->param('keywords'))) {
    $cgi->param(-name=>$_, -value=>'on');
  }
  foreach ($cgi->param) {
    next if /^(?:URL|Data|File|TimeOut)$/oi;
    $cgi->param(-name=>$_, -value=>'on') if $cgi->param($_) eq '';
  }
  my %shortNames = (
    Method          => 'M',
    CharCode        => 'C',
    NoWarnings      => 'N',
    ViewSource      => 'V',
    LynxView        => 'L',
    TextView        => 'X',
    OtherWindow     => 'O',
    IgnoreDOCTYPE   => 'I',
    HTMLVersion     => 'H',
    Pedantic        => 'P',
    NoReligious     => 'R',
    NoAccessibility => 'A',
    TimeOut         => 'T',
    Enable          => 'E',
    Disable         => 'D',
  );
  foreach (keys(%shortNames)) {
    $cgi->param(-name=>$_, -value=>$cgi->param($shortNames{$_})) if !defined($cgi->param($_));
  }
}

# チェックオプションを得る
sub GetOptions
{
  my $x = $defaultrule;
  foreach (keys(%doctypes)) {
    if ($cgi->param('HTMLVersion') =~ /^(${$doctypes{$_}}{'name'})$/i) { $x = $_; last; }
  }
  push @OPT, '-x', $x,
    $cgi->param('IgnoreDOCTYPE')?   '-ignd':  '-used',
    $cgi->param('NoWarnings')?      '-nowar': '-war',
    $cgi->param('NoReligious')?     '-norel': '-rel',
    $cgi->param('NoAccessibility')? '-noacc': '-acc';
  push @OPT, '-limit', $cgi->param('LimitWhines') if $cgi->param('LimitWhines') > 0;
  my (@warnings, @enable, @disable);
  &htmllint::ListWarnings(\@warnings);
  foreach (@warnings) {
    if (/^(\S+)\s+(\S+)\s+(ENABLED|DISABLED)\s+(\S+)(?:\s+(\S+)\s+(\S+))?/) {
      my ($id, $sh, $ed, $n, $swa, $wna) = ($1, $2, $3, $4, $5, $6);
      $whines{$id} = int($n+0.9);
      $whines{$id} = 9 if $whines{$id} > 9;
      $whines{$swa} = $wna if $swa;
      next if $id eq 'over-limit-whines';
      $sh = $id if $sh eq '-';
      if ($cgi->param($id)) { push(@enable,  $sh) if $ed =~ /^D/o; }
      else { push(@disable, $sh) if $ed =~ /^E/o; }
    }
  }
  if ($cgi->param('Pedantic')) {
    push @OPT, '-ped';
  } else {
    push @OPT, '-noped';
    if ($cgi->param('CheckList')) {
      push @OPT, '-e', join(',', @enable)  if @enable;
      push @OPT, '-d', join(',', @disable) if @disable;
    } else {
      push @OPT, '-e', $cgi->param('Enable')  if $cgi->param('Enable')  ne '';
      push @OPT, '-d', $cgi->param('Disable') if $cgi->param('Disable') ne '';
    }
  }
}