/[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.15 by wakaba, Sat Jul 21 04:58:17 2007 UTC revision 1.32 by wakaba, Sun Feb 10 02:30:14 2008 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl  #!/usr/bin/perl
2  use strict;  use strict;
3    use utf8;
4    
5  use lib qw[/home/httpd/html/www/markup/html/whatpm  use lib qw[/home/httpd/html/www/markup/html/whatpm
6             /home/wakaba/work/manakai/lib             /home/wakaba/work/manakai2/lib];
            /home/wakaba/public_html/-temp/wiki/lib];  
7  use CGI::Carp qw[fatalsToBrowser];  use CGI::Carp qw[fatalsToBrowser];
8  use Scalar::Util qw[refaddr];  use Scalar::Util qw[refaddr];
9    use Time::HiRes qw/time/;
 use SuikaWiki::Input::HTTP; ## TODO: Use some better CGI module  
10    
11  sub htescape ($) {  sub htescape ($) {
12    my $s = $_[0];    my $s = $_[0];
# Line 21  sub htescape ($) { Line 20  sub htescape ($) {
20    return $s;    return $s;
21  } # htescape  } # htescape
22    
23  my $http = SuikaWiki::Input::HTTP->new;    use Message::CGI::HTTP;
24      my $http = Message::CGI::HTTP->new;
 ## TODO: _charset_  
25    
26    if ($http->meta_variable ('PATH_INFO') ne '/') {    if ($http->get_meta_variable ('PATH_INFO') ne '/') {
27      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";
28      exit;      exit;
29    }    }
# Line 54  my $http = SuikaWiki::Input::HTTP->new; Line 52  my $http = SuikaWiki::Input::HTTP->new;
52    
53    $| = 0;    $| = 0;
54    my $input = get_input_document ($http, $dom);    my $input = get_input_document ($http, $dom);
55    my $inner_html_element = $http->parameter ('e');    my $char_length = 0;
56      my %time;
57    
58    print qq[    print qq[
59  <div id="document-info" class="section">  <div id="document-info" class="section">
# Line 62  my $http = SuikaWiki::Input::HTTP->new; Line 61  my $http = SuikaWiki::Input::HTTP->new;
61  <dt>Request URI</dt>  <dt>Request URI</dt>
62      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{request_uri}]}">@{[htescape $input->{request_uri}]}</a>&gt;</code></dd>      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{request_uri}]}">@{[htescape $input->{request_uri}]}</a>&gt;</code></dd>
63  <dt>Document URI</dt>  <dt>Document URI</dt>
64      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{uri}]}">@{[htescape $input->{uri}]}</a>&gt;</code></dd>      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{uri}]}" id=anchor-document-uri>@{[htescape $input->{uri}]}</a>&gt;</code>
65        <script>
66          document.title = '<'
67              + document.getElementById ('anchor-document-uri').href + '> \\u2014 '
68              + document.title;
69        </script></dd>
70  ]; # no </dl> yet  ]; # no </dl> yet
71    push @nav, ['#document-info' => 'Information'];    push @nav, ['#document-info' => 'Information'];
72    
73  if (defined $input->{s}) {  if (defined $input->{s}) {
74      $char_length = length $input->{s};
75    
76    print STDOUT qq[    print STDOUT qq[
77  <dt>Base URI</dt>  <dt>Base URI</dt>
78      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{base_uri}]}">@{[htescape $input->{base_uri}]}</a>&gt;</code></dd>      <dd><code class="URI" lang="">&lt;<a href="@{[htescape $input->{base_uri}]}">@{[htescape $input->{base_uri}]}</a>&gt;</code></dd>
79  <dt>Internet Media Type</dt>  <dt>Internet Media Type</dt>
80      <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>      <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
81      @{[$input->{media_type_overridden} ? '<em>(overridden)</em>' : '']}</dd>      @{[$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>
82  <dt>Character Encoding</dt>  <dt>Character Encoding</dt>
83      <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}      <dd>@{[defined $input->{charset} ? '<code class="charset" lang="en">'.htescape ($input->{charset}).'</code>' : '(none)']}
84      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>
85    <dt>Length</dt>
86        <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>
87  </dl>  </dl>
88  </div>  </div>
89  ];  ];
90    
91    print_http_header_section ($input);    my $result = {conforming_min => 1, conforming_max => 1};
92      check_and_print ($input => $result);
93      print_result_section ($result);
94    } else {
95      print STDOUT qq[</dl></div>];
96      print_result_input_error_section ($input);
97    }
98    
99      print STDOUT qq[
100    <ul class="navigation" id="nav-items">
101    ];
102      for (@nav) {
103        print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];
104      }
105      print STDOUT qq[
106    </ul>
107    </body>
108    </html>
109    ];
110    
111      for (qw/decode parse parse_html parse_xml parse_manifest
112              check check_manifest/) {
113        next unless defined $time{$_};
114        open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
115        print $file $char_length, "\t", $time{$_}, "\n";
116      }
117    
118    exit;
119    
120    sub add_error ($$$) {
121      my ($layer, $err, $result) = @_;
122      if (defined $err->{level}) {
123        if ($err->{level} eq 's') {
124          $result->{$layer}->{should}++;
125          $result->{$layer}->{score_min} -= 2;
126          $result->{conforming_min} = 0;
127        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
128          $result->{$layer}->{warning}++;
129        } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
130          $result->{$layer}->{unsupported}++;
131          $result->{unsupported} = 1;
132        } else {
133          $result->{$layer}->{must}++;
134          $result->{$layer}->{score_max} -= 2;
135          $result->{$layer}->{score_min} -= 2;
136          $result->{conforming_min} = 0;
137          $result->{conforming_max} = 0;
138        }
139      } else {
140        $result->{$layer}->{must}++;
141        $result->{$layer}->{score_max} -= 2;
142        $result->{$layer}->{score_min} -= 2;
143        $result->{conforming_min} = 0;
144        $result->{conforming_max} = 0;
145      }
146    } # add_error
147    
148    sub check_and_print ($$) {
149      my ($input, $result) = @_;
150      $input->{id_prefix} = '';
151      #$input->{nested} = 1/0;
152    
153      print_http_header_section ($input, $result);
154    
155    my $doc;    my $doc;
156    my $el;    my $el;
157      my $manifest;
158    
159    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
160      require Encode;      ($doc, $el) = print_syntax_error_html_section ($input, $result);
161      require Whatpm::HTML;      print_source_string_section
162            (\($input->{s}), $input->{charset} || $doc->input_encoding);
163      } elsif ({
164                'text/xml' => 1,
165                'application/atom+xml' => 1,
166                'application/rss+xml' => 1,
167                'application/svg+xml' => 1,
168                'application/xhtml+xml' => 1,
169                'application/xml' => 1,
170               }->{$input->{media_type}}) {
171        ($doc, $el) = print_syntax_error_xml_section ($input, $result);
172        print_source_string_section (\($input->{s}), $doc->input_encoding);
173      } elsif ($input->{media_type} eq 'text/cache-manifest') {
174    ## TODO: MUST be text/cache-manifest
175        $manifest = print_syntax_error_manifest_section ($input, $result);
176        print_source_string_section (\($input->{s}), 'utf-8');
177      } else {
178        ## TODO: Change HTTP status code??
179        print_result_unknown_type_section ($input, $result);
180      }
181    
182      $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.    if (defined $doc or defined $el) {
183            print_structure_dump_dom_section ($input, $doc, $el);
184      my $t = Encode::decode ($input->{charset}, $input->{s});      my $elements = print_structure_error_dom_section
185            ($input, $doc, $el, $result);
186        print_table_section ($input, $elements->{table}) if @{$elements->{table}};
187        print_id_section ($input, $elements->{id}) if keys %{$elements->{id}};
188        print_term_section ($input, $elements->{term}) if keys %{$elements->{term}};
189        print_class_section ($input, $elements->{class}) if keys %{$elements->{class}};
190      } elsif (defined $manifest) {
191        print_structure_dump_manifest_section ($input, $manifest);
192        print_structure_error_manifest_section ($input, $manifest, $result);
193      }
194    } # check_and_print
195    
196      print STDOUT qq[  sub print_http_header_section ($$) {
197  <div id="parse-errors" class="section">    my ($input, $result) = @_;
198      return unless defined $input->{header_status_code} or
199          defined $input->{header_status_text} or
200          @{$input->{header_field}};
201      
202      push @nav, ['#source-header' => 'HTTP Header'] unless $input->{nested};
203      print STDOUT qq[<div id="$input->{id_prefix}source-header" class="section">
204    <h2>HTTP Header</h2>
205    
206    <p><strong>Note</strong>: Due to the limitation of the
207    network library in use, the content of this section might
208    not be the real header.</p>
209    
210    <table><tbody>
211    ];
212    
213      if (defined $input->{header_status_code}) {
214        print STDOUT qq[<tr><th scope="row">Status code</th>];
215        print STDOUT qq[<td><code>@{[htescape ($input->{header_status_code})]}</code></td></tr>];
216      }
217      if (defined $input->{header_status_text}) {
218        print STDOUT qq[<tr><th scope="row">Status text</th>];
219        print STDOUT qq[<td><code>@{[htescape ($input->{header_status_text})]}</code></td></tr>];
220      }
221      
222      for (@{$input->{header_field}}) {
223        print STDOUT qq[<tr><th scope="row"><code>@{[htescape ($_->[0])]}</code></th>];
224        print STDOUT qq[<td><code>@{[htescape ($_->[1])]}</code></td></tr>];
225      }
226    
227      print STDOUT qq[</tbody></table></div>];
228    } # print_http_header_section
229    
230    sub print_syntax_error_html_section ($$) {
231      my ($input, $result) = @_;
232      
233      require Encode;
234      require Whatpm::HTML;
235      
236      print STDOUT qq[
237    <div id="$input->{id_prefix}parse-errors" class="section">
238  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
239    
240  <dl>];  <dl>];
241    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
242    
243    my $onerror = sub {    my $onerror = sub {
244      my (%opt) = @_;      my (%opt) = @_;
# Line 113  if (defined $input->{s}) { Line 252  if (defined $input->{s}) {
252      $type =~ tr/ /-/;      $type =~ tr/ /-/;
253      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
254      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
255      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
256        print STDOUT qq[$msg</dd>\n];
257    
258        add_error ('syntax', \%opt => $result);
259    };    };
260    
261    $doc = $dom->create_document;    my $doc = $dom->create_document;
262      my $el;
263      my $inner_html_element = $http->get_parameter ('e');
264    if (defined $inner_html_element and length $inner_html_element) {    if (defined $inner_html_element and length $inner_html_element) {
265        $input->{charset} ||= 'windows-1252'; ## TODO: for now.
266        my $time1 = time;
267        my $t = Encode::decode ($input->{charset}, $input->{s});
268        $time{decode} = time - $time1;
269        
270      $el = $doc->create_element_ns      $el = $doc->create_element_ns
271          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
272        $time1 = time;
273      Whatpm::HTML->set_inner_html ($el, $t, $onerror);      Whatpm::HTML->set_inner_html ($el, $t, $onerror);
274        $time{parse} = time - $time1;
275    } else {    } else {
276      Whatpm::HTML->parse_string ($t => $doc, $onerror);      my $time1 = time;
277        Whatpm::HTML->parse_byte_string
278            ($input->{charset}, $input->{s} => $doc, $onerror);
279        $time{parse_html} = time - $time1;
280    }    }
281      $doc->manakai_charset ($input->{official_charset})
282          if defined $input->{official_charset};
283      
284      print STDOUT qq[</dl></div>];
285    
286    print STDOUT qq[</dl>    return ($doc, $el);
287  </div>  } # print_syntax_error_html_section
 ];  
   
     print_source_string_section (\($input->{s}), $input->{charset});  
   } elsif ({  
             'text/xml' => 1,  
             'application/xhtml+xml' => 1,  
             'application/xml' => 1,  
            }->{$input->{media_type}}) {  
     require Message::DOM::XMLParserTemp;  
288    
289      print STDOUT qq[  sub print_syntax_error_xml_section ($$) {
290  <div id="parse-errors" class="section">    my ($input, $result) = @_;
291      
292      require Message::DOM::XMLParserTemp;
293      
294      print STDOUT qq[
295    <div id="$input->{id_prefix}parse-errors" class="section">
296  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
297    
298  <dl>];  <dl>];
299    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{prefix};
300    
301    my $onerror = sub {    my $onerror = sub {
302      my $err = shift;      my $err = shift;
# Line 150  if (defined $input->{s}) { Line 304  if (defined $input->{s}) {
304      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
305      print STDOUT $err->location->column_number, "</dt><dd>";      print STDOUT $err->location->column_number, "</dt><dd>";
306      print STDOUT htescape $err->text, "</dd>\n";      print STDOUT htescape $err->text, "</dd>\n";
307    
308        add_error ('syntax', {type => $err->text,
309                    level => [
310                              $err->SEVERITY_FATAL_ERROR => 'm',
311                              $err->SEVERITY_ERROR => 'm',
312                              $err->SEVERITY_WARNING => 's',
313                             ]->[$err->severity]} => $result);
314    
315      return 1;      return 1;
316    };    };
317    
318      my $time1 = time;
319    open my $fh, '<', \($input->{s});    open my $fh, '<', \($input->{s});
320    $doc = Message::DOM::XMLParserTemp->parse_byte_stream    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
321        ($fh => $dom, $onerror, charset => $input->{charset});        ($fh => $dom, $onerror, charset => $input->{charset});
322      $time{parse_xml} = time - $time1;
323      $doc->manakai_charset ($input->{official_charset})
324          if defined $input->{official_charset};
325    
326      print STDOUT qq[</dl>    print STDOUT qq[</dl></div>];
 </div>  
327    
328  ];    return ($doc, undef);
329      print_source_string_section (\($input->{s}), $doc->input_encoding);  } # print_syntax_error_xml_section
   } else {  
     ## TODO: Change HTTP status code??  
     print STDOUT qq[  
 <div id="result-summary" class="section">  
 <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  
 </div>  
 ];  
     push @nav, ['#result-summary' => 'Result'];  
   }  
   
   
   if (defined $doc or defined $el) {  
     print STDOUT qq[  
 <div id="document-tree" class="section">  
 <h2>Document Tree</h2>  
 ];  
     push @nav, ['#document-tree' => 'Tree'];  
   
     print_document_tree ($el || $doc);  
   
     print STDOUT qq[  
 </div>  
   
 <div id="document-errors" class="section">  
 <h2>Document Errors</h2>  
   
 <dl>];  
     push @nav, ['#document-errors' => 'Document Error'];  
   
     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_node_link ($opt{node}) .  
           qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";  
     };  
   
     my $elements;  
     if ($el) {  
       $elements = Whatpm::ContentChecker->check_element ($el, $onerror);  
     } else {  
       $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);  
     }  
   
     print STDOUT qq[</dl>  
 </div>  
 ];  
   
     if (@{$elements->{table}}) {  
       require JSON;  
   
       push @nav, ['#tables' => 'Tables'];  
       print STDOUT qq[  
 <div id="tables" class="section">  
 <h2>Tables</h2>  
   
 <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->  
 <script src="../table-script.js" type="text/javascript"></script>  
 <noscript>  
 <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>  
 </noscript>  
 ];  
330    
331        my $i = 0;  sub print_syntax_error_manifest_section ($$) {
332        for my $table_el (@{$elements->{table}}) {    my ($input, $result) = @_;
         $i++;  
         print STDOUT qq[<div class="section" id="table-$i"><h3>] .  
             get_node_link ($table_el) . q[</h3>];  
   
         ## TODO: Make |ContentChecker| return |form_table| result  
         ## so that this script don't have to run the algorithm twice.  
         my $table = Whatpm::HTMLTable->form_table ($table_el);  
           
         for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {  
           next unless $_;  
           delete $_->{element};  
         }  
           
         for (@{$table->{row_group}}) {  
           next unless $_;  
           next unless $_->{element};  
           $_->{type} = $_->{element}->manakai_local_name;  
           delete $_->{element};  
         }  
           
         for (@{$table->{cell}}) {  
           next unless $_;  
           for (@{$_}) {  
             next unless $_;  
             for (@$_) {  
               $_->{id} = refaddr $_->{element} if defined $_->{element};  
               delete $_->{element};  
               $_->{is_header} = $_->{is_header} ? 1 : 0;  
             }  
           }  
         }  
           
         print STDOUT '</div><script type="text/javascript">tableToCanvas (';  
         print STDOUT JSON::objToJson ($table);  
         print STDOUT qq[, document.getElementById ('table-$i'));</script>];  
       }  
       
       print STDOUT qq[</div>];  
     }  
