# MTValidate 0.1 # $Date: 2003/02/15 04:42:31 $ # by Alexei Kosut # Based on: # # W3C MarkUp Validation Service # A CGI script to retrieve and validate a MarkUp file # # Copyright 1995-2002 Gerald Oskoboiny # 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.321 2003/01/03 20:21:55 ville Exp # We need Perl 5.6.0+. use 5.006; ############################################################################### #### Load modules. ############################################################ ############################################################################### # Movable Type use MT::Template::Context; use MT; # # 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 Config::General 2.06 qw(); # Need 2.06 for -SplitPolicy use File::Spec qw(); use HTML::Parser 3.25 qw(); # Need 3.25 for $p->ignore_elements. use HTML::Template 2.6 qw(); 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 $VDIR); # # Prototypes # sub parsetree ($$); sub parse_errors ($$$); sub abort_if_error_flagged ($$$); my $vdir; if ($0 =~ m!(^/.*[/\\])!) { $vdir = "$1/plugins/validator"; } else { $vdir = "/home/staff/akosut/web-docs/mt/plugins/validator"; } # # Read Config Files. eval { my %config_opts = (-ConfigFile => "$vdir/config/validator.conf", -MergeDuplicateOptions => 'yes', -SplitPolicy => 'equalsign', -UseApacheInclude => TRUE, -IncludeRelative => TRUE, -InterPolateVars => TRUE, -DefaultConfig => { SGML_Parser => '/usr/bin/onsgmls', SGML_Library => "$vdir/sgml-lib", }, ); my %cfg = Config::General->new(%config_opts)->getall(); $CFG = \%cfg; }; if ($@) { die <<".EOF."; Couldn't read configuration. The error reported was: '$@' .EOF. } # # Make sure onsgmls exists and is executable. unless (-x $CFG->{SGML_Parser}) { die qq(Configured SGML Parser "$CFG->{SGML_Parser}" not executable!\n); } { # Make types config indexed by FPI. my $_types = {}; map {$_types->{$CFG->{Types}->{$_}->{PubID}} = $CFG->{Types}->{$_}} keys %{$CFG->{Types}}; $CFG->{Types} = $_types; } # # Set debug flag. $DEBUG = TRUE if $ENV{W3C_VALIDATOR_DEBUG} || $CFG->{DEBUG}; MT::Template::Context->add_container_tag('Validate', sub { my ($ctx, $args) = @_; my $output = ''; # Build the content my $builder = $ctx->stash('builder'); my $tokens = $ctx->stash('tokens'); my $content; defined($content = $builder->build($ctx, $tokens)) or return $ctx->error($ctx->errstr); # # The data structure that will hold all session data. my $File; ################################# # Initialize the datastructure. # ################################# # # Charset data (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 . $File->{Charset}->{XML} = ''; # From the XML Declaration. $File->{Charset}->{Override} = ''; # From CGI/user override. # # Misc simple types. $File->{Type} = ''; # # Array (ref) used to store character offsets for the XML report. $File->{Offsets}->[0] = [0, 0]; # The first item isn't used... # # Listrefs. $File->{Lines} = []; # Line numbers for encoding errors. $File->{Warnings} = []; # Warnings... $File->{'Other Namespaces'} = []; # Other (non-root) Namespaces. ########################################################################### #### Generate Template for Result. ######################################## ########################################################################### my $T = HTML::Template->new( filename => "$vdir/templates/result.tmpl", die_on_bad_params => FALSE, ); my $E = HTML::Template->new( filename => "$vdir/templates/fatal-error.tmpl", die_on_bad_params => FALSE, ); $T->param(cfg_home_page => $CFG->{Home_Page}); ######################################### # Populate $File->{Opt} -- CGI Options. # ######################################### # # Set session switches. $File->{Opt}->{'Outline'} = $args->{'outline'}; $File->{Opt}->{'Show Source'} = $args->{'ss'}; $File->{Opt}->{'Show Parsetree'} = $args->{'sp'}; $File->{Opt}->{'No Attributes'} = $args->{'noatt'}; $File->{Opt}->{'Show ESIS'} = $args->{'esis'}; $File->{Opt}->{'Show Errors'} = $args->{'errors'}; $File->{Opt}->{'Verbose'} = exists($args->{'verbose'}) ? $args->{'verbose'} : TRUE; $File->{Opt}->{'Debug'} = $args->{'debug'}; $File->{Opt}->{'Charset'} = $args->{'charset'} ? lc $args->{'charset'}: ''; $File->{Opt}->{'DOCTYPE'} = $args->{'doctype'} ? $args->{'doctype'} : ''; $File->{Opt}->{'URI'} = $args->{'uri'} ? $args->{'uri'} : ''; $File->{Opt}->{'Output'} = $args->{'output'} ? $args->{'output'} : 'html'; # # If ";debug" was given, let it overrule the value from the config file, # regardless of whether it's "0" or "1" (on or off). $DEBUG = $args->{'debug'} if defined $args->{'debug'}; return $E->output if (&abort_if_error_flagged($File, $E, 0)); # # Get the file and metadata. $File->{Bytes} = $content; $File->{Type} = 'html'; $File->{'Is Upload'} = TRUE; # # Abort if an error was flagged during initialization. return $E->output if (&abort_if_error_flagged($File, $E, 0)); ########################################################################### #### Output validation results. ########################################### ########################################################################### # # Find the XML Encoding. $File = &find_xml_encoding($File); # # Decide on a charset to use (first part) # if ($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'; } $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 ) $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.";

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:

