--- test/html-webhacc/cc.cgi 2008/07/21 05:24:32 1.55
+++ test/html-webhacc/cc.cgi 2008/07/21 12:56:33 1.59
@@ -1,53 +1,42 @@
#!/usr/bin/perl
use strict;
-use utf8;
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];
require WebHACC::Input;
- require WebHACC::Result;
- require WebHACC::Output;
-my $out;
-
- require Message::DOM::DOMImplementation;
- my $dom = Message::DOM::DOMImplementation->new;
{
- 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;
}
-
- load_text_catalog ('en'); ## TODO: conneg
- $out = WebHACC::Output->new;
- $out->handle (*STDOUT);
- $out->set_utf8;
+ ## 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->html (qq[Content-Type: text/html; charset=utf-8
-
-
-
-
-Web Document Conformance Checker (BETA)
-
-
-
-
-]);
-
- my $input = get_input_document ($http, $dom);
+ $out->http_header;
+ $out->html_header;
+ $out->unset_flush;
+ my $input = get_input_document ($http);
$out->input ($input);
- $out->unset_flush;
+ require WebHACC::Result;
my $result = WebHACC::Result->new;
$result->output ($out);
$result->{conforming_min} = 1;
@@ -118,26 +107,6 @@
$checker->generate_structure_error_section;
$checker->generate_additional_sections;
-=pod
-
- if (defined $doc or defined $el) {
-
- print_table_section ($input, $elements->{table}) if @{$elements->{table}};
- print_listing_section ({
- id => 'identifiers', label => 'IDs', heading => 'Identifiers',
- }, $input, $elements->{id}) if keys %{$elements->{id}};
- print_listing_section ({
- id => 'terms', label => 'Terms', heading => 'Terms',
- }, $input, $elements->{term}) if keys %{$elements->{term}};
- print_listing_section ({
- id => 'classes', label => 'Classes', heading => 'Classes',
- }, $input, $elements->{class}) if keys %{$elements->{class}};
-
- print_rdf_section ($input, $elements->{rdf}) if @{$elements->{rdf}};
- }
-
-=cut
-
my $id_prefix = 0;
for my $_subinput (@subdoc) {
my $subinput = WebHACC::Input::Subdocument->new (++$id_prefix);
@@ -154,202 +123,11 @@
$out->input ($original_input);
} # check_and_print
-sub print_table_section ($$) {
- my ($input, $tables) = @_;
-
-# push @nav, [qq[#$input->{id_prefix}tables] => 'Tables']
-# unless $input->{nested};
- print STDOUT qq[
-];
-} # print_table_section
-
-sub print_listing_section ($$$) {
- my ($opt, $input, $ids) = @_;
-
-# push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]
-# unless $input->{nested};
- print STDOUT qq[
-];
-} # print_listing_section
-
-
-sub print_rdf_section ($$$) {
- my ($input, $rdfs) = @_;
-
-# push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']
-# unless $input->{nested};
- print STDOUT qq[
-];
-} # print_rdf_section
-
-sub get_rdf_resource_html ($) {
- my $resource = shift;
- if (defined $resource->{uri}) {
- my $euri = htescape ($resource->{uri});
- return '<' . $euri .
- '>';
- } elsif (defined $resource->{bnodeid}) {
- return htescape ('_:' . $resource->{bnodeid});
- } elsif ($resource->{nodes}) {
- return '(rdf:XMLLiteral)';
- } elsif (defined $resource->{value}) {
- my $elang = htescape (defined $resource->{language}
- ? $resource->{language} : '');
- my $r = qq[] . htescape ($resource->{value}) . '
';
- if (defined $resource->{datatype}) {
- my $euri = htescape ($resource->{datatype});
- $r .= '^^<' . $euri .
- '>';
- } elsif (length $resource->{language}) {
- $r .= '@' . htescape ($resource->{language});
- }
- return $r;
- } else {
- return '??';
- }
-} # get_rdf_resource_html
-
-{
- my $Msg = {};
-
-sub load_text_catalog ($) {
-# my $self = shift;
- my $lang = shift; # MUST be a canonical lang name
- open my $file, '<:utf8', "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_input_document ($) {
+ my $http = shift;
-sub get_text ($;$$) {
-# my $self = shift;
- my ($type, $level, $node) = @_;
- $type = $level . ':' . $type if defined $level;
- $level = 'm' unless defined $level;
- my @arg;
- {
- if (defined $Msg->{$type}) {
- my $msg = $Msg->{$type}->[1];
- $msg =~ s{\$([0-9]+)}{
- defined $arg[$1] ? ($arg[$1]) : '(undef)';
- }ge; ##BUG: ^ must be escaped
- $msg =~ s{{\@([A-Za-z0-9:_.-]+)}}{
- UNIVERSAL::can ($node, 'get_attribute_ns')
- ? ($node->get_attribute_ns (undef, $1)) : ''
- }ge; ## BUG: ^ must be escaped
- $msg =~ s{{\@}}{ ## BUG: v must be escaped
- UNIVERSAL::can ($node, 'value') ? ($node->value) : ''
- }ge;
- $msg =~ s{{local-name}}{
- UNIVERSAL::can ($node, 'manakai_local_name')
- ? ($node->manakai_local_name) : ''
- }ge; ## BUG: ^ must be escaped
- $msg =~ s{{element-local-name}}{
- (UNIVERSAL::can ($node, 'owner_element') and
- $node->owner_element)
- ? ($node->owner_element->manakai_local_name)
- : '' ## BUG: ^ must be escaped
- }ge;
- return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
- } elsif ($type =~ s/:([^:]*)$//) {
- unshift @arg, $1;
- redo;
- }
- }
- return ($type, 'level-'.$level, ($_[0]));
- ## BUG: ^ must be escaped
-} # get_text
-
-}
-
-sub get_input_document ($$) {
- my ($http, $dom) = @_;
+ require Message::DOM::DOMImplementation;
+ my $dom = Message::DOM::DOMImplementation->new;
require Encode;
my $request_uri = Encode::decode ('utf-8', $http->get_parameter ('uri'));
@@ -543,4 +321,4 @@
=cut
-## $Date: 2008/07/21 05:24:32 $
+## $Date: 2008/07/21 12:56:33 $