--- test/html-webhacc/cc.cgi 2007/09/11 08:25:23 1.21
+++ test/html-webhacc/cc.cgi 2008/08/15 16:44:03 1.63
@@ -4,907 +4,137 @@
use lib qw[/home/httpd/html/www/markup/html/whatpm
/home/wakaba/work/manakai2/lib];
use CGI::Carp qw[fatalsToBrowser];
-use Scalar::Util qw[refaddr];
-use Time::HiRes qw/time/;
-sub htescape ($) {
- my $s = $_[0];
- $s =~ s/&/&/g;
- $s =~ s//>/g;
- $s =~ s/"/"/g;
- $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{
- sprintf 'U+%04X ', ord $1;
- }ge;
- return $s;
-} # htescape
+ require WebHACC::Input;
- use Message::CGI::HTTP;
+{
+ require Message::CGI::HTTP;
my $http = Message::CGI::HTTP->new;
+ require WebHACC::Output;
+ my $out = WebHACC::Output->new;
+ $out->handle (*STDOUT);
+ $out->set_utf8;
+
if ($http->get_meta_variable ('PATH_INFO') ne '/') {
- print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";
+ $out->http_error (404);
exit;
}
- binmode STDOUT, ':utf8';
- $| = 1;
-
- require Message::DOM::DOMImplementation;
- my $dom = Message::DOM::DOMImplementation->new;
-
- load_text_catalog ('en'); ## TODO: conneg
-
- my @nav;
- print STDOUT qq[Content-Type: text/html; charset=utf-8
-
-
-
-
-Web Document Conformance Checker (BETA)
-
-
-Request URI
- <@{[htescape $input->{request_uri}]} >Document URI
- <@{[htescape $input->{uri}]} > yet
- push @nav, ['#document-info' => 'Information'];
-
-if (defined $input->{s}) {
- $char_length = length $input->{s};
-
- print STDOUT qq[
-
Base URI
-
<@{[htescape $input->{base_uri}]} >
-
Internet Media Type
-
@{[htescape $input->{media_type}]}
- @{[$input->{media_type_overridden} ? '(overridden) ' : '']}
-
Character Encoding
-
@{[defined $input->{charset} ? ''.htescape ($input->{charset}).'' : '(none)']}
- @{[$input->{charset_overridden} ? '(overridden) ' : '']}
-
Length
-
$char_length byte@{[$char_length == 1 ? '' : 's']}
-
-
-];
- for (@nav) {
- print STDOUT qq[$_->[1]
-
-
-];
-
- for (qw/decode parse parse_xml check/) {
- next unless defined $time{$_};
- open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
- print $file $char_length, "\t", $time{$_}, "\n";
- }
-
-exit;
-
-sub add_error ($$$) {
- my ($layer, $err, $result) = @_;
- if (defined $err->{level}) {
- if ($err->{level} eq 's') {
- $result->{$layer}->{should}++;
- $result->{$layer}->{score_min} -= 2;
- $result->{conforming_min} = 0;
- } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
- $result->{$layer}->{warning}++;
- } elsif ($err->{level} eq 'unsupported') {
- $result->{$layer}->{unsupported}++;
- $result->{unsupported} = 1;
- } else {
- $result->{$layer}->{must}++;
- $result->{$layer}->{score_max} -= 2;
- $result->{$layer}->{score_min} -= 2;
- $result->{conforming_min} = 0;
- $result->{conforming_max} = 0;
- }
- } else {
- $result->{$layer}->{must}++;
- $result->{$layer}->{score_max} -= 2;
- $result->{$layer}->{score_min} -= 2;
- $result->{conforming_min} = 0;
- $result->{conforming_max} = 0;
- }
-} # add_error
-
-sub print_http_header_section ($$) {
- my ($input, $result) = @_;
- return unless defined $input->{header_status_code} or
- defined $input->{header_status_text} or
- @{$input->{header_field}};
-
- push @nav, ['#source-header' => 'HTTP Header'];
- print STDOUT qq[];
-} # print_http_header_section
-
-sub print_syntax_error_html_section ($$) {
- my ($input, $result) = @_;
-
- require Encode;
- require Whatpm::HTML;
-
- $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.
-
- my $time1 = time;
- my $t = Encode::decode ($input->{charset}, $input->{s});
- $time{decode} = time - $time1;
-
- print STDOUT qq[
-
-
Parse Errors
-
-
];
- push @nav, ['#parse-errors' => 'Parse Error'];
-
- my $onerror = sub {
- my (%opt) = @_;
- my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
- if ($opt{column} > 0) {
- print STDOUT qq[Line $opt{line} column $opt{column}Line $opt{line} Description ]];
- print STDOUT qq[$msg \n];
-
- add_error ('syntax', \%opt => $result);
- };
-
- my $doc = $dom->create_document;
- my $el;
- $time1 = time;
- if (defined $inner_html_element and length $inner_html_element) {
- $el = $doc->create_element_ns
- ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
- Whatpm::HTML->set_inner_html ($el, $t, $onerror);
- } else {
- Whatpm::HTML->parse_string ($t => $doc, $onerror);
- }
- $time{parse} = time - $time1;
-
- print STDOUT qq[
-
Parse Errors
-
-
];
- push @nav, ['#parse-errors' => 'Parse Error'];
-
- my $onerror = sub {
- my $err = shift;
- my $line = $err->location->line_number;
- print STDOUT qq[Line $line column ];
- print STDOUT $err->location->column_number, "";
- print STDOUT htescape $err->text, " \n";
-
- add_error ('syntax', {type => $err->text,
- level => [
- $err->SEVERITY_FATAL_ERROR => 'm',
- $err->SEVERITY_ERROR => 'm',
- $err->SEVERITY_WARNING => 's',
- ]->[$err->severity]} => $result);
-
- return 1;
- };
-
- my $time1 = time;
- open my $fh, '<', \($input->{s});
- my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
- ($fh => $dom, $onerror, charset => $input->{charset});
- $time{parse_xml} = time - $time1;
-
- print STDOUT qq[
-
Document Source
-
\n];
- if (length $$s) {
- while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
- print STDOUT qq[], htescape $1, " \n";
- $i++;
- }
- if ($$s =~ /\G([^\x0A]+)/gc) {
- print STDOUT qq[], htescape $1, " \n";
- }
- } else {
- print STDOUT q[ ';
-
- my @node = ($node);
- while (@node) {
- my $child = shift @node;
- unless (ref $child) {
- $r .= $child;
- next;
- }
-
- my $node_id = 'node-'.refaddr $child;
- my $nt = $child->node_type;
- if ($nt == $child->ELEMENT_NODE) {
- my $child_nsuri = $child->namespace_uri;
- $r .= qq[] . htescape ($child->tag_name) .
- ''; ## ISSUE: case
-
- if ($child->has_attributes) {
- $r .= '';
- for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }
- @{$child->attributes}) {
- $r .= qq[] . htescape ($attr->[0]) . ' = '; ## ISSUE: case?
- $r .= '' . htescape ($attr->[1]) . ' ';
- }
-
- if ($child->has_child_nodes) {
- $r .= '';
- unshift @node, @{$child->child_nodes}, ' ' . htescape ($child->data) . ' <[CDATA[' . htescape ($child->data) . ' ]]>Document';
- $r .= qq[];
- $r .= qq[@{[scalar get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]} ];
- $r .= qq[@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]} ];
- unless ($child->manakai_is_html) {
- $r .= qq[XML version = @{[htescape ($child->xml_version)]} ];
- if (defined $child->xml_encoding) {
- $r .= qq[XML encoding = @{[htescape ($child->xml_encoding)]} ];
- } else {
- $r .= qq[XML encoding = (null) ];
- }
- $r .= qq[XML standalone = @{[$child->xml_standalone ? 'true' : 'false']} ];
- }
- $r .= qq[ ];
- if ($child->has_child_nodes) {
- $r .= '';
- unshift @node, @{$child->child_nodes}, ' ';
- }
- } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {
- $r .= qq'<!DOCTYPE>';
- $r .= qq[Name = @{[htescape ($child->name)]} ];
- $r .= qq[Public identifier = @{[htescape ($child->public_id)]} ];
- $r .= qq[System identifier = @{[htescape ($child->system_id)]} ];
- $r .= ' <?@{[htescape ($child->target)]} @{[htescape ($child->data)]} ?>@{[$child->node_type]} @{[htescape ($child->node_name)]} '; # error
- }
- }
-
- $r .= ' ';
- print STDOUT $r;
-} # print_document_tree
-
-sub print_structure_dump_section ($$) {
- my ($doc, $el) = @_;
-
- print STDOUT qq[
-
-
Document Tree
-];
- push @nav, ['#document-tree' => 'Tree'];
-
- print_document_tree ($el || $doc);
-
- print STDOUT qq[];
-} # print_structure_dump_section
-
-sub print_structure_error_section ($$$) {
- my ($doc, $el, $result) = @_;
-
- print STDOUT qq[
-
Document Errors
-
-
];
- push @nav, ['#document-errors' => 'Document Error'];
-
- require Whatpm::ContentChecker;
- my $onerror = sub {
- my %opt = @_;
- my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
- $type =~ tr/ /-/;
- $type =~ s/\|/%7C/g;
- $msg .= qq[ [Description ]];
- print STDOUT qq[] . get_node_link ($opt{node}) .
- qq[ \n], $msg, " \n";
- add_error ('structure', \%opt => $result);
- };
-
- my $elements;
- my $time1 = time;
- if ($el) {
- $elements = Whatpm::ContentChecker->check_element ($el, $onerror);
- } else {
- $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);
- }
- $time{check} = time - $time1;
-
- print STDOUT qq[
-
Tables
-
-
-
-
-Structure of tables are visualized here if scripting is enabled.
-
-];
-
- require JSON;
-
- my $i = 0;
- for my $table_el (@$tables) {
- $i++;
- print STDOUT qq[
] .
- get_node_link ($table_el) . q[ ];
-
- ## TODO: Make |ContentChecker| return |form_table| result
- ## so that this script don't have to run the algorithm twice.
- my $table = Whatpm::HTMLTable->form_table ($table_el);
-
- for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
- next unless $_;
- delete $_->{element};
- }
-
- for (@{$table->{row_group}}) {
- next unless $_;
- next unless $_->{element};
- $_->{type} = $_->{element}->manakai_local_name;
- delete $_->{element};
- }
-
- for (@{$table->{cell}}) {
- next unless $_;
- for (@{$_}) {
- next unless $_;
- for (@$_) {
- $_->{id} = refaddr $_->{element} if defined $_->{element};
- delete $_->{element};
- $_->{is_header} = $_->{is_header} ? 1 : 0;
- }
- }
- }
-
- print STDOUT '];
+ ## TODO: We need real conneg support...
+ my $primary_language = 'en';
+ if ($ENV{HTTP_ACCEPT_LANGUAGE} =~ /ja/) {
+ $primary_language = 'ja';
+ }
+ $out->load_text_catalog ($primary_language);
+
+ $out->set_flush;
+ $out->http_header;
+ $out->html_header;
+ $out->unset_flush;
+
+ $out->generate_input_section ($http);
+
+ my $u = $http->get_parameter ('uri');
+ my $s = $http->get_parameter ('s');
+ if ((not defined $u or not length $u) and
+ (not defined $s or not length $s)) {
+ exit;
}
-
- print STDOUT qq[
-
Identifiers
-
-
-];
- for my $id (sort {$a cmp $b} keys %$ids) {
- print STDOUT qq[@{[htescape $id]}].get_node_link ($_).qq[ ];
- }
- }
- print STDOUT qq[
-
Terms
-
-
-];
- for my $term (sort {$a cmp $b} keys %$terms) {
- print STDOUT qq[@{[htescape $term]} ];
- for (@{$terms->{$term}}) {
- print STDOUT qq[].get_node_link ($_).qq[ ];
- }
- }
- print STDOUT qq[
-
Classes
-
-
-];
- for my $class (sort {$a cmp $b} keys %$classes) {
- print STDOUT qq[@{[htescape $class]}].get_node_link ($_).qq[ ];
- }
- }
- print STDOUT qq[
-
Result ];
-
- if ($result->{unsupported} and $result->{conforming_max}) {
- print STDOUT qq[
The conformance
- checker cannot decide whether the document is conforming or
- not, since the document contains one or more unsupported
- features. The document might or might not be conforming.
];
- } elsif ($result->{conforming_min}) {
- print STDOUT qq[
No conformance-error is
- found in this document.
];
- } elsif ($result->{conforming_max}) {
- print STDOUT qq[
This document
- is likely non -conforming , but in rare case
- it might be conforming.
];
- } else {
- print STDOUT qq[
This document is
- non -conforming
];
- }
-
- print STDOUT qq[
-
-MUST -level
-ErrorsSHOULD -level
-ErrorsWarnings Score ];
-
- my $must_error = 0;
- my $should_error = 0;
- my $warning = 0;
- my $score_min = 0;
- my $score_max = 0;
- my $score_base = 20;
- my $score_unit = $score_base / 100;
- for (
- [Transfer => 'transfer', ''],
- [Character => 'char', ''],
- [Syntax => 'syntax', '#parse-errors'],
- [Structure => 'structure', '#document-errors'],
- ) {
- $must_error += ($result->{$_->[1]}->{must} += 0);
- $should_error += ($result->{$_->[1]}->{should} += 0);
- $warning += ($result->{$_->[1]}->{warning} += 0);
- $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
- $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
-
- my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
- my $label = $_->[0];
- if ($result->{$_->[1]}->{must} or
- $result->{$_->[1]}->{should} or
- $result->{$_->[1]}->{warning} or
- $result->{$_->[1]}->{unsupported}) {
- $label = qq[$label ];
- }
-
- print STDOUT qq[$label $result->{$_->[1]}->{must}$uncertain $result->{$_->[1]}->{should}$uncertain $result->{$_->[1]}->{warning}$uncertain ];
- if ($uncertain) {
- print qq[−∞..$result->{$_->[1]}->{score_max} ];
- } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
- print qq[$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max} $result->{$_->[1]}->{score_min} ];
- }
- }
-
- $score_max += $score_base;
-
- print STDOUT qq[
-Semantics 0? 0? 0? −∞..$score_base
-Total
-$must_error?
-$should_error?
-$warning?
-−∞..$score_max
-
-
Important : This conformance checking service
-is under development . The result above might be wrong .
-
-
Media type @{[htescape $input->{media_type}]} is not supported!
-
-
Input Error : @{[htescape ($input->{error_status_text})]}
-
] .
- htescape (get_node_path ($_[0])) . qq[ ];
-} # get_node_link
-
-{
- my $Msg = {};
-
-sub load_text_catalog ($) {
- my $lang = shift; # MUST be a canonical lang name
- open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";
- while (<$file>) {
- if (s/^([^;]+);([^;]*);//) {
- my ($type, $cls, $msg) = ($1, $2, $_);
- $msg =~ tr/\x0D\x0A//d;
- $Msg->{$type} = [$cls, $msg];
- }
- }
-} # load_text_catalog
-
-sub get_text ($) {
- my ($type, $level, $node) = @_;
- $type = $level . ':' . $type if defined $level;
- my @arg;
- {
- if (defined $Msg->{$type}) {
- my $msg = $Msg->{$type}->[1];
- $msg =~ s{\$([0-9]+) }{
- defined $arg[$1] ? htescape ($arg[$1]) : '(undef)';
- }ge;
- $msg =~ s{{\@([A-Za-z0-9:_.-]+)} }{
- UNIVERSAL::can ($node, 'get_attribute_ns')
- ? htescape ($node->get_attribute_ns (undef, $1)) : ''
- }ge;
- $msg =~ s{{\@} }{
- UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''
- }ge;
- $msg =~ s{{local-name} }{
- UNIVERSAL::can ($node, 'manakai_local_name')
- ? htescape ($node->manakai_local_name) : ''
- }ge;
- $msg =~ s{{element-local-name} }{
- (UNIVERSAL::can ($node, 'owner_element') and
- $node->owner_element)
- ? htescape ($node->owner_element->manakai_local_name)
- : ''
- }ge;
- return ($type, $Msg->{$type}->[0], $msg);
- } elsif ($type =~ s/:([^:]*)$//) {
- unshift @arg, $1;
- redo;
- }
- }
- return ($type, '', htescape ($_[0]));
-} # get_text
+ $out->nav_list;
+ exit;
}
-sub get_input_document ($$) {
- my ($http, $dom) = @_;
-
- my $request_uri = $http->get_parameter ('uri');
- my $r = {};
- if (defined $request_uri and length $request_uri) {
- my $uri = $dom->create_uri_reference ($request_uri);
- unless ({
- http => 1,
- }->{lc $uri->uri_scheme}) {
- return {uri => $request_uri, request_uri => $request_uri,
- error_status_text => 'URI scheme not allowed'};
- }
-
- require Message::Util::HostPermit;
- my $host_permit = new Message::Util::HostPermit;
- $host_permit->add_rule (<check ($uri->uri_host, $uri->uri_port || 80)) {
- return {uri => $request_uri, request_uri => $request_uri,
- error_status_text => 'Connection to the host is forbidden'};
- }
-
- require LWP::UserAgent;
- my $ua = WDCC::LWPUA->new;
- $ua->{wdcc_dom} = $dom;
- $ua->{wdcc_host_permit} = $host_permit;
- $ua->agent ('Mozilla'); ## TODO: for now.
- $ua->parse_head (0);
- $ua->protocols_allowed ([qw/http/]);
- $ua->max_size (1000_000);
- my $req = HTTP::Request->new (GET => $request_uri);
- my $res = $ua->request ($req);
- ## TODO: 401 sets |is_success| true.
- if ($res->is_success or $http->get_parameter ('error-page')) {
- $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and
+Copyright 2007-2008 Wakaba
This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.
=cut
-## $Date: 2007/09/11 08:25:23 $
+## $Date: 2008/08/15 16:44:03 $