path: root/httpd/cgi-bin/check

#!/usr/bin/perl -T
#
# W3C HTML Validation Service
# A CGI script to retrieve and validate an HTML file
#
# Copyright 1995-2002 Gerald Oskoboiny <gerald@w3.org>
# for additional contributors, see http://dev.w3.org/cvsweb/validator/
#
# This source code is available under the license at:
#     http://www.w3.org/Consortium/Legal/copyright-software
#
# $Id: check,v 1.251 2002-10-12 12:55:23 duerst Exp $

#
# Disable buffering on STDOUT!
$| = 1;

#
# We need Perl 5.005_03. (no access to 5.004 testing box any more)
require 5.005_03;

###############################################################################
#### Load modules. ############################################################
###############################################################################

#
# Pragmas.
use strict;
use warnings;

#
# Modules.
#
# Version numbers given where we absolutely need a minimum version of a given
# module (gives nicer error messages). By default, add an empty import list
# when loading modules to prevent non-OO or poorly written modules from
# polluting our namespace.
#
use CGI            2.81 qw(-newstyle_urls -private_tempfiles); # 2.81 for XHTML
use CGI::Carp           qw(carp croak);
use File::Spec          qw();
use HTML::Parser   3.25 qw(); # Need 3.25 for $p->ignore_elements.
use HTTP::Request       qw();
use IO::File            qw();
use IPC::Open3          qw(open3);
use LWP::UserAgent 1.90 qw(); # Need 1.90 for protocols_(allowed|forbidden)
use Set::IntSpan        qw();
use Text::Iconv         qw();
use Text::Wrap          qw(wrap);
use URI                 qw();
use URI::Escape         qw(uri_escape);


###############################################################################
#### Constant definitions. ####################################################
###############################################################################

#
# Define global constants
use constant TRUE  => 1;
use constant FALSE => 0;

#
# Tentative Validation Severities.
use constant T_DEBUG =>  1; # 0000 0001
use constant T_INFO  =>  2; # 0000 0010
use constant T_WARN  =>  4; # 0000 0100
use constant T_ERROR =>  8; # 0000 1000
use constant T_FATAL => 16; # 0001 0000

#
# Output flags for error processing
use constant O_SOURCE  =>  1; # 0000 0001
use constant O_CHARSET =>  2; # 0000 0010
use constant O_DOCTYPE =>  4; # 0000 0100


#
# Define global variables.
use vars qw($DEBUG $CFG $VERSION);