And I even tried to autodetect it using the algorithm defined in Appendix F of the XML 1.0 Recommendation.

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.

IANA maintains the list of official names for character sets.

.EOF. } # # Abort if an error was flagged while finding the encoding. return $E->output if &abort_if_error_flagged($File, $E, O_CHARSET|O_DOCTYPE); # # Check the detected Encoding and transcode. if (&conflict($File->{Charset}->{Use}, 'utf-8')) { $File = &transcode($File); return $E->output if &abort_if_error_flagged($File, $E, 0); } $File = &check_utf8($File); # always check $File = &byte_error($File); # # Abort if an error was flagged during transcoding return $E->output if &abort_if_error_flagged($File, $E, 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 = &override_doctype($File); my $dtd = ent($File->{Opt}->{DOCTYPE}); &add_warning($File, 'DOCTYPE Override in effect!', <<".EOF."); Any DOCTYPE Declaration in the document has been suppressed and the DOCTYPE for «$dtd» 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); # # By default, use SGML catalog file and SGML Declaration. my $catalog = File::Spec->catfile($CFG->{SGML_Library}, 'sgml.soc'); my @xmlflags = qw( -wvalid -wnon-sgml-char-ref -wno-duplicate ); # # Switch to XML semantics if file is XML. if (&is_xml($File)) { $catalog = File::Spec->catfile($CFG->{SGML_Library}, 'xml.soc'); push(@xmlflags, '-wxml'); &add_warning($File, 'Note:', <<".EOF."); The Validator XML support has some limitations. .EOF. } # # 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}; # # Set final command to use. my @cmd = ($CFG->{SGML_Parser}, '-c', $catalog, '-E0', @xmlflags); # # Set debug info for HTML report. $T->param(is_debug => $DEBUG); $T->param( debug => [ {name => 'Command', value => &ent("@cmd")}, {name => 'SP_CHARSET_FIXED', value => &ent($ENV{SP_CHARSET_FIXED})}, {name => 'SP_ENCODING', value => &ent($ENV{SP_ENCODING})}, {name => 'SP_BCTF', value => &ent($ENV{SP_BCTF})}, ], ); # # 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, $E); # Parse error output. return $E->output unless $File; 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 (/^Axmlns() \w+ (.*)/ or /^Axmlns:([^ ]+) \w+ (.*)/) { if (not $File->{Namespace} and $elements_found == 0 and $1 eq "") { $File->{Namespace} = $2; } $File->{Namespaces}->{$2}++ unless $2 eq $File->{Namespace}; } next if / IMPLIED$/; next if /^ASDAFORM CDATA /; next if /^ASDAPREF CDATA /; chomp; # Removes trailing newlines push @{$File->{ESIS}}, $_; } undef $spout; # # Check whether the parser thought it was Valid. if ($File->{ESIS}->[-1] =~ /^C$/) { delete $File->{ESIS}->[-1]; $File->{'Is Valid'} = TRUE; } else { $File->{'Is Valid'} = FALSE; } # # Extract the Namespaces. $File->{Namespaces} = [map {name => '', uri => $_}, keys %{$File->{Namespaces}}]; # # 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) and not $File->{DOCTYPE}) { $File->{Version} = 'XML'; } else { $File->{Version} = $File->{DOCTYPE} unless $File->{Version}; } # # Get the pretty text version of the FPI if a mapping exists. if (my $prettyver = $CFG->{Types}->{$File->{Version}}->{Display}) { $File->{Version} = $prettyver; } else { $File->{Version} = &ent($File->{Version}); } # # Warn about unknown Namespaces. if (&is_xml($File) and $File->{Namespace}) { my $ns = &ent($File->{Namespace}); if (&is_xhtml($File) and $File->{Namespace} ne 'http://www.w3.org/1999/xhtml') { &add_warning( $File, 'Warning:', "Unknown namespace («$ns») for text/html document!" ); } elsif (&is_svg($File) and $File->{Namespace} ne 'http://www.w3.org/2000/svg') { &add_warning( $File, 'Warning:', "Unknown namespace («$ns») for SVG document!" ); } } 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.";

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.

