- From: Olivier Thereaux via cvs-syncmail <cvsmail@w3.org>
- Date: Fri, 08 Sep 2006 05:33:21 +0000
- To: www-validator-cvs@w3.org
Update of /sources/public/perl/modules/W3C/XHTML/HTMLCompatChecker/bin
In directory hutz:/tmp/cvs-serv32224
Modified Files:
appCcheck.pl
Log Message:
Moving the ugly inline code to HTML::Template-ing.
Index: appCcheck.pl
===================================================================
RCS file: /sources/public/perl/modules/W3C/XHTML/HTMLCompatChecker/bin/appCcheck.pl,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -d -r1.32 -r1.33
--- appCcheck.pl 7 Sep 2006 23:45:59 -0000 1.32
+++ appCcheck.pl 8 Sep 2006 05:33:19 -0000 1.33
@@ -9,11 +9,16 @@
use strict;
use warnings;
use XML::Parser;
-use CGI qw(hr img dt dd start_dl input submit p strong escapeHTML
- a start_form start_html header param h1 start_div :standard);
+use CGI qw(param);
require LWP::UserAgent;
use URI;
use CGI::Carp 'fatalsToBrowser';
+use HTML::Template 2.6 qw();
+
+# Define global constants
+use constant TRUE => 1;
+use constant FALSE => 0;
+
use constant APPC_FOUND_XML_DECL => 1; # http://www.w3.org/TR/xhtml1/#C_1
use constant APPC_FOUND_XML_PI => 2; # http://www.w3.org/TR/xhtml1/#C_1
@@ -121,10 +126,6 @@
#print p($ct);
if ($ct ne "text/html") {
$IS_RELEVANT_CT = 0;
- my $incorrect_ct_msg = join(' ', "This document is served with the Content-Type",
- $ct,
- "which is different from \"text/html\". HTML compatibility guidelines checking does not apply.");
- push @MESSAGES, {severity => "Info", line => 0, column => 0, cnum => -1, message_text => $incorrect_ct_msg};
}
}
@@ -247,234 +248,70 @@
my $doctypeint = shift;
if (defined $doctypename) {
$IS_RELEVANT_DOC = 0 if ($doctypename ne "html");
- # print p($doctypename);
- # print p($IS_RELEVANT_DOC);
}
if(defined $doctypesys) {
$_ = $doctypesys;
$IS_RELEVANT_DOC = 0 if (not /http:\/\/www.w3.org\/TR\/xhtml1\/DTD\/xhtml1-(strict|transitional|frameset).dtd/);
- # print p($doctypesys);
- # print p($IS_RELEVANT_DOC);
}
if (defined $doctypepub) {
$_ = $doctypepub;
$IS_RELEVANT_DOC = 0 if (not /-\/\/W3C\/\/DTD XHTML 1.0 (Strict|Transitional|Frameset)\/\/EN/);
- # print p($doctypepub);
- # print p($IS_RELEVANT_DOC);
}
if (defined $doctypeint) # there should be no internal subset
{
$IS_RELEVANT_DOC = 0 if (length $doctypeint);
}
$IS_RELEVANT_DOC = 0 if ((not defined $doctypesys) and (not defined $doctypepub)); # should not happen with XHTML 1.0
- #print p($IS_RELEVANT_DOC);
- my $bad_doc_msg = "Your document appears to not be XHTML 1.0. HTML compatibility guidelines checking does not apply.";
- push @MESSAGES, {severity => "Info", line => 0, column => 0, cnum => -1, message_text => $bad_doc_msg} if (not $IS_RELEVANT_DOC);
}
## Output routines ########################################################
-sub output_start
-{
- my $output = shift;
- if ($output eq "html")
- {
- &output_start_html;
- }
- else
- {
- &output_start_xml;
- }
-}
-
-sub output_start_html
-{
- print header,
- start_html(-style=>{-src=>'http://qa-dev.w3.org:8001/css-validator/base.css'},
- -title=>"Experimental XHTML 1.0 Appendix C checker"),
- div({-id=>"banner"},
- h1( {-id=> "title"},
-
- a({-href=>'http://www.w3.org'},
- img{-src=>'http://www.w3.org/Icons/WWW/w3c_home.gif', -alt=>'W3C'}),
- "XHTML 1.0 Appendix C checker"
- ),
- ),
- p({-id=>"tagline"}, "Checks XHTML 1.0 documents against HTML compatibility guidelines"),
- start_form("GET"),
- start_div;
-}
-
-sub output_start_xml
-{
- #print header(-type => 'application/soap+xml; charset=UTF-8');
- print header(-type => 'text/xml; charset=UTF-8');
- print '<?xml version="1.0" encoding="UTF-8"?>';
-}
-
-sub output_messages
-{
- my $output = shift;
- my $uri = shift;
- if ($output eq "html")
- {
- &output_messages_html;
- }
- else
- {
- &output_messages_xml($uri);
- }
-}
-
-
-sub output_messages_html
-{
- print start_dl;
- for (my $i=0; $i < scalar @MESSAGES; $i++)
- {
- if ($MESSAGES[$i]{'cnum'} != -1)
- {
- print dt(strong($MESSAGES[$i]{'severity'}), "Line", $MESSAGES[$i]{'line'}, "column", $MESSAGES[$i]{'column'}),
- dd(a({-href=>'http://www.w3.org/TR/xhtml1/#C_' . $MESSAGES[$i]{'cnum'}}, escapeHTML($MESSAGES[$i]{'message_text'})));
- }
- else
- {
- print dt(strong($MESSAGES[$i]{'severity'})),
- dd(escapeHTML($MESSAGES[$i]{'message_text'}));
- }
- }
- print end_dl;
-}
-sub output_messages_xml
-{
- my $uri = shift;
- my (@ERRORS, @WARNINGS, @INFO);
- for (my $i=0; $i < scalar @MESSAGES; $i++)
- {
- if ($MESSAGES[$i]{'severity'} eq "Error") {
- push @ERRORS, $MESSAGES[$i];
- }
- elsif ($MESSAGES[$i]{'severity'} eq "Warning")
- {
- push @WARNINGS, $MESSAGES[$i];
-
- }
- else # info
- {
- push @INFO, $MESSAGES[$i];
- }
- }
- print '<observationresponse xmlns="http://www.w3.org/unicorn/observationresponse"
- xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
- xsi:schemaLocation="http://www.w3.org/QA/2006/obs_framework/ns/observation/ http://www.w3.org/QA/2006/obs_framework/response/observer-response.xsd">', "\n",
- '<uri>', $uri,'</uri>', "\n";
- if (@ERRORS){
- print '<passed>false</passed><result>';
- print '<errors><errorcount>', scalar @ERRORS, '</errorcount><errorlist>';
- print '<uri>', $uri, '</uri>';
- for (my $i=0; $i < scalar @ERRORS; $i++)
- {
- print '<error><line>', $ERRORS[$i]{'line'}, '</line>',
- '<column>', $ERRORS[$i]{'column'}, '</column>',
- '<message>',
- escapeHTML($ERRORS[$i]{'message_text'}),
- ' see ', 'http://www.w3.org/TR/xhtml1/#C_' . $ERRORS[$i]{'cnum'},
- '</message></error>';
- }
- print '</errorlist></errors>';
- }
- else
- {
- print '<passed>true</passed><result>';
- }
- if (@WARNINGS){
- print '<warnings><warningcount>', scalar @WARNINGS, '</warningcount><warninglist>';
- print '<uri>', $uri, '</uri>';
- for (my $i=0; $i < scalar @WARNINGS; $i++)
- {
- print '<warning><line>', $WARNINGS[$i]{'line'}, '</line>',
- '<column>', $WARNINGS[$i]{'column'}, '</column>',
- '<message>',
- escapeHTML($WARNINGS[$i]{'message_text'}),
- ' see ', 'http://www.w3.org/TR/xhtml1/#C_' . $WARNINGS[$i]{'cnum'},
- '</message></warning>';
- }
- print '</warninglist></warnings>';
- }
- if (@INFO){
- print '<informations><infocount>', scalar @INFO, '</infocount><infolist>';
- print '<uri>', $uri, '</uri>';
- for (my $i=0; $i < scalar @INFO; $i++)
- {
- print '<info><line>', $INFO[$i]{'line'}, '</line>',
- '<column>', $INFO[$i]{'column'}, '</column>',
- '<message>',
- escapeHTML($INFO[$i]{'message_text'});
- if ($INFO[$i]{'cnum'} != -1) { # ignoring the "your document is irrelevant" message in xml format
- print ' see ', 'http://www.w3.org/TR/xhtml1/#C_' . $INFO[$i]{'cnum'},
- '</message></info>';
- }
- }
- print '</infolist></informations>';
- }
-
- print '</result></observationresponse>';
-}
+sub prep_output {
+ my $output_param = shift;
+ my $html_output_template_text = 'Content-Type: text/html; charset=UTF-8
+
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
+<head>
+<title>Experimental XHTML 1.0 Appendix C checker</title>
+<link rel="stylesheet" type="text/css" href="http://qa-dev.w3.org:8001/css-validator/base.css" />
+<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />
+</head>
+<body>
+<div id="banner"><h1 id="title"><a href="http://www.w3.org"><img src="http://www.w3.org/Icons/WWW/w3c_home.gif" alt="W3C" /></a> XHTML 1.0 Appendix C checker</h1></div>
+<p id="tagline">Checks XHTML 1.0 documents against HTML compatibility guidelines</p>
-sub output_NoError
-{
- my $output = shift;
- my $uri = shift;
- if ($output eq "html")
- {
- &output_NoError_html;
- }
-}
+<form method="get" action="/appc/" enctype="multipart/form-data">
+<div><input name="uri" size="60" <TMPL_IF NAME="uri">value="<TMPL_VAR NAME="uri" ESCAPE="HTML">"</TMPL_IF> /><input type="submit" value="Check" />
+<dl>
+<TMPL_LOOP NAME="message_loop">
+ <dt><strong><TMPL_VAR NAME="severity" ESCAPE="HTML"></strong> Line <TMPL_VAR NAME="line" ESCAPE="HTML"> column <TMPL_VAR NAME="column" ESCAPE="HTML"></dt>
+ <dd><a href="http://www.w3.org/TR/xhtml1/#C_<TMPL_VAR NAME="cnum" ESCAPE="HTML">"><TMPL_VAR NAME="message_text" ESCAPE="HTML"></a></dd>
+</TMPL_LOOP>
-sub output_NoError_html
-{
- print p("Cool, no errors found");
-}
+</dl>
-sub output_fault{
- my $output = shift;
- if ($output eq "html")
- {
- &output_fault_html;
- }
- else
- {
- &output_fault_xml;
- }
-}
+<TMPL_UNLESS NAME="uri"><p>Enter the URI of an XHTML 1.0 document which you would like to check against the
+<a href="http://www.w3.org/TR/xhtml1/#guidelines">HTML Compatibility Guidelines</a> .</p></TMPL_UNLESS>
-sub output_fault_html
-{
- print p("Oops.");
-}
+<TMPL_UNLESS NAME="is_wf">
+<p>The document appears to not be well-formed XML. Either it is not XHTML (e.g HTML up to version 4.01) or it has XML well-formedness errors.
+HTML Compatibility guidelines checking does not apply.
+</p>
+</TMPL_UNLESS>
+<TMPL_UNLESS NAME="is_relevant_ct">
+foo
+</TMPL_UNLESS>
+<TMPL_UNLESS NAME="is_relevant_doctype">
+bar
+</TMPL_UNLESS>
-sub output_fault_xml
-{
- print '<env:Fault><env:Reason><env:Text xml:lang="en-US">oops</env:Text></env:Reason></env:Fault>';
-}
-sub output_end
-{
- my $output = shift;
- if ($output eq "html")
- {
- &output_end_html;
- }
- else
- {
- &output_end_xml;
- }
-}
+</div>
+</form>
-sub output_end_html
-{
- print end_div, end_form,
- '
<ul class="navbar" id="menu">
<li><a href="" title="About this service">About</a> <span class="hideme">|</span></li>
</ul>
@@ -483,6 +320,7 @@
<a href="http://www.w3.org/QA/" title="W3C\'s Quality Assurance Activity, bringing you free Web quality tools and more"><img src="http://www.w3.org/QA/2002/12/qa-small.png" alt="QA" /></a>
</p>
<p id="support_logo">
+
Support this tool, become a<br />
<a href="http://www.w3.org/Consortium/supporters"><img src="http://www.w3.org/Consortium/supporter-logos/csupporter.png" alt="W3C Supporter" /></a>
</p>
@@ -504,69 +342,104 @@
with our <a href="http://www.w3.org/Consortium/Legal/privacy-statement#Public">public</a> and
<a href="http://www.w3.org/Consortium/Legal/privacy-statement#Members">Member</a> privacy
statements.
- </p>',
- end_html;
-}
+ </p>
+</body>
+</html>
+';
-sub output_end_xml
-{
-}
+ my $html_output = HTML::Template->new_scalar_ref(\$html_output_template_text,
+ die_on_bad_params => FALSE,
+ loop_context_vars => TRUE,
+ );
-sub output_noinput {
- my $output = shift;
- if ($output eq "html") {
- &output_formEmpty_html;
- }
-}
+ my $xml_output_template_text = 'Content-Type: text/xml; charset=UTF-8
-sub output_formEmpty_html
-{
- print input({-name=>"uri", -size=>60}),input({-type=>'submit', -value=>"Check"});
- print p("Enter the URI of an XHTML 1.0 document which you would like to check against the ", a({-href=>"http://www.w3.org/TR/xhtml1/#guidelines"}, "HTML Compatibility Guidelines"), ".")
-}
+<?xml version="1.0" encoding="UTF-8"?><observationresponse xmlns="http://www.w3.org/unicorn/observationresponse"
+ xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
+ xsi:schemaLocation="http://www.w3.org/QA/2006/obs_framework/ns/observation/ http://www.w3.org/QA/2006/obs_framework/response/observer-response.xsd">
+<uri><TMPL_VAR NAME="uri" ESCAPE="HTML"></uri>
+<passed><TMPL_IF NAME="passed">true<TMPL_ELSE>false</TMPL_IF></passed>
+<result>
+<errors>
+ <errorcount><TMPL_VAR NAME="error_count" ESCAPE="HTML"></errorcount>
+ <errorlist>
+ <uri><TMPL_VAR NAME="uri" ESCAPE="HTML"></uri>
+ <TMPL_LOOP NAME="error_loop">
+ <error>
+ <line><TMPL_VAR NAME="line" ESCAPE="HTML"></line>
+ <column><TMPL_VAR NAME="column" ESCAPE="HTML"></column>
+ <message><a href="http://www.w3.org/TR/xhtml1/#C_<TMPL_VAR NAME="cnum" ESCAPE="HTML">"><TMPL_VAR NAME="message_text" ESCAPE="HTML"></a></message>
+ </error>
+ </TMPL_LOOP>
+ <TMPL_UNLESS NAME="is_wf">
+ <error>
+ <message>The document appears to not be well-formed XML. Either it is not XHTML (e.g HTML up to version 4.01) or it has XML well-formedness errors.
+ HTML Compatibility guidelines checking does not apply.</message>
+ </error>
+ </TMPL_UNLESS>
+ </errorlist>
+</errors>
+<warnings>
+ <warningcount><TMPL_VAR NAME="warning_count" ESCAPE="HTML"></warningcount>
+ <warninglist>
+ <uri><TMPL_VAR NAME="uri" ESCAPE="HTML"></uri>
+ <TMPL_LOOP NAME="warning_loop">
+ <warning>
+ <line><TMPL_VAR NAME="line" ESCAPE="HTML"></line>
+ <column><TMPL_VAR NAME="column" ESCAPE="HTML"></column>
+ <message><a href="http://www.w3.org/TR/xhtml1/#C_<TMPL_VAR NAME="cnum" ESCAPE="HTML">"><TMPL_VAR NAME="message_text" ESCAPE="HTML"></a></message>
+ </warning>
+ </TMPL_LOOP>
+ </warninglist>
+</warnings>
+<informations>
+ <infocount><TMPL_VAR NAME="info_count" ESCAPE="HTML"></infocount>
+ <infolist>
+ <uri><TMPL_VAR NAME="uri" ESCAPE="HTML"></uri>
+ <TMPL_LOOP NAME="info_loop">
+ <info>
+ <line><TMPL_VAR NAME="line" ESCAPE="HTML"></line>
+ <column><TMPL_VAR NAME="column" ESCAPE="HTML"></column>
+ <message><a href="http://www.w3.org/TR/xhtml1/#C_<TMPL_VAR NAME="cnum" ESCAPE="HTML">"><TMPL_VAR NAME="message_text" ESCAPE="HTML"></a></message>
+ </info>
+ </TMPL_LOOP>
+ </infolist>
+</informations>
+</result>
+</observationresponse>
+';
-sub output_formFilled_html
-{
- my $uri = shift;
- print input({-value=>$uri, -name=>"uri", -size=>60}),input({-type=>'submit', -value=>"Check"});
-
-}
+ my $xml_output = HTML::Template->new_scalar_ref(\$xml_output_template_text,
+ die_on_bad_params => FALSE,
+ loop_context_vars => TRUE,
+ );
-sub output_NotWellFormed
-{
- my $output = shift;
- if ($output eq "html")
- {
- print p("The document appears to not be well-formed XML. Either it is not XHTML (e.g HTML up to version 4.01) or it has XML well-formedness errors. HTML Compatibility guidelines checking does not apply.");
- }
- else
- {
- # TODO add an ERROR message about non-wellformedness
- }
+ if ($output_param eq "html") {
+ return $html_output;
+ }
+ else {
+ return $xml_output;
+ }
}
## Main ###################################################################
my $uri = param('uri'); # "http://www.w3.org/TR/xhtml1/";
-my $output = "html";
+my $output_param = "html";
if (defined param('output'))
{
- $output = param('output');
- if ($output ne "html" and $output ne "xml") {
- $output = "html";
+ $output_param = param('output');
+ if ($output_param ne "html" and $output_param ne "xml") {
+ $output_param = "html";
}
}
-&output_start($output);
+
+my $output = &prep_output($output_param);
if (defined $uri and length $uri and URI->new($uri)->scheme eq "http")
{
- if ($output eq "html")
- {
- &output_formFilled_html($uri);
- }
-
-
+ $output->param(uri => $uri);
my $ua = LWP::UserAgent->new;
my $response = $ua->get($uri);
my $xml = undef;
@@ -585,25 +458,16 @@
$p->setHandlers(Doctype => \&_doctype);
eval { $p->parsestring($xml); };
- if (not $IS_RELEVANT_CT) #content type no good
- {
- @MESSAGES = () if ($output eq "xml");
- &output_messages($output, $uri);
- print "<!-- not relevant CT -->\n";
- @MESSAGES = (); #reset
- }
- elsif (not $IS_RELEVANT_DOC) # wrong doctype,
- {
- @MESSAGES = () if ($output eq "xml");
- &output_messages($output, $uri);
- @MESSAGES = (); #reset
- }
- elsif ($@) # not well-formed
+ $output->param(is_relevant_ct => $IS_RELEVANT_CT);
+ $output->param(is_relevant_doctype => $IS_RELEVANT_DOC);
+
+ if ($@) # not well-formed
{
- &output_NotWellFormed($output, $uri);
$IS_WF = 0;
+ $output->param(passed => 0);
+ $output->param(error_count => 1);
}
- else
+ else # woot, WF
{
my $p = XML::Parser->new;
$p->setHandlers(Char => \&_char,
@@ -611,29 +475,33 @@
Start => \&_start,
XMLDecl => \&_xmldecl);
eval { $p->parsestring($xml); };
- if (@MESSAGES)
- {
- &output_messages($output, $uri);
- }
- else
- {
- &output_NoError($output, $uri);
+ my (@ERRORS, @WARNINGS, @INFOS);
+ for (my $i=0; $i < scalar @MESSAGES; $i++)
+ {
+ if ($MESSAGES[$i]{'severity'} eq "Error") { push @ERRORS, $MESSAGES[$i];}
+ elsif ($MESSAGES[$i]{'severity'} eq "Warning") {push @WARNINGS, $MESSAGES[$i];}
+ else {push @INFOS, $MESSAGES[$i];}
}
+ $output->param(message_loop => \@MESSAGES);
+ if (@ERRORS) {$output->param(passed => 0) } else {$output->param(passed => 1)}
+ $output->param(info_loop => \@INFOS);
+ $output->param(info_count => scalar @INFOS);
+ $output->param(warning_loop => \@WARNINGS);
+ $output->param(warning_count => scalar @WARNINGS);
+ $output->param(error_loop => \@ERRORS);
+ $output->param(error_count => scalar @ERRORS);
}
- #else do nothing, this document is not relevant to us
+ $output->param(is_wf => $IS_WF);
}
- else
+ else # houston, we had a problem
{
- &output_fault;
+ # TODO some fault code
}
}
-else
-{
- &output_noinput($output);
-}
-&output_end($output);
+print $output->output();
+
__END__
Received on Friday, 8 September 2006 05:33:36 UTC