/[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.9 by wakaba, Sun Jul 15 16:39:10 2007 UTC revision 1.34 by wakaba, Sun Feb 10 03:11:06 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 15  sub htescape ($) { Line 14  sub htescape ($) {
14    $s =~ s/</&lt;/g;    $s =~ s/</&lt;/g;
15    $s =~ s/>/&gt;/g;    $s =~ s/>/&gt;/g;
16    $s =~ s/"/&quot;/g;    $s =~ s/"/&quot;/g;
17    $s =~ s!([\x00-\x09\x0B-\x1F\x7F-\x80])!sprintf '<var>U+%04X</var>', ord $1!ge;    $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{
18        sprintf '<var>U+%04X</var>', ord $1;
19      }ge;
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    }    }
30    
31      binmode STDOUT, ':utf8';
32      $| = 1;
33    
34    require Message::DOM::DOMImplementation;    require Message::DOM::DOMImplementation;
35    my $dom = Message::DOM::DOMImplementation->new;    my $dom = Message::DOM::DOMImplementation->new;
36    
   my $input = get_input_document ($http, $dom);  
   my $inner_html_element = $http->parameter ('e');  
   
37    load_text_catalog ('en'); ## TODO: conneg    load_text_catalog ('en'); ## TODO: conneg
38    
39    my @nav;    my @nav;
# Line 46  my $http = SuikaWiki::Input::HTTP->new; Line 46  my $http = SuikaWiki::Input::HTTP->new;
46  <link rel="stylesheet" href="../cc-style.css" type="text/css">  <link rel="stylesheet" href="../cc-style.css" type="text/css">
47  </head>  </head>
48  <body>  <body>
49  <h1>Web Document Conformance Checker (<em>beta</em>)</h1>  <h1><a href="../cc-interface">Web Document Conformance Checker</a>
50    (<em>beta</em>)</h1>
51    ];
52    
53      $| = 0;
54      my $input = get_input_document ($http, $dom);
55      my $char_length = 0;
56      my %time;
57    
58      print qq[
59  <div id="document-info" class="section">  <div id="document-info" class="section">
60  <dl>  <dl>
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    my $doc;    print_result_section ($result);
94    my $el;  } else {
95      print STDOUT qq[</dl></div>];
96      print_result_input_error_section ($input);
97    }
98    
99    if ($input->{media_type} eq 'text/html') {    print STDOUT qq[
100      require Encode;  <ul class="navigation" id="nav-items">
101      require Whatpm::HTML;  ];
102          for (@nav) {
103      my $t = Encode::decode ($input->{charset}, $input->{s});      print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];
104      }
105      print STDOUT qq[
106    </ul>
107    </body>
108    </html>
109    ];
110    
111      print STDOUT qq[    for (qw/decode parse parse_html parse_xml parse_manifest
112  <div id="parse-errors" class="section">            check check_manifest/) {
113  <h2>Parse Errors</h2>      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  <dl>  exit;
 ];  
   push @nav, ['#parse-errors' => 'Parse Error'];  
119    
120    my $onerror = sub {  sub add_error ($$$) {
121      my (%opt) = @_;    my ($layer, $err, $result) = @_;
122      my ($cls, $msg) = get_text ($opt{type}, $opt{level});    if (defined $err->{level}) {
123      if ($opt{column} > 0) {      if ($err->{level} eq 's') {
124        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];        $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 {      } else {
133        $opt{line} = $opt{line} - 1 || 1;        $result->{$layer}->{must}++;
134        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];        $result->{$layer}->{score_max} -= 2;
135          $result->{$layer}->{score_min} -= 2;
136          $result->{conforming_min} = 0;
137          $result->{conforming_max} = 0;
138      }      }
     $opt{type} =~ tr/ /-/;  
     $opt{type} =~ s/\|/%7C/g;  
     $msg .= qq[ [<a href="../error-description#$opt{type}">Description</a>]];  
     print STDOUT qq[<dd class="$cls">$msg</dd>\n];  
   };  
   
   $doc = $dom->create_document;  
   if (defined $inner_html_element and length $inner_html_element) {  
     $el = $doc->create_element_ns  
         ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);  
     Whatpm::HTML->set_inner_html ($el, $t, $onerror);  
139    } else {    } else {
140      Whatpm::HTML->parse_string ($t => $doc, $onerror);      $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    print STDOUT qq[  sub check_and_print ($$) {
149  </dl>    my ($input, $result) = @_;
150  </div>    $input->{id_prefix} = '';
151  ];    #$input->{nested} = 1/0;
152    
153      print_http_header_section ($input, $result);
154    
155      print_source_string_section (\($input->{s}), $input->{charset});    my $doc;
156      my $el;
157      my $manifest;
158      my @subdoc;
159    
160      if ($input->{media_type} eq 'text/html') {
161        ($doc, $el) = print_syntax_error_html_section ($input, $result);
162        print_source_string_section
163            (\($input->{s}), $input->{charset} || $doc->input_encoding);
164    } elsif ({    } elsif ({
165              'text/xml' => 1,              'text/xml' => 1,
166                'application/atom+xml' => 1,
167                'application/rss+xml' => 1,
168                'application/svg+xml' => 1,
169              'application/xhtml+xml' => 1,              'application/xhtml+xml' => 1,
170              'application/xml' => 1,              'application/xml' => 1,
171             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
172      require Message::DOM::XMLParserTemp;      ($doc, $el) = print_syntax_error_xml_section ($input, $result);
   
     print STDOUT qq[  
 <div id="parse-errors" class="section">  
 <h2>Parse Errors</h2>  
   
 <dl>];  
   push @nav, ['#parse-errors' => 'Parse Error'];  
   
   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";  
     return 1;  
   };  
   
   open my $fh, '<', \($input->{s});  
   $doc = Message::DOM::XMLParserTemp->parse_byte_stream  
       ($fh => $dom, $onerror, charset => $input->{charset});  
   
     print STDOUT qq[</dl>  
 </div>  
   
 ];  
173      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
174      } elsif ($input->{media_type} eq 'text/cache-manifest') {
175    ## TODO: MUST be text/cache-manifest
176        $manifest = print_syntax_error_manifest_section ($input, $result);
177        print_source_string_section (\($input->{s}), 'utf-8');
178    } else {    } else {
179      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
180      print STDOUT qq[      print_result_unknown_type_section ($input, $result);
 <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'];  
181    }    }
182    
   
183    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
184      print STDOUT qq[      $doc->document_uri ($input->{uri});
185  <div id="document-tree" class="section">      $doc->manakai_entity_base_uri ($input->{base_uri});
186  <h2>Document Tree</h2>      print_structure_dump_dom_section ($input, $doc, $el);
187  ];      my $elements = print_structure_error_dom_section
188      push @nav, ['#document-tree' => 'Tree'];          ($input, $doc, $el, $result, sub {
189              push @subdoc, shift;
190      print_document_tree ($el || $doc);          });
191        print_table_section ($input, $elements->{table}) if @{$elements->{table}};
192      print STDOUT qq[      print_listing_section ({
193  </div>        id => 'identifiers', label => 'IDs', heading => 'Identifiers',
194        }, $input, $elements->{id}) if keys %{$elements->{id}};
195  <div id="document-errors" class="section">      print_listing_section ({
196  <h2>Document Errors</h2>        id => 'terms', label => 'Terms', heading => 'Terms',
197        }, $input, $elements->{term}) if keys %{$elements->{term}};
198  <dl>];      print_listing_section ({
199      push @nav, ['#document-errors' => 'Document Error'];        id => 'classes', label => 'Classes', heading => 'Classes',
200        }, $input, $elements->{class}) if keys %{$elements->{class}};
201      require Whatpm::ContentChecker;    } elsif (defined $manifest) {
202      my $onerror = sub {      print_structure_dump_manifest_section ($input, $manifest);
203        my %opt = @_;      print_structure_error_manifest_section ($input, $manifest, $result);
       my ($cls, $msg) = get_text ($opt{type}, $opt{level});  
       $opt{type} = $opt{level} . ':' . $opt{type} if defined $opt{level};  
       $opt{type} =~ tr/ /-/;  
       $opt{type} =~ s/\|/%7C/g;  
       $msg .= qq[ [<a href="../error-description#$opt{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;  
   
       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>  
 ];  
   
       my $i = 0;  
       for my $table_el (@{$elements->{table}}) {  
         $i++;  
         print STDOUT qq[<div class="section" id="table-$i"><h3>] .  
             get_node_link ($table_el) . q[</h3>];  
           
         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};  
             }  
           }  
         }  
           
         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>];  
     }  
   
     if (keys %{$elements->{term}}) {  
       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>];  
     }  
