/[pub]/test/html-webhacc/cc.cgi
Suika

Diff of /test/html-webhacc/cc.cgi

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.33 by wakaba, Sun Feb 10 02:42:01 2008 UTC revision 1.53 by wakaba, Sun Jul 20 14:58:24 2008 UTC
# Line 6  use lib qw[/home/httpd/html/www/markup/h Line 6  use lib qw[/home/httpd/html/www/markup/h
6             /home/wakaba/work/manakai2/lib];             /home/wakaba/work/manakai2/lib];
7  use CGI::Carp qw[fatalsToBrowser];  use CGI::Carp qw[fatalsToBrowser];
8  use Scalar::Util qw[refaddr];  use Scalar::Util qw[refaddr];
 use Time::HiRes qw/time/;  
9    
10  sub htescape ($) {    require WebHACC::Input;
11    my $s = $_[0];    require WebHACC::Result;
12    $s =~ s/&/&/g;    require WebHACC::Output;
   $s =~ s/</&lt;/g;  
   $s =~ s/>/&gt;/g;  
   $s =~ s/"/&quot;/g;  
   $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{  
     sprintf '<var>U+%04X</var>', ord $1;  
   }ge;  
   return $s;  
 } # htescape  
13    
14    my $out;
15    
16      require Message::DOM::DOMImplementation;
17      my $dom = Message::DOM::DOMImplementation->new;
18    {
19    use Message::CGI::HTTP;    use Message::CGI::HTTP;
20    my $http = Message::CGI::HTTP->new;    my $http = Message::CGI::HTTP->new;
21    
# Line 27  sub htescape ($) { Line 23  sub htescape ($) {
23      print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";      print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";
24      exit;      exit;
25    }    }
26      
   binmode STDOUT, ':utf8';  
   $| = 1;  
   
   require Message::DOM::DOMImplementation;  
   my $dom = Message::DOM::DOMImplementation->new;  
   
27    load_text_catalog ('en'); ## TODO: conneg    load_text_catalog ('en'); ## TODO: conneg
28    
29    my @nav;    $out = WebHACC::Output->new;
30    print STDOUT qq[Content-Type: text/html; charset=utf-8    $out->handle (*STDOUT);
31      $out->set_utf8;
32      $out->set_flush;
33      $out->html (qq[Content-Type: text/html; charset=utf-8
34    
35  <!DOCTYPE html>  <!DOCTYPE html>
36  <html lang="en">  <html lang="en">
# Line 48  sub htescape ($) { Line 41  sub htescape ($) {
41  <body>  <body>
42  <h1><a href="../cc-interface">Web Document Conformance Checker</a>  <h1><a href="../cc-interface">Web Document Conformance Checker</a>
43  (<em>beta</em>)</h1>  (<em>beta</em>)</h1>
44  ];  ]);
45    
   $| = 0;  
46    my $input = get_input_document ($http, $dom);    my $input = get_input_document ($http, $dom);
47      $out->input ($input);
48      $out->unset_flush;
49    
50    my $char_length = 0;    my $char_length = 0;
   my %time;  
51    
52    print qq[    $out->start_section (id => 'document-info', title => 'Information');
53  <div id="document-info" class="section">    $out->html (qq[<dl>
54  <dl>  <dt>Request URL</dt>
55  <dt>Request URI</dt>      <dd>]);
56      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{request_uri}]}">@{[htescape $input->{request_uri}]}</a>&gt;</code></dd>    $out->url ($input->{request_uri});
57  <dt>Document URI</dt>    $out->html (q[<dt>Document URL<!-- HTML5 document's address? -->
58      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{uri}]}" id=anchor-document-uri>@{[htescape $input->{uri}]}</a>&gt;</code>      <dd>]);
59      $out->url ($input->{uri}, id => 'anchor-document-url');
60      $out->html (q[
61      <script>      <script>
62        document.title = '<'        document.title = '<'
63            + document.getElementById ('anchor-document-uri').href + '> \\u2014 '            + document.getElementById ('anchor-document-url').href + '> \\u2014 '
64            + document.title;            + document.title;
65      </script></dd>      </script>]);
66  ]; # no </dl> yet    ## NOTE: no </dl> yet
   push @nav, ['#document-info' => 'Information'];  
67    
68  if (defined $input->{s}) {    if (defined $input->{s}) {
69    $char_length = length $input->{s};      $char_length = length $input->{s};
70    
71    print STDOUT qq[      $out->html (qq[<dt>Base URI<dd>]);
72  <dt>Base URI</dt>      $out->url ($input->{base_uri});
73      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{base_uri}]}">@{[htescape $input->{base_uri}]}</a>&gt;</code></dd>      $out->html (qq[<dt>Internet Media Type</dt>
74  <dt>Internet Media Type</dt>      <dd><code class="MIME" lang="en">]);
75      <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>      $out->text ($input->{media_type});
76      @{[$input->{media_type_overridden} ? '<em>(overridden)</em>' : defined $input->{official_type} ? $input->{media_type} eq $input->{official_type} ? '' : '<em>(sniffed; official type is: <code class=MIME lang=en>'.htescape ($input->{official_type}).'</code>)' : '<em>(sniffed)</em>']}</dd>      $out->html (qq[</code> ]);
77  <dt>Character Encoding</dt>      if ($input->{media_type_overridden}) {
78      <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}        $out->html ('<em>(overridden)</em>');
79      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>      } elsif (defined $input->{official_type}) {
80          if ($input->{media_type} eq $input->{official_type}) {
81            #
82          } else {
83            $out->html ('<em>(sniffed; official type is: <code class=MIME lang=en>');
84            $out->text ($input->{official_type});
85            $out->html ('</code>)');
86          }
87        } else {
88          $out->html ('<em>(sniffed)</em>');
89        }
90        $out->html (q[<dt>Character Encoding<dd>]);
91        if (defined $input->{charset}) {
92          $out->html ('<code class="charset" lang="en">');
93          $out->text ($input->{charset});
94          $out->html ('</code>');
95        } else {
96          $out->text ('(none)');
97        }
98        $out->html (' <em>overridden</em>') if $input->{charset_overridden};
99        $out->html (qq[
100  <dt>Length</dt>  <dt>Length</dt>
101      <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>      <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>
102  </dl>  </dl>
 </div>  
 ];  
   
   my $result = {conforming_min => 1, conforming_max => 1};  
   check_and_print ($input => $result);  
   print_result_section ($result);  
 } else {  
   print STDOUT qq[</dl></div>];  
   print_result_input_error_section ($input);  
 }  