#
# Things inside BEGIN don't happen on every request in persistent
# environments, such as mod_perl.  So let's do globals, eg. read config here.
BEGIN {

  #
  # Read Config Files.
  $CFG = &read_cfg($ENV{W3C_VALIDATOR_CFG} || '/etc/w3c/validator.conf');

  #
  # Set debug flag.
  $DEBUG = TRUE if $ENV{W3C_VALIDATOR_DEBUG} || $CFG->{DEBUG};

  #
  # Strings
  $VERSION    =  q$Revision: 1.251 $;
  $VERSION    =~ s/Revision: ([\d\.]+) /$1/;


  #
  # Read TAB-delimited configuration files. Returns a hash reference.
  sub read_cfg {
    my $file = shift;
    my %cfg;

    my $fh = new IO::File $file
      or die "open($file) returned: $!\n";

    while (<$fh>) {
      next if /^\s*$/;
      next if /^\s*\#/;
      chomp;
      my($k, $v) = split /\t+/, $_, 2;
      $v = '' unless defined $v;

      if    ($v =~ s(^file://){}) {$cfg{$k} = &read_cfg($v)  }
      elsif ($v =~ /,/)           {$cfg{$k} = [split /,/, $v]}
      else                        {$cfg{$k} = $v             }
    }
    undef $fh;
    return \%cfg;
  }

} # end of BEGIN block.

#
# Get rid of (possibly insecure) $PATH.
delete $ENV{PATH};


###############################################################################
#### Process CGI variables and initialize. ####################################
###############################################################################

#
# Create a new CGI object.
my $q = new CGI;

#
# The data structure that will hold all session data.
my $File;

#
# Pseudo-SSI include header and footer for output.
$File->{'Header'} = &prepSSI({
			      File     => $CFG->{'Header'},
			      Title    => 'Validation Results',
			      Revision => $VERSION,
			     });
$File->{'Footer'} = &prepSSI({
			      File => $CFG->{'Footer'},
			      Date => q$Date: 2002-10-12 12:55:23 $,
			     });

#
# SSI Footer for static pages does not include closing tags for body & html.
$File->{'Footer'} .= qq(  </body>\n</html>\n);

#
# Prepare standard HTML preamble for output.
$File->{'Results'}  = "Content-Language: en\n";
$File->{'Results'} .= "Content-Type: text/html; charset=utf-8\n\n";
$File->{'Results'} .= $File->{'Header'};


##############################################
# Populate $File->{Env} -- Session Metadata. #
##############################################

#
# The URL to this CGI Script.
$File->{Env}->{'Self URI'} = $q->url(-query => 0);

#
# Initialize parameters we'll need (and override) later.
# (casing policy: lowercase early)
$File->{Charset}->{Use}      = ''; # The charset used for validation.
$File->{Charset}->{Auto}     = ''; # Autodetection using XML rules (Appendix F)
$File->{Charset}->{HTTP}     = ''; # From HTTP's "charset" parameter.
$File->{Charset}->{META}     = ''; # From HTML's <meta http-equiv>.
$File->{Charset}->{XML}      = ''; # From the XML Declaration.
$File->{Charset}->{Override} = ''; # From CGI/user override.

#
# Array (ref) used to store character offsets for the XML report.
$File->{Offsets}->[0] = [0, 0]; # The first item isn't used...

#
# List to hold line numbers for encoding errors
$File->{Lines} = [];


#########################################
# Populate $File->{Opt} -- CGI Options. #
#########################################

#
# Preprocess the CGI parameters.
$q = &prepCGI($File, $q);

#
# Set session switches.
$File->{Opt}->{'Outline'}        = $q->param('outline') ? TRUE                   :  FALSE;
$File->{Opt}->{'Show Source'}    = $q->param('ss')      ? TRUE                   :  FALSE;
$File->{Opt}->{'Show Parsetree'} = $q->param('sp')      ? TRUE                   :  FALSE;
$File->{Opt}->{'No Attributes'}  = $q->param('noatt')   ? TRUE                   :  FALSE;
$File->{Opt}->{'Show ESIS'}      = $q->param('esis')    ? TRUE                   :  FALSE;
$File->{Opt}->{'Show Errors'}    = $q->param('errors')  ? TRUE                   :  FALSE;
$File->{Opt}->{'Verbose'}        = $q->param('verbose') ? TRUE                   :  FALSE;
$File->{Opt}->{'Debug'}          = $q->param('debug')   ? TRUE                   :  FALSE;
$File->{Opt}->{'No200'}          = $q->param('No200')   ? TRUE                   :  FALSE;
$File->{Opt}->{'Charset'}        = $q->param('charset') ? lc $q->param('charset'):     '';
$File->{Opt}->{'DOCTYPE'}        = $q->param('doctype') ? $q->param('doctype')   :     '';
$File->{Opt}->{'URI'}            = $q->param('uri')     ? $q->param('uri')       :     '';
$File->{Opt}->{'Output'}         = $q->param('output')  ? $q->param('output')    : 'html';

$DEBUG = $File->{Opt}->{Debug};

&abort_if_error_flagged($File, 0);

#
# Get the file and metadata.
if ($q->param('uploaded_file')) {
  $File = &handle_file($q, $File);
} elsif ($q->param('fragment')) {
  $File = &handle_frag($q, $File);
} elsif ($q->param('uri')) {
  $File = &handle_uri($q, $File);
}


#
# Get rid of the CGI object.
undef $q;

#
# We don't need STDIN any more, so get rid of it to avoid getting clobbered
# by Apache::Registry's idiotic interference under mod_perl.
untie *STDIN;


#
# Abort if an error was flagged during initialization.
&abort_if_error_flagged($File, 0);


###############################################################################
#### Output validation results. ###############################################
###############################################################################


$File = &find_xml_encoding ($File);

#
# Decide on a charset to use (first part)
#
if ($File->{Charset}->{HTTP}) { # HTTP, if given, is authoritative.
  $File->{Charset}->{Use} = $File->{Charset}->{HTTP};
} elsif ($File->{ContentType} =~ m(^text/([-.a-zA-Z0-9]\+)?xml$)) {
  # Act as if $http_charset was 'us-ascii'. (MIME rules)
  $File->{Charset}->{Use} = 'us-ascii';
  &add_warning($File, <<".EOF.");
      <em>Note:</em>
      The HTTP Content-Type field did not contain a "charset" attribute,
      but the Content-Type was one of the XML text/* sub-types. The relevant
      specification (RFC 3023) specifies a strong default of "us-ascii" for
      such documents so we will use this value regardless of any encoding you
      may have indicated elsewhere. If you would like to use a different
      encoding, you should arrange to have your server send this new encoding
      information.
.EOF.
} elsif ($File->{Charset}->{XML}) {
  $File->{Charset}->{Use} = $File->{Charset}->{XML};
} elsif ($File->{Charset}->{Auto} =~ /^utf-16[bl]e$/ && $File->{BOM} == 2) {
  $File->{Charset}->{Use} = 'utf-16';
} elsif ($File->{ContentType} =~ m(^application/([-.a-zA-Z0-9]+\+)?xml$)) {
  $File->{Charset}->{Use} = "utf-8";
}

$File->{Content} = &normalize_newlines($File->{Bytes},
                       exact_charset($File, $File->{Charset}->{Use}));
$File->{Content}->[0] = substr $File->{Content}->[0], $File->{BOM}; # remove BOM
#### add warning about BOM in UTF-8

#
# Try to extract META charset
# (works only if ascii-based and reasonably clean before <meta>)
$File = &preparse($File);
unless ($File->{Charset}->{Use}) {
  $File->{Charset}->{Use} = $File->{Charset}->{META};
}

if (&conflict($File->{Opt}->{Charset}, '(detect automatically)')) {
  my ($override, undef) = split(/\s/, $File->{Opt}->{Charset}, 2);
  $File->{Charset}->{Use} = $File->{Charset}->{Override} = lc($override);
  # message about 'charset override' in effect comes later
}

unless ($File->{Charset}->{Use}) {
  $File->{'Error Flagged'} = TRUE;
  $File->{'Error Message'} = <<".EOF.";
    <p>
      I was not able to extract a character encoding labeling from any of
      the valid sources for such information. Without encoding information it
      is impossible to validate the document. The sources I tried are:
    </p>
    <ul>
      <li>The HTTP Content-Type field.</li>
      <li>The XML Declaration.</li>
      <li>The HTML "META" element.</li>
    </ul>
    <p>
      And I even tried to autodetect it using the algorithm defined in
      <a href="http://www.w3.org/TR/REC-xml#sec-guessing">Appendix F of
        the XML 1.0 Recommendation</a>.
    </p>
    <p>
      Since none of these sources yielded any usable information, I will not be
      able to validate this document. Sorry. Please make sure you specify the
      character encoding in use.
    </p>
.EOF.
}

#
# Abort if an error was flagged while finding the encoding.
&abort_if_error_flagged($File, 0);


#
# Check the detected Encoding and transcode.
if (&conflict($File->{Charset}->{Use}, 'utf-8')) {
  $File = &transcode($File);
  &abort_if_error_flagged($File, 0);
}


$File = &check_utf8($File) unless $File->{Charset}->{Use};
$File = &byte_error($File);

#
# Abort if an error was flagged during transcoding
&abort_if_error_flagged($File, O_SOURCE);



#
# 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 ($File->{Opt}->{DOCTYPE}
    and not $File->{Opt}->{DOCTYPE} =~ /(Inline|detect)/i) {
  $File->{Content} = &suppress_doctype($File->{Content});
  unshift @{$File->{Content}}, $CFG->{'Doctypes'}->{$File->{Opt}->{DOCTYPE}};
  my $dtd = ent($File->{Opt}->{DOCTYPE});
  &add_warning($File, <<".EOF.");
  <strong>DOCTYPE Override in effect!</strong> Any DOCTYPE Declaration in the
  document has been suppressed and the DOCTYPE for
  &#171;<code>$dtd</code>&#187; inserted instead. The document will not be
  Valid until you alter the source file to reflect this new DOCTYPE.
.EOF.
  $File->{Tentative} |= T_ERROR; # Tag it as Invalid.
}

#
# 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+xml'  if $File->{DOCTYPE} =~ /xhtml/i;
$File->{Type} = 'mathml+xml' if $File->{DOCTYPE} =~ /mathml/i;


#
# Sanity check Charset information and add any warnings necessary.
$File = &charset_conflicts($File);


#
# Print different things if we got redirected or had a file upload.
if ($File->{'Is Upload'}) {
  &add_table($File, 'File', &ent($File->{URI}));
} else {
  my $size = (length($File->{Opt}->{URI}) || 38) + 2;
  $size = 70 if $size > 70;

  if (URI::eq("$File->{Opt}->{URI}", $File->{URI})) {
    &add_table($File, qq(<label title="Address of Page to Validate (accesskey: 1)" for="uri">Address</label>),
	       [1, 2, '<input accesskey="1" type="text" id="uri" name="uri" size="' . $size
	       . '" value="' . &ent($File->{Opt}->{URI}) . '" />']);
  } else {
    my $furi = &ent($File->{URI});
    &add_table($File, qq(<label title="Address of Page to Validate (accesskey: 1)" for="uri">URI</label>),
	       '<input accesskey="1" type="text" id="uri" name="uri" size="' . $size
	       . '" value="' . $furi . '" />');
    &add_warning($File, '<em>Note:</em> The URI you gave me, &#171;<code>' .
		 &ent($File->{Opt}->{URI}) . '</code>&#187;, ' .
		 'returned a redirect to ' .
		 '&#171;<code>' . $furi . '</code>&#187;.');
  }
}


if ($File->{Opt}->{Verbose}) {
  &add_table($File, "Modified", &ent($File->{Modified})) if $File->{Modified};
  &add_table($File, "Server",   &ent($File->{Server}))   if $File->{Server};
  &add_table($File, "Size",     &ent($File->{Size}))     if $File->{Size};
}

if ($File->{'Is Upload'}) {
  &add_table($File, 'Encoding', &ent($File->{Charset}->{Use}));
} else {
  &add_table($File,
	     qq(<label accesskey="2" title="Character Encoding (accesskey: 2)" for="charset">Encoding</label>),
	     &ent($File->{Charset}->{Use}),
	     &CGI::popup_menu(
			      -name      => 'charset',
			      -id        => 'charset',
			      -values => [
					  '(detect automatically)',
					  'utf-8 (Unicode, worldwide)',
					  'utf-16 (Unicode, worldwide)',
					  'iso-8859-1 (Western Europe)',
					  'iso-8859-2 (Central Europe)',
					  'iso-8859-3 (Maltese)',
					  'iso-8859-4 (Baltic Rim)',
					  'iso-8859-5 (Cyrillic)',
					  'iso-8859-6-i (Arabic)',
					  'iso-8859-7 (Greek)',
					  'iso-8859-8-i (Hebrew)',
					  'iso-8859-9 (Turkish)',
					  'iso-8859-10 (Latin 6)',
					  'iso-8859-13 (Latin 7)',
					  'iso-8859-14 (Celtic)',
					  'iso-8859-15 (Latin 9)',
					  'us-ascii (basic English)',
					  'euc-jp (Japanese, Unix)',
					  'shift_jis (Japanese, Win/Mac)',
					  'iso-2022-jp (Japanese, email)',
					  'euc-kr (Korean)',
					  'gb2312 (Chinese, simplified)',
					  'gb18030 (Chinese, simplified)',
					  'big5 (Chinese, traditional)',
					  'tis-620 (Thai)',
					  'koi8-r (Russian)',
					  'koi8-u (Ukrainian)',
					  'macintosh (MacRoman)',
					  'windows-1250 (Central Europe)',
					  'windows-1251 (Cyrillic)',
					  'windows-1252 (Western Europe)',
					  'windows-1253 (Greek)',
					  'windows-1254 (Turkish)',
					  'windows-1255 (Hebrew)',
					  'windows-1256 (Arabic)',
					  'windows-1257 (Baltic Rim)',
					 ],
			   )
	    );
}


#
# By default, use SGML catalog file and SGML Declaration.
my $catalog  = File::Spec->catfile($CFG->{'SGML Library'}, 'sgml.soc');
my @xmlflags = qw(
		  -R
		  -wvalid
		  -wnon-sgml-char-ref
		  -wno-duplicate
		  -wunclosed
		 );

#
# Switch to XML semantics if file is XML.
if (&is_xml($File->{Type})) {
  $catalog  = File::Spec->catfile($CFG->{'SGML Library'}, 'xml.soc');
  push(@xmlflags, '-wxml');
}


#
# Defaults for SP; turn off fixed charset mode and set encoding to UTF-8.
$ENV{SP_CHARSET_FIXED} = 'NO';
$ENV{SP_ENCODING}      = 'UTF-8';
$ENV{SP_BCTF}          = 'UTF-8';

#
# Tell onsgmls about the SGML Library.
$ENV{SGML_SEARCH_PATH} = $CFG->{'SGML Library'};


##
## HTML. Turn back to SGML semantics.
#if (&is_html($File->{Type})) {
#  $ENV{SP_CHARSET_FIXED} = 'YES';
#  $ENV{SP_ENCODING}      = 'UTF-8';
#  $catalog  = File::Spec->catfile($CFG->{'SGML Library'}, 'catalog');
#  @xmlflags = '-wnon-sgml-char-ref';
#}

##
## MathML and XHTML. Must be here because they're usually served as text/html
## to deal with braindead browsers. In other words, these override the check for &is_html.
#$catalog = File::Spec->catfile($CFG->{'SGML Library'}, 'xhtml.soc')
#  if &is_xhtml($File->{Type});
#$catalog = File::Spec->catfile($CFG->{'SGML Library'}, 'mathml.soc')
#  if &is_mathml($File->{Type});


my @cmd = ($CFG->{'SGML Parser'}, '-c', $catalog, '-E0', @xmlflags);

if ($DEBUG) {
  &add_table($File, 'Command',
             [1, 2, &ent("@cmd")]);
  &add_table($File, 'SP_CHARSET_FIXED',
             [1, 2, '<code>' . &ent($ENV{SP_CHARSET_FIXED}) . '</code>']);
  &add_table($File, 'SP_ENCODING',
             [1, 2, '<code>' . &ent($ENV{SP_ENCODING})      . '</code>']);
  &add_table($File, 'SP_BCTF',
             [1, 2, '<code>' . &ent($ENV{SP_BCTF})          . '</code>']);
}

#
# Temporary filehandles.
my $spin  = IO::File->new_tmpfile;
my $spout = IO::File->new_tmpfile;
my $sperr = IO::File->new_tmpfile;

#
# Dump file to a temp file for parsing.
for (@{$File->{Content}}) {
  print $spin $_, "\n";
}

#
# seek() to beginning of the file.
seek $spin, 0, 0;

#
# Run it through SP, redirecting output to temporary files.
my $pid = do {
  no warnings 'once';
  local(*SPIN, *SPOUT, *SPERR)  = ($spin, $spout, $sperr);
  open3("<&SPIN", ">&SPOUT", ">&SPERR", @cmd);
};


#
# Close input file, reap the kid, and rewind temporary filehandles.
undef $spin;
waitpid $pid, 0;
seek $_, 0, 0 for $spout, $sperr;

$File = &parse_errors($File, $sperr); # Parse error output.
undef $sperr; # Get rid of no longer needed filehandle.

$File->{ESIS} = [];
my $elements_found = 0;
while (<$spout>) {
  push @{$File->{'DEBUG'}->{ESIS}}, $_;
  $elements_found++ if /^\(/;

  if ($File->{Type} eq 'xml' or $File->{Type} eq 'xhtml') {
    if (/^Axmlns() \w+ (.*)/ or /^Axmlns:([^ ]+) \w+ (.*)/) {
      if (not $File->{Namespace} and $elements_found == 0 and $1 eq "") {
	$File->{Namespace} = $2;
      }
      $File->{Namespaces}->{$2}++;
    }
  }
  next if / IMPLIED$/;
  next if /^ASDAFORM CDATA /;
  next if /^ASDAPREF CDATA /;
  chomp; # Removes trailing newlines
  push @{$File->{ESIS}}, $_;
}
undef $spout;

if ($File->{ESIS}->[-1] =~ /^C$/) {
  undef $File->{ESIS}->[-1];
  $File->{'Is Valid'} = TRUE;
} else {
  $File->{'Is Valid'} = FALSE;
}


#
# Set Version to be the FPI initially.
$File->{Version} = $File->{DOCTYPE};

#
# Extract any version attribute from the ESIS.
for (@{$File->{ESIS}}) {
  no warnings 'uninitialized';
  next unless /^AVERSION CDATA (.*)/;
  $File->{Version} = $1;
  last;
}

#
# Force "XML" if type is an XML type and an FPI was not found.
# Otherwise set the type to be the FPI.
if (&is_xml($File->{Type}) and not $File->{DOCTYPE}) {
  $File->{Version} = 'XML';
} else {
  $File->{Version} = $File->{DOCTYPE} unless $File->{Version};
}


#$File->{Version} = $File->{DOCTYPE} if &is_xhtml($File->{Type});
#$File->{Version} = $File->{DOCTYPE} if &is_mathml($File->{Type});
#$File->{Version} = $File->{DOCTYPE} if &is_svg($File->{Type});
#$File->{Version} = $File->{DOCTYPE} if &is_smil($File->{Type});

#
# Get the pretty text version of the FPI if a mapping exists.
if (my $prettyver = $CFG->{'FPI to Text'}->{$File->{Version}}) {
  $File->{Version} = $prettyver;
} else {
  $File->{Version} = &ent($File->{Version});
}

if ($File->{'Is Upload'}) {
  &add_table($File, 'Doctype', $File->{Version});
} else {
  &add_table($File, qq(<label accesskey="3" for="doctype" title="Document Type (accesskey: 3)">Doctype</label>),
	     $File->{Version},
	     &CGI::popup_menu(
			      -name => 'doctype',
			      -id => 'doctype',
			      -values => [
					  '(detect automatically)',
					  'XHTML 1.0 Strict',
					  'XHTML 1.0 Transitional',
					  'XHTML 1.0 Frameset',
					  'HTML 4.01 Strict',
					  'HTML 4.01 Transitional',
					  'HTML 4.01 Frameset',
					  'HTML 3.2',
					  'HTML 2.0',
					 ],
			     )
	    );
}


if ($File->{Type} eq 'xml' or $File->{Type} eq 'xhtml') {
  my $rns = &ent($File->{Namespace});
  if ($File->{Type} eq 'xhtml' and $File->{Namespace} ne 'http://www.w3.org/1999/xhtml') {
    &add_warning($File, "Unknown namespace (&#171;<code>$rns</code>&#187;) for text/html document!");
  } elsif ($File->{Type} eq 'svg' and $File->{Namespace} ne 'http://www.w3.org/2000/svg') {
    &add_warning($File, "Unknown namespace (&#171;<code>$rns</code>&#187;) for SVG document!");
  }
  if ($File->{Namespace} ne '') {
    &add_table($File, 'Root Namespace', qq(<a href="$rns">$rns</a>));
  }

  if (scalar keys %{$File->{Namespaces}} > 1) {
    my $namespaces = '<ul>';
    for (keys %{$File->{Namespaces}}) {
      my $ns = &ent($_);
      $namespaces .= qq(\t<li><a href="$ns">$ns</a></li>\n)
          unless $_ eq $File->{Namespace}; # Don't repeat Root Namespace.
    }
    &add_table($File, 'Other Namespaces', $namespaces . '</ul>');
  }
}


if (defined $File->{Tentative}) {
  my $class = '';
     $class .= ($File->{Tentative} & T_INFO  ? ' info'    :'');
     $class .= ($File->{Tentative} & T_WARN  ? ' warning' :'');
     $class .= ($File->{Tentative} & T_ERROR ? ' error'   :'');
     $class .= ($File->{Tentative} & T_FATAL ? ' fatal'   :'');

  unless ($File->{Tentative} == T_DEBUG) {
    $File->{Notice} = <<".EOF.";
    <p id="Notice" class="$class">
      Please note that you have chosen one or more options that alter the
      content of the document before validation, or have not provided enough
      information to accurately validate the document. Even if no errors are
      reported below, the document will not be valid until you manually make
      the changes we have performed automatically. Specifically, if you used
      some of the options that override a property of the document (e.g. the
      DOCTYPE or Character Encoding), you must make the same change to the
      source document or the server setup before it can be valid. You will
      also need to insert an appropriate DOCTYPE Declaration or Character
      Encoding (the "charset" parameter for the Content-Type HTTP header) if
      any of those are missing.
    </p>
.EOF.
  }
}


if ($File->{Opt}->{Output} eq 'xml') {
  &report_xml($File);
} elsif ($File->{Opt}->{Output} eq 'earl') {
  &report_earl($File);
} elsif ($File->{Opt}->{Output} eq 'n3') {
  &report_n3($File);
} else {
  print $File->{Results};
  print qq(    <div class="meat">\n);

  if ($File->{'Is Valid'} and not $DEBUG) {
    &report_valid($File);
  } else {
    $File->{Opt}->{'Show Source'} = TRUE;
    print &jump_links($File);
    print qq(<div class="splash">\n);
    &print_table($File);
    &print_warnings($File);
    print qq(</div>\n);
    &report_errors($File);
    &outline($File)     if $File->{Opt}->{'Outline'};
    &show_source($File) if $File->{Opt}->{'Show Source'};
    &parse_tree($File)  if $File->{Opt}->{'Show Parsetree'};
    &show_esis($File)   if $File->{Opt}->{'Show ESIS'};
    &show_errors($File) if $File->{Opt}->{'Show Errors'};
  }

  print qq(</div> <!-- End of "meat". -->\n); # End of "Meat".
  print $File->{'Footer'};
}

#
# Get rid of $File object and exit.
undef $File;
exit;


#############################################################################
# Subroutine definitions
#############################################################################

#
# Add a row to the metadata-table datastructure.
#
# Takes 3 or more arguments. The first is the reference to the datastructure to
# use for storing the table. The second is the header for this row. The third
# and subsequent arguments are table data cells. Each argument corresponds to
# exactly one table data cell. If the argument is a string it is inserted
# directly. If it is a reference it is assumed to be a reference to an array
# of 3 elements. The 3 are: rowspan, colspan, and data.
#
# Make sure that the arguments are properly encoded, this uses them as is.
#
sub add_table {
  my $File = shift;
  my $TH   = shift;
  my @td;

  foreach my $td (@_) {
    if (ref $td) {
      push @td, $td;
    } else {
      push @td, [1, 1, $td];
    }
  }

  if (defined $File->{Table}->{Max}) {
    $File->{Table}->{Max} = scalar @td
      if $File->{Table}->{Max} < scalar @td;
  } else {
    $File->{Table}->{Max} = scalar @td;
  }

  push @{$File->{Table}->{Data}}, { Head => $TH, Tail => \@td};
}



#
# Print the table containing the metadata about the Document Entity.
sub print_table {
  my $File = shift;

  unless ($File->{'Is Valid'}) {
    &add_table($File, 'Errors', scalar(@{$File->{Errors}}));
  }

  print qq(  <form id="form" method="get" action="check">\n)
    unless $File->{'Is Upload'};

  print join '', @{&serialize_table($File, 'header')};

  my $Options = {};
  my $Form    = {};
  $Form->{Table}->{Fieldset}  = TRUE;
  $Form->{Table}->{Accesskey} = '4';
  $Form->{Table}->{Legend}    = 'Revalidate With Options: (accesskey: 4)';


  add_table($Options, '', qq(<label title="Show Page Source (accesskey: 5)"><input type="checkbox" value="" name="ss" ) .
	    qq(accesskey="5" ) .
	     ($File->{Opt}->{'Show Source'}      ? 'checked="checked"' : '') . ' />Show&nbsp;Source</label>',
	    '<label title="Show an Outline of the document (accesskey: 6)"><input type="checkbox" value="" name="outline" ' .
	    qq(accesskey="6" ) .
	    ($File->{Opt}->{'Outline'} ? 'checked="checked"' : '') . ' />Outline</label>');
  add_table($Options, '',
	    '<label title="Show Parse Tree (accesskey: 7)"><input type="checkbox" value="" name="sp" ' .
	    qq(accesskey="7" ) .
	    ($File->{Opt}->{'Show Parsetree'}      ? 'checked="checked"' : '') . ' />Parse&nbsp;Tree</label>',
	    '<label title="Exclude Attributes from Parse Tree (accesskey: 8)"><input type="checkbox" value="" name="noatt" ' .
	    qq(accesskey="8" ) .
	    ($File->{Opt}->{'No Attributes'}   ? 'checked="checked"' : '') . ' />...no&nbsp;attributes</label>'
	   );

  add_table(
	    $Form,
	    '<input type="submit" value="Revalidate" accesskey="9" title="Revalidate file (accesskey: 9)" />',
	    [1, $File->{Table}->{Max}, join('', @{&serialize_table($Options, 'options')})]
	   );

  print <<".EOF.";
      <fieldset>
        <legend accesskey="4">Revalidate With Options</legend>
.EOF.
  print join '', @{&serialize_table($Form, 'header')};
  print qq(      </fieldset>\n);

  print qq(  </form>\n) unless $File->{'Is Upload'};
}

#
# Serialize a table datastructure ($th, @td) into HTML.
# Takes two arguments; the datastructure, and a CSS class name for the table.
# Returns a reference to an array of lines (to enable re-indentation).
sub serialize_table {
  my $table = shift;
  my $class = shift;
  my @table = ();

  push @table, qq(<table class="$class">\n);

  foreach my $tr (@{$table->{Table}->{Data}}) {
    if (ref $tr->{Head}) {
      my $opts = '';
      push @table, "  <tr>\n";
      if ($tr->{Head}->[0] > 1) {
	$opts .= qq( rowspan="$tr->{Head}->[0]");
      }
      if ($tr->{Head}->[1] > 1) {
	$opts .= qq( colspan="$tr->{Head}->[1]");
      }
      push @table, "    <th$opts>" . $tr->{Head}->[2] . ": </th>\n";
    } elsif ($tr->{Head}) {
      push @table, "  <tr>\n";
      push @table, "    <th>" . $tr->{Head} . ": </th>\n";
    } else {
      push @table, "  <tr>\n";
      # Table has no header column.
    }

    for (my $i = 0; $i < scalar @{$tr->{Tail}}; $i++) {
      my $opts = '';
      if ($tr->{Tail}->[$i]->[0] > 1) {
	$opts .= qq( rowspan="$tr->{Tail}->[$i]->[0]");
      }
      if ($tr->{Tail}->[$i]->[1] > 1) {
	$opts .= qq( colspan="$tr->{Tail}->[$i]->[1]");
      }
      push @table, qq(    <td$opts>) . $tr->{Tail}->[$i]->[2] . "</td>\n";
    }
    push @table, "  </tr>\n";
  }
  push @table, qq(</table>\n);

  return \@table;
}


#
# Add a waring message to the output.
sub add_warning {push @{shift->{Warnings}}, shift};


#
# Print out a list of warnings.
sub print_warnings {
  my $File = shift;
  return unless defined @{$File->{Warnings}};
  print qq(  <ul id="Warnings">\n);
  print qq(    <li>$_</li>\n) for @{$File->{Warnings}};
  print "  </ul>\n";
}

#
# Print HTML explaining why/how to use a DOCTYPE Declaration.
sub doctype_spiel {
  return <<".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/xhtml1/">XHTML 1.0</a> document:
    </p>

    <pre>
      &lt;!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
        "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"&gt;
      &lt;html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en"&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.
}


#
# Leave a message and then die (use for internal errors only)
sub internal_error {
  my $File = shift;
  my ($dieMessage) = shift;
  print <<"EOF";
    <hr />
    <strong class="error">Internal server error ($dieMessage).</strong>
    Please contact <a href="mailto:$CFG->{Maintainer}">maintainer</a>.
EOF
  print $File->{'Footer'};
  croak $dieMessage, "\n";
}


#
# Generate HTML for the "Jump to:" links in results.
sub jump_links {
  return <<".EOF.";
      <p id="skip" class="jumpbar">
        Jump To:
        [<a title="Result of Validation" href="#results">Results</a>]
        [<a title="Listing of Source Input" href="#source">Source&nbsp;Listing</a>]
        [<a title="Document Parse Tree" href="#parse">Parse&nbsp;Tree</a>]
        [<a title="Document Outline" href="#outline">Outline</a>]
      </p>
.EOF.
}


#
# Proxy authentication requests.
sub authenticate {
  my $File       = shift;
  my $resource   = shift;
  my $authHeader = shift;
  my $realm = $resource;
  $realm =~ s([^\w\d.-]*){}g;
  $authHeader =~ s( realm=([\'\"])?([^\1]+)\1){ realm="$realm-$2"};

    print <<"EOF";
Status: 401 Authorization Required
WWW-Authenticate: $authHeader
Connection: close
Content-Type: text/html; charset=utf-8

<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
  "http://www.w3.org/TR/1999/REC-html401-19991224/loose.dtd">
<html lang="en" xml:lang="en">
  <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, <code><a href="$resource">$resource</a></code>,
      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="$CFG->{'Home Page'}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>
      You should also be aware that the way we proxy this authentication
      information defeats the normal working of HTTP Authentication.
      If you authenticate to server A, your browser may keep sending
      the authentication information to us every time you validate
      a page, regardless of what server it's on, and we'll happily pass
      that on to the server thereby making it possible for a malicious
      server operator to capture your credentials.
    </p>
    <p>
      Due to the way HTTP Authentication works there is no way we can
      avoid this. We are using some "tricks" to fool your client into
      not sending this information in the first place, but there is no
      guarantee this will work. If security is a concern to you, you
      may wish to avoid validating protected resources or take extra
      precautions to prevent your browser from sending authentication
      information when validating other servers.
    </p>
    <p>
      Also 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
}


#
# Complain about unknown HTTP responses.
sub http_error {
  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>
    <p><code>$code $message</code></p>
  </blockquote>

  <p>
    Please make sure you have entered the URI correctly.
  </p>

EOF
}


#
# Print blurb advocating using the CSS Validator.
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
}


sub daily_tip {
  my @tipAddrs = keys %{$CFG->{'Tips DB'}};
  srand(time());
  my $tipAddr = $tipAddrs[rand scalar @tipAddrs];
  my $tipSlug = $CFG->{'Tips DB'}->{$tipAddr};

  return <<"EOHD";
  <dl class="tip">
    <dt><a href="http://www.w3.org/2001/06tips/">Tip Of The Day</a>:</dt>
    <dd><a href="$tipAddr">$tipSlug</a></dd>
  </dl>
EOHD
}


#
# Fetch an URI and return the content and selected meta-info.
sub handle_uri {
  my $q    = shift; # The CGI object.
  my $File = shift; # The master datastructure.

  my $uri = new 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?

  # @@@FIXME@@@:
  #   Disable checking if the URI is local (or private) for security reasons,
  #   or at least make it configurable to do so.
  #   eg. /^(localhost(\.localdomain)?|127\..+)$/ (+ private networks)
  #
  $ua->protocols_allowed($CFG->{'Allowed Protocols'} || ['http', 'https']);

  unless ($ua->is_protocol_supported($uri)) {
    $File->{'Error Flagged'} = TRUE;
    $File->{'Error Message'} = &uri_rejected($uri);
    return $File;
  }

  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 || $File->{Opt}->{'No200'}) {
    if ($res->code == 401) {
      &authenticate($File, $res->request->url, $res->www_authenticate);
    } else {
      print $File->{Results};
      &http_error($uri->as_string, $res->code, $res->message);
    }
    print $File->{'Footer'};
    exit;
  }

  my($type, $ct, $charset) = &parse_content_type($File, $res->header('Content-Type'));

  my $lastmod = undef;
  if ( $res->last_modified ) {
    $lastmod = scalar(gmtime($res->last_modified));
  }

  $File->{Bytes}           = $res->content;
  $File->{Type}            = $type;
  $File->{ContentType}     = $ct;
  $File->{Charset}->{HTTP} = lc $charset;
  $File->{Modified}        = $lastmod;
  $File->{Server}          = scalar $res->server;
  $File->{Size}            = scalar $res->content_length;
  $File->{URI}             = scalar $res->request->url;
  $File->{'Is Upload'}     = FALSE;

  return $File;

}

#
# Handle uploaded file and return the content and selected meta-info.
sub handle_file {
  my $q    = shift; # The CGI object.
  my $File = shift; # The master datastructure.

  my $f = $q->param('uploaded_file');
  my $h = $q->uploadInfo($f);
  my $file;

  local $/ = undef; # set line delimiter so that <> reads rest of file
  $file = <$f>;

  my($type, $ct, $charset) = &parse_content_type($File, $h->{'Content-Type'});

  $File->{Bytes}           = $file;
  $File->{Type}            = $type;
  $File->{ContentType}     = $ct;
  $File->{Charset}->{HTTP} = lc $charset;
  $File->{Modified}        = $h->{'Last-Modified'};
  $File->{Server}          = $h->{'Server'};
  $File->{Size}            = $h->{'Content-Length'};
  $File->{URI}             = "$f"; # Need to stringify because we want ref
                                   # to return false later in add_table.  This
                                   # is also a file handle... see man CGI.
  $File->{'Is Upload'}     = TRUE;

  return $File;
}

#
# Handle uploaded file and return the content and selected meta-info.
sub handle_frag {
  my $q    = shift; # The CGI object.
  my $File = shift; # The master datastructure.

  $File->{Bytes}       = $q->param('fragment');
  $File->{Type}        = 'html';
  $File->{Modified}    = '';
  $File->{Server}      = '';
  $File->{Size}        = '';
  $File->{URI}         = 'upload://Form Submission';
  $File->{'Is Upload'} = TRUE;

  return $File;
}


#
# Parse a Content-Type and parameters. Return document type and charset.
sub parse_content_type {
  my $File         = shift;
  my $Content_Type = shift;
  my $charset      = '';
  my $type         = '';

  my($ct, @param) = split /\s*;\s*/, lc $Content_Type;

  $type = $CFG->{'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;
    }
  }

  if ($type =~ m(/)) {
    $File->{'Error Flagged'} = TRUE;
    $File->{'Error Message'} = <<"    EOF";
    <p class="error">
      Sorry, I am unable to validate this document because its returned
      content-type was <code>$type</code>, which is not currently supported
      by this service.
    </p>
    EOF
  }

  return $type, $ct, $charset;
}


#
# Normalize newline forms (CRLF/CR/LF) to native newline.
sub normalize_newlines {
  my $file = shift;
  local $_ = shift;  #charset
  my $pattern = '';

  # don't use backreference parentheses!
  $pattern = '\x00\x0D(?:\x00\x0A)?|\x00\x0A' if /^utf-16be$/;
  $pattern = '\x0D\x00(?:\x0A\x00)?|\x0A\x00' if /^utf-16le$/;
  # $pattern = '\x00\x00\x00\x0D(?:\x00\x00\x00\x0A)?|\x00\x00\x00\x0A' if /^UCS-4be$/;
  # $pattern = '\x0D\x00\x00\x00(?:\x0A\x00\x00\x00)?|\x0A\x00\x00\x00' if /^UCS-4le$/;
  # insert other special cases here, such as EBCDIC
  $pattern = '\x0D(?:\x0A)?|\x0A' if !$pattern;    # all other cases

  return [split /$pattern/, $file];
}

#
# find exact charset from general one (utf-16)
#
# needed for per-line conversion and line splitting
# (BE is default, but this will apply only to HTML)
sub exact_charset {
  my $File = shift;
  my $general_charset = shift;
  my $exact_charset = $general_charset;

  if ($general_charset eq 'utf-16') {
    if ($File->{Charset}->{Auto} =~ m/^utf-16[bl]e$/) {
	$exact_charset = $File->{Charset}->{Auto};
    } else { $exact_charset = 'utf-16be'; }
  }
  # add same code for ucs-4 here
  return $exact_charset;
}



#
# Return $_[0] encoded for HTML entities (cribbed from merlyn).
#
# Note that this is used both for HTML and XML escaping.
#
sub ent {
  local $_ = shift;
  return '' unless defined; # Eliminate warnings
  s(["<&>"]){'&#' . ord($&) . ';'}ge;  # should switch to hex sooner or later
  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;
}


#
# Suppress any existing DOCTYPE by commenting it out.
sub suppress_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})->eof();
  return [split /\n/, $HTML];
}