333    
334      if (keys %{$elements->{id}}) {    require Whatpm::CacheManifest;
       push @nav, ['#identifiers' => 'IDs'];  
       print STDOUT qq[  
 <div id="identifiers" class="section">  
 <h2>Identifiers</h2>  
335    
 <dl>  
 ];  
       for my $id (sort {$a cmp $b} keys %{$elements->{id}}) {  
         print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];  
         for (@{$elements->{id}->{$id}}) {  
           print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];  
         }  
       }  
       print STDOUT qq[</dl></div>];  
     }  
   
     if (keys %{$elements->{term}}) {  
       push @nav, ['#terms' => 'Terms'];  
       print STDOUT qq[  
 <div id="terms" class="section">  
 <h2>Terms</h2>  
   
 <dl>  
 ];  
       for my $term (sort {$a cmp $b} keys %{$elements->{term}}) {  
         print STDOUT qq[<dt>@{[htescape $term]}</dt>];  
         for (@{$elements->{term}->{$term}}) {  
           print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];  
         }  
       }  
       print STDOUT qq[</dl></div>];  
     }  
   
     if (keys %{$elements->{class}}) {  
       push @nav, ['#classes' => 'Classes'];  
       print STDOUT qq[  
 <div id="classes" class="section">  
 <h2>Classes</h2>  
   
 <dl>  
 ];  
       for my $class (sort {$a cmp $b} keys %{$elements->{class}}) {  
         print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];  
         for (@{$elements->{class}->{$class}}) {  
           print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];  
         }  
       }  
       print STDOUT qq[</dl></div>];  
     }  
   }  
   
   ## TODO: Show result  
 } else {  
336    print STDOUT qq[    print STDOUT qq[
337  </dl>  <div id="$input->{id_prefix}parse-errors" class="section">
338  </div>  <h2>Parse Errors</h2>
   
 <div class="section" id="result-summary">  
 <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>  
 </div>  
 ];  
   push @nav, ['#result-summary' => 'Result'];  
   
 }  
   
   print STDOUT qq[  
 <ul class="navigation" id="nav-items">  
 ];  
   for (@nav) {  
     print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];  
   }  
   print STDOUT qq[  
 </ul>  
 </body>  
 </html>  
 ];  