103    
104    print STDOUT qq[  <script src="../cc-script.js"></script>
105  <ul class="navigation" id="nav-items">  ]);
106  ];      $out->end_section;
107    for (@nav) {  
108      print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];      my $result = WebHACC::Result->new;
109        $result->{conforming_min} = 1;
110        $result->{conforming_max} = 1;
111        check_and_print ($input => $result => $out);
112        print_result_section ($result);
113      } else {
114        $out->html ('</dl>');
115        $out->end_section;
116        print_result_input_error_section ($input);
117    }    }
   print STDOUT qq[  
 </ul>  
 </body>  
 </html>  
 ];  
118    
119    for (qw/decode parse parse_html parse_xml parse_manifest    $out->nav_list;
           check check_manifest/) {  
     next unless defined $time{$_};  
     open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";  
     print $file $char_length, "\t", $time{$_}, "\n";  
   }  
120    
121  exit;    exit;
122    }
123    
124  sub add_error ($$$) {  sub add_error ($$$) {
125    my ($layer, $err, $result) = @_;    my ($layer, $err, $result) = @_;
# Line 129  sub add_error ($$$) { Line 133  sub add_error ($$$) {
133      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
134        $result->{$layer}->{unsupported}++;        $result->{$layer}->{unsupported}++;
135        $result->{unsupported} = 1;        $result->{unsupported} = 1;
136        } elsif ($err->{level} eq 'i') {
137          #
138      } else {      } else {
139        $result->{$layer}->{must}++;        $result->{$layer}->{must}++;
140        $result->{$layer}->{score_max} -= 2;        $result->{$layer}->{score_max} -= 2;
# Line 145  sub add_error ($$$) { Line 151  sub add_error ($$$) {
151    }    }
152  } # add_error  } # add_error
153    
154  sub check_and_print ($$) {  sub check_and_print ($$$) {
155    my ($input, $result) = @_;    my ($input, $result, $out) = @_;
156    $input->{id_prefix} = '';    my $original_input = $out->input;
157    #$input->{nested} = 1/0;    $out->input ($input);
158    
159    print_http_header_section ($input, $result);    print_http_header_section ($input, $result);
160    
161    my $doc;    my @subdoc;
162    my $el;  
163    my $manifest;    my $checker_class = {
164        'text/cache-manifest' => 'WebHACC::Language::CacheManifest',
165    if ($input->{media_type} eq 'text/html') {      'text/css' => 'WebHACC::Language::CSS',
166      ($doc, $el) = print_syntax_error_html_section ($input, $result);      'text/html' => 'WebHACC::Language::HTML',
167      print_source_string_section      'text/x-webidl' => 'WebHACC::Language::WebIDL',
168          (\($input->{s}), $input->{charset} || $doc->input_encoding);  
169    } elsif ({      'text/xml' => 'WebHACC::Language::XML',
170              'text/xml' => 1,      'application/atom+xml' => 'WebHACC::Language::XML',
171              'application/atom+xml' => 1,      'application/rss+xml' => 'WebHACC::Language::XML',
172              'application/rss+xml' => 1,      'image/svg+xml' => 'WebHACC::Language::XML',
173              'application/svg+xml' => 1,      'application/xhtml+xml' => 'WebHACC::Language::XML',
174              'application/xhtml+xml' => 1,      'application/xml' => 'WebHACC::Language::XML',
175              'application/xml' => 1,      ## TODO: Should we make all XML MIME Types fall
176             }->{$input->{media_type}}) {      ## into this category?
177      ($doc, $el) = print_syntax_error_xml_section ($input, $result);  
178      print_source_string_section (\($input->{s}), $doc->input_encoding);      ## NOTE: This type has different model from normal XML types.
179    } elsif ($input->{media_type} eq 'text/cache-manifest') {      'application/rdf+xml' => 'WebHACC::Language::XML',
180  ## TODO: MUST be text/cache-manifest    }->{$input->{media_type}} || 'WebHACC::Language::Default';
181      $manifest = print_syntax_error_manifest_section ($input, $result);  
182      print_source_string_section (\($input->{s}), 'utf-8');    eval qq{ require $checker_class } or die "$0: Loading $checker_class: $@";
183    } else {    my $checker = $checker_class->new;
184      ## TODO: Change HTTP status code??    $checker->input ($input);
185      print_result_unknown_type_section ($input, $result);    $checker->output ($out);
186    }    $checker->result ($result);
187    
188      ## TODO: A cache manifest MUST be text/cache-manifest
189      ## TODO: WebIDL media type "text/x-webidl"
190    
191      $checker->generate_syntax_error_section;
192      $checker->generate_source_string_section;
193    
194      $checker->onsubdoc (sub {
195        push @subdoc, shift;
196      });
197    
198      $checker->generate_structure_dump_section;
199      $checker->generate_structure_error_section;
200      $checker->generate_additional_sections;
201    
202    =pod
203    
204    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
205      print_structure_dump_dom_section ($input, $doc, $el);  
     my $elements = print_structure_error_dom_section  
         ($input, $doc, $el, $result);  
206      print_table_section ($input, $elements->{table}) if @{$elements->{table}};      print_table_section ($input, $elements->{table}) if @{$elements->{table}};
207      print_listing_section ({      print_listing_section ({
208        id => 'identifiers', label => 'IDs', heading => 'Identifiers',        id => 'identifiers', label => 'IDs', heading => 'Identifiers',
# Line 193  sub check_and_print ($$) { Line 213  sub check_and_print ($$) {
213      print_listing_section ({      print_listing_section ({
214        id => 'classes', label => 'Classes', heading => 'Classes',        id => 'classes', label => 'Classes', heading => 'Classes',
215      }, $input, $elements->{class}) if keys %{$elements->{class}};      }, $input, $elements->{class}) if keys %{$elements->{class}};
216    } elsif (defined $manifest) {    
217      print_structure_dump_manifest_section ($input, $manifest);      print_rdf_section ($input, $elements->{rdf}) if @{$elements->{rdf}};
218      print_structure_error_manifest_section ($input, $manifest, $result);    }
219    
220    =cut
221    
222      my $id_prefix = 0;
223      for my $_subinput (@subdoc) {
224        my $subinput = WebHACC::Input->new;
225        $subinput->{$_} = $_subinput->{$_} for keys %$_subinput;
226        $subinput->id_prefix ('subdoc-' . ++$id_prefix);
227        $subinput->nested (1);
228        $subinput->{base_uri} = $subinput->{container_node}->base_uri
229            unless defined $subinput->{base_uri};
230        my $ebaseuri = htescape ($subinput->{base_uri});
231        $out->start_section (id => $subinput->id_prefix,
232                             title => qq[Subdocument #$id_prefix]);
233        print STDOUT qq[
234          <dl>
235          <dt>Internet Media Type</dt>
236            <dd><code class="MIME" lang="en">@{[htescape $subinput->{media_type}]}</code>
237          <dt>Container Node</dt>
238            <dd>@{[get_node_link ($input, $subinput->{container_node})]}</dd>
239          <dt>Base <abbr title="Uniform Resource Identifiers">URI</abbr></dt>
240            <dd><code class=URI>&lt;<a href="$ebaseuri">$ebaseuri</a>></code></dd>
241          </dl>];              
242    
243        $subinput->{id_prefix} .= '-';
244        check_and_print ($subinput => $result => $out);
245    
246        $out->end_section;
247    }    }
248    
249      $out->input ($original_input);
250  } # check_and_print  } # check_and_print
251    
252  sub print_http_header_section ($$) {  sub print_http_header_section ($$) {
253    my ($input, $result) = @_;    my ($input, $result) = @_;
254    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
255        defined $input->{header_status_text} or        defined $input->{header_status_text} or
256        @{$input->{header_field}};        @{$input->{header_field} or []};
257        
258    push @nav, ['#source-header' => 'HTTP Header'] unless $input->{nested};    $out->start_section (id => 'source-header', title => 'HTTP Header');
259    print STDOUT qq[<div id="$input->{id_prefix}source-header" class="section">    print STDOUT qq[<p><strong>Note</strong>: Due to the limitation of the
 <h2>HTTP Header</h2>  
   
 <p><strong>Note</strong>: Due to the limitation of the  
260  network library in use, the content of this section might  network library in use, the content of this section might
261  not be the real header.</p>  not be the real header.</p>
262    
# Line 218  not be the real header.</p> Line 265  not be the real header.</p>
265    
266    if (defined $input->{header_status_code}) {    if (defined $input->{header_status_code}) {
267      print STDOUT qq[<tr><th scope="row">Status code</th>];      print STDOUT qq[<tr><th scope="row">Status code</th>];
268      print STDOUT qq[<td><code>@{[htescape ($input->{header_status_code})]}</code></td></tr>];      print STDOUT qq[<td>];
269        $out->code ($input->{header_status_code});
270    }    }
271    if (defined $input->{header_status_text}) {    if (defined $input->{header_status_text}) {
272      print STDOUT qq[<tr><th scope="row">Status text</th>];      print STDOUT qq[<tr><th scope="row">Status text</th>];
273      print STDOUT qq[<td><code>@{[htescape ($input->{header_status_text})]}</code></td></tr>];      print STDOUT qq[<td>];
274        $out->code ($input->{header_status_text});
275    }    }
276        
277    for (@{$input->{header_field}}) {    for (@{$input->{header_field}}) {
278      print STDOUT qq[<tr><th scope="row"><code>@{[htescape ($_->[0])]}</code></th>];      print STDOUT qq[<tr><th scope="row">];
279      print STDOUT qq[<td><code>@{[htescape ($_->[1])]}</code></td></tr>];      $out->code ($_->[0]);
280    }      print STDOUT qq[<td>];
281        $out->code ($_->[1]);
   print STDOUT qq[</tbody></table></div>];  
 } # print_http_header_section  
   
 sub print_syntax_error_html_section ($$) {  
   my ($input, $result) = @_;  
     
   require Encode;  
   require Whatpm::HTML;  
     
   print STDOUT qq[  
 <div id="$input->{id_prefix}parse-errors" class="section">  
 <h2>Parse Errors</h2>  
   
 <dl>];  
   push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};  
   
   my $onerror = sub {  
     my (%opt) = @_;  
     my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});  
     if ($opt{column} > 0) {  
       print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];  
     } else {  
       $opt{line} = $opt{line} - 1 || 1;  
       print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];  
     }  
     $type =~ tr/ /-/;  
     $type =~ s/\|/%7C/g;  
     $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];  
     print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);  
     print STDOUT qq[$msg</dd>\n];  
   
     add_error ('syntax', \%opt => $result);  
   };  
   
   my $doc = $dom->create_document;  
   my $el;  
   my $inner_html_element = $http->get_parameter ('e');  
   if (defined $inner_html_element and length $inner_html_element) {  
     $input->{charset} ||= 'windows-1252'; ## TODO: for now.  
     my $time1 = time;  
     my $t = Encode::decode ($input->{charset}, $input->{s});  
     $time{decode} = time - $time1;  
       
     $el = $doc->create_element_ns  
         ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);  
     $time1 = time;  
     Whatpm::HTML->set_inner_html ($el, $t, $onerror);  
     $time{parse} = time - $time1;  
   } else {  
     my $time1 = time;  
     Whatpm::HTML->parse_byte_string  
         ($input->{charset}, $input->{s} => $doc, $onerror);  
     $time{parse_html} = time - $time1;  
   }  
   $doc->manakai_charset ($input->{official_charset})  
       if defined $input->{official_charset};  
     
   print STDOUT qq[</dl></div>];  
   
   return ($doc, $el);  
 } # print_syntax_error_html_section  
   
 sub print_syntax_error_xml_section ($$) {  
   my ($input, $result) = @_;  
     
   require Message::DOM::XMLParserTemp;  
     
   print STDOUT qq[  
 <div id="$input->{id_prefix}parse-errors" class="section">  
 <h2>Parse Errors</h2>  
   
 <dl>];  
   push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{prefix};  
   
   my $onerror = sub {  
     my $err = shift;  
     my $line = $err->location->line_number;  
     print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];  
     print STDOUT $err->location->column_number, "</dt><dd>";  
     print STDOUT htescape $err->text, "</dd>\n";  
   
     add_error ('syntax', {type => $err->text,  
                 level => [  
                           $err->SEVERITY_FATAL_ERROR => 'm',  
                           $err->SEVERITY_ERROR => 'm',  
                           $err->SEVERITY_WARNING => 's',  
                          ]->[$err->severity]} => $result);  
   
     return 1;  
   };  
   
   my $time1 = time;  
   open my $fh, '<', \($input->{s});  
   my $doc = Message::DOM::XMLParserTemp->parse_byte_stream  
       ($fh => $dom, $onerror, charset => $input->{charset});  
   $time{parse_xml} = time - $time1;  
   $doc->manakai_charset ($input->{official_charset})  
       if defined $input->{official_charset};  
   
   print STDOUT qq[</dl></div>];  
   
   return ($doc, undef);  
 } # print_syntax_error_xml_section  
   
 sub print_syntax_error_manifest_section ($$) {  
   my ($input, $result) = @_;  
   
   require Whatpm::CacheManifest;  
   
   print STDOUT qq[  
 <div id="$input->{id_prefix}parse-errors" class="section">  
 <h2>Parse Errors</h2>  
   
 <dl>];  
   push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};  
   
   my $onerror = sub {  
     my (%opt) = @_;  
     my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});  
     print STDOUT qq[<dt class="$cls">], get_error_label ($input, \%opt),  
         qq[</dt>];  
     $type =~ tr/ /-/;  
     $type =~ s/\|/%7C/g;  
     $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];  
     print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);  
     print STDOUT qq[$msg</dd>\n];  
   
     add_error ('syntax', \%opt => $result);  
   };  
   
   my $time1 = time;  
   my $manifest = Whatpm::CacheManifest->parse_byte_string  
       ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);  
   $time{parse_manifest} = time - $time1;  
   
   print STDOUT qq[</dl></div>];  
   
   return $manifest;  
 } # print_syntax_error_manifest_section  
   
 sub print_source_string_section ($$) {  
   require Encode;  
   my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name  
   return unless $enc;  
   
   my $s = \($enc->decode (${$_[0]}));  
   my $i = 1;                              
   push @nav, ['#source-string' => 'Source'] unless $input->{nested};  
   print STDOUT qq[<div id="$input->{id_prefix}source-string" class="section">  
 <h2>Document Source</h2>  
 <ol lang="">\n];  
   if (length $$s) {  
     while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {  
       print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,  
           "</li>\n";  
       $i++;  
     }  
     if ($$s =~ /\G([^\x0A]+)/gc) {  
       print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,  
           "</li>\n";  
     }  
   } else {  
     print STDOUT q[<li id="$input->{id_prefix}line-1"></li>];  
   }  
   print STDOUT "</ol></div>";  
 } # print_input_string_section  
   
 sub print_document_tree ($) {  
   my $node = shift;  
   my $r = '<ol class="xoxo">';  
   
   my @node = ($node);  
   while (@node) {  
     my $child = shift @node;  
     unless (ref $child) {  
       $r .= $child;  
       next;  
     }  
   
     my $node_id = $input->{id_prefix} . 'node-'.refaddr $child;  
     my $nt = $child->node_type;  
     if ($nt == $child->ELEMENT_NODE) {  
       my $child_nsuri = $child->namespace_uri;  
       $r .= qq[<li id="$node_id" class="tree-element"><code title="@{[defined $child_nsuri ? $child_nsuri : '']}">] . htescape ($child->tag_name) .  
           '</code>'; ## ISSUE: case  
   
       if ($child->has_attributes) {  
         $r .= '<ul class="attributes">';  
         for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }  
                       @{$child->attributes}) {  
           $r .= qq[<li id="$input->{id_prefix}$attr->[3]" class="tree-attribute"><code title="@{[defined $attr->[2] ? htescape ($attr->[2]) : '']}">] . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?  
           $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children  
         }  
         $r .= '</ul>';  
       }  
   
       if ($child->has_child_nodes) {  
         $r .= '<ol class="children">';  
         unshift @node, @{$child->child_nodes}, '</ol></li>';  
       } else {  
         $r .= '</li>';  
       }  
     } elsif ($nt == $child->TEXT_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-text"><q lang="">' . htescape ($child->data) . '</q></li>';  
     } elsif ($nt == $child->CDATA_SECTION_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-cdata"><code>&lt;[CDATA[</code><q lang="">' . htescape ($child->data) . '</q><code>]]&gt;</code></li>';  
     } elsif ($nt == $child->COMMENT_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-comment"><code>&lt;!--</code><q lang="">' . htescape ($child->data) . '</q><code>--&gt;</code></li>';  
     } elsif ($nt == $child->DOCUMENT_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-document">Document';  
       $r .= qq[<ul class="attributes">];  
       my $cp = $child->manakai_charset;  
       if (defined $cp) {  
         $r .= qq[<li><code>charset</code> parameter = <code>];  
         $r .= htescape ($cp) . qq[</code></li>];  
       }  
       $r .= qq[<li><code>inputEncoding</code> = ];  
       my $ie = $child->input_encoding;  
       if (defined $ie) {  
         $r .= qq[<code>@{[htescape ($ie)]}</code>];  
         if ($child->manakai_has_bom) {  
           $r .= qq[ (with <code class=charname><abbr>BOM</abbr></code>)];  
         }  
       } else {  
         $r .= qq[(<code>null</code>)];  
       }  
       $r .= qq[<li>@{[scalar get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]}</li>];  
       $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];  
       unless ($child->manakai_is_html) {  
         $r .= qq[<li>XML version = <code>@{[htescape ($child->xml_version)]}</code></li>];  
         if (defined $child->xml_encoding) {  
           $r .= qq[<li>XML encoding = <code>@{[htescape ($child->xml_encoding)]}</code></li>];  
         } else {  
           $r .= qq[<li>XML encoding = (null)</li>];  
         }  
         $r .= qq[<li>XML standalone = @{[$child->xml_standalone ? 'true' : 'false']}</li>];  
       }  
       $r .= qq[</ul>];  
       if ($child->has_child_nodes) {  
         $r .= '<ol class="children">';  
         unshift @node, @{$child->child_nodes}, '</ol></li>';  
       }  
     } elsif ($nt == $child->DOCUMENT_TYPE_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-doctype"><code>&lt;!DOCTYPE&gt;</code><ul class="attributes">';  
       $r .= qq[<li class="tree-doctype-name">Name = <q>@{[htescape ($child->name)]}</q></li>];  
       $r .= qq[<li class="tree-doctype-publicid">Public identifier = <q>@{[htescape ($child->public_id)]}</q></li>];  
       $r .= qq[<li class="tree-doctype-systemid">System identifier = <q>@{[htescape ($child->system_id)]}</q></li>];  
       $r .= '</ul></li>';  
     } elsif ($nt == $child->PROCESSING_INSTRUCTION_NODE) {  
       $r .= qq'<li id="$node_id" class="tree-id"><code>&lt;?@{[htescape ($child->target)]}</code> <q>@{[htescape ($child->data)]}</q><code>?&gt;</code></li>';  
     } else {  
       $r .= qq'<li id="$node_id" class="tree-unknown">@{[$child->node_type]} @{[htescape ($child->node_name)]}</li>'; # error  
     }  
   }  
   
   $r .= '</ol>';  
   print STDOUT $r;  
 } # print_document_tree  
   
 sub print_structure_dump_dom_section ($$$) {  
   my ($input, $doc, $el) = @_;  
   
   print STDOUT qq[  
 <div id="$input->{id_prefix}document-tree" class="section">  
 <h2>Document Tree</h2>  
 ];  
   push @nav, ['#document-tree' => 'Tree'] unless $input->{nested};  
   
   print_document_tree ($el || $doc);  
   
   print STDOUT qq[</div>];  
 } # print_structure_dump_dom_section  
   
 sub print_structure_dump_manifest_section ($$) {  
   my ($input, $manifest) = @_;  
   
   print STDOUT qq[  
 <div id="$input->{id_prefix}dump-manifest" class="section">  
 <h2>Cache Manifest</h2>  
 ];  
   push @nav, ['#dump-manifest' => 'Caceh Manifest'] unless $input->{nested};  
   
   print STDOUT qq[<dl><dt>Explicit entries</dt>];  
   for my $uri (@{$manifest->[0]}) {  
     my $euri = htescape ($uri);  
     print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];  
   }  
   
   print STDOUT qq[<dt>Fallback entries</dt><dd>  
       <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>  
       <th scope=row>Fallback Entry</tr><tbody>];  
   for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {  
     my $euri = htescape ($uri);  
     my $euri2 = htescape ($manifest->[1]->{$uri});  
     print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>  
         <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];  
   }  
   
   print STDOUT qq[</table><dt>Online whitelist</dt>];  
   for my $uri (@{$manifest->[2]}) {  
     my $euri = htescape ($uri);  
     print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];  
