#!/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]; 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 my @nav; my %time; require Message::DOM::DOMImplementation; my $dom = Message::DOM::DOMImplementation->new; { use Message::CGI::HTTP; my $http = Message::CGI::HTTP->new; if ($http->get_meta_variable ('PATH_INFO') ne '/') { print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400"; exit; } binmode STDOUT, ':utf8'; $| = 1; load_text_catalog ('en'); ## TODO: conneg print STDOUT qq[Content-Type: text/html; charset=utf-8 Web Document Conformance Checker (BETA)

Web Document Conformance Checker (beta)

]; $| = 0; my $input = get_input_document ($http, $dom); my $char_length = 0; print qq[
Request URI
<@{[htescape $input->{request_uri}]}>
Document URI
<@{[htescape $input->{uri}]}>
]; # no
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)' : defined $input->{official_type} ? $input->{media_type} eq $input->{official_type} ? '' : '(sniffed; official type is: '.htescape ($input->{official_type}).')' : '(sniffed)']}
Character Encoding
@{[defined $input->{charset} ? ''.htescape ($input->{charset}).'' : '(none)']} @{[$input->{charset_overridden} ? '(overridden)' : '']}
Length
$char_length byte@{[$char_length == 1 ? '' : 's']}
]; $input->{id_prefix} = ''; #$input->{nested} = 0; my $result = {conforming_min => 1, conforming_max => 1}; check_and_print ($input => $result); print_result_section ($result); } else { print STDOUT qq[]; print_result_input_error_section ($input); } print STDOUT qq[ ]; for (qw/decode parse parse_html parse_xml parse_manifest check check_manifest/) { 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 'u' or $err->{level} eq 'unsupported') { $result->{$layer}->{unsupported}++; $result->{unsupported} = 1; } elsif ($err->{level} eq 'i') { # } 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 check_and_print ($$) { my ($input, $result) = @_; print_http_header_section ($input, $result); my $doc; my $el; my $cssom; my $manifest; my @subdoc; if ($input->{media_type} eq 'text/html') { ($doc, $el) = print_syntax_error_html_section ($input, $result); print_source_string_section ($input, \($input->{s}), $input->{charset} || $doc->input_encoding); } elsif ({ 'text/xml' => 1, 'application/atom+xml' => 1, 'application/rss+xml' => 1, 'image/svg+xml' => 1, 'application/xhtml+xml' => 1, 'application/xml' => 1, ## TODO: Should we make all XML MIME Types fall ## into this category? 'application/rdf+xml' => 1, ## NOTE: This type has different model. }->{$input->{media_type}}) { ($doc, $el) = print_syntax_error_xml_section ($input, $result); print_source_string_section ($input, \($input->{s}), $doc->input_encoding); } elsif ($input->{media_type} eq 'text/css') { $cssom = print_syntax_error_css_section ($input, $result); print_source_string_section ($input, \($input->{s}), $cssom->manakai_input_encoding); } elsif ($input->{media_type} eq 'text/cache-manifest') { ## TODO: MUST be text/cache-manifest $manifest = print_syntax_error_manifest_section ($input, $result); print_source_string_section ($input, \($input->{s}), 'utf-8'); } else { ## TODO: Change HTTP status code?? print_result_unknown_type_section ($input, $result); } if (defined $doc or defined $el) { $doc->document_uri ($input->{uri}); $doc->manakai_entity_base_uri ($input->{base_uri}); print_structure_dump_dom_section ($input, $doc, $el); my $elements = print_structure_error_dom_section ($input, $doc, $el, $result, sub { push @subdoc, shift; }); 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}}; } elsif (defined $cssom) { print_structure_dump_cssom_section ($input, $cssom); ## TODO: CSSOM validation add_error ('structure', {level => 'u'} => $result); } elsif (defined $manifest) { print_structure_dump_manifest_section ($input, $manifest); print_structure_error_manifest_section ($input, $manifest, $result); } my $id_prefix = 0; for my $subinput (@subdoc) { $subinput->{id_prefix} = 'subdoc-' . ++$id_prefix; $subinput->{nested} = 1; $subinput->{base_uri} = $subinput->{container_node}->base_uri unless defined $subinput->{base_uri}; my $ebaseuri = htescape ($subinput->{base_uri}); push @nav, ['#' . $subinput->{id_prefix} => 'Sub #' . $id_prefix]; print STDOUT qq[

Subdocument #$id_prefix