diff options
| -rwxr-xr-x | httpd/cgi-bin/check | 297 |
1 files changed, 148 insertions, 149 deletions
diff --git a/httpd/cgi-bin/check b/httpd/cgi-bin/check index 289d798..fc3551b 100755 --- a/httpd/cgi-bin/check +++ b/httpd/cgi-bin/check @@ -14,7 +14,7 @@ # This source code is available under the license at: # http://www.w3.org/Consortium/Legal/copyright-software # -# $Id: check,v 1.710 2009-10-05 19:49:45 ville Exp $ +# $Id: check,v 1.711 2009-10-05 20:34:37 ville Exp $ # # Disable buffering on STDOUT! $| = 1; @@ -208,7 +208,7 @@ Directory not readable (permission denied): @_r # # Strings - $VERSION = q$Revision: 1.710 $; + $VERSION = q$Revision: 1.711 $; $VERSION =~ s/Revision: ([\d\.]+) /$1/; # @@ -822,6 +822,151 @@ else { } &abort_if_error_flagged($File, 0); +# +# 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} and lc($File->{Root}) ne 'html') { + $File->{Version} = 'XML'; +} else { + $File->{Version} ||= $File->{DOCTYPE}; +} + +# +# Get the pretty text version of the FPI if a mapping exists. +if (my $prettyver = $CFG->{Types}->{$File->{Version}}->{Display}) { + $File->{Version} = $prettyver; +} + +# +# check the received mime type against Allowed mime types +if ($File->{ContentType}){ + my @allowedMediaType = + split(/\s+/, $CFG->{Types}->{$File->{DOCTYPE}}->{Types}->{Allowed} || ''); + my $usedCTisAllowed; + if (scalar @allowedMediaType) { + $usedCTisAllowed = FALSE; + foreach (@allowedMediaType) { $usedCTisAllowed = TRUE if ($_ eq $File->{ContentType}); } + } + else { + # wedon't know what media type is recommended, so better shut up + $usedCTisAllowed = TRUE; + } + if(! $usedCTisAllowed ){ + &add_warning('W23', { + W23_type => $File->{ContentType}, + W23_type_pref => $CFG->{Types}->{$File->{DOCTYPE}}->{Types}->{Preferred}, + w23_doctype => $File->{Version} + }); + } +} + +# +# Warn about unknown, incorrect, or missing Namespaces. +if ($File->{Namespace}) { + my $ns = $CFG->{Types}->{$File->{Version}}->{Namespace} || FALSE; + + if (&is_xml($File)) { + if ($ns eq $File->{Namespace}) { + &add_warning('W10', { + W10_ns => $File->{Namespace}, + W10_type => $File->{Type}, + }); + } + } else { + &add_warning('W11', {W11_ns => $File->{Namespace}, + w11_doctype => $File->{DOCTYPE}}); + } +} else { + if (&is_xml($File) and $CFG->{Types}->{$File->{Version}}->{Namespace}) { + &add_warning('W12', {}); + } +} + + +## if invalid content, AND if requested, pass through tidy +if (!$File->{'Is Valid'} && $File->{Opt}->{'Show Tidy'}) { + eval { + local $SIG{__DIE__}; + require HTML::Tidy; + my $tidy = HTML::Tidy->new({config_file => $CFG->{Paths}->{TidyConf}}); + my $cleaned = $tidy->clean(join("\n", @{$File->{Content}})); + $cleaned = Encode::decode_utf8($cleaned); + $File->{Tidy} = $cleaned; + }; + if ($@) { + (my $errmsg = $@) =~ s/ at .*//s; + &add_warning('W29', { W29_msg => $errmsg }); + } +} + +my $template; + +if ($File->{Opt}->{Output} eq 'xml') { + $template = $File->{Templates}->{XML}; +} elsif ($File->{Opt}->{Output} eq 'earl') { + $template = $File->{Templates}->{EARLXML}; +} elsif ($File->{Opt}->{Output} eq 'n3') { + $template = $File->{Templates}->{EARLN3}; +} elsif ($File->{Opt}->{Output} eq 'json') { + $template = $File->{Templates}->{JSON}; +} elsif ($File->{Opt}->{Output} eq 'ucn') { + $template = $File->{Templates}->{UCN}; +} elsif ($File->{Opt}->{Output} eq 'soap12') { + if ($CFG->{'Enable SOAP'} != 1) { # API disabled - ideally this should have been sent before performing validation... + print CGI::header(-status => 503, -content_language => "en", + -type => "text/html", -charset => "utf-8" + ); + $template = $File->{Templates}->{SOAPDisabled}; + } elsif ($File->{'Error Flagged'}) { # should send SOAP fault message + $template = $File->{Templates}->{SOAPFault}; + # we fill the soap fault template + #with the variables that had been passed to the HTML fatal error template + foreach my $fault_param ($File->{Templates}->{Error}->param()) { + $template->param($fault_param => $File->{Templates}->{Error}->param($fault_param)); + } + } else { + $template = $File->{Templates}->{SOAP}; + } +} else { + $template = $File->{Templates}->{Result}; +} + +&prep_template($File, $template); +&fin_template($File, $template); + +$template->param(file_warnings => $File->{Warnings}); +$template->param(tidy_output => $File->{Tidy}); +$template->param(file_source => &source($File)) + if ($template->param('opt_show_source') or ($File->{'Is Upload'}) or ($File->{'Direct Input'})); + +if ($File->{Opt}->{Output} eq 'json') { + # No JSON escaping in HTML::Template (and "JS" is not the right thing here) + my $json = JSON->new(); + $json->allow_nonref(TRUE); + for my $msgs ($template->param("file_errors"), + $template->param("file_warnings")) { + next unless $msgs; + for my $msg (@$msgs) { + for my $key (qw(msg expl)) { + $msg->{$key} = $json->encode($msg->{$key}) if $msg->{$key}; + } + } + } +} + +# transcode output from perl's internal to utf-8 and output +print Encode::encode('UTF-8', $template->output); + +# +# Get rid of $File object and exit. +undef $File; +exit; + + +############################################################################# +# Subroutine definitions +############################################################################# + # TODO: need to bring in fixes from html5_validate() here sub compoundxml_validate (\$) { my $File = shift; @@ -1088,6 +1233,7 @@ sub html5_validate (\$) { return $File; } + sub dtd_validate (\$) { my $File = shift; my $opensp = SGML::Parser::OpenSP->new(); @@ -1154,153 +1300,6 @@ sub dtd_validate (\$) { return $File; } - - - -# -# 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} and lc($File->{Root}) ne 'html') { - $File->{Version} = 'XML'; -} else { - $File->{Version} ||= $File->{DOCTYPE}; -} - -# -# Get the pretty text version of the FPI if a mapping exists. -if (my $prettyver = $CFG->{Types}->{$File->{Version}}->{Display}) { - $File->{Version} = $prettyver; -} - -# -# check the received mime type against Allowed mime types -if ($File->{ContentType}){ - my @allowedMediaType = - split(/\s+/, $CFG->{Types}->{$File->{DOCTYPE}}->{Types}->{Allowed} || ''); - my $usedCTisAllowed; - if (scalar @allowedMediaType) { - $usedCTisAllowed = FALSE; - foreach (@allowedMediaType) { $usedCTisAllowed = TRUE if ($_ eq $File->{ContentType}); } - } - else { - # wedon't know what media type is recommended, so better shut up - $usedCTisAllowed = TRUE; - } - if(! $usedCTisAllowed ){ - &add_warning('W23', { - W23_type => $File->{ContentType}, - W23_type_pref => $CFG->{Types}->{$File->{DOCTYPE}}->{Types}->{Preferred}, - w23_doctype => $File->{Version} - }); - } -} - -# -# Warn about unknown, incorrect, or missing Namespaces. -if ($File->{Namespace}) { - my $ns = $CFG->{Types}->{$File->{Version}}->{Namespace} || FALSE; - - if (&is_xml($File)) { - if ($ns eq $File->{Namespace}) { - &add_warning('W10', { - W10_ns => $File->{Namespace}, - W10_type => $File->{Type}, - }); - } - } else { - &add_warning('W11', {W11_ns => $File->{Namespace}, - w11_doctype => $File->{DOCTYPE}}); - } -} else { - if (&is_xml($File) and $CFG->{Types}->{$File->{Version}}->{Namespace}) { - &add_warning('W12', {}); - } -} - - -## if invalid content, AND if requested, pass through tidy -if (!$File->{'Is Valid'} && $File->{Opt}->{'Show Tidy'}) { - eval { - local $SIG{__DIE__}; - require HTML::Tidy; - my $tidy = HTML::Tidy->new({config_file => $CFG->{Paths}->{TidyConf}}); - my $cleaned = $tidy->clean(join("\n", @{$File->{Content}})); - $cleaned = Encode::decode_utf8($cleaned); - $File->{Tidy} = $cleaned; - }; - if ($@) { - (my $errmsg = $@) =~ s/ at .*//s; - &add_warning('W29', { W29_msg => $errmsg }); - } -} - -my $template; - -if ($File->{Opt}->{Output} eq 'xml') { - $template = $File->{Templates}->{XML}; -} elsif ($File->{Opt}->{Output} eq 'earl') { - $template = $File->{Templates}->{EARLXML}; -} elsif ($File->{Opt}->{Output} eq 'n3') { - $template = $File->{Templates}->{EARLN3}; -} elsif ($File->{Opt}->{Output} eq 'json') { - $template = $File->{Templates}->{JSON}; -} elsif ($File->{Opt}->{Output} eq 'ucn') { - $template = $File->{Templates}->{UCN}; -} elsif ($File->{Opt}->{Output} eq 'soap12') { - if ($CFG->{'Enable SOAP'} != 1) { # API disabled - ideally this should have been sent before performing validation... - print CGI::header(-status => 503, -content_language => "en", - -type => "text/html", -charset => "utf-8" - ); - $template = $File->{Templates}->{SOAPDisabled}; - } elsif ($File->{'Error Flagged'}) { # should send SOAP fault message - $template = $File->{Templates}->{SOAPFault}; - # we fill the soap fault template - #with the variables that had been passed to the HTML fatal error template - foreach my $fault_param ($File->{Templates}->{Error}->param()) { - $template->param($fault_param => $File->{Templates}->{Error}->param($fault_param)); - } - } else { - $template = $File->{Templates}->{SOAP}; - } -} else { - $template = $File->{Templates}->{Result}; -} - -&prep_template($File, $template); -&fin_template($File, $template); - -$template->param(file_warnings => $File->{Warnings}); -$template->param(tidy_output => $File->{Tidy}); -$template->param(file_source => &source($File)) - if ($template->param('opt_show_source') or ($File->{'Is Upload'}) or ($File->{'Direct Input'})); - -if ($File->{Opt}->{Output} eq 'json') { - # No JSON escaping in HTML::Template (and "JS" is not the right thing here) - my $json = JSON->new(); - $json->allow_nonref(TRUE); - for my $msgs ($template->param("file_errors"), - $template->param("file_warnings")) { - next unless $msgs; - for my $msg (@$msgs) { - for my $key (qw(msg expl)) { - $msg->{$key} = $json->encode($msg->{$key}) if $msg->{$key}; - } - } - } -} - -# transcode output from perl's internal to utf-8 and output -print Encode::encode('UTF-8', $template->output); - -# -# Get rid of $File object and exit. -undef $File; -exit; - -############################################################################# -# Subroutine definitions -############################################################################# - # # Generate HTML report. sub prep_template ($$) { |