339    
340  exit;  <dl>];
341      push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
342    
343  sub print_http_header_section ($) {    my $onerror = sub {
344    my $input = shift;      my (%opt) = @_;
345    return unless defined $input->{header_status_code} or      my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
346        defined $input->{header_status_text} or      print STDOUT qq[<dt class="$cls">], get_error_label ($input, \%opt),
347        @{$input->{header_field}};          qq[</dt>];
348          $type =~ tr/ /-/;
349    push @nav, ['#source-header' => 'HTTP Header'];      $type =~ s/\|/%7C/g;
350    print STDOUT qq[<div id="source-header" class="section">      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
351  <h2>HTTP Header</h2>      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
352        print STDOUT qq[$msg</dd>\n];
353    
354  <p><strong>Note</strong>: Due to the limitation of the      add_error ('syntax', \%opt => $result);
355  network library in use, the content of this section might    };
 not be the real header.</p>  
356    
357  <table><tbody>    my $time1 = time;
358  ];    my $manifest = Whatpm::CacheManifest->parse_byte_string
359          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
360      $time{parse_manifest} = time - $time1;
361    
362    if (defined $input->{header_status_code}) {    print STDOUT qq[</dl></div>];
     print STDOUT qq[<tr><th scope="row">Status code</th>];  
     print STDOUT qq[<td><code>@{[htescape ($input->{header_status_code})]}</code></td></tr>];  
   }  
   if (defined $input->{header_status_text}) {  
     print STDOUT qq[<tr><th scope="row">Status text</th>];  
     print STDOUT qq[<td><code>@{[htescape ($input->{header_status_text})]}</code></td></tr>];  
   }  
     
   for (@{$input->{header_field}}) {  
     print STDOUT qq[<tr><th scope="row"><code>@{[htescape ($_->[0])]}</code></th>];  
     print STDOUT qq[<td><code>@{[htescape ($_->[1])]}</code></td></tr>];  
   }  
363    
364    print STDOUT qq[</tbody></table></div>];    return $manifest;
365  } # print_http_header_section  } # print_syntax_error_manifest_section
366    
367  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
368    require Encode;    require Encode;
# Line 391  sub print_source_string_section ($$) { Line 371  sub print_source_string_section ($$) {
371    
372    my $s = \($enc->decode (${$_[0]}));    my $s = \($enc->decode (${$_[0]}));
373    my $i = 1;                                my $i = 1;                            
374    push @nav, ['#source-string' => 'Source'];    push @nav, ['#source-string' => 'Source'] unless $input->{nested};
375    print STDOUT qq[<div id="source-string" class="section">    print STDOUT qq[<div id="$input->{id_prefix}source-string" class="section">
376  <h2>Document Source</h2>  <h2>Document Source</h2>
377  <ol lang="">\n];  <ol lang="">\n];
378    if (length $$s) {    if (length $$s) {
379      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
380        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
381              "</li>\n";
382        $i++;        $i++;
383      }      }
384      if ($$s =~ /\G([^\x0A]+)/gc) {      if ($$s =~ /\G([^\x0A]+)/gc) {
385        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
386              "</li>\n";
387      }      }
388    } else {    } else {
389      print STDOUT q[<li id="line-1"></li>];      print STDOUT q[<li id="$input->{id_prefix}line-1"></li>];
390    }    }
391    print STDOUT "</ol></div>";    print STDOUT "</ol></div>";
392  } # print_input_string_section  } # print_input_string_section
# Line 421  sub print_document_tree ($) { Line 403  sub print_document_tree ($) {
403        next;        next;
404      }      }
405    
406      my $node_id = 'node-'.refaddr $child;      my $node_id = $input->{id_prefix} . 'node-'.refaddr $child;
407      my $nt = $child->node_type;      my $nt = $child->node_type;
408      if ($nt == $child->ELEMENT_NODE) {      if ($nt == $child->ELEMENT_NODE) {
409        my $child_nsuri = $child->namespace_uri;        my $child_nsuri = $child->namespace_uri;
# Line 432  sub print_document_tree ($) { Line 414  sub print_document_tree ($) {
414          $r .= '<ul class="attributes">';          $r .= '<ul class="attributes">';
415          for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }          for my $attr (sort {$a->[0] cmp $b->[0]} map { [$_->name, $_->value, $_->namespace_uri, 'node-'.refaddr $_] }
416                        @{$child->attributes}) {                        @{$child->attributes}) {
417            $r .= qq[<li id="$attr->[3]" class="tree-attribute"><code title="@{[defined $_->[2] ? $_->[2] : '']}">] . htescape ($attr->[0]) . '</code> = '; ## ISSUE: case?            $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?
418            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children
419          }          }
420          $r .= '</ul>';          $r .= '</ul>';
# Line 453  sub print_document_tree ($) { Line 435  sub print_document_tree ($) {
435      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
436        $r .= qq'<li id="$node_id" class="tree-document">Document';        $r .= qq'<li id="$node_id" class="tree-document">Document';
437        $r .= qq[<ul class="attributes">];        $r .= qq[<ul class="attributes">];
438          my $cp = $child->manakai_charset;
439          if (defined $cp) {
440            $r .= qq[<li><code>charset</code> parameter = <code>];
441            $r .= htescape ($cp) . qq[</code></li>];
442          }
443          $r .= qq[<li><code>inputEncoding</code> = ];
444          my $ie = $child->input_encoding;
445          if (defined $ie) {
446            $r .= qq[<code>@{[htescape ($ie)]}</code>];
447            if ($child->manakai_has_bom) {
448              $r .= qq[ (with <code class=charname><abbr>BOM</abbr></code>)];
449            }
450          } else {
451            $r .= qq[(<code>null</code>)];
452          }
453        $r .= qq[<li>@{[scalar get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]}</li>];        $r .= qq[<li>@{[scalar get_text ('manakaiIsHTML:'.($child->manakai_is_html?1:0))]}</li>];
454        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];
455        unless ($child->manakai_is_html) {        unless ($child->manakai_is_html) {
# Line 486  sub print_document_tree ($) { Line 483  sub print_document_tree ($) {
483    print STDOUT $r;    print STDOUT $r;
484  } # print_document_tree  } # print_document_tree
485    
486    sub print_structure_dump_dom_section ($$$) {
487      my ($input, $doc, $el) = @_;
488    
489      print STDOUT qq[
490    <div id="$input->{id_prefix}document-tree" class="section">
491    <h2>Document Tree</h2>
492    ];
493      push @nav, ['#document-tree' => 'Tree'] unless $input->{nested};
494    
495      print_document_tree ($el || $doc);
496    
497      print STDOUT qq[</div>];
498    } # print_structure_dump_dom_section
499    
500    sub print_structure_dump_manifest_section ($$) {
501      my ($input, $manifest) = @_;
502    
503      print STDOUT qq[
504    <div id="$input->{id_prefix}dump-manifest" class="section">
505    <h2>Cache Manifest</h2>
506    ];
507      push @nav, ['#dump-manifest' => 'Caceh Manifest'] unless $input->{nested};
508    
509      print STDOUT qq[<dl><dt>Explicit entries</dt>];
510      for my $uri (@{$manifest->[0]}) {
511        my $euri = htescape ($uri);
512        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
513      }
514    
515      print STDOUT qq[<dt>Fallback entries</dt><dd>
516          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
517          <th scope=row>Fallback Entry</tr><tbody>];
518      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
519        my $euri = htescape ($uri);
520        my $euri2 = htescape ($manifest->[1]->{$uri});
521        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
522            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
523      }
524    
525      print STDOUT qq[</table><dt>Online whitelist</dt>];
526      for my $uri (@{$manifest->[2]}) {
527        my $euri = htescape ($uri);
528        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
529      }
530    
531      print STDOUT qq[</dl></div>];
532    } # print_structure_dump_manifest_section
533    
534    sub print_structure_error_dom_section ($$$$) {
535      my ($input, $doc, $el, $result) = @_;
536    
537      print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
538    <h2>Document Errors</h2>
539    
540    <dl>];
541      push @nav, ['#document-errors' => 'Document Error'] unless $input->{nested};
542    
543      require Whatpm::ContentChecker;
544      my $onerror = sub {
545        my %opt = @_;
546        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
547        $type =~ tr/ /-/;
548        $type =~ s/\|/%7C/g;
549        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
550        print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
551            qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
552        print STDOUT $msg, "</dd>\n";
553        add_error ('structure', \%opt => $result);
554      };
555    
556      my $elements;
557      my $time1 = time;
558      if ($el) {
559        $elements = Whatpm::ContentChecker->check_element ($el, $onerror);
560      } else {
561        $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);
562      }
563      $time{check} = time - $time1;
564    
565      print STDOUT qq[</dl></div>];
566    
567      return $elements;
568    } # print_structure_error_dom_section
569    
570    sub print_structure_error_manifest_section ($$$) {
571      my ($input, $manifest, $result) = @_;
572    
573      print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
574    <h2>Document Errors</h2>
575    
576    <dl>];
577      push @nav, ['#document-errors' => 'Document Error'] unless $input->{nested};
578    
579      require Whatpm::CacheManifest;
580      Whatpm::CacheManifest->check_manifest ($manifest, sub {
581        my %opt = @_;
582        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
583        $type =~ tr/ /-/;
584        $type =~ s/\|/%7C/g;
585        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
586        print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
587            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
588        add_error ('structure', \%opt => $result);
589      });
590    
591      print STDOUT qq[</div>];
592    } # print_structure_error_manifest_section
593    
594    sub print_table_section ($$) {
595      my ($input, $tables) = @_;
596      
597      push @nav, ['#tables' => 'Tables'] unless $input->{nested};
598      print STDOUT qq[
599    <div id="$input->{id_prefix}tables" class="section">
600    <h2>Tables</h2>
601    
602    <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
603    <script src="../table-script.js" type="text/javascript"></script>
604    <noscript>
605    <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
606    </noscript>
607    ];
608      
609      require JSON;
610      
611      my $i = 0;
612      for my $table_el (@$tables) {
613        $i++;
614        print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .
615            get_node_link ($input, $table_el) . q[</h3>];
616    
617        ## TODO: Make |ContentChecker| return |form_table| result
618        ## so that this script don't have to run the algorithm twice.
619        my $table = Whatpm::HTMLTable->form_table ($table_el);
620        
621        for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
622          next unless $_;
623          delete $_->{element};
624        }
625        
626        for (@{$table->{row_group}}) {
627          next unless $_;
628          next unless $_->{element};
629          $_->{type} = $_->{element}->manakai_local_name;
630          delete $_->{element};
631        }
632        
633        for (@{$table->{cell}}) {
634          next unless $_;
635          for (@{$_}) {
636            next unless $_;
637            for (@$_) {
638              $_->{id} = refaddr $_->{element} if defined $_->{element};
639              delete $_->{element};
640              $_->{is_header} = $_->{is_header} ? 1 : 0;
641            }
642          }
643        }
644            
645        print STDOUT '</div><script type="text/javascript">tableToCanvas (';
646        print STDOUT JSON::objToJson ($table);
647        print STDOUT qq[, document.getElementById ('$input->{id_prefix}table-$i')];
648        print STDOUT qq[, '$input->{id_prefix}');</script>];
649      }
650      
651      print STDOUT qq[</div>];
652    } # print_table_section
653    
654    sub print_id_section ($$) {
655      my ($input, $ids) = @_;
656      
657      push @nav, ['#identifiers' => 'IDs'] unless $input->{nested};
658      print STDOUT qq[
659    <div id="$input->{id_prefix}identifiers" class="section">
660    <h2>Identifiers</h2>
661    
662    <dl>
663    ];
664      for my $id (sort {$a cmp $b} keys %$ids) {
665        print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
666        for (@{$ids->{$id}}) {
667          print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
668        }
669      }
670      print STDOUT qq[</dl></div>];
671    } # print_id_section
672    
673    sub print_term_section ($$) {
674      my ($input, $terms) = @_;
675      
676      push @nav, ['#terms' => 'Terms'] unless $input->{nested};
677      print STDOUT qq[
678    <div id="$input->{id_prefix}terms" class="section">
679    <h2>Terms</h2>
680    
681    <dl>
682    ];
683      for my $term (sort {$a cmp $b} keys %$terms) {
684        print STDOUT qq[<dt>@{[htescape $term]}</dt>];
685        for (@{$terms->{$term}}) {
686          print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
687        }
688      }
689      print STDOUT qq[</dl></div>];
690    } # print_term_section
691    
692    sub print_class_section ($$) {
693      my ($input, $classes) = @_;
694      
695      push @nav, ['#classes' => 'Classes'] unless $input->{nested};
696      print STDOUT qq[
697    <div id="$input->{id_prefix}classes" class="section">
698    <h2>Classes</h2>
699    
700    <dl>
701    ];
702      for my $class (sort {$a cmp $b} keys %$classes) {
703        print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];
704        for (@{$classes->{$class}}) {
705          print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
706        }
707      }
708      print STDOUT qq[</dl></div>];
709    } # print_class_section
710    
711    sub print_result_section ($) {
712      my $result = shift;
713    
714      print STDOUT qq[
715    <div id="result-summary" class="section">
716    <h2>Result</h2>];
717    
718      if ($result->{unsupported} and $result->{conforming_max}) {  
719        print STDOUT qq[<p class=uncertain id=result-para>The conformance
720            checker cannot decide whether the document is conforming or
721            not, since the document contains one or more unsupported
722            features.  The document might or might not be conforming.</p>];
723      } elsif ($result->{conforming_min}) {
724        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
725            found in this document.</p>];
726      } elsif ($result->{conforming_max}) {
727        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
728            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
729            it might be conforming.</p>];
730      } else {
731        print STDOUT qq[<p class=FAIL id=result-para>This document is
732            <strong><em>non</em>-conforming</strong>.</p>];
733      }
734    
735      print STDOUT qq[<table>
736    <colgroup><col><colgroup><col><col><col><colgroup><col>
737    <thead>
738    <tr><th scope=col></th>
739    <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
740    Errors</a></th>
741    <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
742    Errors</a></th>
743    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
744    <th scope=col>Score</th></tr></thead><tbody>];
745    
746      my $must_error = 0;
747      my $should_error = 0;
748      my $warning = 0;
749      my $score_min = 0;
750      my $score_max = 0;
751      my $score_base = 20;
752      my $score_unit = $score_base / 100;
753      for (
754        [Transfer => 'transfer', ''],
755        [Character => 'char', ''],
756        [Syntax => 'syntax', '#parse-errors'],
757        [Structure => 'structure', '#document-errors'],
758      ) {
759        $must_error += ($result->{$_->[1]}->{must} += 0);
760        $should_error += ($result->{$_->[1]}->{should} += 0);
761        $warning += ($result->{$_->[1]}->{warning} += 0);
762        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
763        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
764    
765        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
766        my $label = $_->[0];
767        if ($result->{$_->[1]}->{must} or
768            $result->{$_->[1]}->{should} or
769            $result->{$_->[1]}->{warning} or
770            $result->{$_->[1]}->{unsupported}) {
771          $label = qq[<a href="$_->[2]">$label</a>];
772        }
773    
774        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>];
775        if ($uncertain) {
776          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
777        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
778          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
779        } else {
780          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
781        }
782      }
783    
784      $score_max += $score_base;
785    
786      print STDOUT qq[
787    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
788    </tbody>
789    <tfoot><tr class=uncertain><th scope=row>Total</th>
790    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
791    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
792    <td>$warning?</td>
793    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
794    </table>
795    
796    <p><strong>Important</strong>: This conformance checking service
797    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
798    </div>];
799      push @nav, ['#result-summary' => 'Result'];
800    } # print_result_section
801    
802    sub print_result_unknown_type_section ($$) {
803      my ($input, $result) = @_;
804    
805      my $euri = htescape ($input->{uri});
806      print STDOUT qq[
807    <div id="parse-errors" class="section">
808    <h2>Errors</h2>
809    
810    <dl>
811    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
812        <dd class=unsupported><strong><a href="../error-description#level-u">Not
813            supported</a></strong>:
814        Media type
815        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
816        is not supported.</dd>
817    </dl>
818    </div>
819    ];
820      push @nav, ['#parse-errors' => 'Errors'];
821      add_error (char => {level => 'u'} => $result);
822      add_error (syntax => {level => 'u'} => $result);
823      add_error (structure => {level => 'u'} => $result);
824    } # print_result_unknown_type_section
825    
826    sub print_result_input_error_section ($) {
827      my $input = shift;
828      print STDOUT qq[<div class="section" id="result-summary">
829    <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>
830    </div>];
831      push @nav, ['#result-summary' => 'Result'];
832    } # print_result_input_error_section
833    
834    sub get_error_label ($$) {
835      my ($input, $err) = @_;
836    
837      my $r = '';
838    
839      if (defined $err->{line}) {
840        if ($err->{column} > 0) {
841          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
842        } else {
843          $err->{line} = $err->{line} - 1 || 1;
844          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
845        }
846      }
847    
848      if (defined $err->{node}) {
849        $r .= ' ' if length $r;
850        $r = get_node_link ($input, $err->{node});
851      }
852    
853      if (defined $err->{index}) {
854        $r .= ' ' if length $r;
855        $r .= 'Index ' . (0+$err->{index});
856      }
857    
858      if (defined $err->{value}) {
859        $r .= ' ' if length $r;
860        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
861      }
862    
863      return $r;
864    } # get_error_label
865    
866    sub get_error_level_label ($) {
867      my $err = shift;
868    
869      my $r = '';
870    
871      if (not defined $err->{level} or $err->{level} eq 'm') {
872        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
873            error</a></strong>: ];
874      } elsif ($err->{level} eq 's') {
875        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
876            error</a></strong>: ];
877      } elsif ($err->{level} eq 'w') {
878        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
879            ];
880      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
881        $r = qq[<strong><a href="../error-description#level-u">Not
882            supported</a></strong>: ];
883      } else {
884        my $elevel = htescape ($err->{level});
885        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
886            ];
887      }
888    
889      return $r;
890    } # get_error_level_label
891    
892  sub get_node_path ($) {  sub get_node_path ($) {
893    my $node = shift;    my $node = shift;
894    my @r;    my @r;
# Line 513  sub get_node_path ($) { Line 916  sub get_node_path ($) {
916    return join '/', @r;    return join '/', @r;
917  } # get_node_path  } # get_node_path
918    
919  sub get_node_link ($) {  sub get_node_link ($$) {
920    return qq[<a href="#node-@{[refaddr $_[0]]}">] .    return qq[<a href="#$_[0]->{id_prefix}node-@{[refaddr $_[1]]}">] .
921        htescape (get_node_path ($_[0])) . qq[</a>];        htescape (get_node_path ($_[1])) . qq[</a>];
922  } # get_node_link  } # get_node_link
923    
924  {  {
# Line 523  sub get_node_link ($) { Line 926  sub get_node_link ($) {
926    
927  sub load_text_catalog ($) {  sub load_text_catalog ($) {
928    my $lang = shift; # MUST be a canonical lang name    my $lang = shift; # MUST be a canonical lang name
929    open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";    open my $file, '<:utf8', "cc-msg.$lang.txt"
930          or die "$0: cc-msg.$lang.txt: $!";
931    while (<$file>) {    while (<$file>) {
932      if (s/^([^;]+);([^;]*);//) {      if (s/^([^;]+);([^;]*);//) {
933        my ($type, $cls, $msg) = ($1, $2, $_);        my ($type, $cls, $msg) = ($1, $2, $_);
# Line 536  sub load_text_catalog ($) { Line 940  sub load_text_catalog ($) {
940  sub get_text ($) {  sub get_text ($) {
941    my ($type, $level, $node) = @_;    my ($type, $level, $node) = @_;
942    $type = $level . ':' . $type if defined $level;    $type = $level . ':' . $type if defined $level;
943      $level = 'm' unless defined $level;
944    my @arg;    my @arg;
945    {    {
946      if (defined $Msg->{$type}) {      if (defined $Msg->{$type}) {
# Line 550  sub get_text ($) { Line 955  sub get_text ($) {
955        $msg =~ s{<var>{\@}</var>}{        $msg =~ s{<var>{\@}</var>}{
956          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''          UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''
957        }ge;        }ge;
958        return ($type, $Msg->{$type}->[0], $msg);        $msg =~ s{<var>{local-name}</var>}{
959            UNIVERSAL::can ($node, 'manakai_local_name')
960              ? htescape ($node->manakai_local_name) : ''
961          }ge;
962          $msg =~ s{<var>{element-local-name}</var>}{
963            (UNIVERSAL::can ($node, 'owner_element') and
964             $node->owner_element)
965              ? htescape ($node->owner_element->manakai_local_name)
966              : ''
967          }ge;
968          return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
969      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
970        unshift @arg, $1;        unshift @arg, $1;
971        redo;        redo;
972      }      }
973    }    }
974    return ($type, '', htescape ($_[0]));    return ($type, 'level-'.$level, htescape ($_[0]));
975  } # get_text  } # get_text
976    
977  }  }
# Line 564  sub get_text ($) { Line 979  sub get_text ($) {
979  sub get_input_document ($$) {  sub get_input_document ($$) {
980    my ($http, $dom) = @_;    my ($http, $dom) = @_;
981    
982    my $request_uri = $http->parameter ('uri');    my $request_uri = $http->get_parameter ('uri');
983    my $r = {};    my $r = {};
984    if (defined $request_uri and length $request_uri) {    if (defined $request_uri and length $request_uri) {
985      my $uri = $dom->create_uri_reference ($request_uri);      my $uri = $dom->create_uri_reference ($request_uri);
# Line 612  EOH Line 1027  EOH
1027      $ua->protocols_allowed ([qw/http/]);      $ua->protocols_allowed ([qw/http/]);
1028      $ua->max_size (1000_000);      $ua->max_size (1000_000);
1029      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
1030        $req->header ('Accept-Encoding' => 'identity, *; q=0');
1031      my $res = $ua->request ($req);      my $res = $ua->request ($req);
1032      if ($res->is_success or $http->parameter ('error-page')) {      ## TODO: 401 sets |is_success| true.
1033        if ($res->is_success or $http->get_parameter ('error-page')) {
1034        $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and <base>. ## TODO: Use our own code!        $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and <base>. ## TODO: Use our own code!
1035        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1036        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
1037    
1038        ## TODO: More strict parsing...        ## TODO: More strict parsing...
1039        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
1040        if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
         $r->{media_type} = lc $1;  
       }  
       if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?(\S+)"?/i) {  
1041          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1042          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1043            $r->{official_charset} = $r->{charset};
1044        }        }
1045    
1046        my $input_charset = $http->parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
1047        if (defined $input_charset and length $input_charset) {        if (defined $input_charset and length $input_charset) {
1048          $r->{charset_overridden}          $r->{charset_overridden}
1049              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1050          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
1051        }        }
1052    
1053          ## TODO: Support for HTTP Content-Encoding
1054    
1055        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
1056    
1057          require Whatpm::ContentType;
1058          ($r->{official_type}, $r->{media_type})
1059              = Whatpm::ContentType->get_sniffed_type
1060                  (get_file_head => sub {
1061                     return substr $r->{s}, 0, shift;
1062                   },
1063                   http_content_type_byte => $ct,
1064                   has_http_content_encoding =>
1065                       defined $res->header ('Content-Encoding'),
1066                   supported_image_types => {});
1067      } else {      } else {
1068        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1069        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 649  EOH Line 1077  EOH
1077      $r->{header_status_code} = $res->code;      $r->{header_status_code} = $res->code;
1078      $r->{header_status_text} = $res->message;      $r->{header_status_text} = $res->message;
1079    } else {    } else {
1080      $r->{s} = ''.$http->parameter ('s');      $r->{s} = ''.$http->get_parameter ('s');
1081      $r->{uri} = q<thismessage:/>;      $r->{uri} = q<thismessage:/>;
1082      $r->{request_uri} = q<thismessage:/>;      $r->{request_uri} = q<thismessage:/>;
1083      $r->{base_uri} = q<thismessage:/>;      $r->{base_uri} = q<thismessage:/>;
1084      $r->{charset} = ''.$http->parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
1085      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1086      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1087        $r->{official_charset} = $r->{charset};
1088      $r->{header_field} = [];      $r->{header_field} = [];
1089    
1090        require Whatpm::ContentType;
1091        ($r->{official_type}, $r->{media_type})
1092            = Whatpm::ContentType->get_sniffed_type
1093                (get_file_head => sub {
1094                   return substr $r->{s}, 0, shift;
1095                 },
1096                 http_content_type_byte => undef,
1097                 has_http_content_encoding => 0,
1098                 supported_image_types => {});
1099    }    }
1100    
1101    my $input_format = $http->parameter ('i');    my $input_format = $http->get_parameter ('i');
1102    if (defined $input_format and length $input_format) {    if (defined $input_format and length $input_format) {
1103      $r->{media_type_overridden}      $r->{media_type_overridden}
1104          = (not defined $r->{media_type} or $input_format ne $r->{media_type});          = (not defined $r->{media_type} or $input_format ne $r->{media_type});
# Line 673  EOH Line 1112  EOH
1112    if ($r->{media_type} eq 'text/xml') {    if ($r->{media_type} eq 'text/xml') {
1113      unless (defined $r->{charset}) {      unless (defined $r->{charset}) {
1114        $r->{charset} = 'us-ascii';        $r->{charset} = 'us-ascii';
1115          $r->{official_charset} = $r->{charset};
1116      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
1117        $r->{charset_overridden} = 0;        $r->{charset_overridden} = 0;
1118      }      }
Legend:
Removed from v.1.15  
changed lines
  Added in v.1.32
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24