#!/usr/local/bin/perl -w # # W3C HTML Validation Service # A CGI script to retrieve and validate an HTML file # # Copyright 1995-1999 Gerald Oskoboiny # # 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 = ''; # "

Note: This service will be ..."; # # DOCTYPEs my $html32_doctype = q(); my $html40s_doctype = q(); my $html40t_doctype = q(); my $html40f_doctype = q(); my $xhtmlt_doctype = q( 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 W3C HTML Validation Service Results

W3C HTML Validation Service Results

$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";

Sorry, this type of URI is not supported by this service.

URIs should be in the form:

$abs_svc_uri

(There are other types of URIs, too, but only http:// URIs are currently supported by this service.)

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";

Sorry, I am unable to validate this document because its returned content-type was $File->{Type}, which is not currently supported by this service.

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 =~ /]*)/i) { $File->{META_Charset} = lc $1; last; } elsif ($line =~ /{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

Document Checked

\n), &build_jump_links; # # Print the list of meta data. print " #

# Sorry, I am unable to validate this document because on # $lines it contained # some byte(s) that I cannot interpret as # $File->{Charset}. # Please check both the content of the file # and the character encoding indication. #

#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
  • nsgmls command line: $command\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} = []; 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 () { $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(
  • Document type: ), $version; if ($File->{Type} eq 'xhtml' and $root_namespace ne 'http://www.w3.org/1999/xhtml') { print "
    warning: unknown namespace for text/html document!"; if ($root_namespace ne '') { print qq{, $root_namespace}; } print "\n"; } else { if ($root_namespace ne '') { print qq( with namespace $root_namespace); } } if (scalar keys %other_namespaces >= 1) { print "
    Other namespaces in this document: "; for (keys %other_namespaces) { print qq($_, ), "\n"; } } print qq(
  • \n); } else { print ' ' x 4, qq(
  • Document type: ), $version, qq(
  • \n); } print ' ' x 2, qq(\n\n); if ($File->{Type} eq 'xml' or $File->{Type} eq 'xhtml') { my $xmlvalid = ($File->{DOCTYPE} ? ' and validity' : ''); print <<"EOHD";

    Below are the results of checking this document for XML well-formedness$xmlvalid.

    EOHD } else { print <<"EOHD";

    Below are the results of attempting to parse this document with an SGML parser.

    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";

    You should make the first line of your HTML document a DOCTYPE declaration, for example, for a typical HTML 4.01 document:

          <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
          <HTML>
    	<HEAD>
    	  <TITLE>Title</TITLE>
    	</HEAD>
    
    	<BODY>
    	  <-- ... body of document ... -->
    	</BODY>
          </HTML>
    EOF } sub output_closing { print <<"EOF";
    Valid HTML 4.01! Gerald Oskoboiny
    Last modified: $DATE
    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 Moved!

    Please see the home page.

    .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 .= "

    \n Jump to: "; if ( $q->param('weblint') ) { $text .= "Weblint Results"; $count--; $text .= " or " if ( $count == 1 ); $text .= ", " if ( $count > 1 ); } if ( $q->param('outline') ) { $text .= "Outline"; $count--; $text .= " or " if ( $count == 1 ); $text .= ", " if ( $count > 1 ); } if ( $q->param('ss') ) { $text .= "Source Listing"; $count--; $text .= " or " if ( $count == 1 ); $text .= ", " if ( $count > 1 ); } if ( $q->param('sp') ) { $text .= "Parse Tree"; } $text .= ".\n

    \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 401 Authorization Required

    Authorization Required

    Sorry, I am not authorized to access the specified URI.

    The URI you specified,

    $resource

    returned a 401 "authorization required" response when I tried to download it.

    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.

    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 download the source for this service 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. :-)

    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.

    EOF } sub print_unknown_http_error_message { my $uri = shift; my $code = shift; my $message = shift; print <<"EOF";

    I got the following unexpected response when trying to retrieve $uri:

    $code $message

    Please make sure you have entered the URI correctly.

    EOF } # # Complain about strange charsets. sub print_charset_error { my $error = shift; my $charset = shift; print <<".EOF.";

    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").

    The detected charset was "$charset".

    The error was "$error".

    If you believe the charset to be valid you can submit a request for that character encoding (see the feedback page for details) and we will look into supporting it in the future.

    .EOF. } sub output_css_validator_blurb { my $uri = shift; $uri = ent($uri); print <<"EOHD";

    If you use CSS in your document, you should also check it for validity using the W3C CSS Validation Service.

    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 () { 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 .= ''}, '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(){$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 "\n"; print "
    \n"; if ($version eq 'unknown') { print "\n

    \n Sorry, I can't validate this document.\n

    \n"; } elsif ($File->{Type} eq 'xml') { print "\n

    \n Sorry, this document is not well-formed XML.\n

    \n"; } else { print "\n

    \n Sorry, this document does not validate as $version.\n

    \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
    \n    No errors found! ";
        print "*
    \n\n"; } else { print "\n
    \n    No errors found!
    \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 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";

    $alttext Congratulations, this document validates as $version!

    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>
        <a href="${abs_svc_uri}check/referer"><img$gifborder
            src="$image_uri"
            alt="$alttext"$gifhw$xhtmlendtag></a>
      </p>

    If you like, you can download a copy of this image (in PNG or GIF 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.

    EOHD } } if ($File->{Type} eq 'xml' and not $File->{DOCTYPE}) { print "

    \n Congratulations, this document is well-formed XML.\n

    \n"; } elsif ($version eq 'unknown' or not defined $image_uri) { print "

    \n Congratulations, this document validates as the document type specified! (I don't have an icon for this one yet, sorry.)\n

    \n"; } unless ($q->param('uploaded_file')) { my $thispage = $q->url(-query => 1); &output_css_validator_blurb($q->param('uri')); print <<"EOHD";

    If you would like to create a link to this 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:

    $thispage

    (Or, you can just add the current page to your bookmarks or hotlist.)

    EOHD } if ($File->{Type} eq 'xml' or $File->{Type} eq 'xhtml') { print qq{

    Caveat

    This validator is based on SP, which has some limitations in its support for XML.

    }; } } # # 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";

    Weblint Results

    Below are the results of running Weblint on this document$pedantic_blurb:

    Note: 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.

    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 "
      \n"; open WEBLINTOUT, "$temp.weblint" or die "open($temp.weblint) returned: $!\n"; while () { s/ \(use "-x " to allow this\)\.$/./go; s/&/&/go; s//>/go; print "
    • $_"; } close WEBLINTOUT or die "close($temp.weblint) returned: $!\n"; print "
    \n"; } else { print "\n
    \n Looks good to me!\n
    \n"; } print "\n\n"; } # # Produce an outline of the document based on Hn elements from the ESIS. sub outline { my $File = shift; print <<'EOF';

    Outline

    Below is an outline for this document, automatically generated from the heading tags (<H1> through <H6>.)

    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 " \n" x ($prevlevel - $level); # perl is so cool. if ($level - $prevlevel == 1) {print "
      \n"}; foreach my $i (($prevlevel + 1) .. ($level - 1)) { print qq(
        \n
      • A level $i heading is missing!\n); } if ($level - $prevlevel > 1) {print "
          \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/&/&/go; $heading =~ s/$heading\n"; } print "
        \n" x $level; print <<'EOF';

        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.)

    EOF } # # Create a HTML representation of the document. sub show_source { my $File = shift; my $line = 1; print <<'EOF';

    Source Listing

    Below is the source input I used for this validation:

    EOF
    
      for (@{$File->{Content}}) {
        printf "%4d: %s\n", $line, $line, ent $_;
        $line++;
      }
      print "    
    \n
    "; } # # Create a HTML Parse Tree of the document for validation report. sub parse_tree { my $File = shift; print <<'EOF';

    Parse Tree

    EOF if ($q->param('noatt')) { print <<'EOF';

    I am excluding the attributes, as you requested.

    EOF } else { print <<'EOF';

    You can also view this parse tree without attributes by selecting the appropriate option on the form.

    EOF } my $indent = 0; my $prevdata = ''; print "
    \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/&/&/go;
          $prevdata =~ s/ close-tag
    		   "<" . $close . "{lc($2)} .
    		   "\">$2<\/a>>"
    		 }egx;
        $printme =~ s,^A,  A,;	# indent attributes a bit
        print ' ' x $indent, $printme, "\n";
        if ($line =~ /^\(/) {
          $indent += 2;
        }
      }
      print "
    \n"; print "
    \n"; } # # @@FIXME@@ Add description. sub preparse { my $File = shift; my $dtd = sub {return if $File->{Root}; ($File->{Root}, $File->{DOCTYPE}) = shift =~ m()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; }