204    }    }
205    
206    ## TODO: Show result    my $id_prefix = 0;
207  } else {    for my $subinput (@subdoc) {
208    print STDOUT qq[      $subinput->{id_prefix} = 'subdoc-' . ++$id_prefix;
209  </dl>      $subinput->{nested} = 1;
210  </div>      $subinput->{base_uri} = $subinput->{container_node}->base_uri
211            unless defined $subinput->{base_uri};
212  <div class="section" id="result-summary">      my $ebaseuri = htescape ($subinput->{base_uri});
213  <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>      push @nav, ['#' . $subinput->{id_prefix} => 'Sub #' . $id_prefix];
214  </div>      print STDOUT qq[<div id="$subinput->{id_prefix}" class=section>
215  ];        <h2>Subdocument #$id_prefix</h2>
216    push @nav, ['#result-summary' => 'Result'];  
217          <dl>
218          <dt>Internet Media Type</dt>
219            <dd><code class="MIME" lang="en">@{[htescape $subinput->{media_type}]}</code>
220          <dt>Container Node</dt>
221            <dd>@{[get_node_link ($input, $subinput->{container_node})]}</dd>
222          <dt>Base <abbr title="Uniform Resource Identifiers">URI</abbr></dt>
223            <dd><code class=URI>&lt;<a href="$ebaseuri">$ebaseuri</a>></code></dd>
224          </dl>];              
225    
226  }      check_and_print ($subinput => $result);
227    
228    print STDOUT qq[      print STDOUT qq[</div>];
 <ul class="navigation" id="nav-items">  
 ];  
   for (@nav) {  
     print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];  
229    }    }
230    print STDOUT qq[  } # check_and_print
 </ul>  
 </body>  
 </html>  
 ];  
   
 exit;  
