/[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.32 by wakaba, Sun Feb 10 02:30:14 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_id_section ($input, $elements->{id}) if keys %{$elements->{id}};      print_listing_section ({
208      print_term_section ($input, $elements->{term}) if keys %{$elements->{term}};        id => 'identifiers', label => 'IDs', heading => 'Identifiers',
209      print_class_section ($input, $elements->{class}) if keys %{$elements->{class}};      }, $input, $elements->{id}) if keys %{$elements->{id}};
210    } elsif (defined $manifest) {      print_listing_section ({
211      print_structure_dump_manifest_section ($input, $manifest);        id => 'terms', label => 'Terms', heading => 'Terms',
212      print_structure_error_manifest_section ($input, $manifest, $result);      }, $input, $elements->{term}) if keys %{$elements->{term}};
213        print_listing_section ({
214          id => 'classes', label => 'Classes', heading => 'Classes',
215        }, $input, $elements->{class}) if keys %{$elements->{class}};
216      
217        print_rdf_section ($input, $elements->{rdf}) if @{$elements->{rdf}};
218      }
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 212  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>];  
282    }    }
   print STDOUT "</ol></div>";  
 } # print_input_string_section  
283    
284  sub print_document_tree ($) {    print STDOUT qq[</tbody></table>];
   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>';  
       }  
285    
286        if ($child->has_child_nodes) {    $out->end_section;
287          $r .= '<ol class="children">';  } # print_http_header_section
         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>];  
   }  
   
   print STDOUT qq[</dl></div>];  
 } # print_structure_dump_manifest_section  
   
 sub print_structure_error_dom_section ($$$$) {  
   my ($input, $doc, $el, $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::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 609  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 651  sub print_table_section ($$) { Line 346  sub print_table_section ($$) {
346    print STDOUT qq[</div>];    print STDOUT qq[</div>];
347  } # print_table_section  } # print_table_section
348    
349  sub print_id_section ($$) {  sub print_listing_section ($$$) {
350    my ($input, $ids) = @_;    my ($opt, $input, $ids) = @_;
351        
352    push @nav, ['#identifiers' => 'IDs'] 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}identifiers" class="section">  <div id="$input->{id_prefix}$opt->{id}" class="section">
356  <h2>Identifiers</h2>  <h2>$opt->{heading}</h2>
357    
358  <dl>  <dl>
359  ];  ];
# Line 668  sub print_id_section ($$) { Line 364  sub print_id_section ($$) {
364      }      }
365    }    }
366    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
367  } # print_id_section  } # print_listing_section
368    
369  sub print_term_section ($$) {  
370    my ($input, $terms) = @_;  sub print_rdf_section ($$$) {
371      my ($input, $rdfs) = @_;
372        
373    push @nav, ['#terms' => 'Terms'] unless $input->{nested};  #  push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']
374    #      unless $input->{nested};
375    print STDOUT qq[    print STDOUT qq[
376  <div id="$input->{id_prefix}terms" class="section">  <div id="$input->{id_prefix}rdf" class="section">
377  <h2>Terms</h2>  <h2>RDF Triples</h2>
378    
379  <dl>  <dl>];
380  ];    my $i = 0;
381    for my $term (sort {$a cmp $b} keys %$terms) {    for my $rdf (@$rdfs) {
382      print STDOUT qq[<dt>@{[htescape $term]}</dt>];      print STDOUT qq[<dt id="$input->{id_prefix}rdf-@{[$i++]}">];
383      for (@{$terms->{$term}}) {      print STDOUT get_node_link ($input, $rdf->[0]);
384        print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];      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>];    print STDOUT qq[</dl></div>];
396  } # print_term_section  } # print_rdf_section
397    
398  sub print_class_section ($$) {  sub get_rdf_resource_html ($) {
399    my ($input, $classes) = @_;    my $resource = shift;
400        if (defined $resource->{uri}) {
401    push @nav, ['#classes' => 'Classes'] unless $input->{nested};      my $euri = htescape ($resource->{uri});
402    print STDOUT qq[      return '<code class=uri>&lt;<a href="' . $euri . '">' . $euri .
403  <div id="$input->{id_prefix}classes" class="section">          '</a>></code>';
404  <h2>Classes</h2>    } elsif (defined $resource->{bnodeid}) {
405        return htescape ('_:' . $resource->{bnodeid});
406  <dl>    } elsif ($resource->{nodes}) {
407  ];      return '(rdf:XMLLiteral)';
408    for my $class (sort {$a cmp $b} keys %$classes) {    } elsif (defined $resource->{value}) {
409      print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];      my $elang = htescape (defined $resource->{language}
410      for (@{$classes->{$class}}) {                                ? $resource->{language} : '');
411        print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];      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    print STDOUT qq[</dl></div>];  } # get_rdf_resource_html
 } # print_class_section  
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 773  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 937  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 946  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 971  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 980  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 1124  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 1156  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.32  
changed lines
  Added in v.1.53

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24