#!/usr/local/bin/perl -w## W3C HTML Validation Service# A CGI script to retrieve and validate an HTML file## Copyright 1995-1999 Gerald Oskoboiny <gerald@w3.org>## This source code is available under the license at:#     http://www.w3.org/Consortium/Legal/copyright-software## $Id: check,v 1.122 2001/06/22 08:53:26 link Exp $## We need Perl 5.004.require 5.004;## Load modulesuse strict;use LWP::UserAgent;use URI;use URI::Escape;use CGI::Carp;use CGI qw(:cgi -newstyle_urls -private_tempfiles);use Text::Wrap;use Text::Iconv;use HTML::Parser 3.25; # Need 3.25 for $p->ignore_elements.############################################################################## Constant definitions############################################################################### Define global constantsuse constant TRUE  => 1;use constant FALSE => 0;use constant UNDEF => undef;use constant DEBUG => 0;## Define global variablesuse vars qw($VERSION $DATE $MAINTAINER $NOTICE);               # Strings.use vars qw($frag $pub_ids $element_uri $file_type $doctypes $charsets);                                                               # Cfg hashes.use vars qw($DEBUG);$DEBUG += 1 unless $ENV{SERVER_PORT} == 80;## Paths and file locationsmy $base_path = '/usr/local/validator/';   $base_path = '/home/gerald/validator/' if $DEBUG;my $html_path = $base_path . 'htdocs/';my $elem_db   = $html_path . 'config/eref.cfg';my $fpis_db   = $html_path . 'config/fpis.cfg';my $frag_db   = $html_path . 'config/frag.cfg';my $type_db   = $html_path . 'config/type.cfg';my $dtds_db   = $html_path . 'config/doctypes.cfg';my $chst_db   = $html_path . 'config/charset.cfg';my $sgmlstuff = $html_path . 'sgml-lib';my $temp      = "/tmp/validate.$$"; # @@ Use POSIX/IO::File tmpfiles instead!## Executables and binariesmy $sp      = 'D:/webroot/validate/sp/bin/nsgmls.exe';my $weblint = '/usr/bin/weblint';## URIs and fragmentsmy $abs_svc_uri	= 'http://validator.w3.org/';my $uri_def_uri	= 'http://www.w3.org/Addressing/#terms';my $faqloc	= '/docs/';my $faqerrloc	= $faqloc . 'errors.html';my $element_ref = 'http://www.htmlhelp.com/reference/html40/';## Strings$VERSION    =  q$Revision: 1.122 $;$VERSION    =~ s/Revision: ([\d\.]+) /$1/;$DATE       =  q$Date: 2001/06/22 08:53:26 $;$MAINTAINER =  'gerald@w3.org';$NOTICE     =  ''; # "<p><strong>Note: This service will be ...</strong>";## DOCTYPEsmy $html32_doctype  = q(<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN">);my $html40s_doctype = q(<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/1999/REC-html401-19991224/strict.dtd">);my $html40t_doctype = q(<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/1999/REC-html401-19991224/loose.dtd">);my $html40f_doctype = q(<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN" "http://www.w3.org/TR/1999/REC-html401-19991224/frameset.dtd">);my $xhtmlt_doctype  = q(<!DOCTYPE HTML PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN");## Read configuration files.$frag        = &read_cfg($frag_db); # FPIs    -> plain text version string$pub_ids     = &read_cfg($fpis_db); # Errors  -> fragment identifier$element_uri = &read_cfg($elem_db); # Element -> URI fragment$file_type   = &read_cfg($type_db); # Content -> File -type$doctypes    = &read_cfg($dtds_db); # Name    -> doctype$charsets    = &read_cfg($chst_db); # charset -> iconv parameter## Set up signal handlers.$SIG{TERM} = \&erase_stuff;$SIG{KILL} = \&erase_stuff;$SIG{PIPE} = 'IGNORE';## delete() the, possibly tainted, $PATH.delete $ENV{PATH};############################################################################## Process CGI variables############################################################################### Create a new CGI object.my $q = new CGI;## Backwards compatibility; see# http://lists.w3.org/Archives/Public/www-validator/1999JulSep/0197# http://lists.w3.org/Archives/Public/www-validator/1999JulSep/0212if (scalar $q->param) {  foreach my $param ($q->param) {    $q->param($param, TRUE) unless $q->param($param);  }}## Futz the URI so "/referer" works.if ($q->path_info eq '/referer') {  $q->param('uri', $q->referer);}## USe HTTP Referer if uri=referer.if ($q->param('uri') =~ m(referer)i) {  $q->param('uri', $q->referer);}## Use "url" unless a "uri" was also given.if ($q->param('url') and not $q->param('uri')) {  $q->param('uri', $q->param('url'));}## Supercede URI with an uploaded file.if ($q->param('uploaded_file')) {  &redirect_to_home_page unless length($q->param('uploaded_file')); # Must have filename.  $q->param('uri', 'upload://' . $q->param('uploaded_file'));}## Supercede URI with an uploaded fragment.if ($q->param('fragment')) {$q->param('uri', 'upload://Form Submission')};## Send them to the homepage unless we can extract a URI from either of the# acceptable sources: uri, url or /referer.&redirect_to_home_page unless length($q->param('uri')) > 5;## Munge the URI to include commonly omitted prefix.$q->param('uri', 'http://' . $q->param('uri')) if $q->param('uri') =~ m(^www)i;############################################################################## Output validation results############################################################################### A string containing the HTML header for validation results.# We save it in a string instead of printing it in case we need to abort before# we have any meaningfull results to report. @@ May not be necessary!my $header = <<"EOF";Content-Type: text/html; charset=utf-8$html40t_doctype<html>  <head>    <title>W3C HTML Validation Service Results</title>    <link rev="made" href="mailto:$MAINTAINER">    <link rel="stylesheet" href="/results.css" media="screen">  </head>  <body bgcolor="#FFFFFF" text="#000000" link="#0000ee" vlink="#551a8b">    <h1><a href="http://www.w3.org/"><img       src="http://www.w3.org/Icons/WWW/w3c_home"       width=72 height=48 border="0" alt="W3C"></a>      <a href="/">HTML Validation Service</a> Results</h1>    $NOTICEEOF## Punt if we don't recognize this URI scheme.# @@ LWP does a whole bunch more: transparently!unless ($q->param('uri') =~ m(^(http|upload)://)) {  print $header;  print <<"EOF";  <p>    Sorry, this type of <a href="http://www.w3.org/Addressing/#terms">URI</a>    is not supported by this service.  </p>  <p>    URIs should be in the form:  </p>  <blockquote>    <code>$abs_svc_uri</code>  </blockquote>  <p>    (There are other types of URIs, too, but only <code>http://</code> URIs    are currently supported by this service.)  </p>EOF  &clean_up_and_exit;}## Get the file and metadata.my $File;if    ($q->param('uploaded_file')) {$File = &handle_file($q)}elsif ($q->param('fragment'))      {$File = &handle_frag($q)}elsif ($q->param('uri'))           {$File = &handle_uri($q)};## Abort if there was no document type mapping for this Content-Type, in which# case the document type will be equal to the content type (contains a "/").if ($File->{'Type'} =~ m(/) and not $q->param('uploaded_file')) {  print $header;  print <<"EOF";    <p class="error">      Sorry, I am unable to validate this document because its returned      content-type was <code>$File->{Type}</code>, which is not      currently supported by this service.    </p>EOF  &clean_up_and_exit;}## Overall parsing algorithm for documents returned as text/html:## For documents that come to us as text/html,##  1. check if there's a doctype#  2. if there is a doctype, parse/validate against that DTD#  3. if no doctype, check for an xmlns= attribute on the first element#  4. if there is an xmlns= attribute, check for XML well-formedness#  5. if there is no xmlns= attribute, and no DOCTYPE, punt.### Override DOCTYPE if user asked for it.if (defined $q->param('doctype') and not $q->param('doctype') =~ /Inline/i) {  $File->{Content} = &supress_doctype($File->{Content});  unshift @{$File->{Content}}, $doctypes->{$q->param('doctype')};}## Try to extract a DOCTYPE or xmlns.$File = &preparse($File);## Set document type to XHTML if the DOCTYPE was for XHTML.# Set document type to MathML if the DOCTYPE was for MathML.# This happens when the file is served as text/html$File->{Type} = 'xhtml'  if $File->{DOCTYPE} =~ /xhtml/i;$File->{Type} = 'mathml' if $File->{DOCTYPE} =~ /mathml/i;## If we find a XML declaration with charset information,# we take it into account.foreach my $line (@{$File->{Content}}) {  # @@ needs to handle declarations that span more than one line  if ($line =~ /<\?xml\s/) {    if ($line =~ /encoding\s*=[\s\"\']*([^\s;\"\'>]*)/) {      $File->{XML_Charset} = lc $1;    }    last;  }}## If we find a META element with charset information, we take it into account.foreach my $line (@{$File->{Content}}) {  # @@ needs to handle meta elements that span more than one line  if ($line =~ /<meta/i) {    if ($line =~ /charset\s*=[\s\"\']*([^\s;\"\'>]*)/i) {      $File->{META_Charset} = lc $1;      last;    } elsif ($line =~ /<body/i || $line =~ /<body/i) {      last;    }  }}## Figure out which charset to use for the validation.if ($File->{HTTP_Charset}) {  $File->{Charset} = $File->{HTTP_Charset};} elsif ($File->{XML_Charset}) {  $File->{Charset} = $File->{XML_Charset};} elsif ($File->{META_Charset}) {  $File->{Charset} = $File->{META_Charset};} else {  $File->{Charset} = 'unknown';}## Setup SP environment for the charset.if ($File->{Charset} ne 'unknown' and $File->{Charset} ne 'us-ascii') {  $ENV{SP_CHARSET_FIXED} = 'YES';  $ENV{SP_ENCODING}      = 'utf-8';}## Print header and jump links.print $header, qq(\n    <h2>Document Checked</h2>\n), &build_jump_links;## Print the list of meta data.print "  <ul>\n";## Print different things if we got redirected or had a file upload.if (URI::eq("$File->{URI}", $q->param('uri'))) { # @@ Why do we need to stringify here?  print ' ' x 4, qq(<li><a href="$uri_def_uri">URI</a>: );  print '<a href="', ent($File->{URI}), '">', ent($File->{URI}), qq(</a>\n);} elsif ($q->param('uploaded_file')) {  print ' ' x 4, '<li>File: ', $File->{URI}, "</li>\n";} else {  print ' ' x 4, qq(<li><a href="$uri_def_uri">URI</a>: );  print '<a href="', $q->param('uri'), '">', $q->param('uri'), qq(</a>\n),  ' ' x 6, qq(<span class="note">), qq(I was redirected to &lt;URI:),  '<a href="', $File->{URI}, '">', $File->{URI}, '</a>&gt;', qq(</span>\n),  ' ' x 4, qq(</li>\n);}print(' ' x 4, q(<li>Last modified: ),  $File->{Modified}, qq(</li>\n))  if $File->{Modified};print(' ' x 4, q(<li>Server: ),         $File->{Server},   qq(</li>\n))  if $File->{Server};print(' ' x 4, q(<li>Content length: ), $File->{Size},     qq(</li>\n))  if $File->{Size};print ' ' x 4, q(<li>Character encoding: ), $File->{Charset};if ($File->{HTTP_Charset} ne $File->{META_Charset}    and $File->{HTTP_Charset} ne ''    and $File->{META_Charset} ne ''    and $File->{Charset} ne 'unknown') {  print <<"EOHD";      <em><span class="warning">The character encoding specified in the HTTP      header ("<code>$File->{HTTP_Charset}</code>") is different from the one      specified in the META element ("<code>$File->{META_Charset}</code>").      I will use "<code>$File->{Charset}</code>" for this validation.</span></em>EOHD} elsif ($File->{HTTP_Charset} ne $File->{XML_Charset}    and $File->{HTTP_Charset} ne ''    and $File->{XML_Charset} ne ''    and $File->{Charset} ne 'unknown') {  print <<"EOHD";      <em><span class="warning">The character encoding specified in the HTTP      header ("<code>$File->{HTTP_Charset}</code>") is different from the one      specified in the XML declaration ("<code>$File->{XML_Charset}</code>").      I will use "<code>$File->{Charset}</code>" for this validation.</span></em>EOHD}print ' ' x 4, qq(</li>\n);#{  # block for character conversion and checking#  my @lines;#  unless ($File->{Charset} eq 'utf-8' or $File->{Charset} eq 'unknown') {#    my ($command, $result_charset) = split " ", $charsets->{$File->{Charset}}, 2;#    # workaround for Windows 3.1 cruft:#    #iso-8859-1-Windows-3.1-Latin-1	I cp1252#    if ($command eq 'I') {#      eval {my $c = Text::Iconv->new($result_charset, 'utf-8')};#      $command = '' if ($@);#    }#    elsif ($command eq 'X') {#      $@ = "$File->{Charset} undefined; replace by $result_charset";#    }#    if ($command ne 'I') {#      &print_charset_error($@, $File->{Charset});#      &clean_up_and_exit;#    }#    my $c = Text::Iconv->new($result_charset, 'utf-8');#    my $line = 0;#    for (@{$File->{Content}}) {#      my $in = $_;#      $line++;#      $_ = $c->convert($_); # $_ is local!!#      push @lines, $line if ($in ne "" and $_ eq "");#    }#  }#  # check correctness of UTF-8 both for UTF-8 input and for conversion results#  unless ($File->{Charset} eq 'unknown') {#    my $line = 0;#    for (@{$File->{Content}}) {#      $line++;#      push @lines, $line unless (m/#        ^(#        [\x00-\x7F]                             # ASCII#        | [\xC2-\xDF]        [\x80-\xBF]        # non-overlong 2-byte sequences#        |  \xE0[\xA0-\xBF]   [\x80-\xBF]        # excluding overlongs#        | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2}     # straight 3-byte sequences#        |  \xED[\x80-\x9F]   [\x80-\xBF]        # excluding surrogates#        |  \xF0[\x90-\xBF]   [\x80-\xBF]{2}     # planes 1-3#        | [\xF1-\xF3]        [\x80-\xBF]{3}     # planes 4-15#        |  \xF4[\x80-\x8F][\x80-\xBF]{2}        # plane 16#        )*$#        /x);#    }#  }#  if(@lines) {#    my $lines = $#lines ? "lines " : "line ";#    $lines .= join ", ", @lines;#    print <<"EOF";#    </ul>#    <p class="error">#      Sorry, I am unable to validate this document because on#      <strong>$lines</strong> it contained#      some byte(s) that I cannot interpret as#      <code>$File->{Charset}</code>.#      Please check both the content of the file#      and the character encoding indication.#    </p>#EOF#    &clean_up_and_exit;#  }#}my $xmlflags = '';my $catalog  = $sgmlstuff . '/catalog';if ($File->{Type} eq 'xhtml') {  $catalog               = $sgmlstuff . '/REC-xhtml1-20000126/xhtml.soc';  $ENV{SP_CHARSET_FIXED} = 'YES';  $ENV{SP_ENCODING}      = 'UTF-8';  $xmlflags              = '-wxml';} elsif ($File->{Type} eq 'mathml') {  $catalog               = $sgmlstuff . '/CR-MathML2-20001113/catalog';  $ENV{SP_CHARSET_FIXED} = 'YES';  $ENV{SP_ENCODING}      = 'XML';  $xmlflags              = '-wxml ';} elsif ($File->{Type} eq 'xml' or $File->{Namespace}) {  # no doctype, with xmlns attr on 1st element  $File->{Type} = 'xml'; # @@ probably a better way to do this  $catalog               = $sgmlstuff . '/sp-1.3/pubtext/xml.soc';  $ENV{SP_CHARSET_FIXED} = 'YES';  $ENV{SP_ENCODING}      = 'XML';  $xmlflags              = '-wxml';  $xmlflags             .= ' -wno-valid' unless $File->{DOCTYPE};}my $command  = "$sp -f$temp -E0 $xmlflags -c $catalog";print "\t<li>nsgmls command line: <code>$command</code>\n" if $DEBUG;open CHECKER, "|$command - >$temp.esis"  or die "open(|$command - >$temp.esis) returned: $!\n";for (@{$File->{Content}}) {print CHECKER $_, "\n"};close CHECKER;open ERRORS, "<$temp" or die  "open($temp) returned: $!\n";$File->{Errors} = [<ERRORS>];close ERRORS          or warn "close($temp) returned: $!\n";$File->{ESIS} = [];my $elements_found = 0;my $root_namespace;my %other_namespaces;open ESIS, "$temp.esis" or die  "open($temp.esis) returned: $!\n";while (<ESIS>) {    $elements_found++ if ( /^\(/ );						# look for xml namespaces    if ( ( ($File->{Type} eq 'xml') || ($File->{Type} eq 'xhtml')) &&         ( (/^Axmlns() \w+ (.*)/) || (/^Axmlns:([^ ]+) \w+ (.*)/) ) ) {        if ( ( ! defined $root_namespace ) &&	     ( $elements_found == 0 ) && ( $1 eq "" ) ) {	    $root_namespace = $2;	} else {	  $other_namespaces{$2}++;	}    }    next if / IMPLIED$/;    next if /^ASDAFORM CDATA /;    next if /^ASDAPREF CDATA /;    chomp; # Removes trailing newlines    push @{$File->{ESIS}}, $_;}close ESIS              or warn "close($temp.esis) returned: $!";my $fpi;my $version = 'unknown';if (($File->{Type} eq 'xhtml') || ($File->{Type} eq 'mathml')) {  $fpi = $File->{DOCTYPE};} elsif ($File->{Type} eq 'xml') {  $fpi = 'XML';} else {  for (@{$File->{ESIS}}) {    next unless /^AVERSION CDATA (.*)/;    $fpi = $1;    last;  }  # Needed for HTML4 Strict, which has no version attribute on the HTML element  if (length $File->{DOCTYPE} and not defined $fpi) {$fpi = $File->{DOCTYPE}};}$version = $pub_ids->{$fpi} || 'unknown';if ($File->{Type} eq 'xml' || 'xhtml') {  print ' ' x 4, qq(<li>Document type: ), $version;  if ($File->{Type} eq 'xhtml'      and $root_namespace ne 'http://www.w3.org/1999/xhtml') {    print "<br>warning: unknown namespace for text/html document!";    if ($root_namespace ne '') {      print qq{, <a href="$root_namespace">$root_namespace</a>};    }    print "\n";  } else {    if ($root_namespace ne '') {      print qq( with namespace <a href="$root_namespace">$root_namespace</a>);    }  }  if (scalar keys %other_namespaces >= 1) {    print "<br>Other namespaces in this document: ";    for (keys %other_namespaces) {      print qq(<a href="$_">$_</a>, ), "\n";    }  }  print qq(</li>\n);} else {  print ' ' x 4, qq(<li>Document type: ), $version, qq(</li>\n);}print ' ' x 2, qq(</ul>\n\n);if ($File->{Type} eq 'xml' or $File->{Type} eq 'xhtml') {  my $xmlvalid = ($File->{DOCTYPE} ? ' and validity' : '');  print <<"EOHD";  <p>    Below are the results of checking this document for <a    href="http://www.w3.org/TR/REC-xml#sec-conformance">XML    well-formedness</a>$xmlvalid.  </p>EOHD} else {  print <<"EOHD";  <p>    Below are the results of attempting to parse this document with    an SGML parser.  </p>EOHD}if   ($?) {&process_errors($File)}else      {&report_valid($File)};&weblint($File)     if $q->param('weblint');&outline($File)     if $q->param('outline');&show_source($File) if $q->param('ss');&parse_tree($File)  if $q->param('sp');&clean_up_and_exit;############################################################################## Subroutine definitions#############################################################################sub output_doctype_spiel {    print <<"EOF";    <p>      You should make the first line of your HTML document a DOCTYPE      declaration, for example, for a typical <a      href="http://www.w3.org/TR/html4/">HTML 4.01</a> document:    </p>    <pre>      &lt;!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"&gt;      &lt;HTML&gt;	&lt;HEAD&gt;	  &lt;TITLE&gt;Title&lt;/TITLE&gt;	&lt;/HEAD&gt;	&lt;BODY&gt;	  &lt;-- ... body of document ... --&gt;	&lt;/BODY&gt;      &lt;/HTML&gt;</pre>EOF}sub output_closing {    print <<"EOF";<hr><address>  <a href="${abs_svc_uri}check/referer"><img     src="http://www.w3.org/Icons/valid-html401" height="31" width="88"     align=right border="0" alt="Valid HTML 4.01!"></a>  <a href="/feedback.html">Gerald Oskoboiny</a><br>  Last modified: $DATE</address></body></html>EOF}sub erase_stuff {  unlink $temp        or warn "unlink($temp) returned: $!\n";  unlink "$temp.esis" or warn "unlink($temp.esis) returned: $!\n";  unlink "$temp.weblint";}sub clean_up_and_exit {  &output_closing;  &erase_stuff;  exit;}sub redirect_to_home_page {  print <<".EOF.";Status: 301 Moved PermanentlyContent-Type: text/htmlLocation: $abs_svc_uri<title>Moved!</title><p>Please see <a href="$abs_svc_uri">the home page.</a></p>.EOF.  &clean_up_and_exit;}sub build_jump_links {    my $text  = '';    my $count = 0;    $count++ if $q->param('ss');    $count++ if $q->param('sp');    $count++ if $q->param('weblint');    $count++ if $q->param('outline');    if ( $count ) {	$text .= "  <p>\n    Jump to: ";	if ( $q->param('weblint') ) {	    $text .= "<a\n      href=\"#weblint\">Weblint Results</a>";	    $count--;	    $text .= " or " if ( $count == 1 );	    $text .= ", "   if ( $count >  1 );	}	if ( $q->param('outline') ) {	    $text .= "<a\n      href=\"#outline\">Outline</a>";	    $count--;	    $text .= " or " if ( $count == 1 );	    $text .= ", "   if ( $count >  1 );	}	if ( $q->param('ss') ) {	    $text .= "<a\n      href=\"#source\">Source Listing</a>";	    $count--;	    $text .= " or " if ( $count == 1 );	    $text .= ", "   if ( $count >  1 );	}	if ( $q->param('sp') ) {	    $text .= "<a\n      href=\"#parse\">Parse Tree</a>";	}	$text .= ".\n  </p>\n\n";    }    return $text;}sub authenticate {  my $resource   = shift;  my $authHeader = shift;    print <<"EOF";Status: 401 Authorization RequiredWWW-Authenticate: $authHeaderConnection: closeContent-Type: text/html<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\"><HTML><HEAD><TITLE>401 Authorization Required</TITLE></HEAD><BODY><H1>Authorization Required</H1><p>  Sorry, I am not authorized to access the specified URI.</p><p>  The URI you specified,</p><blockquote>  <code><a href="$resource">$resource</a></code></blockquote><p>  returned a 401 "authorization required" response when I tried  to download it.</p><p>  You should have been prompted by your browser for a  username/password pair; if you had supplied this information, I  would have forwarded it to your server for authorization to  access the resource. You can use your browser's "reload" function  to try again, if you wish.</p><p>  Of course, you may not want to trust me with this information,  which is fine. I can tell you that I don't log it or do  anything else nasty with it, and you can <a  href="${abs_svc_uri}source/">download the source for  this service</a> to see what it does, but you have no guarantee  that this is actually the code I'm using; you basically have to  decide whether to trust me or not. :-)</p><p>  Note that you shouldn't use HTTP Basic Authentication for  anything which really needs to be private, since the password  goes across the network unencrypted.</p>EOF}sub print_unknown_http_error_message {    my $uri = shift;    my $code = shift;    my $message = shift;    print <<"EOF";  <p>    I got the following unexpected response when trying to    retrieve <code><a href="$uri">$uri</a></code>:  </p>  <blockquote>    <code>$code $message</code>  </blockquote>  <p>    Please make sure you have entered the URI correctly.  </p>EOF}## Complain about strange charsets.sub print_charset_error {  my $error   = shift;  my $charset = shift;  print <<".EOF.";  </ul>  <p>    A fatal error occurred when attempting to transliterate the document    charset. Either we do not support this character encoding yet, or you have    specified a non-existent character encoding (typically a misspelling such as    "iso8859-1" for "iso-8859-1").  </p>  <p>The detected charset was "$charset".</p>  <p>The error was "$error".</p>  <p>    If you believe the charset to be valid you can submit a request for that    character encoding (see the <a href="/feedback.html">feedback page</a> for    details) and we will look into supporting it in the future.  </p>.EOF.}sub output_css_validator_blurb {  my $uri = shift;  $uri = ent($uri);  print <<"EOHD";  <p>    If you use <a href="http://www.w3.org/Style/CSS/">CSS</a> in your document,    you should also <a    href="http://jigsaw.w3.org/css-validator/validator?uri=$uri">check it for    validity</a> using the W3C <a    href="http://jigsaw.w3.org/css-validator/">CSS Validation Service</a>.  </p>EOHD}## Read TAB-delimited configuration files. Returns a hash reference.sub read_cfg {  my $file = shift;  my %cfg;  open CFG, $file or die "open($file) returned: $!\n";  while (<CFG>) {    next if /^\s*$/;    next if /^\s*#/;    chomp;    my($k, $v) = split /\t+/, $_;    $cfg{$k} = $v;  }  close CFG;  return \%cfg;}## Fetch an URI and return the content and selected meta-info.sub handle_uri {  my $q   = shift;  my $uri = $q->param('uri'); # The URI to fetch.  my $ua = new LWP::UserAgent;  $ua->agent("W3C_Validator/$VERSION " . $ua->agent);  $ua->parse_head(0);  # Parse the http-equiv stuff ourselves. @@ Why?  my $req = new HTTP::Request(GET => $uri);  # If we got a Authorization header, the client is back at it after being  # prompted for a password so we insert the header as is in the request.  if($ENV{HTTP_AUTHORIZATION}){    $req->headers->header(Authorization => $ENV{HTTP_AUTHORIZATION});  }  my $res = $ua->request($req);  unless ($res->code == 200) {    if ($res->code == 401) {      &authenticate($res->request->url, $res->www_authenticate);    } else {      print $header;      &print_unknown_http_error_message($uri, $res->code, $res->message);    }    &clean_up_and_exit;  }  my($type, $charset) = &parse_content_type($res->header('Content-Type'));  my $lastmod = undef;  if ( $res->last_modified ) {    $lastmod = scalar(gmtime($res->last_modified));  }  return {Content       => &normalize_newlines($res->content),	  Type          => $type,	  HTTP_Charset  => $charset,	  Modified      => $lastmod,	  Server        => scalar($res->server),	  Size          => scalar($res->content_length),	  URI           => scalar($res->request->url)};}## Handle uploaded file and return the content and selected meta-info.sub handle_file {  my $q = shift; # The CGI object.  my $f = $q->param('uploaded_file');  my $h = $q->uploadInfo($f);  my $file;  while (not eof $f) {$file .= <$f>};  my($type, $charset) = &parse_content_type($h->{'Content-Type'});  return {Content      => &normalize_newlines($file),	  Type         => $type,	  HTTP_Charset => $charset,	  Modified     => $h->{'Last-Modified'},	  Server       => $h->{'Server'},	  Size         => $h->{'Content-Length'},	  URI          => $q->param('uploaded_file')};}## Handle uploaded file and return the content and selected meta-info.sub handle_frag {  return {Content      => &normalize_newlines(shift->param('fragment')),	  Type         => 'html',	  HTTP_Charset => '',	  Modified     => '',	  Server       => '',	  Size         => '',	  URI          => 'upload://Form Submission'};}## Parse a Content-Type and parameters. Return document type and charset.sub parse_content_type {  my $Content_Type = shift;  my $charset      = '';  my $type         = '';  my($ct, @param) = split /\s*;\s*/, lc $Content_Type;  $type = $file_type->{$ct} || $ct;  foreach my $param (@param) {    my($p, $v) = split /\s*=\s*/, $param;    next unless $p =~ m(charset)i;    if ($v =~ m/([\'\"]?)(\S+)\1/i) {      $charset = lc $2;      last;    }  }  return $type, $charset;}## Normalize newline forms (CRLF/CR/LF) to native newline.sub normalize_newlines {  my $file = shift;  $file =~ s(\015\012?|\012){\n}g; # Turn ASCII CRLF into native newline.  return [split /\n/, $file];}## Return $_[0] encoded for HTML entities (cribbed from merlyn).sub ent {  local $_ = shift;  s(["<&>"]){'&#' . ord($&) . ';'}ge;  return $_;}## Truncate source lines for report.sub truncate_line {  my $line = shift;  my $col  = shift;  if (length $line > 70) {    if ($col < 25) {      # Truncate at 70 chars and right side only.      $line = substr($line, 0, 70) . " ...";    } elsif ($col > 70) { # Keep rightmost 70 chars; left side only.      my $diff = $col - 50;      $line = "... " . substr($line, $diff, 70);      if (length $line == 70 + 4) {	$line .= " ...";      }      if ($col > $diff) {	$col -= $diff;      } else {	$col -= 70;      }    } else { # Truncate both sides; leave more on left, and 30 chars on right.      if ($col < 35) {	$line = "... " . substr($line, 0, 60);      } else {	$line = "... " . substr($line, $col - 35, 60);	$col = 35;      }      if (length $line == 60 + 4) {$line .= " ..."};    }  }  return $line, $col;}## Supress any existing DOCTYPE by commenting it out.sub supress_doctype {  no strict 'vars';  my $file = shift;  local $HTML = '';  HTML::Parser->new(default_h     => [sub {$HTML .= shift}, 'text'],		    declaration_h => [sub {$HTML .= '<!-- ' . $_[0] . ' -->'}, 'text']		   )->parse(join "\n", @{$file});  return [split /\n/, $HTML];}## Extract a DOCTYPE to determine what kind of document this is.sub get_doctype {  no strict 'vars';  my $file = shift;  local $dtd = '';  HTML::Parser->new(declaration_h => [sub {$dtd = $_[0]}, 'text'])->parse(join "\n", @{$file});  $dtd =~ s(<!DOCTYPE\s+\w+\s+PUBLIC\s+"([^\"]+)".*>){$1}si;  return $dtd;}## Process errors reported by SP and produce a report.sub process_errors {  my $File = shift;  my($line, $col, $type, $msg);  print "<ul>\n";  for (@{$File->{Errors}}) {    next if /^<OSFD>0:[0-9]+:[0-9]+:[^A-Z]/;    next if / numbers exceeding 65535 not supported$/;    next if /^$sp:\(invalid location\):W: URL Redirected to/;    s/^$sp:<OSFD>//g;    unless (($line, $col, $type, $msg) = (/^(?:D:)?[^:]*:([0-9]+):([0-9]+):([A-Z]?):? (.*)/)) {      print "Uh oh! I got the following unknown error:\n\n   $_\n\n";      print "Please make sure you specified the DOCTYPE properly!\n\n";      &output_doctype_spiel;      last;    }    if ($msg =~ /^cannot generate system identifier for entity /) {      print "<p><b>Fatal error</b>! $msg\n\n";      print "<p>I couldn't parse this document, because it " .	"uses a public\n    identifier that's not in my <a\n " .	  "    href=\"sgml-lib/catalog\">catalog</a>!\n  </p>\n";      &output_doctype_spiel;      last;    }    if ($msg =~ /unrecognized ({{)?DOCTYPE(}})?/i) {      print "<p><b>Fatal error</b>! $msg\n\n";      print "<p>I couldn't parse this document, because it " .	"uses a public\n    identifier that's not in my <a\n " .	  "    href=\"sgml-lib/catalog\">catalog</a>!\n  </p>\n";      &output_doctype_spiel;      last;    }    if ($msg =~ /^cannot open /) {      print "<p>Fatal error! $msg\n\n";      print "<p>I couldn't parse this document, because it " .	"makes reference to\n    a system-specific file instead of " .	  "using a well-known public identifier\n    to specify the " .	    "level of HTML being used.\n  </p>\n";      &output_doctype_spiel;      last;    }    if ($msg =~ /^cannot find /) {      print "<p>Fatal error! $msg\n\n";      print "<p>I couldn't parse this document, because it " .	"makes reference to\n    a system-specific file instead of " .	  "using a well-known public identifier\n    to specify the " .	    "level of HTML being used.\n  </p>\n";      &output_doctype_spiel;      last;    }    my $newline = $File->{Content}->[$line - 1];    # make sure there are no ^P's or ^Q's in the file, since we need to use    # them to represent '<' and '>' temporarily. We'll just change them to    # literal P's and Q's for a lack of anything better to do with them.    my $lt = "\020";    my $gt = "\021";    $newline =~ s/\020/P/go;    $newline =~ s/\021/Q/g;    my $orig_col = $col;    ($newline, $col) = &truncate_line($newline, $col);    # temporarily strip curlies from lq-nsgmls output.    # @@ should link HTML elements using $elem_db instead.    $msg =~ s/[{}]//g;    # figure out the index into the %frag associative array for the    # "explanation..." links to the KGV FAQ.    my $msgindex = $msg;    $msgindex =~ s/"[^\"]+"/FOO/g;    $msgindex =~ s/[^A-Za-z ]//g;    $newline =~ s/&/&amp;/go;    $newline =~ s/</&lt;/go;    $newline =~ s/$lt/</g;    $newline =~ s/$gt/>/g;    $newline =~ s/\t/ /g;    $newline =~ s/\r//g;    print "  <li>";    print qq{<a href="#line-$line">} if $q->param('ss');    print "Line $line";    print "</a>"		     if $q->param('ss');    print ", column $orig_col:\n";    print "<pre>  <code class=input>$newline</code>\n";    print " " x ($col + 2);	        # 2 is the number of spaces before <code> above    print " " x 4 if $col != $orig_col;	# only for truncated lines    print "<span class=markup>^</span></pre>\n";    print "<p>\n";    print qq{<span class=error>Error: $msg</span>};    if (defined $frag->{$msgindex}) {      print qq{ (<a href="$faqerrloc#$frag->{$msgindex}">explanation...</a>)};    }    print "</p>\n";  }  print "</ul>\n";  print "<hr>\n";  if ($version eq 'unknown') {    print "\n  <p>\n    Sorry, I can't validate this document.\n  </p>\n";  } elsif ($File->{Type} eq 'xml') {    print "\n  <p>\n    Sorry, this document is not well-formed XML.\n  </p>\n";  } else {    print "\n  <p>\n    Sorry, this document does not validate as $version.\n  </p>\n\n";    &output_css_validator_blurb($q->param('uri'));  }}## Output "This page is Valid" report.sub report_valid {  my $File = shift;  my $gifborder   = ' border="0"';  my $xhtmlendtag = '';  my($image_uri, $alttext, $gifhw);  if ($File->{Type} eq 'xml' or $File->{Type} eq 'xhtml') {    print "\n  <pre>\n    No errors found! ";    print "<a href=\"#sp-lim\">*</a></pre>\n\n";  } else {    print "\n  <pre>\n    No errors found!</pre>\n\n";  }  unless ($version eq 'unknown') {    if ($version =~ /^HTML 2\.0$/) {      $image_uri = "${abs_svc_uri}images/vh20";      $alttext = "Valid HTML 2.0!";      $gifborder = "";    } elsif ($version =~ /HTML 3\.2</) {      $image_uri = "http://www.w3.org/Icons/valid-html32";      $alttext = "Valid HTML 3.2!";      $gifhw   = ' height="31" width="88"';    } elsif ($version =~ /HTML 4\.0<\/a> Strict$/) {      $image_uri = "http://www.w3.org/Icons/valid-html40";      $alttext = "Valid HTML 4.0!";      $gifborder = "";      $gifhw   = ' height="31" width="88"';    } elsif ($version =~ /HTML 4\.0<\/a> /) {      $image_uri = "http://www.w3.org/Icons/valid-html40";      $alttext = "Valid HTML 4.0!";      $gifhw   = ' height="31" width="88"';    } elsif ($version =~ /HTML 4\.01<\/a> Strict$/) {      $image_uri = "http://www.w3.org/Icons/valid-html401";      $alttext = "Valid HTML 4.01!";      $gifborder = "";      $gifhw   = ' height="31" width="88"';    } elsif ($version =~ /HTML 4\.01<\/a> /) {      $image_uri = "http://www.w3.org/Icons/valid-html401";      $alttext = "Valid HTML 4.01!";      $gifhw   = ' height="31" width="88"';    } elsif ($version =~ /XHTML 1\.0<\/a> /) {      $image_uri = "http://www.w3.org/Icons/valid-xhtml10";      $alttext = "Valid XHTML 1.0!";      $gifborder = "";      $gifhw   = ' height="31" width="88"';      $xhtmlendtag = " /";    } elsif ($version =~ /HTML 3\.0/) {      $image_uri = "${abs_svc_uri}images/vh30";      $alttext = "Valid HTML 3.0!";    } elsif ($version =~ /Netscape/) {      $image_uri = "${abs_svc_uri}images/vhns";      $alttext = "Valid Netscape-HTML!";    } elsif ($version =~ /Hotjava/) {      $image_uri = "${abs_svc_uri}images/vhhj";      $alttext = "Valid Hotjava-HTML!";    }    if (defined $image_uri) {      print <<"EOHD";  <p>    <img src="$image_uri" alt="$alttext"> Congratulations, this    document validates as $version!  </p>  <p>    To show your readers that you have taken the care to create an    interoperable Web page, you may display this icon on any page    that validates. Here is the HTML you could use to add this icon    to your Web page:  </p>  <pre>  &lt;p&gt;    &lt;a href="${abs_svc_uri}check/referer"&gt;&lt;img$gifborder        src="$image_uri"        alt="$alttext"$gifhw$xhtmlendtag&gt;&lt;/a&gt;  &lt;/p&gt;</pre>  <p>    If you like, you can download a copy of this image (in <a    href="${image_uri}.png">PNG</a> or <a href="${image_uri}.gif">GIF</a>    format) to keep in your local web directory, and change the HTML fragment    above to reference your local image rather than the one on this server.  </p>EOHD    }  }  if ($File->{Type} eq 'xml' and not $File->{DOCTYPE}) {    print "  <p>\n    Congratulations, this document is well-formed XML.\n  </p>\n";  } elsif ($version eq 'unknown' or not defined $image_uri) {    print "  <p>\n    Congratulations, this document validates as the document type specified! (I don't have an icon for this one yet, sorry.)\n  </p>\n";  }  unless ($q->param('uploaded_file')) {    my $thispage = $q->url(-query => 1);    &output_css_validator_blurb($q->param('uri'));    print <<"EOHD";  <p>    If you would like to create a link to <em>this</em> page (i.e., this    validation result) to make it easier to re-validate this page in the    future or to allow others to validate your page, the URI is:  </p>  <blockquote>    <code><a href="$thispage">$thispage</a></code>  </blockquote>  <p>    (Or, you can just add the current page to your bookmarks or hotlist.)  </p>EOHD  }  if ($File->{Type} eq 'xml' or $File->{Type} eq 'xhtml') {    print qq{    <h2><a name="sp-lim">Caveat</a></h2>      <p>	This validator is based on SP, which has <a	href="http://www.jclark.com/sp/xml.htm">some limitations	in its support for XML</a>.      </p>	    };  }}## Run file through Neil Bower's "weblint". Legacy support. Deprecated!sub weblint {  my $File = shift;  my $pedanticflags;  my $pedantic_blurb;  if ($q->param('pw')) {    $pedanticflags  = '-pedantic -e mailto-link';    $pedantic_blurb = ' (in "pedantic" mode)';  } else {    $pedanticflags = '';  }  print <<"EOF";  <hr>  <h2><a name="weblint">Weblint Results</a></h2>  <p>    Below are the results of running <a    href="http://www.weblint.org/">Weblint</a>    on this document$pedantic_blurb:  </p>  <p>    <strong>Note</strong>:    Weblint is a useful HTML syntax and style checker, but does    not do true HTML validation.    Also, the version of weblint used by this service has not    been updated for some time, so some of the messages below may    be misleading or inaccurate.  </p>EOF  open WEBLINT, "|$weblint -s $pedanticflags - 2>&1 >$temp.weblint"    or die "open($weblint) returned: $!\n";  for (@{$File->{Content}}) {print WEBLINT $_, "\n"};  close WEBLINT;  print "\n\n";  if ($?) {    print "  <ul>\n";    open WEBLINTOUT, "$temp.weblint"      or die "open($temp.weblint) returned: $!\n";    while (<WEBLINTOUT>) {      s/ \(use "-x <extension>" to allow this\)\.$/./go;      s/&/&amp;/go;      s/</&lt;/go;      s/>/&gt;/go;      print "    <li>$_";    }    close WEBLINTOUT or die "close($temp.weblint) returned: $!\n";    print "  </ul>\n";  } else {    print "\n  <blockquote>\n    Looks good to me!\n  </blockquote>\n";  }  print "\n\n";}## Produce an outline of the document based on Hn elements from the ESIS.sub outline {  my $File = shift;  print <<'EOF';  <div id="outline" class="mtb">    <hr>    <h2><a name="outline">Outline</a></h2>    <p>      Below is an outline for this document, automatically generated from the      heading tags (<code>&lt;H1&gt;</code> through <code>&lt;H6&gt;</code>.)    </p>EOF  my $prevlevel = 0;  my $indent    = 0;  my $level     = 0;  for (1 .. $#{$File->{ESIS}}) {    my $line = $File->{ESIS}->[$_];    next unless $line =~ /^\(H([1-6])$/i;    $prevlevel = $level;    $level     = $1;    print "    </ul>\n" x ($prevlevel - $level); # perl is so cool.    if ($level - $prevlevel == 1) {print "    <ul>\n"};    foreach my $i (($prevlevel + 1) .. ($level - 1)) {      print qq(  <ul>\n    <li class="warning">A level $i heading is missing!\n);    }    if ($level - $prevlevel > 1) {print "    <ul>\n"};    $line       = '';    my $heading = '';    until (substr($line, 0, 3) =~ /^\)H$level/i) {      $line = $File->{ESIS}->[$_++];      $line =~ s/\\011/ /g;      $line =~ s/\\012/ /g;      if ($line =~ /^-/) {	my $headcont = $line;	substr($headcont, 0, 1) = " ";	$headcont =~ s/\\n/ /g;	$heading .= $headcont;      } elsif ($line =~ /^AALT CDATA( .+)/i) {	my $headcont = $1;	$headcont =~ s/\\n/ /g;	$heading .= $headcont;      }    }    $heading = substr($heading, 1); # chop the leading '-' or ' '.    $heading =~ s/&/&amp;/go; $heading =~ s/</&lt;/go;    print "    <li>$heading\n";  }  print "    </ul>\n" x $level;  print <<'EOF';    <p>      If this does not look like a real outline, it is likely that the      heading tags are not being used properly. (Headings should reflect      the logical structure of the document; they should not be used simply      to add emphasis, or to change the font size.)    </p>    </div>EOF}## Create a HTML representation of the document.sub show_source {  my $File = shift;  my $line = 1;  print <<'EOF';  <div id="source" class="mtb">    <hr>    <h2><a name="source">Source Listing</a></h2>    <p>Below is the source input I used for this validation:</p>    <pre>EOF  for (@{$File->{Content}}) {    printf "<a name=\"line-%s\">%4d</a>: %s\n", $line, $line, ent $_;    $line++;  }  print "    </pre>\n  </div>";}## Create a HTML Parse Tree of the document for validation report.sub parse_tree {  my $File = shift;  print <<'EOF';  <div id="parse" class="mtb">    <hr>    <h2><a name="parse">Parse Tree</a></h2>EOF  if ($q->param('noatt')) {    print <<'EOF';    <p class="note">      I am excluding the attributes, as you requested.    </p>EOF  } else {    print <<'EOF';    <p class="note">      You can also view this parse tree without attributes by selecting the      appropriate option on <a href="./#byURI">the form</a>.    </p>EOF  }  my $indent   = 0;  my $prevdata = '';  print "<pre>\n";  foreach my $line (@{$File->{ESIS}}) {    if ($q->param('noatt')) {	# don't show attributes      next if $line =~ /^A/;      next if $line =~ /^\(A$/;      next if $line =~ /^\)A$/;    }    $line =~ s/\\n/ /g;    $line =~ s/\\011/ /g;    $line =~ s/\\012/ /g;    $line =~ s/\s+/ /g;    next if $line =~ /^-\s*$/;    if ($line =~ /^-/) {      substr($line, 0, 1) = ' ';      $prevdata .= $line;      next;    } elsif ($prevdata) {      $prevdata =~ s/&/&amp;/go;      $prevdata =~ s/</&lt;/go;      $prevdata =~ s/\s+/ /go;      print wrap(' ' x $indent, ' ' x $indent, $prevdata), "\n";      undef $prevdata;    }    $line =~ s/&/&amp;/go;    $line =~ s/</&lt;/go;    if ($line =~ /^\)/) {      $indent -= 2;    }    my $printme;    chomp($printme = $line);    $printme =~ s{^([()])(.*)}	# reformat and add links on HTML elements		 { my $close = '';		      $close = "/" if $1 eq ")";	# ")" -> close-tag		   "&lt;" . $close . "<a href=\"" .		   $element_ref . $element_uri->{lc($2)} .		   "\">$2<\/a>&gt;"		 }egx;    $printme =~ s,^A,  A,;	# indent attributes a bit    print ' ' x $indent, $printme, "\n";    if ($line =~ /^\(/) {      $indent += 2;    }  }  print "</pre>\n";  print "</div>\n";}## @@FIXME@@ Add description.sub preparse {  my $File = shift;  my $dtd   = sub {return if $File->{Root}; ($File->{Root}, $File->{DOCTYPE}) = shift =~  m(<!DOCTYPE\s+(\w+)\s+PUBLIC\s+"([^\"]+)".*>)si};#  my $dtd   = sub {print "DTD:   ", shift(), "\n"};#  my $pi    = sub {print "PI:    ", shift(), "\n"};  my $start = sub {    my $tag  = shift;    my $attr = shift;    if ($File->{Root}) {      return unless $tag eq $File->{Root};    } else {      $File->{Root} = $tag;    }    if ($attr->{xmlns}) {$File->{Namespace} = $attr->{xmlns}};  };  my $p =  HTML::Parser->new(api_version => 3);  $p->xml_mode(TRUE);  $p->ignore_elements('BODY');  $p->ignore_elements('body');  $p->handler(declaration => $dtd, 'text');#  $p->handler(process => $pi, 'text');  $p->handler(start => $start, 'tag,attr');  $p->parse(join "\n", @{$File->{Content}});  return $File;}