--- test/html-webhacc/cc.cgi 2008/07/21 05:24:32 1.55 +++ test/html-webhacc/cc.cgi 2008/07/21 09:40:59 1.58 @@ -1,53 +1,37 @@ #!/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; $out->set_flush; - $out->html (qq[Content-Type: text/html; charset=utf-8 - - - - -Web Document Conformance Checker (BETA) - - - -

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 +102,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,141 +118,6 @@ $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[ -
-

Tables

- - - - -]; - - require JSON; - - my $i = 0; - for my $table (@$tables) { - $i++; - print STDOUT qq[

] . - get_node_link ($input, $table->{element}) . q[

]; - - delete $table->{element}; - - for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}, - @{$table->{row}}) { - 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 '
]; - } - - 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[ -
-

$opt->{heading}

- -
-]; - for my $id (sort {$a cmp $b} keys %$ids) { - print STDOUT qq[
@{[htescape $id]}
]; - for (@{$ids->{$id}}) { - print STDOUT qq[
].get_node_link ($input, $_).qq[
]; - } - } - 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[ -
-

RDF Triples

- -
]; - my $i = 0; - for my $rdf (@$rdfs) { - print STDOUT qq[
]; - print STDOUT get_node_link ($input, $rdf->[0]); - print STDOUT qq[
]; - for my $triple (@{$rdf->[1]}) { - print STDOUT '
' . get_node_link ($input, $triple->[0]) . '
'; - print STDOUT get_rdf_resource_html ($triple->[1]); - print STDOUT ' '; - print STDOUT get_rdf_resource_html ($triple->[2]); - print STDOUT ' '; - print STDOUT get_rdf_resource_html ($triple->[3]); - } - print STDOUT qq[
]; - } - 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 = {}; @@ -348,8 +177,11 @@ } -sub get_input_document ($$) { - my ($http, $dom) = @_; +sub get_input_document ($) { + my $http = shift; + + 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 +375,4 @@ =cut -## $Date: 2008/07/21 05:24:32 $ +## $Date: 2008/07/21 09:40:59 $