282    }    }
283    
284    print STDOUT qq[</dl></div>];    print STDOUT qq[</tbody></table>];
 } # print_structure_dump_manifest_section  
285    
286  sub print_structure_error_dom_section ($$$$) {    $out->end_section;
287    my ($input, $doc, $el, $result) = @_;  } # print_http_header_section
   
   print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">  
 <h2>Document Errors</h2>  
   
 <dl>];  
   push @nav, ['#document-errors' => 'Document Error'] unless $input->{nested};  
   
   require Whatpm::ContentChecker;  
   my $onerror = sub {  
     my %opt = @_;  
     my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});  
     $type =~ tr/ /-/;  
     $type =~ s/\|/%7C/g;  
     $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];  
     print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .  
         qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);  
     print STDOUT $msg, "</dd>\n";  
     add_error ('structure', \%opt => $result);  
   };  
   
   my $elements;  
   my $time1 = time;  
   if ($el) {  
     $elements = Whatpm::ContentChecker->check_element ($el, $onerror);  
   } else {  
     $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);  
   }  
   $time{check} = time - $time1;  
   
   print STDOUT qq[</dl></div>];  
   
   return $elements;  
 } # print_structure_error_dom_section  
   
 sub print_structure_error_manifest_section ($$$) {  
   my ($input, $manifest, $result) = @_;  
   
   print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">  
 <h2>Document Errors</h2>  
   
 <dl>];  
   push @nav, ['#document-errors' => 'Document Error'] unless $input->{nested};  
   
   require Whatpm::CacheManifest;  
   Whatpm::CacheManifest->check_manifest ($manifest, sub {  
     my %opt = @_;  
     my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});  
     $type =~ tr/ /-/;  
     $type =~ s/\|/%7C/g;  
     $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];  
     print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .  
         qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";  
     add_error ('structure', \%opt => $result);  
   });  
   
   print STDOUT qq[</div>];  
 } # print_structure_error_manifest_section  
