#!/usr/bin/perl use strict; use lib qw[/home/httpd/html/www/markup/html/whatpm /home/wakaba/work/manakai/lib /home/wakaba/public_html/-temp/wiki/lib]; use CGI::Carp qw[fatalsToBrowser]; use Scalar::Util qw[refaddr]; use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module sub htescape ($) { my $s = $_[0]; $s =~ s/&/&/g; $s =~ s//>/g; $s =~ s/"/"/g; $s =~ s!([\x00-\x09\x0B-\x1F\x7F-\x80])!sprintf 'U+%04X', ord $1!ge; return $s; } # htescape my $http = SuikaWiki::Input::HTTP->new; ## TODO: _charset_ my $input_format = $http->parameter ('i') || 'text/html'; my $inner_html_element = $http->parameter ('e'); my $input_uri = 'thismessage:/'; my $s = $http->parameter ('s'); if (length $s > 1000_000) { print STDOUT "Status: 400 Document Too Long\nContent-Type: text/plain; charset=us-ascii\n\nToo long"; exit; } print STDOUT qq[Content-Type: text/html; charset=utf-8 Web Document Conformance Checker (BETA)

Web Document Conformance Checker (beta)

Document URI
<@{[htescape $input_uri]}>
Internet Media Type
@{[htescape $input_format]}
]; # no
yet require Message::DOM::DOMImplementation; my $dom = Message::DOM::DOMImplementation->____new; my $doc; my $el; if ($input_format eq 'text/html') { require Encode; require Whatpm::HTML; $s = Encode::decode ('utf-8', $s); print STDOUT qq[
Character Encoding
(none)
]; print_source_string (\$s); print STDOUT qq[

Parse Errors

]; } elsif ($input_format eq 'application/xhtml+xml') { require Message::DOM::XMLParserTemp; require Encode; my $t = Encode::decode ('utf-8', $s); print STDOUT qq[
Character Encoding
(none)
]; print_source_string (\$t); print STDOUT qq[

Parse Errors

]; } else { print STDOUT qq[

Media type @{[htescape $input_format]} is not supported!

]; } if (defined $doc or defined $el) { print STDOUT qq[

Document Tree

]; print_document_tree ($el || $doc); print STDOUT qq[

Document Errors

]; } ## TODO: Show result print STDOUT qq[ ]; exit; sub print_source_string ($) { my $s = $_[0]; my $i = 1; print STDOUT qq[
    \n]; while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) { print STDOUT qq[
  1. ], htescape $1, "
  2. \n"; $i++; } if ($$s =~ /\G([^\x0A]+)/gc) { print STDOUT qq[
  3. ], htescape $1, "
  4. \n"; } print STDOUT "
"; } # print_input_string sub print_document_tree ($) { my $node = shift; my $r = '
    '; 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) { $r .= qq'
  1. ' . htescape ($child->tag_name) . ''; ## ISSUE: case if ($child->has_attributes) { $r .= ''; } if ($node->has_child_nodes) { $r .= '
      '; unshift @node, @{$child->child_nodes}, '
    '; } } elsif ($nt == $child->TEXT_NODE) { $r .= qq'
  2. ' . htescape ($child->data) . '
  3. '; } elsif ($nt == $child->CDATA_SECTION_NODE) { $r .= qq'
  4. <[CDATA[' . htescape ($child->data) . ']]>
  5. '; } elsif ($nt == $child->COMMENT_NODE) { $r .= qq'
  6. <!--' . htescape ($child->data) . '-->
  7. '; } elsif ($nt == $child->DOCUMENT_NODE) { $r .= qq'
  8. Document
  9. '; if ($child->has_child_nodes) { $r .= '
      '; unshift @node, @{$child->child_nodes}, '
    '; } } elsif ($nt == $child->DOCUMENT_TYPE_NODE) { $r .= qq'
  10. <!DOCTYPE>
  11. '; } elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) { $r .= qq'
  12. <?@{[htescape ($child->target)]}?>'; $r .= '
  13. '; } else { $r .= qq'
  14. @{[$child->node_type]} @{[htescape ($child->node_name)]}
  15. '; # error } } $r .= '
'; print STDOUT $r; } # print_document_tree sub get_node_path ($) { my $node = shift; my @r; while (defined $node) { my $rs; if ($node->node_type == 1) { $rs = $node->manakai_local_name; $node = $node->parent_node; } elsif ($node->node_type == 2) { $rs = '@' . $node->manakai_local_name; $node = $node->owner_element; } elsif ($node->node_type == 3) { $rs = '"' . $node->data . '"'; $node = $node->parent_node; } elsif ($node->node_type == 9) { $rs = ''; $node = $node->parent_node; } else { $rs = '#' . $node->node_type; $node = $node->parent_node; } unshift @r, $rs; } return join '/', @r; } # get_node_path =head1 AUTHOR Wakaba . =head1 LICENSE Copyright 2007 Wakaba This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut ## $Date: 2007/06/27 12:35:24 $