--- test/html-webhacc/cc.cgi 2007/07/15 16:39:10 1.9
+++ test/html-webhacc/cc.cgi 2007/09/02 07:59:01 1.17
@@ -2,12 +2,10 @@
use strict;
use lib qw[/home/httpd/html/www/markup/html/whatpm
- /home/wakaba/work/manakai/lib
- /home/wakaba/public_html/-temp/wiki/lib];
+ /home/wakaba/work/manakai2/lib];
use CGI::Carp qw[fatalsToBrowser];
use Scalar::Util qw[refaddr];
-
-use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module
+use Time::HiRes qw/time/;
sub htescape ($) {
my $s = $_[0];
@@ -15,25 +13,26 @@
$s =~ s/</g;
$s =~ s/>/>/g;
$s =~ s/"/"/g;
- $s =~ s!([\x00-\x09\x0B-\x1F\x7F-\x80])!sprintf 'U+%04X ', ord $1!ge;
+ $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{
+ sprintf 'U+%04X ', ord $1;
+ }ge;
return $s;
} # htescape
-my $http = SuikaWiki::Input::HTTP->new;
-
-## TODO: _charset_
+ use Message::CGI::HTTP;
+ my $http = Message::CGI::HTTP->new;
- if ($http->meta_variable ('PATH_INFO') ne '/') {
+ 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;
+
require Message::DOM::DOMImplementation;
my $dom = Message::DOM::DOMImplementation->new;
- my $input = get_input_document ($http, $dom);
- my $inner_html_element = $http->parameter ('e');
-
load_text_catalog ('en'); ## TODO: conneg
my @nav;
@@ -46,8 +45,19 @@
-
Tables
@@ -224,7 +252,9 @@
$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}) {
@@ -246,6 +276,7 @@
for (@$_) {
$_->{id} = refaddr $_->{element} if defined $_->{element};
delete $_->{element};
+ $_->{is_header} = $_->{is_header} ? 1 : 0;
}
}
}
@@ -258,7 +289,25 @@
print STDOUT qq[];
}
+ if (keys %{$elements->{id}}) {
+ push @nav, ['#identifiers' => 'IDs'];
+ print STDOUT qq[
+
+
Identifiers
+
+
+];
+ for my $id (sort {$a cmp $b} keys %{$elements->{id}}) {
+ print STDOUT qq[@{[htescape $id]}
];
+ for (@{$elements->{id}->{$id}}) {
+ print STDOUT qq[].get_node_link ($_).qq[ ];
+ }
+ }
+ print STDOUT qq[ ];
+ }
+
if (keys %{$elements->{term}}) {
+ push @nav, ['#terms' => 'Terms'];
print STDOUT qq[
Terms
@@ -273,6 +322,23 @@
}
print STDOUT qq[];
}
+
+ if (keys %{$elements->{class}}) {
+ push @nav, ['#classes' => 'Classes'];
+ print STDOUT qq[
+
+
Classes
+
+
+];
+ for my $class (sort {$a cmp $b} keys %{$elements->{class}}) {
+ print STDOUT qq[@{[htescape $class]}
];
+ for (@{$elements->{class}->{$class}}) {
+ print STDOUT qq[].get_node_link ($_).qq[ ];
+ }
+ }
+ print STDOUT qq[ ];
+ }
}
## TODO: Show result
@@ -301,6 +367,12 @@
];
+ 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 print_http_header_section ($) {
@@ -487,20 +559,39 @@
} # load_text_catalog
sub get_text ($) {
- my ($type, $level) = @_;
+ 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;
- return ($Msg->{$type}->[0], $msg);
+ $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 ('', htescape ($_[0]));
+ return ($type, '', htescape ($_[0]));
} # get_text
}
@@ -508,7 +599,7 @@
sub get_input_document ($$) {
my ($http, $dom) = @_;
- my $request_uri = $http->parameter ('uri');
+ 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);
@@ -557,7 +648,8 @@
$ua->max_size (1000_000);
my $req = HTTP::Request->new (GET => $request_uri);
my $res = $ua->request ($req);
- if ($res->is_success or $http->parameter ('error-page')) {
+ ## 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
. ## TODO: Use our own code!
$r->{uri} = $res->request->uri;
$r->{request_uri} = $request_uri;
@@ -572,7 +664,7 @@
$r->{charset} =~ tr/\\//d;
}
- my $input_charset = $http->parameter ('charset');
+ my $input_charset = $http->get_parameter ('charset');
if (defined $input_charset and length $input_charset) {
$r->{charset_overridden}
= (not defined $r->{charset} or $r->{charset} ne $input_charset);
@@ -593,17 +685,17 @@
$r->{header_status_code} = $res->code;
$r->{header_status_text} = $res->message;
} else {
- $r->{s} = ''.$http->parameter ('s');
+ $r->{s} = ''.$http->get_parameter ('s');
$r->{uri} = q
;
$r->{request_uri} = q
;
$r->{base_uri} = q
;
- $r->{charset} = ''.$http->parameter ('_charset_');
+ $r->{charset} = ''.$http->get_parameter ('_charset_');
$r->{charset} =~ s/\s+//g;
$r->{charset} = 'utf-8' if $r->{charset} eq '';
$r->{header_field} = [];
}
- my $input_format = $http->parameter ('i');
+ my $input_format = $http->get_parameter ('i');
if (defined $input_format and length $input_format) {
$r->{media_type_overridden}
= (not defined $r->{media_type} or $input_format ne $r->{media_type});
@@ -667,4 +759,4 @@
=cut
-## $Date: 2007/07/15 16:39:10 $
+## $Date: 2007/09/02 07:59:01 $