288    
289  sub print_table_section ($$) {  sub print_table_section ($$) {
290    my ($input, $tables) = @_;    my ($input, $tables) = @_;
291        
292    push @nav, ['#tables' => 'Tables'] unless $input->{nested};  #  push @nav, [qq[#$input->{id_prefix}tables] => 'Tables']
293    #      unless $input->{nested};
294    print STDOUT qq[    print STDOUT qq[
295  <div id="$input->{id_prefix}tables" class="section">  <div id="$input->{id_prefix}tables" class="section">
296  <h2>Tables</h2>  <h2>Tables</h2>
# Line 615  sub print_table_section ($$) { Line 305  sub print_table_section ($$) {
305    require JSON;    require JSON;
306        
307    my $i = 0;    my $i = 0;
308    for my $table_el (@$tables) {    for my $table (@$tables) {
309      $i++;      $i++;
310      print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .      print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .
311          get_node_link ($input, $table_el) . q[</h3>];          get_node_link ($input, $table->{element}) . q[</h3>];
312    
313      ## TODO: Make |ContentChecker| return |form_table| result      delete $table->{element};
314      ## so that this script don't have to run the algorithm twice.  
315      my $table = Whatpm::HTMLTable->form_table ($table_el);      for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption},
316                 @{$table->{row}}) {
     for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {  
317        next unless $_;        next unless $_;
318        delete $_->{element};        delete $_->{element};
319      }      }
# Line 660  sub print_table_section ($$) { Line 349  sub print_table_section ($$) {
349  sub print_listing_section ($$$) {  sub print_listing_section ($$$) {
350    my ($opt, $input, $ids) = @_;    my ($opt, $input, $ids) = @_;
351        
352    push @nav, ['#' . $opt->{id} => $opt->{label}] unless $input->{nested};  #  push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]
353    #      unless $input->{nested};
354    print STDOUT qq[    print STDOUT qq[
355  <div id="$input->{id_prefix}$opt->{id}" class="section">  <div id="$input->{id_prefix}$opt->{id}" class="section">
356  <h2>$opt->{heading}</h2>  <h2>$opt->{heading}</h2>
# Line 676  sub print_listing_section ($$$) { Line 366  sub print_listing_section ($$$) {
366    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
367  } # print_listing_section  } # print_listing_section
368    
369    
370    sub print_rdf_section ($$$) {
371      my ($input, $rdfs) = @_;
372      
373    #  push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']
374    #      unless $input->{nested};
375      print STDOUT qq[
376    <div id="$input->{id_prefix}rdf" class="section">
377    <h2>RDF Triples</h2>
378    
379    <dl>];
380      my $i = 0;
381      for my $rdf (@$rdfs) {
382        print STDOUT qq[<dt id="$input->{id_prefix}rdf-@{[$i++]}">];
383        print STDOUT get_node_link ($input, $rdf->[0]);
384        print STDOUT qq[<dd><dl>];
385        for my $triple (@{$rdf->[1]}) {
386          print STDOUT '<dt>' . get_node_link ($input, $triple->[0]) . '<dd>';
387          print STDOUT get_rdf_resource_html ($triple->[1]);
388          print STDOUT ' ';
389          print STDOUT get_rdf_resource_html ($triple->[2]);
390          print STDOUT ' ';
391          print STDOUT get_rdf_resource_html ($triple->[3]);
392        }
393        print STDOUT qq[</dl>];
394      }
395      print STDOUT qq[</dl></div>];
396    } # print_rdf_section
397    
398    sub get_rdf_resource_html ($) {
399      my $resource = shift;
400      if (defined $resource->{uri}) {
401        my $euri = htescape ($resource->{uri});
402        return '<code class=uri>&lt;<a href="' . $euri . '">' . $euri .
403            '</a>></code>';
404      } elsif (defined $resource->{bnodeid}) {
405        return htescape ('_:' . $resource->{bnodeid});
406      } elsif ($resource->{nodes}) {
407        return '(rdf:XMLLiteral)';
408      } elsif (defined $resource->{value}) {
409        my $elang = htescape (defined $resource->{language}
410                                  ? $resource->{language} : '');
411        my $r = qq[<q lang="$elang">] . htescape ($resource->{value}) . '</q>';
412        if (defined $resource->{datatype}) {
413          my $euri = htescape ($resource->{datatype});
414          $r .= '^^<code class=uri>&lt;<a href="' . $euri . '">' . $euri .
415              '</a>></code>';
416        } elsif (length $resource->{language}) {
417          $r .= '@' . htescape ($resource->{language});
418        }
419        return $r;
420      } else {
421        return '??';
422      }
423    } # get_rdf_resource_html
424    
425  sub print_result_section ($) {  sub print_result_section ($) {
426    my $result = shift;    my $result = shift;
427    
428    print STDOUT qq[    $out->start_section (id => 'result-summary',
429  <div id="result-summary" class="section">                         title => 'Result');
 <h2>Result</h2>];  
430    
431    if ($result->{unsupported} and $result->{conforming_max}) {      if ($result->{unsupported} and $result->{conforming_max}) {  
432      print STDOUT qq[<p class=uncertain id=result-para>The conformance      print STDOUT qq[<p class=uncertain id=result-para>The conformance
# Line 741  Errors</a></th> Line 486  Errors</a></th>
486    
487      print STDOUT qq[<tr class="@{[$uncertain ? 'uncertain' : '']}"><th scope=row>$label</th><td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{must}$uncertain</td><td class="@{[$result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">$result->{$_->[1]}->{should}$uncertain</td><td>$result->{$_->[1]}->{warning}$uncertain</td>];      print STDOUT qq[<tr class="@{[$uncertain ? 'uncertain' : '']}"><th scope=row>$label</th><td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{must}$uncertain</td><td class="@{[$result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">$result->{$_->[1]}->{should}$uncertain</td><td>$result->{$_->[1]}->{warning}$uncertain</td>];
488      if ($uncertain) {      if ($uncertain) {
489        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}];
490      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
491        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}];
492      } else {      } else {
493        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}];
494      }      }
495        print qq[ / 20];
496    }    }
497    
498    $score_max += $score_base;    $score_max += $score_base;
499    
500    print STDOUT qq[    print STDOUT qq[
501  <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>  <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base / 20
502  </tbody>  </tbody>
503  <tfoot><tr class=uncertain><th scope=row>Total</th>  <tfoot><tr class=uncertain><th scope=row>Total</th>
504  <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>  <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
505  <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>  <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
506  <td>$warning?</td>  <td>$warning?</td>
507  <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>  <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong> / 100
508  </table>  </table>
509    
510  <p><strong>Important</strong>: This conformance checking service  <p><strong>Important</strong>: This conformance checking service
511  is <em>under development</em>.  The result above might be <em>wrong</em>.</p>  is <em>under development</em>.  The result above might be <em>wrong</em>.</p>];
512  </div>];    $out->end_section;
   push @nav, ['#result-summary' => 'Result'];  
513  } # print_result_section  } # print_result_section
514    
 sub print_result_unknown_type_section ($$) {  
   my ($input, $result) = @_;  
   
   my $euri = htescape ($input->{uri});  
   print STDOUT qq[  
 <div id="parse-errors" class="section">  
 <h2>Errors</h2>  
   
 <dl>  
 <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>  
     <dd class=unsupported><strong><a href="../error-description#level-u">Not  
         supported</a></strong>:  
     Media type  
     <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>  
     is not supported.</dd>  
 </dl>  
 </div>  
 ];  
   push @nav, ['#parse-errors' => 'Errors'];  
   add_error (char => {level => 'u'} => $result);  
   add_error (syntax => {level => 'u'} => $result);  
   add_error (structure => {level => 'u'} => $result);  
 } # print_result_unknown_type_section  
   
515  sub print_result_input_error_section ($) {  sub print_result_input_error_section ($) {
516    my $input = shift;    my $input = shift;
517    print STDOUT qq[<div class="section" id="result-summary">    $out->start_section (id => 'result-summary', title => 'Result');
518  <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>    print STDOUT qq[
519  </div>];  <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>];
520    push @nav, ['#result-summary' => 'Result'];    $out->end_section;
521  } # print_result_input_error_section  } # print_result_input_error_section
522    
 sub get_error_label ($$) {  
   my ($input, $err) = @_;  
   
   my $r = '';  
   
   if (defined $err->{line}) {  
     if ($err->{column} > 0) {  
       $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];  
     } else {  
       $err->{line} = $err->{line} - 1 || 1;  
       $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];  
     }  
   }  
   
   if (defined $err->{node}) {  
     $r .= ' ' if length $r;  
     $r = get_node_link ($input, $err->{node});  
   }  
   
   if (defined $err->{index}) {  
     $r .= ' ' if length $r;  
     $r .= 'Index ' . (0+$err->{index});  
   }  
   
   if (defined $err->{value}) {  
     $r .= ' ' if length $r;  
     $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';  
   }  
   
   return $r;  
 } # get_error_label  
   
 sub get_error_level_label ($) {  
   my $err = shift;  
   
   my $r = '';  
   
   if (not defined $err->{level} or $err->{level} eq 'm') {  
     $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level  
         error</a></strong>: ];  
   } elsif ($err->{level} eq 's') {  
     $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level  
         error</a></strong>: ];  
   } elsif ($err->{level} eq 'w') {  
     $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:  
         ];  
   } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {  
     $r = qq[<strong><a href="../error-description#level-u">Not  
         supported</a></strong>: ];  
   } else {  
     my $elevel = htescape ($err->{level});  
     $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:  
         ];  
   }  
   
   return $r;  
 } # get_error_level_label  
   
 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) {  
       @r = ('') unless @r;  
       $rs = '';  
       $node = $node->parent_node;  
     } else {  
       $rs = '#' . $node->node_type;  
       $node = $node->parent_node;  
     }  
     unshift @r, $rs;  
   }  
   return join '/', @r;  
 } # get_node_path  
   
 sub get_node_link ($$) {  
   return qq[<a href="#$_[0]->{id_prefix}node-@{[refaddr $_[1]]}">] .  
       htescape (get_node_path ($_[1])) . qq[</a>];  
 } # get_node_link  
   