231    
232  sub print_http_header_section ($) {  sub print_http_header_section ($$) {
233    my $input = shift;    my ($input, $result) = @_;
234    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
235        defined $input->{header_status_text} or        defined $input->{header_status_text} or
236        @{$input->{header_field}};        @{$input->{header_field} or []};
237        
238    push @nav, ['#source-header' => 'HTTP Header'];    push @nav, ['#source-header' => 'HTTP Header'] unless $input->{nested};
239    print STDOUT qq[<div id="source-header" class="section">    print STDOUT qq[<div id="$input->{id_prefix}source-header" class="section">
240  <h2>HTTP Header</h2>  <h2>HTTP Header</h2>
241    
242  <p><strong>Note</strong>: Due to the limitation of the  <p><strong>Note</strong>: Due to the limitation of the
# Line 337  not be the real header.</p> Line 263  not be the real header.</p>
263    print STDOUT qq[</tbody></table></div>];    print STDOUT qq[</tbody></table></div>];
264  } # print_http_header_section  } # print_http_header_section
265    
266    sub print_syntax_error_html_section ($$) {
267      my ($input, $result) = @_;
268      
269      require Encode;
270      require Whatpm::HTML;
271      
272      print STDOUT qq[
273    <div id="$input->{id_prefix}parse-errors" class="section">
274    <h2>Parse Errors</h2>
275    
276    <dl>];
277      push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
278    
279      my $onerror = sub {
280        my (%opt) = @_;
281        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
282        if ($opt{column} > 0) {
283          print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];
284        } else {
285          $opt{line} = $opt{line} - 1 || 1;
286          print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];
287        }
288        $type =~ tr/ /-/;
289        $type =~ s/\|/%7C/g;
290        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
291        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
292        print STDOUT qq[$msg</dd>\n];
293    
294        add_error ('syntax', \%opt => $result);
295      };
296    
297      my $doc = $dom->create_document;
298      my $el;
299      my $inner_html_element = $http->get_parameter ('e');
300      if (defined $inner_html_element and length $inner_html_element) {
301        $input->{charset} ||= 'windows-1252'; ## TODO: for now.
302        my $time1 = time;
303        my $t = Encode::decode ($input->{charset}, $input->{s});
304        $time{decode} = time - $time1;
305        
306        $el = $doc->create_element_ns
307            ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
308        $time1 = time;
309        Whatpm::HTML->set_inner_html ($el, $t, $onerror);
310        $time{parse} = time - $time1;
311      } else {
312        my $time1 = time;
313        Whatpm::HTML->parse_byte_string
314            ($input->{charset}, $input->{s} => $doc, $onerror);
315        $time{parse_html} = time - $time1;
316      }
317      $doc->manakai_charset ($input->{official_charset})
318          if defined $input->{official_charset};
319      
320      print STDOUT qq[</dl></div>];
321    
322      return ($doc, $el);
323    } # print_syntax_error_html_section
324    
325    sub print_syntax_error_xml_section ($$) {
326      my ($input, $result) = @_;
327      
328      require Message::DOM::XMLParserTemp;
329      
330      print STDOUT qq[
331    <div id="$input->{id_prefix}parse-errors" class="section">
332    <h2>Parse Errors</h2>
333    
334    <dl>];
335      push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{prefix};
336    
337      my $onerror = sub {
338        my $err = shift;
339        my $line = $err->location->line_number;
340        print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
341        print STDOUT $err->location->column_number, "</dt><dd>";
342        print STDOUT htescape $err->text, "</dd>\n";
343    
344        add_error ('syntax', {type => $err->text,
345                    level => [
346                              $err->SEVERITY_FATAL_ERROR => 'm',
347                              $err->SEVERITY_ERROR => 'm',
348                              $err->SEVERITY_WARNING => 's',
349                             ]->[$err->severity]} => $result);
350    
351        return 1;
352      };
353    
354      my $time1 = time;
355      open my $fh, '<', \($input->{s});
356      my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
357          ($fh => $dom, $onerror, charset => $input->{charset});
358      $time{parse_xml} = time - $time1;
359      $doc->manakai_charset ($input->{official_charset})
360          if defined $input->{official_charset};
361    
362      print STDOUT qq[</dl></div>];
363    
364      return ($doc, undef);
365    } # print_syntax_error_xml_section
366    
367    sub print_syntax_error_manifest_section ($$) {
368      my ($input, $result) = @_;
369    
370      require Whatpm::CacheManifest;
371    
372      print STDOUT qq[
373    <div id="$input->{id_prefix}parse-errors" class="section">
374    <h2>Parse Errors</h2>
375    
376    <dl>];
377      push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
378    
379      my $onerror = sub {
380        my (%opt) = @_;
381        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
382        print STDOUT qq[<dt class="$cls">], get_error_label ($input, \%opt),
383            qq[</dt>];
384        $type =~ tr/ /-/;
385        $type =~ s/\|/%7C/g;
386        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
387        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
388        print STDOUT qq[$msg</dd>\n];
389    
390        add_error ('syntax', \%opt => $result);
391      };
392    
393      my $time1 = time;
394      my $manifest = Whatpm::CacheManifest->parse_byte_string
395          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
396      $time{parse_manifest} = time - $time1;
397    
398      print STDOUT qq[</dl></div>];
399    
400      return $manifest;
401    } # print_syntax_error_manifest_section
402    
403  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
404    require Encode;    require Encode;
405    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name
# Line 344  sub print_source_string_section ($$) { Line 407  sub print_source_string_section ($$) {
407    
408    my $s = \($enc->decode (${$_[0]}));    my $s = \($enc->decode (${$_[0]}));
409    my $i = 1;                                my $i = 1;                            
410    push @nav, ['#source-string' => 'Source'];    push @nav, ['#source-string' => 'Source'] unless $input->{nested};
411    print STDOUT qq[<div id="source-string" class="section">    print STDOUT qq[<div id="$input->{id_prefix}source-string" class="section">
412  <h2>Document Source</h2>  <h2>Document Source</h2>
413  <ol lang="">\n];  <ol lang="">\n];
414    if (length $$s) {    if (length $$s) {
415      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
416        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
417              "</li>\n";
418        $i++;        $i++;
419      }      }
420      if ($$s =~ /\G([^\x0A]+)/gc) {      if ($$s =~ /\G([^\x0A]+)/gc) {
421        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
422              "</li>\n";
423      }      }
424    } else {    } else {
425      print STDOUT q[<li id="line-1"></li>];      print STDOUT q[<li id="$input->{id_prefix}line-1"></li>];
426    }    }
427    print STDOUT "</ol></div>";    print STDOUT "</ol></div>";
428  } # print_input_string_section  } # print_input_string_section
# Line 374  sub print_document_tree ($) { Line 439  sub print_document_tree ($) {
439        next;        next;
440      }      }
441    
442      my $node_id = 'node-'.refaddr $child;      my $node_id = $input->{id_prefix} . 'node-'.refaddr $child;
443      my $nt = $child->node_type;      my $nt = $child->node_type;
444      if ($nt == $child->ELEMENT_NODE) {      if ($nt == $child->ELEMENT_NODE) {
445        my $child_nsuri = $child->namespace_uri;        my $child_nsuri = $child->namespace_uri;
# Line 385  sub print_document_tree ($) { Line 450  sub print_document_tree ($) {
450          $r .= '<ul class="attributes">';          $r .= '<ul class="attributes">';
451          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 $_] }
452                        @{$child->attributes}) {                        @{$child->attributes}) {
453            $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?
454            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children
455          }          }
456          $r .= '</ul>';          $r .= '</ul>';
# Line 406  sub print_document_tree ($) { Line 471  sub print_document_tree ($) {
471      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
472        $r .= qq'<li id="$node_id" class="tree-document">Document';        $r .= qq'<li id="$node_id" class="tree-document">Document';
473        $r .= qq[<ul class="attributes">];        $r .= qq[<ul class="attributes">];
474          my $cp = $child->manakai_charset;
475          if (defined $cp) {
476            $r .= qq[<li><code>charset</code> parameter = <code>];
477            $r .= htescape ($cp) . qq[</code></li>];
478          }
479          $r .= qq[<li><code>inputEncoding</code> = ];
480          my $ie = $child->input_encoding;
481          if (defined $ie) {
482            $r .= qq[<code>@{[htescape ($ie)]}</code>];
483            if ($child->manakai_has_bom) {
484              $r .= qq[ (with <code class=charname><abbr>BOM</abbr></code>)];
485            }
486          } else {
487            $r .= qq[(<code>null</code>)];
488          }
489        $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>];
490        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];
491        unless ($child->manakai_is_html) {        unless ($child->manakai_is_html) {
# Line 439  sub print_document_tree ($) { Line 519  sub print_document_tree ($) {
519    print STDOUT $r;    print STDOUT $r;
520  } # print_document_tree  } # print_document_tree
521    
522    sub print_structure_dump_dom_section ($$$) {
523      my ($input, $doc, $el) = @_;
524    
525      print STDOUT qq[
526    <div id="$input->{id_prefix}document-tree" class="section">
527    <h2>Document Tree</h2>
528    ];
529      push @nav, ['#document-tree' => 'Tree'] unless $input->{nested};
530    
531      print_document_tree ($el || $doc);
532    
533      print STDOUT qq[</div>];
534    } # print_structure_dump_dom_section
535    
536    sub print_structure_dump_manifest_section ($$) {
537      my ($input, $manifest) = @_;
538    
539      print STDOUT qq[
540    <div id="$input->{id_prefix}dump-manifest" class="section">
541    <h2>Cache Manifest</h2>
542    ];
543      push @nav, ['#dump-manifest' => 'Caceh Manifest'] unless $input->{nested};
544    
545      print STDOUT qq[<dl><dt>Explicit entries</dt>];
546      for my $uri (@{$manifest->[0]}) {
547        my $euri = htescape ($uri);
548        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
549      }
550    
551      print STDOUT qq[<dt>Fallback entries</dt><dd>
552          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
553          <th scope=row>Fallback Entry</tr><tbody>];
554      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
555        my $euri = htescape ($uri);
556        my $euri2 = htescape ($manifest->[1]->{$uri});
557        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
558            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
559      }
560    
561      print STDOUT qq[</table><dt>Online whitelist</dt>];
562      for my $uri (@{$manifest->[2]}) {
563        my $euri = htescape ($uri);
564        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
565      }
566    
567      print STDOUT qq[</dl></div>];
568    } # print_structure_dump_manifest_section
569    
570    sub print_structure_error_dom_section ($$$$$) {
571      my ($input, $doc, $el, $result, $onsubdoc) = @_;
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::ContentChecker;
580      my $onerror = 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">], get_error_level_label (\%opt);
588        print STDOUT $msg, "</dd>\n";
589        add_error ('structure', \%opt => $result);
590      };
591    
592      my $elements;
593      my $time1 = time;
594      if ($el) {
595        $elements = Whatpm::ContentChecker->check_element
596            ($el, $onerror, $onsubdoc);
597      } else {
598        $elements = Whatpm::ContentChecker->check_document
599            ($doc, $onerror, $onsubdoc);
600      }
601      $time{check} = time - $time1;
602    
603      print STDOUT qq[</dl></div>];
604    
605      return $elements;
606    } # print_structure_error_dom_section
607    
608    sub print_structure_error_manifest_section ($$$) {
609      my ($input, $manifest, $result) = @_;
610    
611      print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
612    <h2>Document Errors</h2>
613    
614    <dl>];
615      push @nav, ['#document-errors' => 'Document Error'] unless $input->{nested};
616    
617      require Whatpm::CacheManifest;
618      Whatpm::CacheManifest->check_manifest ($manifest, sub {
619        my %opt = @_;
620        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
621        $type =~ tr/ /-/;
622        $type =~ s/\|/%7C/g;
623        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
624        print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
625            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
626        add_error ('structure', \%opt => $result);
627      });
628    
629      print STDOUT qq[</div>];
630    } # print_structure_error_manifest_section
631    
632    sub print_table_section ($$) {
633      my ($input, $tables) = @_;
634      
635      push @nav, ['#tables' => 'Tables'] unless $input->{nested};
636      print STDOUT qq[
637    <div id="$input->{id_prefix}tables" class="section">
638    <h2>Tables</h2>
639    
640    <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
641    <script src="../table-script.js" type="text/javascript"></script>
642    <noscript>
643    <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
644    </noscript>
645    ];
646      
647      require JSON;
648      
649      my $i = 0;
650      for my $table_el (@$tables) {
651        $i++;
652        print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .
653            get_node_link ($input, $table_el) . q[</h3>];
654    
655        ## TODO: Make |ContentChecker| return |form_table| result
656        ## so that this script don't have to run the algorithm twice.
657        my $table = Whatpm::HTMLTable->form_table ($table_el);
658        
659        for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {
660          next unless $_;
661          delete $_->{element};
662        }
663        
664        for (@{$table->{row_group}}) {
665          next unless $_;
666          next unless $_->{element};
667          $_->{type} = $_->{element}->manakai_local_name;
668          delete $_->{element};
669        }
670        
671        for (@{$table->{cell}}) {
672          next unless $_;
673          for (@{$_}) {
674            next unless $_;
675            for (@$_) {
676              $_->{id} = refaddr $_->{element} if defined $_->{element};
677              delete $_->{element};
678              $_->{is_header} = $_->{is_header} ? 1 : 0;
679            }
680          }
681        }
682            
683        print STDOUT '</div><script type="text/javascript">tableToCanvas (';
684        print STDOUT JSON::objToJson ($table);
685        print STDOUT qq[, document.getElementById ('$input->{id_prefix}table-$i')];
686        print STDOUT qq[, '$input->{id_prefix}');</script>];
687      }
688      
689      print STDOUT qq[</div>];
690    } # print_table_section
691    
692    sub print_listing_section ($$$) {
693      my ($opt, $input, $ids) = @_;
694      
695      push @nav, ['#' . $opt->{id} => $opt->{label}] unless $input->{nested};
696      print STDOUT qq[
697    <div id="$input->{id_prefix}$opt->{id}" class="section">
698    <h2>$opt->{heading}</h2>
699    
700    <dl>
701    ];
702      for my $id (sort {$a cmp $b} keys %$ids) {
703        print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
704        for (@{$ids->{$id}}) {
705          print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
706        }
707      }
708      print STDOUT qq[</dl></div>];
709    } # print_listing_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 466  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 476  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 487  sub load_text_catalog ($) { Line 938  sub load_text_catalog ($) {
938  } # load_text_catalog  } # load_text_catalog
939    
940  sub get_text ($) {  sub get_text ($) {
941    my ($type, $level) = @_;    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}) {
947        my $msg = $Msg->{$type}->[1];        my $msg = $Msg->{$type}->[1];
948        $msg =~ s/\$([0-9]+)/defined $arg[$1] ? htescape ($arg[$1]) : '(undef)'/ge;        $msg =~ s{<var>\$([0-9]+)</var>}{
949        return ($Msg->{$type}->[0], $msg);          defined $arg[$1] ? htescape ($arg[$1]) : '(undef)';
950          }ge;
951          $msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{
952            UNIVERSAL::can ($node, 'get_attribute_ns')
953                ? htescape ($node->get_attribute_ns (undef, $1)) : ''
954          }ge;
955          $msg =~ s{<var>{\@}</var>}{
956            UNIVERSAL::can ($node, 'value') ? htescape ($node->value) : ''
957          }ge;
958          $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 ('', htescape ($_[0]));    return ($type, 'level-'.$level, htescape ($_[0]));
975  } # get_text  } # get_text
976    
977  }  }
# Line 508  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 556  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 593  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 617  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.9  
changed lines
  Added in v.1.34
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24