.EOF. } } &prep_template($File, $T); if ($File->{'Is Valid'}) { $T->param(VALID => TRUE); &report_valid($File, $T); } else { $T->param(VALID => FALSE); $T->param(opt_show_source => TRUE); $T->param(file_errors => &report_errors($File)); } $T->param(file_warnings => $File->{Warnings}); $T->param(file_outline => &outline($File)); $T->param(file_source => &source($File)); $T->param(file_parsetree => &parsetree($File, $T)); # &show_esis($File) if $File->{Opt}->{'Show ESIS'}; # &show_errors($File) if $File->{Opt}->{'Show Errors'}; $output = $T->output; # # Get rid of $File object and exit. undef $File; return $output; }); ############################################################################# # Subroutine definitions ############################################################################# # # Generate HTML report. sub prep_template ($$) { my $File = shift; my $T = shift; # # XML mode... $T->param(is_xml => &is_xml($File)); # # Metadata... $T->param(file_charset => $File->{Charset}->{Use}); $T->param(file_version => $File->{Version}); # # Output options... $T->param(opt_show_source => $File->{Opt}->{'Show Source'}); $T->param(opt_show_outline => $File->{Opt}->{'Outline'}); $T->param(opt_show_parsetree => $File->{Opt}->{'Show Parsetree'}); $T->param(opt_show_noatt => $File->{Opt}->{'No Attributes'}); $T->param(opt_verbose => $File->{Opt}->{'Verbose'}); # # Namespaces... $T->param(file_namespace => &ent($File->{Namespace})); $T->param(file_namespaces => $File->{Namespaces}) if $File->{Namespaces}; } # # Output "This page is Valid" report. sub report_valid { my $File = shift; my $T = shift; my $gifborder = ' border="0"'; my $xhtmlendtag = ''; my($image_uri, $alttext, $gifhw); unless ($File->{Version} eq 'unknown' or defined $File->{Tentative}) { if (defined $image_uri) { $T->param(have_badge => TRUE); $T->param(badge_uri => $image_uri); $T->param(badge_alt => $alttext); $T->param(badge_gifhw => $gifhw); $T->param(badge_xhtml => $xhtmlendtag); } } elsif (defined $File->{Tentative}) { $T->param(is_tentative => TRUE); } } # # Add a waring message to the output. sub add_warning ($$$) {push @{shift->{Warnings}}, {title => shift, text => shift}}; # # Print HTML explaining why/how to use a DOCTYPE Declaration. sub doctype_spiel { return <<".EOF.";