523  {  {
524    my $Msg = {};    my $Msg = {};
525    
526  sub load_text_catalog ($) {  sub load_text_catalog ($) {
527    #  my $self = shift;
528    my $lang = shift; # MUST be a canonical lang name    my $lang = shift; # MUST be a canonical lang name
529    open my $file, '<:utf8', "cc-msg.$lang.txt"    open my $file, '<:utf8', "cc-msg.$lang.txt"
530        or die "$0: cc-msg.$lang.txt: $!";        or die "$0: cc-msg.$lang.txt: $!";
# Line 905  sub load_text_catalog ($) { Line 537  sub load_text_catalog ($) {
537    }    }
538  } # load_text_catalog  } # load_text_catalog
539    
540  sub get_text ($) {  sub get_text ($;$$) {
541    #  my $self = shift;
542    my ($type, $level, $node) = @_;    my ($type, $level, $node) = @_;
543    $type = $level . ':' . $type if defined $level;    $type = $level . ':' . $type if defined $level;
544    $level = 'm' unless defined $level;    $level = 'm' unless defined $level;
# Line 914  sub get_text ($) { Line 547  sub get_text ($) {
547      if (defined $Msg->{$type}) {      if (defined $Msg->{$type}) {
548        my $msg = $Msg->{$type}->[1];        my $msg = $Msg->{$type}->[1];
549        $msg =~ s{<var>\$([0-9]+)</var>}{        $msg =~ s{<var>\$([0-9]+)</var>}{
550          defined $arg[$1] ? htescape ($arg[$1]) : '(undef)';          defined $arg[$1] ? ($arg[$1]) : '(undef)';
551        }ge;        }ge;                 ##BUG: ^ must be escaped
552        $msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{        $msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{
553          UNIVERSAL::can ($node, 'get_attribute_ns')          UNIVERSAL::can ($node, 'get_attribute_ns')
554              ? htescape ($node->get_attribute_ns (undef, $1)) : ''              ?  ($node->get_attribute_ns (undef, $1)) : ''
555        }ge;        }ge; ## BUG: ^ must be escaped
556        $msg =~ s{<var>{\@}</var>}{        $msg =~ s{<var>{\@}</var>}{        ## BUG: v must be escaped
557          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''          UNIVERSAL::can ($node, 'value') ? ($node->value) : ''
558        }ge;        }ge;
559        $msg =~ s{<var>{local-name}</var>}{        $msg =~ s{<var>{local-name}</var>}{
560          UNIVERSAL::can ($node, 'manakai_local_name')          UNIVERSAL::can ($node, 'manakai_local_name')
561            ? htescape ($node->manakai_local_name) : ''            ? ($node->manakai_local_name) : ''
562        }ge;        }ge;  ## BUG: ^ must be escaped
563        $msg =~ s{<var>{element-local-name}</var>}{        $msg =~ s{<var>{element-local-name}</var>}{
564          (UNIVERSAL::can ($node, 'owner_element') and          (UNIVERSAL::can ($node, 'owner_element') and
565           $node->owner_element)           $node->owner_element)
566            ? htescape ($node->owner_element->manakai_local_name)            ?  ($node->owner_element->manakai_local_name)
567            : ''            : '' ## BUG: ^ must be escaped
568        }ge;        }ge;
569        return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);        return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
570      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
# Line 939  sub get_text ($) { Line 572  sub get_text ($) {
572        redo;        redo;
573      }      }
574    }    }
575    return ($type, 'level-'.$level, htescape ($_[0]));    return ($type, 'level-'.$level, ($_[0]));
576                                     ## BUG: ^ must be escaped
577  } # get_text  } # get_text
578    
579  }  }
# Line 948  sub get_input_document ($$) { Line 582  sub get_input_document ($$) {
582    my ($http, $dom) = @_;    my ($http, $dom) = @_;
583    
584    my $request_uri = $http->get_parameter ('uri');    my $request_uri = $http->get_parameter ('uri');
585    my $r = {};    my $r = WebHACC::Input->new;
586    if (defined $request_uri and length $request_uri) {    if (defined $request_uri and length $request_uri) {
587      my $uri = $dom->create_uri_reference ($request_uri);      my $uri = $dom->create_uri_reference ($request_uri);
588      unless ({      unless ({
# Line 1092  EOH Line 726  EOH
726      return $r;      return $r;
727    }    }
728    
729      $r->{inner_html_element} = $http->get_parameter ('e');
730    
731    return $r;    return $r;
732  } # get_input_document  } # get_input_document
733    
# Line 1124  Wakaba <w@suika.fam.cx>. Line 760  Wakaba <w@suika.fam.cx>.
760    
761  =head1 LICENSE  =head1 LICENSE
762    
763  Copyright 2007 Wakaba <w@suika.fam.cx>  Copyright 2007-2008 Wakaba <w@suika.fam.cx>
764    
765  This library is free software; you can redistribute it  This library is free software; you can redistribute it
766  and/or modify it under the same terms as Perl itself.  and/or modify it under the same terms as Perl itself.
Legend:
Removed from v.1.33  
changed lines
  Added in v.1.53
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24