#
# Parse errors reported by SP.
sub parse_errors ($$) {
  my $File = shift;
  my $fh   = shift;

  $File->{Errors} = []; # Initialize to an (empty) anonymous array ref.

  for (<$fh>) {
    push @{$File->{'DEBUG'}->{Errors}}, $_;
    my($err, @errors);
    next if /^<OSFD>0:[0-9]+:[0-9]+:[^A-Z]/;
    next if /numbers exceeding 65535 not supported/;
    next if /URL Redirected to/;

    my(@_err) = split /:/;
    next unless $_err[1] eq '<OSFD>0';
    if ($_err[1] =~ m(^<URL>)) {
      @errors = ($_err[0], join(':', $_err[1], $_err[2]), @_err[3..$#_err]);
    } else {
      @errors = @_err;
    }
    $err->{src}  = $errors[1];
    $err->{line} = $errors[2];
    $err->{char} = $errors[3];
    $err->{type} = $errors[4];
    if (
	   $err->{type} eq 'W'
	or $err->{type} eq 'E'
	or $err->{type} eq 'X'
	or $err->{type} eq 'Q'
       ) {
      $err->{msg}  = $errors[5];
#      # get rid of non-BMP related error messages
#      # (pretending SP understands characters beyond the BMP)
#      if ($errors[5] =~ m/"(\d*)" is not a character number in the document character set/) {
#	next if $1 >= 65536 && $1 <= 1114110;
#      }
    } else {
      $err->{type} = 'I';
      $err->{msg}  = $errors[4];
    }

    # Strip curlies from lq-nsgmls output.
    $err->{msg} =~ s/[{}]//g;

    # An unknown FPI and no SI.
    if ($err->{msg} =~ m(cannot generate system identifier for entity)
	or $err->{msg} =~ m(unrecognized DOCTYPE)i
	or $err->{msg} =~ m(no document type declaration)i) {
      $File->{'Error Flagged'} = TRUE;
      $File->{'Error Message'} = <<".EOF.";
     <div class="fatal">
       <h2>Fatal Error: $err->{msg}</h2>
       <p>
         I could not parse this document, because it uses a public identifier
         that is not in my catalog.
       </p>
.EOF.
      $File->{'Error Message'} .= &doctype_spiel;
      $File->{'Error Message'} .= "    </div>\n";
    }

    # No or unknown FPI and a relative SI.
    if ($err->{msg} =~ m(cannot (open|find))) {
      $File->{'Error Flagged'} = TRUE;
      $File->{'Error Message'} = <<".EOF.";
    <div class="fatal">
      <h2>Fatal Error: $err->{msg}</h2>
      <p>
        I could not parse this document, because it makes reference to a
        system-specific file instead of using a well-known public identifier
        to specify the type of markup being used.
      </p>
.EOF.
      $File->{'Error Message'} .= &doctype_spiel;
      $File->{'Error Message'} .= "    </div>\n";
    }

    # No DOCTYPE.
    if ($err->{msg} =~ m(prolog can\'t be omitted)) {
      $File->{'Error Flagged'} = TRUE;
      $File->{'Error Message'} = <<".EOF.";
    <div class="fatal">
      <h2>Fatal Error: No DOCTYPE specified!</h2>
      <p>
        I could not parse this document, because it does not include a
        DOCTYPE Declaration. A DOCTYPE Declaration is mandatory for most
        current markup languages and without such a declaration it is
        impossible to validate this document.
      </p>
.EOF.
      $File->{'Error Message'} .= &doctype_spiel;
      $File->{'Error Message'} .= <<".EOF.";
      <p>
        For a list of possible DOCTYPE Declarations, please see
        the W3C QA Activity's
        <a href="http://www.w3.org/QA/2002/04/valid-dtd-list.html">List
        List of Valid Doctypes</a>.
.EOF.
      $File->{'Error Message'} .= "    </div>\n";
    }


    &abort_if_error_flagged($File, O_SOURCE);
    push @{$File->{Errors}}, $err;
  }
  undef $fh;
  return $File;
}

#
# Generate a HTML report of detected errors.
sub report_errors ($) {
  my $File = shift;

  print <<"EOHD";
    <h2 id="results" class="invalid">This Page Is <strong>NOT</strong> Valid $File->{Version}!</h2>
EOHD

  if ($File->{Type} eq 'xml' or $File->{Type} eq 'xhtml' or $File->{Type} eq 'mathml' or $File->{Type} eq 'svg' or $File->{Type} eq 'smil') {
    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
  }

  print qq(  <ol>\n);

  foreach my $err (@{$File->{Errors}}) {
    my($line, $col) = &truncate_line($File->{Content}->[$err->{line}-1], $err->{char});

    # Strip curlies from lq-nsgmls output.
    $err->{msg} =~ s/[{}]//g;

    # Find index into the %frag hash for the "explanation..." links.
    $err->{idx} =  $err->{msg};
    $err->{idx} =~ s/"[^\"]*"/FOO/g;
    $err->{idx} =~ s/[^A-Za-z ]//g;
    $err->{idx} =~ s/\s+/ /g; # Collapse spaces
    $err->{idx} =~ s/(^\s|\s$)//g; # Remove leading and trailing spaces. )
    $err->{idx} =~ s/(FOO )+/FOO /g; # Collapse FOOs.
    $err->{idx} =~ s/FOO FOO/FOO/g; # Collapse FOOs.

    $line = &ent($line); # Entity encode.
    $line =~ s/\t/ /g;   # Collapse TABs.

    print qq(  <li><em>Line <a href="#line-$err->{line}">$err->{line}</a>, column $col</em>: );
    print qq{<span class="msg">$err->{msg}</span>};
    if (defined $CFG->{'Error to URI'}->{$err->{idx}}) {
      print qq{ (<a href="$CFG->{'Msg FAQ URI'}#$CFG->{'Error to URI'}->{$err->{idx}}">explain...</a>).};
    } elsif ($DEBUG) {
      print qq{ (<code style="background: red">"$err->{idx}"</code>)};
    }

    print qq(\n<pre>  <code class="input">$line</code>\n);
    print ' ' x ($col + 2); # 2 is the number of spaces before <code> above
    print ' ' x 4 if $col != $err->{char}; # only for truncated lines
    print qq(<span class="markup">^</span></pre></li>\n);
  }
  print qq(  </ol>\n);
}


#
# Output "This page is Valid" report.
sub report_valid {
  my $File   = shift;
  my $gifborder   = ' border="0"';
  my $xhtmlendtag = '';
  my($image_uri, $alttext, $gifhw);

  unless ($File->{Version} eq 'unknown' or defined $File->{Tentative}) {
    if ($File->{Version} =~ /^HTML 2\.0$/) {
      $image_uri = "$CFG->{'Home Page'}images/vh20";
      $alttext = "Valid HTML 2.0!";
      $gifborder = "";
    } elsif ($File->{Version} =~ /HTML 3\.2</) {
      $image_uri = "http://www.w3.org/Icons/valid-html32";
      $alttext = "Valid HTML 3.2!";
      $gifhw   = ' height="31" width="88"';
    } elsif ($File->{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 ($File->{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 ($File->{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 ($File->{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 ($File->{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 ($File->{Version} =~ /XHTML Basic 1.0/) {
      $image_uri = "$CFG->{'Home Page'}/images/vxhtml-basic10";
      $alttext = "Valid XHTML Basic 1.0!";
      $gifborder = "";
      $gifhw   = ' height="31" width="88"';
      $xhtmlendtag = " /";
    } elsif ($File->{Version} =~ /XHTML 1.1/) {
      $image_uri = "http://www.w3.org/Icons/valid-xhtml11";
      $alttext = "Valid XHTML 1.1!";
      $gifborder = "";
      $gifhw   = ' height="31" width="88"';
      $xhtmlendtag = " /";
    } elsif ($File->{Version} =~ /HTML 3\.0/) {
      $image_uri = "$CFG->{'Home Page'}images/vh30";
      $alttext = "Valid HTML 3.0!";
    } elsif ($File->{Version} =~ /Netscape/) {
      $image_uri = "$CFG->{'Home Page'}images/vhns";
      $alttext = "Valid Netscape-HTML!";
    } elsif ($File->{Version} =~ /Hotjava/) {
      $image_uri = "$CFG->{'Home Page'}images/vhhj";
      $alttext = "Valid Hotjava-HTML!";
    } elsif ($File->{Version} =~ /ISO\/IEC 15445:2000/) {
      $image_uri = "$CFG->{'Home Page'}images/v15445";
      $alttext = "Valid ISO-HTML!";
    }

    if (defined $image_uri) {
      print qq(    <h2 id="skip" class="valid"><img src="$image_uri"
        alt="$alttext"$gifhw />
      This Page Is Valid $File->{Version}!</h2>\n);
    } elsif ($File->{Version}) {
      print qq(<h2 id="skip" class="valid">This Page Is Valid $File->{Version}!</h2>\n);
    } else {
      print qq(<h2 id="skip" class="valid">This Page Is Valid!</h2>\n);
    }

    print &daily_tip($File, $CFG->{'Tips DB'});
    &print_warnings($File);

    print <<".EOF.";
    <p>
      The document located at
      <code>&lt;URL:<a href="$File->{URI}">$File->{URI}</a>&gt;</code>
      was checked and found to be valid $File->{Version}. This means that
      the resource in question identified itself as
      &ldquo;$File->{Version}&rdquo; and that we successfully performed a
      formal validation using an SGML or XML Parser (depending on the
      markup language used).
    </p>
.EOF.
      if (defined $image_uri) {
	print <<".EOF.";
    <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>
    <code>
    &lt;p&gt;
      &lt;a href="$CFG->{'Home Page'}check/referer"&gt;&lt;img$gifborder
          src="$image_uri"
          alt="$alttext"$gifhw$xhtmlendtag&gt;&lt;/a&gt;
    &lt;/p&gt;
    </code>
    <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>
.EOF.
    }
  } elsif (&is_xml($File->{Type}) and not $File->{DOCTYPE}) {
    print qq(  <h2 class="valid">This document is well-formed XML.</h2>\n);
  } elsif (defined $File->{Tentative}) {
    # don't say it validates and then say it would validate :-)
    # print qq(<h2 class="valid">This Page Is Valid $File->{Version}!</h2>);
    print &daily_tip($File, $CFG->{'Tips DB'});
    &print_warnings($File);
    print "
      <p>
        The document located at
        <code>&lt;URL:<a href='$File->{URI}'>$File->{URI}</a>&gt;</code>
              would validate as $File->{Version} if you updated it to
        match the Options used.
      </p>\n";
  } else {
    print qq(  <h2 class="valid">This document validates as the document type specified!</h2>\n);
    print <<".EOF.";
    <p>
      The document located at
      &lt;URL:<a href="$File->{URI}">$File->{URI}</a>&gt; was checked and found
      to be valid $File->{Version}. This means that the resource in question
      identified itself as &ldquo;$File->{Version}&rdquo; and that we
      successfully performed a formal validation using an SGML or XML Parser
      (depending on the markup language used).
    </p>
.EOF.
  }

  unless ($File->{'Is Upload'}) {
    my $thispage = $File->{Env}->{'Self URI'};
    $thispage .= qq(?uri=$File->{URI});
    $thispage .= ';ss=1'      if $File->{Opt}->{'Show Source'};
    $thispage .= ';sp=1'      if $File->{Opt}->{'Show Parsetree'};
    $thispage .= ';noatt=1'   if $File->{Opt}->{'No Attributes'};
    $thispage .= ';outline=1' if $File->{Opt}->{'Outline'};

    &output_css_validator_blurb($File->{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
    <a href="$thispage">$thispage</a> (or you can just add the current page to
    your bookmarks or hotlist.)</p>
EOHD
  }
}


#
# 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">
    <h2>Outline</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!</li>\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 = &ent($heading);
    print "    <li>$heading</li>\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;

  my $comment = '';

  if ($File->{'Error Flagged'}) {
    $comment = "<p>I have marked lines that I haven't been able to decode.</p>\n";
  }

  print <<"EOF";
  <div id="source" class="mtb">
    <h2>Source Listing</h2>

    <p>Below is the source input I used for this validation:</p>
    $comment
    <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">
    <h2>Parse Tree</h2>
EOF
  if ($File->{Opt}->{'No Attributes'}) {
    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="./#form">the form</a>.
    </p>
EOF
  }

  my $indent   = 0;
  my $prevdata = '';

  print "<pre>\n";
  foreach my $line (@{$File->{ESIS}}) {
    if ($File->{Opt}->{'No Attributes'}) { # 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 = &ent($prevdata);
      $prevdata =~ s/\s+/ /go;
      print wrap(' ' x $indent, ' ' x $indent, $prevdata), "\n";
      undef $prevdata;
    }

    $line = &ent($line);
    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=\"" .
		   $CFG->{'Element Ref URI'} . $CFG->{'Element Map'}->{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";
}


#
# Do an initial parse of the Document Entity to extract charset and FPI.
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 $start = sub {
    my $tag  = shift;
    my $attr = shift;
    my %attr = map {lc($_) => $attr->{$_}} keys %{$attr};

    if ($File->{Root}) {
      if (lc $tag eq 'meta') {
	if (lc $attr{'http-equiv'} eq 'content-type') {
	  if ($attr{content} =~ m(charset\s*=[\s\"\']*([^\s;\"\'>]*))si) {
	    $File->{Charset}->{META} = lc $1;
          }
	}
      }
      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}});

  $File->{DOCTYPE} = '' unless defined $File->{DOCTYPE};

  return $File;
}

#
# Print out the raw ESIS output for debugging.
sub show_esis ($) {
  print <<'EOF';
  <div id="raw_esis" class="mtb">
    <hr />
    <h2><a name="raw_esis">Raw ESIS Output</a></h2>
    <pre>
EOF
  for (@{shift->{'DEBUG'}->{ESIS}}) {
    s/\\012//g;
    s/\\n/\n/g;
    print ent $_;
  }
  print "    </pre>\n  </div>";
}

#
# Print out the raw error output for debugging.
sub show_errors ($) {
  print <<'EOF';
  <div id="raw_errors" class="mtb">
    <hr />
    <h2><a name="raw_errors">Raw Error Output</a></h2>
    <pre>
EOF
  for (@{shift->{'DEBUG'}->{Errors}}) {print ent $_};
  print "    </pre>\n  </div>";
}


#
# Preprocess CGI parameters.
sub prepCGI {
  my $File = shift;
  my    $q = shift;

  # Avoid CGI.pm's "exists but undef" behaviour.
  if (scalar $q->param) {
    foreach my $param ($q->param) {
      next if $param eq 'uploaded_file'; # 'uploaded_file' contains data.
      $q->param($param, TRUE) unless $q->param($param);
    }
  }

  # Futz the URI so "/referer" works.
  $q->param('uri', 'referer') if $q->path_info eq '/referer';

  # Issue a redirect for uri=referer.
  if ($q->param('uri') and $q->param('uri') eq 'referer') {
    print $q->redirect($q->url() . '?uri=' . uri_escape($q->referer));
    exit;
  }

  # Use "url" unless a "uri" was also given.
  $q->param('uri', $q->param('url')) if $q->param('url') and not $q->param('uri');

  # Supersede URI with an uploaded file.
  if ($q->param('uploaded_file')) {
    $q->param('uri', 'upload://' . $q->param('uploaded_file'));
    $File->{'Is Upload'} = TRUE; # Tag it for later use.
  }

  # Supersede URI with an uploaded fragment.
  $q->param('uri', 'upload://Form Submission') if $q->param('fragment');

  # Munge the URI to include commonly omitted prefix.
  my $u = $q->param('uri');
  $q->param('uri', "http://$u") if $u && $u =~ m(^www)i;

  #
  # Flag an error if we didn't get a file to validate.
  unless ($q->param('uri')) {
    $File->{'Error Flagged'} = TRUE;
    $File->{'Error Message'} = &uri_rejected;
  }

  return $q;
}

#
# Preprocess SSI files.
sub prepSSI {
  my $opt = shift;

  my $fh = new IO::File "< $opt->{File}"
    or croak "open($opt->{File}) returned: $!\n";
  my $ssi = join '', <$fh>;
  close $fh or carp "close($opt->{File}) returned: $!\n";

  $ssi =~ s/<!--\#echo var="title" -->/$opt->{Title}/g
    if defined $opt->{Title};

  $ssi =~ s/<!--\#echo var="date" -->/$opt->{Date}/g
    if defined $opt->{Date};

  $ssi =~ s/<!--\#echo\s+var="revision"\s+-->/$opt->{Revision}/g
    if defined $opt->{Revision};

  # No need to parametrize this one, it's always "./" in this context.
  $ssi =~ s|<!--\#echo\s+var="relroot"\s+-->|./|g;

  return $ssi;
}


#
# Output errors for a rejected URI.
sub uri_rejected {
  my $scheme = shift || 'undefined';
  unless ($scheme eq 'undefined') {
    $scheme = $scheme->scheme();
  }

  return sprintf(<<".EOF.", &ent($scheme));
    <div class="error">
      <p>
        Sorry, this type of <a
          href="http://www.w3.org/Addressing/#terms">URI</a>
        (<q>%s</q>) is not supported by this service. Please check
        that you entered the URI correctly.
      </p>
      <p>URIs should be in the form: <code>http://validator.w3.org/</code></p>
      <p>
        If you entered a valid URI using a scheme that we should support,
        please let us know as outlined on our
        <a href="feedback.html">Feedback page</a>. Make sure to include the
        specific URI you would like us to support, and if possible provide a
        reference to the relevant standards document describing the URI scheme
        in question.
      </p>
    </div>
.EOF.
}


#
# Utility subs to tell if type "is" something.
sub is_xml    {shift =~ m(^[^+]+\+xml$)};
sub is_svg    {shift =~ m(^svg)};
sub is_smil   {shift =~ m(^smil)};
sub is_html   {shift =~ m(^html$)};
sub is_xhtml  {shift =~ m(^xhtml)};
sub is_mathml {shift =~ m(^mathml)};


#
# Check charset conflicts and add any warnings necessary.
sub charset_conflicts {
  my $File = shift;
  #
  # Handle the case where there was no charset to be found.
  unless ($File->{Charset}->{Use}) {
    &add_warning($File, <<".EOF.");
      <strong>No Character Encoding detected!</strong>
      To ensure correct validation, processing, and display,
      it is important that the character encoding is properly
      labeled.
      <a href="http://www.w3.org/International/O-charset.html">More
      information...</a>
.EOF.
    $File->{Tentative} |= T_WARN;
  }

  my $cs_use  = $File->{Charset}->{Use}  ? &ent($File->{Charset}->{Use})  : '';
  my $cs_opt  = $File->{Opt}->{Charset}  ? &ent($File->{Opt}->{Charset})  : '';
  my $cs_http = $File->{Charset}->{HTTP} ? &ent($File->{Charset}->{HTTP}) : '';
  my $cs_xml  = $File->{Charset}->{XML}  ? &ent($File->{Charset}->{XML})  : '';
  my $cs_meta = $File->{Charset}->{META} ? &ent($File->{Charset}->{META}) : '';

  #
  # warn about charset override
  if ($File->{Charset}->{Override} &&
      $File->{Charset}->{Override} ne $File->{Charset}->{Use}) {
    &add_warning($File, <<".EOF.");
      <strong>Character Encoding Override in effect!</strong>
      The detected character encoding,
      &#171;<code>$cs_use</code>&#187;, has been suppressed and
      the character encoding &#171;<code>$cs_opt</code>&#187;
      is used instead.
.EOF.
    $File->{Tentative} |= T_ERROR;
  }

  #
  # Add a warning if there was charset info conflict (HTTP header,
  # XML declaration, or <meta> element).
  if (&conflict($File->{Charset}->{HTTP}, $File->{Charset}->{XML})) {
    &add_warning($File, <<".EOF.");
      <strong>Character Encoding mismatch!</strong>
      The character encoding specified in the
        HTTP header (<code>$cs_http</code>)
      is different from the value in the
        XML declaration (<code>$cs_xml</code>).
      I will use the value from the
        HTTP header (<code>$cs_use</code>)
      for this validation.
.EOF.
  } elsif (&conflict($File->{Charset}->{HTTP}, $File->{Charset}->{META})) {
    &add_warning($File, <<".EOF.");
      <strong>Character Encoding mismatch!</strong>
      The character encoding specified in the
        HTTP header (<code>$cs_http</code>)
      is different from the value in the
        <code>&lt;meta&gt;</code> element (<code>$cs_meta</code>).
      I will use the value from the
        HTTP header (<code>$cs_use</code>)
      for this validation.
.EOF.
  }
  elsif (&conflict($File->{Charset}->{XML}, $File->{Charset}->{META})) {
    &add_warning($File, <<".EOF.");
      <strong>Character Encoding mismatch!</strong>
      The character encoding specified in the
        XML declaration (<code>$cs_xml</code>)
      is different from the value in the
        <code>&lt;meta&gt;</code> element (<code>$cs_meta</code>).
      I will use the value from the
        XML declaration (<code>$cs_xml</code>)
      for this validation.
.EOF.
    $File->{Tentative} |= T_WARN;
  }

  return $File;
}


#
# Transcode to UTF-8
sub transcode {
  my $File = shift;

  my ($command, $result_charset) = split " ", $CFG->{Charsets}->{$File->{Charset}->{Use}}, 2;

  $result_charset = exact_charset($File, $result_charset);
  if ($command eq 'I') {
    # test if given charset is available
    eval {my $c = Text::Iconv->new($result_charset, 'utf-8')};
    $command = '' if $@;
  } elsif ($command eq 'X') {
    $@ = "$File->{Charset}->{Use} undefined; replace by $result_charset";
  }

  if ($command ne 'I') {
    my $cs = &ent($File->{Charset}->{Use});
    $File->{'Error Flagged'} = TRUE;
    $File->{'Error Message'} = sprintf(<<".EOF.", $cs, &ent($@));
      <p>Sorry!
        A fatal error occurred when attempting to transcode the character
        encoding of the document. Either we do not support this character
        encoding yet, or you have specified a non-existent character encoding
        (often a misspelling).
      </p>
      <p>The detected character encoding was "%s".</p>
      <p>The error was "%s".</p>
      <p>
        If you believe the character encoding 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.
    return $File;
  }

  my $c = Text::Iconv->new($result_charset, 'utf-8');
  my $line = 0;
  for (@{$File->{Content}}) {
    my $in = $_;
    $line++;
    $_ = $c->convert($_); # $_ is local!!
    if ($in ne "" and $_ eq "") {
      push @{$File->{Lines}}, $line;
      $_ = "#### encoding problem on this line, not shown ####";
    }
  }
  return $File;
}

#
# Check correctness of UTF-8 both for UTF-8 input and for conversion results
sub check_utf8 {
  my $File = shift;

  for (my $i = 0; $i < $#{$File->{Content}}; $i++) {
    # substitution needed for very long lines (>32K), to avoid backtrack
    # stack overflow. Handily, this also happens to count characters.
    local $_ = $File->{Content}->[$i];
    my $count =
    s/  [\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
     //xg;
    if (length) {
      push @{$File->{Lines}}, ($i+1);
      $File->{Content}->[$i] = "#### encoding problem on this line, not shown ####";
      $count = 50; # length of above text
    }
    $count += 0; # Force numeric.
    $File->{Offsets}->[$i + 1] = [$count, $File->{Offsets}->[$i]->[1] + $count];
  }
  return $File;
}

#
# byte error analysis
sub byte_error {
  my $File = shift;
  my @lines = @{$File->{Lines}};
  if (scalar @lines) {
    $File->{'Error Flagged'} = TRUE;
    my $s = $#lines ? 's' : '';
    my $lines = join ', ', split ',', Set::IntSpan->new(\@lines)->run_list;
    my $cs = &ent($File->{Charset}->{Use});
    $File->{'Error Message'} = <<".EOF.";
      <p class="error">
        Sorry, I am unable to validate this document because on line$s
        <strong>$lines</strong>
	it contained one or more bytes that I cannot interpret as
        <code>$cs</code> (in other words, the bytes
        found are not valid values in the specified Character Encoding).
        Please check both the content of the file and the character
        encoding indication.
      </p>
.EOF.
  }
  return $File;
}


#
# Return an XML report for the page.
sub report_xml {
  my $File = shift;

  my $valid = ($File->{'Is Valid'} ? 'Valid' : 'Invalid');
  my $errs  = ($File->{'Is Valid'} ? '0' : scalar @{$File->{Errors}});

  print <<".EOF.";
Content-Type: application/xml; charset=UTF-8
X-W3C-Validator-Status: $valid
X-W3C-Validator-Errors: $errs

<?xml version="1.0" encoding="UTF-8"?>
<?xml-stylesheet type="text/css" href="xml-results.css"?>
.EOF.

  print qq(
<results>
  <meta>
    <uri>), &ent($File->{URI}), qq(</uri>
    <modified>), &ent($File->{Modified}), qq(</modified>
    <server>), &ent($File->{Server}), qq(</server>
    <size>), &ent($File->{Size}), qq(</size>
    <encoding>), &ent($File->{Charset}->{Use}), qq(</encoding>
    <doctype>), &ent($File->{DOCTYPE}), qq(</doctype>
  </meta>
  <warnings>);

  printf qq(\n    <warning>%s</warning>), &ent($_) for @{$File->{Warnings}};
  print "\n  </warnings>\n  <messages>\n";

  foreach my $err (@{$File->{Errors}}) {
    # Strip curlies from lq-nsgmls output.
    $err->{msg} =~ s/[{}]//g;
    chomp $err->{msg};

    # Find index into the %frag hash for the "explanation..." links.
    $err->{idx} =  $err->{msg};
    $err->{idx} =~ s/"[^\"]*"/FOO/g;
    $err->{idx} =~ s/[^A-Za-z ]//g;
    $err->{idx} =~ s/\s+/ /g; # Collapse spaces
    $err->{idx} =~ s/(^\s|\s$)//g; # Remove leading and trailing spaces.
    $err->{idx} =~ s/(FOO )+/FOO /g; # Collapse FOOs.
    $err->{idx} =~ s/FOO FOO/FOO/g; # Collapse FOOs.

    my @offsets = (
		   $File->{Offsets}->[$err->{line}    ]->[0],
		   $File->{Offsets}->[$err->{line} - 1]->[1],
		   $File->{Offsets}->[$err->{line} - 1]->[1] + $err->{char} + $err->{line}
		  );
    printf <<".EOF.", &ent($err->{msg});
    <error><line>$err->{line}</line><column>$err->{char}</column><offset>@offsets</offset><msg>%s</msg></error>
.EOF.
  }

  print <<".EOF.";
  </messages>
</results>
.EOF.
}



#
# Return an EARL report for the page.
sub report_earl {
  my $File = shift;

  my $valid = ($File->{'Is Valid'} ? 'Valid' : 'Invalid');
  my $errs  = ($File->{'Is Valid'} ? '0' : scalar @{$File->{Errors}});

  print <<".EOF.";
Content-Type: application/rdf+xml; charset=UTF-8
X-W3C-Validator-Status: $valid
X-W3C-Validator-Errors: $errs

<?xml version="1.0" encoding="UTF-8"?>
<rdf:RDF
  xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
  xmlns="http://www.w3.org/2001/03/earl/1.0-test#"
  xmlns:val="http://validator.w3.org/this_will_change/do_not_rely_on_it!">

  <Assertor rdf:about="http://validator.w3.org/">
    <name>W3 Validator</name>
    <contactInfo rdf:resource="http://validator.w3.org/about.html"/>
    <testMode rdf:resource="http://www.w3.org/2001/03/earl/1.00#Auto" />

.EOF.

  unless ($File->{'Is Valid'}) {
    printf <<".EOF.", &ent($File->{URI});
  <asserts>
   <Assertion>
    <subject rdf:resource="%s" />
    <result rdf:resource="http://www.w3.org/2001/03/earl/1.00#fails" />
    <testCase rdf:resource="http://www.w3.org/HTML/" />
    <note>Invalid!</note>
   </Assertion>
  </asserts>
.EOF.

    foreach my $err (@{$File->{Errors}}) {
      # Strip curlies from lq-nsgmls output.
      $err->{msg} =~ s/[{}]//g;
      chomp $err->{msg};

      # Find index into the %frag hash for the "explanation..." links.
      $err->{idx} =  $err->{msg};
      $err->{idx} =~ s/"[^\"]*"/FOO/g;
      $err->{idx} =~ s/[^A-Za-z ]//g;
      $err->{idx} =~ s/\s+/ /g; # Collapse spaces
      $err->{idx} =~ s/(^\s|\s\Z)//g; # Remove leading and trailing spaces.
      $err->{idx} =~ s/(FOO )+/FOO /g; # Collapse FOOs.
      $err->{idx} =~ s/FOO FOO/FOO/g; # Collapse FOOs.

      my @offsets = (
		     $File->{Offsets}->[$err->{line}    ]->[0],
		     $File->{Offsets}->[$err->{line} - 1]->[1],
		     $File->{Offsets}->[$err->{line} - 1]->[1] + $err->{char} + $err->{line}
		    );
      printf <<".EOF.", &ent($File->{URI}), &ent($err->{msg});
    <asserts>
      <Assertion rdf:about="%s">
        <subject rdf:parseType="Resource">
          <val:line>$err->{line}</val:line>
          <val:column>$err->{char}</val:column>
          <val:offset>@offsets</val:offset>
        </subject>
        <result rdf:resource="http://www.w3.org/2003/03/earl/1.00#fails" />
        <testCase>%s</testCase>
      </Assertion>
    </asserts>
.EOF.
    }
  } else {
    printf <<".EOF.", &ent($File->{URI});
  <asserts>
   <Assertion>
    <subject rdf:resource="%s" />
    <result rdf:resource="http://www.w3.org/2001/03/earl/1.00#passes" />
    <testCase rdf:resource="http://www.w3.org/HTML/" />
    <note>Valid!</note>
   </Assertion>
  </asserts>
.EOF.
  }

  print <<".EOF.";
  </Assertor>
</rdf:RDF>
.EOF.
}



#
# Return a Notation3 EARL report for the page.
#
# @@ TODO: escape output
sub report_n3 {
  my $File = shift;

  my $valid = ($File->{'Is Valid'} ? 'Valid' : 'Invalid');
  my $errs  = ($File->{'Is Valid'} ? '0' : scalar @{$File->{Errors}});

  print <<".EOF.";
Content-Type: text/plain; charset=UTF-8
X-W3C-Validator-Status: $valid
X-W3C-Validator-Errors: $errs

\@prefix earl: <http://www.w3.org/2001/03/earl/1.0-test#> .
\@prefix rdf: <http://www.w3.org/1999/02/22-rdf-syntax-ns#> .
\@prefix val: <http://validator.w3.org/this_will_change/do_not_rely_on_it!> .

<http://validator.w3.org/> a earl:Assertor;
  earl:name "W3 Validator";
  earl:asserts
.EOF.

  unless ($File->{'Is Valid'}) {
    for (my $i = 0; $i <= scalar @{$File->{Errors}}; $i++) {
      my $err = $File->{Errors}->[$i];
      # Strip curlies from lq-nsgmls output.
      $err->{msg} =~ s/[{}]//g;
      chomp $err->{msg};

      # Find index into the %frag hash for the "explanation..." links.
      $err->{idx} =  $err->{msg};
      $err->{idx} =~ s/"[^\"]*"/FOO/g;
      $err->{idx} =~ s/[^A-Za-z ]//g;
      $err->{idx} =~ s/\s+/ /g; # Collapse spaces
      $err->{idx} =~ s/(^\s|\s\Z)//g; # Remove leading and trailing spaces.
      $err->{idx} =~ s/(FOO )+/FOO /g; # Collapse FOOs.
      $err->{idx} =~ s/FOO FOO/FOO/g; # Collapse FOOs.

      my @offsets = (
		     $File->{Offsets}->[$err->{line}    ]->[0],
		     $File->{Offsets}->[$err->{line} - 1]->[1],
		     $File->{Offsets}->[$err->{line} - 1]->[1] + $err->{char} + $err->{line}
		    );
      print <<".EOF.";
    [
      earl:testMode earl:Auto;
      rdf:predicate earl:fails;
      rdf:subject [
                    val:column "$err->{char}";
                    val:line   "$err->{line}";
                    val:offset "@offsets";
                    earl:testSubject <$File->{URI}>
                  ];
      rdf:object [
                   earl:id <http://www.w3.org/HTML/>;
                   earl:note """$err->{msg} """
                 ]
.EOF.

     if ($i == scalar @{$File->{Errors}}) {
       print "    ]\n";
     } else {
       print "    ],\n";
     }
    }
  } else {
    print <<".EOF.";
    [
      earl:testMode earl:Auto;
      rdf:predicate earl:passes;
      rdf:subject   [earl:testSubject <$File->{URI}>];
      rdf:object    [
                      earl:id <http://www.w3.org/HTML/>;
                      earl:note "Valid"
                    ]
    ]
.EOF.
  }
  print " .\n";
}


#
# Autodetection as in Appendix F of the XML 1.0 Recommendation.
# <URL:http://www.w3.org/TR/2000/REC-xml-20001006#sec-guessing>
#
# return values are: (base_encoding, BOMSize, Size, Pattern)
sub find_base_encoding {
  local $_ = shift;

  # With a Byte Order Mark:
  return ('ucs-4be',  4, 4, '\0\0\0(.)')
    if /^\x00\x00\xFE\xFF/; # UCS-4, big-endian machine (1234)
  return ('ucs-4le',  4, 4, '(.)\0\0\0')
    if /^\xFF\xFE\x00\x00/; # UCS-4, little-endian machine (4321)
  return ('utf-16be', 2, 2, '\0(.)')
    if /^\xFE\xFF/;         # UTF-16, big-endian.
  return ('utf-16le', 2, 2, '(.)\0')
    if /^\xFF\xFE/;         # UTF-16, little-endian.
  return ('utf-8',    3, 1, '')
    if /^\xEF\xBB\xBF/; # UTF-8.

  # Without a Byte Order Mark:
  return ('ucs-4be',  0, 4, '\0\0\0(.)')
    if /^\x00\x00\x00\x3C/; # UCS-4 or 32bit; big-endian machine (1234 order).
  return ('ucs-4le',  0, 4, '(.)\0\0\0')
    if /^\x3C\x00\x00\x00/; # UCS-4 or 32bit; little-endian machine (4321 order).
  return ('utf-16be', 0, 2, '\0(.)')
    if /^\x00\x3C\x00\x3F/; # UCS-2, UTF-16, or 16bit; big-endian.
  return ('utf-16le', 0, 2, '(.)\0')
    if /^\x3C\x00\x3F\x00/; # UCS-2, UTF-16, or 16bit; little-endian.
  return ('utf-8',    0, 1, '')
    if /^\x3C\x3F\x78\x6D/; # UTF-8, ISO-646, ASCII, ISO-8859-*, Shift-JIS, EUC, etc.
  return ('ebcdic',   0, 1, '')
    if /^\x4C\x6F\xA7\x94/; # EBCDIC
  return ('',         0, 1, '');
                            # nothing in particular
}


#
# Find encoding in document according to XML rules
# Only meaningful if file contains a BOM, or for well-formed XML!
sub find_xml_encoding {
  my $File = shift;
  my ($CodeUnitSize, $Pattern);

  ($File->{Charset}->{Auto}, $File->{BOM}, $CodeUnitSize, $Pattern)
    = &find_base_encoding($File->{Bytes});
  my $someBytes = substr $File->{Bytes}, $File->{BOM}, ($CodeUnitSize * 100);
  my $someText = '';                  # 100 arbitrary, but enough in any case

  # translate from guessed encoding to ascii-compatible
  if ($File->{Charset}->{Auto} eq 'ebcdic') {
    # special treatment for EBCDIC, maybe use tr///
    # work on this later
  }
  elsif (!$Pattern) {
    $someText = $someBytes; # efficiency shortcut
  }
  else { # generic code for UTF-16/UCS-4
    $someBytes =~ /^(($Pattern)*)/s;
    $someText = $1;       # get initial piece without chars >255
    $someText =~ s/$Pattern/$1/sg;    # select the relevant bytes
  }

  # try to find encoding pseudo-attribute
  my $s = '[\ \t\n\r]';
  $someText =~ m(^<\?xml $s+ version $s* = $s* ([\'\"]) [-._:a-zA-Z0-9]+ \1 $s+
                  encoding $s* = $s* ([\'\"]) ([A-Za-z][-._A-Za-z0-9]*) \2
                )xso;

  $File->{Charset}->{XML} = lc $3;
  return $File;
}

#
# Abort with a message if an error was flagged at point.
sub abort_if_error_flagged {
  my $File = shift;
  my $Flags = shift;
  if ($File->{'Error Flagged'}) {
    print $File->{'Results'};
    print $File->{'Error Message'};
    if ($File->{Opt}->{'Show Source'} and $Flags & O_SOURCE) {
      &show_source($File);
    }
    print $File->{'Footer'};
    undef $File;
    exit;
  }
}

#
# conflicting encodings
sub conflict {
  my $encodingA = shift;
  my $encodingB = shift;
  return $encodingA && $encodingB && ($encodingA ne $encodingB);
}