You should place a DOCTYPE declaration as the very first thing in your HTML document. For example, for a typical XHTML 1.0 document: 

      <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
        "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
      <html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">
        <head>
          <title>Title</title>
        </head>

        <body>
          <!-- ... body of document ... -->
        </body>
      </html>

For XML documents, you may also wish to include an "XML Declaration" even before the DOCTYPE Declaration, but this is not well supported in older browsers. More information about this can be found in the XHTML 1.0 Recommendation.

.EOF. } # # Leave a message and then die (use for internal errors only) sub internal_error { my $File = shift; my ($dieMessage) = shift; print <<"EOF";
Internal server error ($dieMessage). Please contact maintainer. EOF print $File->{'Footer'}; croak $dieMessage, "\n"; } # # 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. # # This *really* wants Perl 5.8.0 and it's improved UNICODE support. # Byte semantics are in effect on all length(), substr(), etc. calls, # so offsets will be wrong if there are multi-byte sequences prior to # the column where the error is detected. # sub truncate_line { my $line = shift; my $col = shift; my $start = $col; my $end = $col; for (1..40) { $start-- if ($start - 1 >= 0); # in/de-crement until... $end++ if ($end + 1 <= length $line); # ...we hit end of line. } unless ($end - $start == 80) { if ($start == 0) { # Hit start of line, maybe grab more at end. my $diff = 40 - $col; for (1..$diff) { $end++ if ($end + 1 <= length $line); } } elsif ($end == length $line) { # Hit end of line, maybe grab more at beginning. my $diff = 80 - $col; for (1..$diff) { $start-- if ($start - 1 >= 0); } } } # # Add elipsis at end if necessary. unless ($end == length $line) {substr $line, -3, 3, '...'}; $col = $col - $start; # New offset is diff from $col to $start. $line = substr $line, $start, $end - $start; # Truncate. # # Add elipsis at start if necessary. unless ($start == 0) {substr $line, 0, 3, '...'}; return $line, $col; } # # Suppress any existing DOCTYPE by commenting it out. sub override_doctype { no strict 'vars'; my $File = shift; my $pubid = $CFG->{Types}->{$File->{Opt}->{DOCTYPE}}->{PubID}; my $sysid = $CFG->{Types}->{$File->{Opt}->{DOCTYPE}}->{SysID}; my $name = $CFG->{Types}->{$File->{Opt}->{DOCTYPE}}->{Name}; local $dtd = qq(); local $HTML = ''; local $seen = FALSE; my $declaration = sub { $seen = TRUE; $HTML .= "$dtd\n" . ''; }; HTML::Parser->new(default_h => [sub {$HTML .= shift}, 'text'], declaration_h => [$declaration, 'text'] )->parse(join "\n", @{$File->{Content}})->eof(); $File->{Content} = [split /\n/, $HTML]; unshift @{$File->{Content}}, $dtd unless $seen; return $File; } # # Parse errors reported by SP. sub parse_errors ($$$) { my $File = shift; my $fh = shift; my $E = shift; $File->{Errors} = []; # Initialize to an (empty) anonymous array ref. for (<$fh>) { push @{$File->{'DEBUG'}->{Errors}}, $_; my($err, @errors); next if /^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 '0'; if ($_err[1] =~ m(^)) { @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 'E' or $err->{type} eq 'X' or $err->{type} eq 'Q') { $err->{msg} = $errors[5]; } elsif ($err->{type} eq 'W') { &add_warning( $File, 'Warning:', "Line $err->{line}, column $err->{char}: $errors[5]" ); $err->{msg} = $errors[5]; } 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.";

Fatal Error: $err->{msg}

I could not parse this document, because it uses a public identifier that is not in my catalog.

.EOF. $File->{'Error Message'} .= &doctype_spiel(); $File->{'Error Message'} .= "
\n"; } # No or unknown FPI and a relative SI. if ($err->{msg} =~ m(cannot (open|find))) { $File->{'Error Flagged'} = TRUE; $File->{'Error Message'} = <<".EOF.";

Fatal Error: $err->{msg}

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.

.EOF. $File->{'Error Message'} .= &doctype_spiel(); $File->{'Error Message'} .= "
\n"; } # No DOCTYPE. if ($err->{msg} =~ m(prolog can\'t be omitted)) { $File->{'Error Flagged'} = TRUE; $File->{'Error Message'} = <<".EOF.";

Fatal Error: No DOCTYPE specified!

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.

.EOF. $File->{'Error Message'} .= &doctype_spiel(); $File->{'Error Message'} .= <<".EOF.";

The W3C QA Activity maintains a List of Valid Doctypes that you can choose from, and the WDG maintains a document on "Choosing a DOCTYPE".

.EOF. $File->{'Error Message'} .= "
\n"; } return undef if &abort_if_error_flagged($File, $E, O_DOCTYPE); push @{$File->{Errors}}, $err; } undef $fh; return $File; } # # Generate a HTML report of detected errors. sub report_errors ($) { my $File = shift; my $Errors = []; if (scalar @{$File->{Errors}}) { 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\Z)//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. if (defined $CFG->{Error_to_URI}->{$err->{idx}}) { $err->{uri} = $CFG->{Msg_FAQ_URI} . '#' . $CFG->{Error_to_URI}->{$err->{idx}}; } $err->{src} = $line; $err->{col} = ' ' x $col; push @{$Errors}, $err; } } return $Errors; } # # Produce an outline of the document based on Hn elements from the ESIS. sub outline { my $File = shift; my $outline = ''; 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; $outline .= " \n" x ($prevlevel - $level); # perl is so cool. if ($level - $prevlevel == 1) {$outline .= "
    \n"}; foreach my $i (($prevlevel + 1) .. ($level - 1)) { $outline .= qq(
      \n
    • A level $i heading is missing!
      • \n); } if ($level - $prevlevel > 1) {$outline .= "
        \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); $outline .= "
      • $heading
        • \n"; } $outline .= "
      \n" x $level; return $outline; } # # Create a HTML representation of the document. sub source { my $File = shift; my $line = 1; my @source = (); for (@{$File->{Content}}) { push @source, { file_source_i => $line, file_source_line => ent $_, }; $line++; } return \@source; } # # Create a HTML Parse Tree of the document for validation report. sub parsetree ($$) { my ($File, $T) = @_; my $tree = ''; $T->param(file_parsetree_noatt => TRUE) if $File->{Opt}->{'No Attributes'}; my $indent = 0; my $prevdata = ''; 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; $tree .= 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 "<" . $close . "{Element_Ref_URI} . $CFG->{Element_Map}->{lc($2)} . "\">$2<\/a>>" }egx; $printme =~ s,^A, A,; # indent attributes a bit $tree .= ' ' x $indent . $printme . "\n"; if ($line =~ /^\(/) { $indent += 2; } } return $tree; } # # Do an initial parse of the Document Entity to extract charset and FPI. sub preparse { my $File = shift; # # Reset DOCTYPE, Root, and Charset (for second invocation). $File->{Charset}->{META} = ''; $File->{DOCTYPE} = ''; $File->{Root} = ''; my $dtd = sub { return if $File->{Root}; ($File->{Root}, $File->{DOCTYPE}) = shift =~ m()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(start => $start, 'tag,attr'); $p->parse(join "\n", @{$File->{Content}}); $File->{DOCTYPE} = '' unless defined $File->{DOCTYPE}; $File->{DOCTYPE} =~ s(^\s+){ }g; $File->{DOCTYPE} =~ s(\s+$){ }g; $File->{DOCTYPE} =~ s(\s+) { }g; return $File; } # # Print out the raw ESIS output for debugging. sub show_esis ($) { print <<'EOF';

      Raw ESIS Output

      EOF
  for (@{shift->{'DEBUG'}->{ESIS}}) {
    s/\\012//g;
    s/\\n/\n/g;
    print ent $_;
  }
  print "
      \n
      "; } # # Print out the raw error output for debugging. sub show_errors ($) { print <<'EOF';

      Raw Error Output

      EOF
  for (@{shift->{'DEBUG'}->{Errors}}) {print ent $_};
  print "
      \n
      "; } # # Output errors for a rejected URI. sub uri_rejected { my $scheme = shift || 'undefined'; return sprintf(<<".EOF.", &ent($scheme));

      Sorry, this type of URI scheme (%s) is not supported by this service. Please check that you entered the URI correctly.

      URIs should be in the form: http://validator.w3.org/

      If you entered a valid URI using a scheme that we should support, please let us know as outlined on our Feedback page. 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.

      .EOF. } # # Utility subs to tell if type "is" something. sub is_xml {shift->{Type} =~ m(^[^+]+\+xml$)}; sub is_svg {shift->{Type} =~ m(svg\+xml$)}; sub is_smil {shift->{Type} =~ m(smil\+xml$)}; sub is_html {shift->{Type} =~ m(html\+sgml$)}; sub is_xhtml {shift->{Type} =~ m(xhtml\+xml$)}; sub is_mathml {shift->{Type} =~ m(mathml\+xml$)}; # # 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, 'No Character Encoding detected!', <<".EOF."); To ensure correct validation, processing, and display, it is important that the character encoding is properly labeled. More information... .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, 'Character Encoding Override in effect!', <<".EOF."); The detected character encoding, «$cs_use», has been suppressed and the character encoding «$cs_opt» used instead. .EOF. $File->{Tentative} |= T_ERROR; } # # Add a warning if there was charset info conflict (HTTP header, # XML declaration, or element). if (&conflict($File->{Charset}->{HTTP}, $File->{Charset}->{XML})) { &add_warning($File, 'Character Encoding mismatch!', <<".EOF."); The character encoding from the HTTP header ($cs_http) is different from the value in the XML declaration ($cs_xml). I will use the value from the HTTP header ($cs_use) for this validation. .EOF. } elsif (&conflict($File->{Charset}->{HTTP}, $File->{Charset}->{META})) { &add_warning($File, 'Character Encoding mismatch!', <<".EOF."); The character encoding from the HTTP header ($cs_http) is different from the value in the <meta> element ($cs_meta). I will use the value from the HTTP header ($cs_use) for this validation. .EOF. } elsif (&conflict($File->{Charset}->{XML}, $File->{Charset}->{META})) { &add_warning($File, 'Character Encoding mismatch!', <<".EOF."); The character encoding from the XML declaration ($cs_xml) is different from the value in the <meta> element ($cs_meta). I will use the value from the XML declaration ($cs_xml) 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($@));

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

      The detected character encoding was "%s".

      The error was "%s".

      If you believe the character encoding 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. $File->{'Error Message'} .= <<'.EOF.';

      IANA maintains the list of official names for character sets.

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

      Sorry, I am unable to validate this document because on line$s $lines it contained one or more bytes that I cannot interpret as $cs (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.

      .EOF. } return $File; } # # Autodetection as in Appendix F of the XML 1.0 Recommendation. # # # 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, $E, $Flags) = @_; return FALSE unless $File->{'Error Flagged'}; &prep_template($File, $E); $E->param(error_message => $File->{'Error Message'}); return TRUE; } # # conflicting encodings sub conflict ($$) {return $_[0] && $_[1] && ($_[0] ne $_[1])};