/[suikacvs]/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.17 by wakaba, Sun Sep 2 07:59:01 2007 UTC revision 1.52 by wakaba, Fri Jul 18 14:44:16 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/manakai2/lib];             /home/wakaba/work/manakai2/lib];
# Line 19  sub htescape ($) { Line 20  sub htescape ($) {
20    return $s;    return $s;
21  } # htescape  } # htescape
22    
23      my @nav;
24      my %time;
25      require Message::DOM::DOMImplementation;
26      my $dom = Message::DOM::DOMImplementation->new;
27    {
28    use Message::CGI::HTTP;    use Message::CGI::HTTP;
29    my $http = Message::CGI::HTTP->new;    my $http = Message::CGI::HTTP->new;
30    
# Line 30  sub htescape ($) { Line 36  sub htescape ($) {
36    binmode STDOUT, ':utf8';    binmode STDOUT, ':utf8';
37    $| = 1;    $| = 1;
38    
   require Message::DOM::DOMImplementation;  
   my $dom = Message::DOM::DOMImplementation->new;  
   
39    load_text_catalog ('en'); ## TODO: conneg    load_text_catalog ('en'); ## TODO: conneg
40    
   my @nav;  
41    print STDOUT qq[Content-Type: text/html; charset=utf-8    print STDOUT qq[Content-Type: text/html; charset=utf-8
42    
43  <!DOCTYPE html>  <!DOCTYPE html>
# Line 51  sub htescape ($) { Line 53  sub htescape ($) {
53    
54    $| = 0;    $| = 0;
55    my $input = get_input_document ($http, $dom);    my $input = get_input_document ($http, $dom);
   my $inner_html_element = $http->get_parameter ('e');  
56    my $char_length = 0;    my $char_length = 0;
   my %time;  
   my $time1;  
   my $time2;  
57    
58    print qq[    print qq[
59  <div id="document-info" class="section">  <div id="document-info" class="section">
# Line 63  sub htescape ($) { Line 61  sub htescape ($) {
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    
# Line 75  if (defined $input->{s}) { Line 78  if (defined $input->{s}) {
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>
# Line 83  if (defined $input->{s}) { Line 86  if (defined $input->{s}) {
86      <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>      <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>
87  </dl>  </dl>
88  </div>  </div>
89    
90    <script src="../cc-script.js"></script>
91  ];  ];
92    
93    print_http_header_section ($input);    $input->{id_prefix} = '';
94      #$input->{nested} = 0;
95      my $result = {conforming_min => 1, conforming_max => 1};
96      check_and_print ($input => $result);
97      print_result_section ($result);
98    } else {
99      print STDOUT qq[</dl></div>];
100      print_result_input_error_section ($input);
101    }
102    
103      print STDOUT qq[
104    <ul class="navigation" id="nav-items">
105    ];
106      for (@nav) {
107        print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];
108      }
109      print STDOUT qq[
110    </ul>
111    </body>
112    </html>
113    ];
114    
115      for (qw/decode parse parse_html parse_xml parse_manifest
116              check check_manifest/) {
117        next unless defined $time{$_};
118        open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
119        print $file $char_length, "\t", $time{$_}, "\n";
120      }
121    
122    exit;
123    }
124    
125    sub add_error ($$$) {
126      my ($layer, $err, $result) = @_;
127      if (defined $err->{level}) {
128        if ($err->{level} eq 's') {
129          $result->{$layer}->{should}++;
130          $result->{$layer}->{score_min} -= 2;
131          $result->{conforming_min} = 0;
132        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
133          $result->{$layer}->{warning}++;
134        } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
135          $result->{$layer}->{unsupported}++;
136          $result->{unsupported} = 1;
137        } elsif ($err->{level} eq 'i') {
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      } else {
147        $result->{$layer}->{must}++;
148        $result->{$layer}->{score_max} -= 2;
149        $result->{$layer}->{score_min} -= 2;
150        $result->{conforming_min} = 0;
151        $result->{conforming_max} = 0;
152      }
153    } # add_error
154    
155    sub check_and_print ($$) {
156      my ($input, $result) = @_;
157    
158      print_http_header_section ($input, $result);
159    
160    my $doc;    my $doc;
161    my $el;    my $el;
162      my $cssom;
163      my $manifest;
164      my $idl;
165      my @subdoc;
166    
167    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
168      require Encode;      ($doc, $el) = print_syntax_error_html_section ($input, $result);
169      require Whatpm::HTML;      print_source_string_section
170            ($input,
171             \($input->{s}),
172             $input->{charset} || $doc->input_encoding);
173      } elsif ({
174                'text/xml' => 1,
175                'application/atom+xml' => 1,
176                'application/rss+xml' => 1,
177                'image/svg+xml' => 1,
178                'application/xhtml+xml' => 1,
179                'application/xml' => 1,
180                ## TODO: Should we make all XML MIME Types fall
181                ## into this category?
182    
183                'application/rdf+xml' => 1, ## NOTE: This type has different model.
184               }->{$input->{media_type}}) {
185        ($doc, $el) = print_syntax_error_xml_section ($input, $result);
186        print_source_string_section ($input,
187                                     \($input->{s}),
188                                     $doc->input_encoding);
189      } elsif ($input->{media_type} eq 'text/css') {
190        $cssom = print_syntax_error_css_section ($input, $result);
191        print_source_string_section
192            ($input, \($input->{s}),
193             $cssom->manakai_input_encoding);
194      } elsif ($input->{media_type} eq 'text/cache-manifest') {
195    ## TODO: MUST be text/cache-manifest
196        $manifest = print_syntax_error_manifest_section ($input, $result);
197        print_source_string_section ($input, \($input->{s}),
198                                     'utf-8');
199      } elsif ($input->{media_type} eq 'text/x-webidl') { ## TODO: type
200        $idl = print_syntax_error_webidl_section ($input, $result);
201        print_source_string_section ($input, \($input->{s}),
202                                     'utf-8'); ## TODO: charset
203      } else {
204        ## TODO: Change HTTP status code??
205        print_result_unknown_type_section ($input, $result);
206      }
207    
208      $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.    if (defined $doc or defined $el) {
209        $doc->document_uri ($input->{uri});
210        $doc->manakai_entity_base_uri ($input->{base_uri});
211        print_structure_dump_dom_section ($input, $doc, $el);
212        my $elements = print_structure_error_dom_section
213            ($input, $doc, $el, $result, sub {
214              push @subdoc, shift;
215            });
216        print_table_section ($input, $elements->{table}) if @{$elements->{table}};
217        print_listing_section ({
218          id => 'identifiers', label => 'IDs', heading => 'Identifiers',
219        }, $input, $elements->{id}) if keys %{$elements->{id}};
220        print_listing_section ({
221          id => 'terms', label => 'Terms', heading => 'Terms',
222        }, $input, $elements->{term}) if keys %{$elements->{term}};
223        print_listing_section ({
224          id => 'classes', label => 'Classes', heading => 'Classes',
225        }, $input, $elements->{class}) if keys %{$elements->{class}};
226        print_uri_section ($input, $elements->{uri}) if keys %{$elements->{uri}};
227        print_rdf_section ($input, $elements->{rdf}) if @{$elements->{rdf}};
228      } elsif (defined $cssom) {
229        print_structure_dump_cssom_section ($input, $cssom);
230        ## TODO: CSSOM validation
231        add_error ('structure', {level => 'u'} => $result);
232      } elsif (defined $manifest) {
233        print_structure_dump_manifest_section ($input, $manifest);
234        print_structure_error_manifest_section ($input, $manifest, $result);
235      } elsif (defined $idl) {
236        print_structure_dump_webidl_section ($input, $idl);
237        print_structure_error_webidl_section ($input, $idl, $result);
238      }
239    
240      my $id_prefix = 0;
241      for my $subinput (@subdoc) {
242        $subinput->{id_prefix} = 'subdoc-' . ++$id_prefix;
243        $subinput->{nested} = 1;
244        $subinput->{base_uri} = $subinput->{container_node}->base_uri
245            unless defined $subinput->{base_uri};
246        my $ebaseuri = htescape ($subinput->{base_uri});
247        push @nav, ['#' . $subinput->{id_prefix} => 'Sub #' . $id_prefix];
248        print STDOUT qq[<div id="$subinput->{id_prefix}" class=section>
249          <h2>Subdocument #$id_prefix</h2>
250    
251          <dl>
252          <dt>Internet Media Type</dt>
253            <dd><code class="MIME" lang="en">@{[htescape $subinput->{media_type}]}</code>
254          <dt>Container Node</dt>
255            <dd>@{[get_node_link ($input, $subinput->{container_node})]}</dd>
256          <dt>Base <abbr title="Uniform Resource Identifiers">URI</abbr></dt>
257            <dd><code class=URI>&lt;<a href="$ebaseuri">$ebaseuri</a>></code></dd>
258          </dl>];              
259    
260        $subinput->{id_prefix} .= '-';
261        check_and_print ($subinput => $result);
262    
263      $time1 = time;      print STDOUT qq[</div>];
264      my $t = Encode::decode ($input->{charset}, $input->{s});    }
265      $time2 = time;  } # check_and_print
266      $time{decode} = $time2 - $time1;  
267    sub print_http_header_section ($$) {
268      my ($input, $result) = @_;
269      return unless defined $input->{header_status_code} or
270          defined $input->{header_status_text} or
271          @{$input->{header_field} or []};
272      
273      push @nav, ['#source-header' => 'HTTP Header'] unless $input->{nested};
274      print STDOUT qq[<div id="$input->{id_prefix}source-header" class="section">
275    <h2>HTTP Header</h2>
276    
277    <p><strong>Note</strong>: Due to the limitation of the
278    network library in use, the content of this section might
279    not be the real header.</p>
280    
281      print STDOUT qq[  <table><tbody>
282  <div id="parse-errors" class="section">  ];
283    
284      if (defined $input->{header_status_code}) {
285        print STDOUT qq[<tr><th scope="row">Status code</th>];
286        print STDOUT qq[<td><code>@{[htescape ($input->{header_status_code})]}</code></td></tr>];
287      }
288      if (defined $input->{header_status_text}) {
289        print STDOUT qq[<tr><th scope="row">Status text</th>];
290        print STDOUT qq[<td><code>@{[htescape ($input->{header_status_text})]}</code></td></tr>];
291      }
292      
293      for (@{$input->{header_field}}) {
294        print STDOUT qq[<tr><th scope="row"><code>@{[htescape ($_->[0])]}</code></th>];
295        print STDOUT qq[<td><code>@{[htescape ($_->[1])]}</code></td></tr>];
296      }
297    
298      print STDOUT qq[</tbody></table></div>];
299    } # print_http_header_section
300    
301    sub print_syntax_error_html_section ($$) {
302      my ($input, $result) = @_;
303      
304      require Encode;
305      require Whatpm::HTML;
306      
307      print STDOUT qq[
308    <div id="$input->{id_prefix}parse-errors" class="section">
309  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
310    
311  <dl>];  <dl id="$input->{id_prefix}parse-errors-list">];
312    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
313    
314    my $onerror = sub {    my $onerror = sub {
315      my (%opt) = @_;      my (%opt) = @_;
316      my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});      my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
317      if ($opt{column} > 0) {      print STDOUT qq[<dt class="$cls">], get_error_label ($input, \%opt),
318        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];          qq[</dt>];
     } else {  
       $opt{line} = $opt{line} - 1 || 1;  
       print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];  
     }  
319      $type =~ tr/ /-/;      $type =~ tr/ /-/;
320      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
321      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
322      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
323        print STDOUT qq[$msg</dd>\n];
324    
325        add_error ('syntax', \%opt => $result);
326    };    };
327    
328    $doc = $dom->create_document;    my $doc = $dom->create_document;
329    $time1 = time;    my $el;
330      my $inner_html_element = $input->{inner_html_element};
331    if (defined $inner_html_element and length $inner_html_element) {    if (defined $inner_html_element and length $inner_html_element) {
332        $input->{charset} ||= 'windows-1252'; ## TODO: for now.
333        my $time1 = time;
334        my $t = \($input->{s});
335        unless ($input->{is_char_string}) {
336          $t = \(Encode::decode ($input->{charset}, $$t));
337        }
338        $time{decode} = time - $time1;
339        
340      $el = $doc->create_element_ns      $el = $doc->create_element_ns
341          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
342      Whatpm::HTML->set_inner_html ($el, $t, $onerror);      $time1 = time;
343        Whatpm::HTML->set_inner_html ($el, $$t, $onerror);
344        $time{parse} = time - $time1;
345    } else {    } else {
346      Whatpm::HTML->parse_string ($t => $doc, $onerror);      my $time1 = time;
347        if ($input->{is_char_string}) {
348          Whatpm::HTML->parse_char_string ($input->{s} => $doc, $onerror);
349        } else {
350          Whatpm::HTML->parse_byte_string
351              ($input->{charset}, $input->{s} => $doc, $onerror);
352        }
353        $time{parse_html} = time - $time1;
354    }    }
355    $time2 = time;    $doc->manakai_charset ($input->{official_charset})
356    $time{parse} = $time2 - $time1;        if defined $input->{official_charset};
357      
358    print STDOUT qq[</dl>    print STDOUT qq[</dl></div>];
 </div>  
 ];  
359    
360      print_source_string_section (\($input->{s}), $input->{charset});    return ($doc, $el);
361    } elsif ({  } # print_syntax_error_html_section
             'text/xml' => 1,  
             'application/atom+xml' => 1,  
             'application/rss+xml' => 1,  
             'application/svg+xml' => 1,  
             'application/xhtml+xml' => 1,  
             'application/xml' => 1,  
            }->{$input->{media_type}}) {  
     require Message::DOM::XMLParserTemp;  
362    
363      print STDOUT qq[  sub print_syntax_error_xml_section ($$) {
364  <div id="parse-errors" class="section">    my ($input, $result) = @_;
365      
366      require Message::DOM::XMLParserTemp;
367      
368      print STDOUT qq[
369    <div id="$input->{id_prefix}parse-errors" class="section">
370  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
371    
372  <dl>];  <dl id="$input->{id_prefix}parse-errors-list">];
373    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{prefix};
374    
375    my $onerror = sub {    my $onerror = sub {
376      my $err = shift;      my $err = shift;
377      my $line = $err->location->line_number;      my $line = $err->location->line_number;
378      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];      print STDOUT qq[<dt><a href="#$input->{id_prefix}line-$line">Line $line</a> column ];
379      print STDOUT $err->location->column_number, "</dt><dd>";      print STDOUT $err->location->column_number, "</dt><dd>";
380      print STDOUT htescape $err->text, "</dd>\n";      print STDOUT htescape $err->text, "</dd>\n";
     return 1;  
   };  
381    
382    $time1 = time;      add_error ('syntax', {type => $err->text,
383    open my $fh, '<', \($input->{s});                  level => [
384    $doc = Message::DOM::XMLParserTemp->parse_byte_stream                            $err->SEVERITY_FATAL_ERROR => 'm',
385        ($fh => $dom, $onerror, charset => $input->{charset});                            $err->SEVERITY_ERROR => 'm',
386    $time2 = time;                            $err->SEVERITY_WARNING => 's',
387    $time{parse_xml} = $time2 - $time1;                           ]->[$err->severity]} => $result);
388    
389      print STDOUT qq[</dl>      return 1;
390  </div>    };
391    
392  ];    my $t = \($input->{s});
393      print_source_string_section (\($input->{s}), $doc->input_encoding);    if ($input->{is_char_string}) {
394    } else {      require Encode;
395      ## TODO: Change HTTP status code??      $t = \(Encode::encode ('utf8', $$t));
396      print STDOUT qq[      $input->{charset} = 'utf-8';
 <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'];  
397    }    }
398    
399      my $time1 = time;
400      open my $fh, '<', $t;
401      my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
402          ($fh => $dom, $onerror, charset => $input->{charset});
403      $time{parse_xml} = time - $time1;
404      $doc->manakai_charset ($input->{official_charset})
405          if defined $input->{official_charset};
406    
407      print STDOUT qq[</dl></div>];
408    
409      return ($doc, undef);
410    } # print_syntax_error_xml_section
411    
412    sub get_css_parser () {
413      our $CSSParser;
414      return $CSSParser if $CSSParser;
415    
416      require Whatpm::CSS::Parser;
417      my $p = Whatpm::CSS::Parser->new;
418    
419      $p->{prop}->{$_} = 1 for qw/
420        alignment-baseline
421        background background-attachment background-color background-image
422        background-position background-position-x background-position-y
423        background-repeat border border-bottom border-bottom-color
424        border-bottom-style border-bottom-width border-collapse border-color
425        border-left border-left-color
426        border-left-style border-left-width border-right border-right-color
427        border-right-style border-right-width
428        border-spacing -manakai-border-spacing-x -manakai-border-spacing-y
429        border-style border-top border-top-color border-top-style border-top-width
430        border-width bottom
431        caption-side clear clip color content counter-increment counter-reset
432        cursor direction display dominant-baseline empty-cells float font
433        font-family font-size font-size-adjust font-stretch
434        font-style font-variant font-weight height left
435        letter-spacing line-height
436        list-style list-style-image list-style-position list-style-type
437        margin margin-bottom margin-left margin-right margin-top marker-offset
438        marks max-height max-width min-height min-width opacity -moz-opacity
439        orphans outline outline-color outline-style outline-width overflow
440        overflow-x overflow-y
441        padding padding-bottom padding-left padding-right padding-top
442        page page-break-after page-break-before page-break-inside
443        position quotes right size table-layout
444        text-align text-anchor text-decoration text-indent text-transform
445        top unicode-bidi vertical-align visibility white-space width widows
446        word-spacing writing-mode z-index
447      /;
448      $p->{prop_value}->{display}->{$_} = 1 for qw/
449        block clip inline inline-block inline-table list-item none
450        table table-caption table-cell table-column table-column-group
451        table-header-group table-footer-group table-row table-row-group
452        compact marker
453      /;
454      $p->{prop_value}->{position}->{$_} = 1 for qw/
455        absolute fixed relative static
456      /;
457      $p->{prop_value}->{float}->{$_} = 1 for qw/
458        left right none
459      /;
460      $p->{prop_value}->{clear}->{$_} = 1 for qw/
461        left right none both
462      /;
463      $p->{prop_value}->{direction}->{ltr} = 1;
464      $p->{prop_value}->{direction}->{rtl} = 1;
465      $p->{prop_value}->{marks}->{crop} = 1;
466      $p->{prop_value}->{marks}->{cross} = 1;
467      $p->{prop_value}->{'unicode-bidi'}->{$_} = 1 for qw/
468        normal bidi-override embed
469      /;
470      for my $prop_name (qw/overflow overflow-x overflow-y/) {
471        $p->{prop_value}->{$prop_name}->{$_} = 1 for qw/
472          visible hidden scroll auto -webkit-marquee -moz-hidden-unscrollable
473        /;
474      }
475      $p->{prop_value}->{visibility}->{$_} = 1 for qw/
476        visible hidden collapse
477      /;
478      $p->{prop_value}->{'list-style-type'}->{$_} = 1 for qw/
479        disc circle square decimal decimal-leading-zero
480        lower-roman upper-roman lower-greek lower-latin
481        upper-latin armenian georgian lower-alpha upper-alpha none
482        hebrew cjk-ideographic hiragana katakana hiragana-iroha
483        katakana-iroha
484      /;
485      $p->{prop_value}->{'list-style-position'}->{outside} = 1;
486      $p->{prop_value}->{'list-style-position'}->{inside} = 1;
487      $p->{prop_value}->{'page-break-before'}->{$_} = 1 for qw/
488        auto always avoid left right
489      /;
490      $p->{prop_value}->{'page-break-after'}->{$_} = 1 for qw/
491        auto always avoid left right
492      /;
493      $p->{prop_value}->{'page-break-inside'}->{auto} = 1;
494      $p->{prop_value}->{'page-break-inside'}->{avoid} = 1;
495      $p->{prop_value}->{'background-repeat'}->{$_} = 1 for qw/
496        repeat repeat-x repeat-y no-repeat
497      /;
498      $p->{prop_value}->{'background-attachment'}->{scroll} = 1;
499      $p->{prop_value}->{'background-attachment'}->{fixed} = 1;
500      $p->{prop_value}->{'font-size'}->{$_} = 1 for qw/
501        xx-small x-small small medium large x-large xx-large
502        -manakai-xxx-large -webkit-xxx-large
503        larger smaller
504      /;
505      $p->{prop_value}->{'font-style'}->{normal} = 1;
506      $p->{prop_value}->{'font-style'}->{italic} = 1;
507      $p->{prop_value}->{'font-style'}->{oblique} = 1;
508      $p->{prop_value}->{'font-variant'}->{normal} = 1;
509      $p->{prop_value}->{'font-variant'}->{'small-caps'} = 1;
510      $p->{prop_value}->{'font-stretch'}->{$_} = 1 for
511          qw/normal wider narrower ultra-condensed extra-condensed
512            condensed semi-condensed semi-expanded expanded
513            extra-expanded ultra-expanded/;
514      $p->{prop_value}->{'text-align'}->{$_} = 1 for qw/
515        left right center justify begin end
516      /;
517      $p->{prop_value}->{'text-transform'}->{$_} = 1 for qw/
518        capitalize uppercase lowercase none
519      /;
520      $p->{prop_value}->{'white-space'}->{$_} = 1 for qw/
521        normal pre nowrap pre-line pre-wrap -moz-pre-wrap
522      /;
523      $p->{prop_value}->{'writing-mode'}->{$_} = 1 for qw/
524        lr rl tb lr-tb rl-tb tb-rl
525      /;
526      $p->{prop_value}->{'text-anchor'}->{$_} = 1 for qw/
527        start middle end
528      /;
529      $p->{prop_value}->{'dominant-baseline'}->{$_} = 1 for qw/
530        auto use-script no-change reset-size ideographic alphabetic
531        hanging mathematical central middle text-after-edge text-before-edge
532      /;
533      $p->{prop_value}->{'alignment-baseline'}->{$_} = 1 for qw/
534        auto baseline before-edge text-before-edge middle central
535        after-edge text-after-edge ideographic alphabetic hanging
536        mathematical
537      /;
538      $p->{prop_value}->{'text-decoration'}->{$_} = 1 for qw/
539        none blink underline overline line-through
540      /;
541      $p->{prop_value}->{'caption-side'}->{$_} = 1 for qw/
542        top bottom left right
543      /;
544      $p->{prop_value}->{'table-layout'}->{auto} = 1;
545      $p->{prop_value}->{'table-layout'}->{fixed} = 1;
546      $p->{prop_value}->{'border-collapse'}->{collapse} = 1;
547      $p->{prop_value}->{'border-collapse'}->{separate} = 1;
548      $p->{prop_value}->{'empty-cells'}->{show} = 1;
549      $p->{prop_value}->{'empty-cells'}->{hide} = 1;
550      $p->{prop_value}->{cursor}->{$_} = 1 for qw/
551        auto crosshair default pointer move e-resize ne-resize nw-resize n-resize
552        se-resize sw-resize s-resize w-resize text wait help progress
553      /;
554      for my $prop (qw/border-top-style border-left-style
555                       border-bottom-style border-right-style outline-style/) {
556        $p->{prop_value}->{$prop}->{$_} = 1 for qw/
557          none hidden dotted dashed solid double groove ridge inset outset
558        /;
559      }
560      for my $prop (qw/color background-color
561                       border-bottom-color border-left-color border-right-color
562                       border-top-color border-color/) {
563        $p->{prop_value}->{$prop}->{transparent} = 1;
564        $p->{prop_value}->{$prop}->{flavor} = 1;
565        $p->{prop_value}->{$prop}->{'-manakai-default'} = 1;
566      }
567      $p->{prop_value}->{'outline-color'}->{invert} = 1;
568      $p->{prop_value}->{'outline-color'}->{'-manakai-invert-or-currentcolor'} = 1;
569      $p->{pseudo_class}->{$_} = 1 for qw/
570        active checked disabled empty enabled first-child first-of-type
571        focus hover indeterminate last-child last-of-type link only-child
572        only-of-type root target visited
573        lang nth-child nth-last-child nth-of-type nth-last-of-type not
574        -manakai-contains -manakai-current
575      /;
576      $p->{pseudo_element}->{$_} = 1 for qw/
577        after before first-letter first-line
578      /;
579    
580    if (defined $doc or defined $el) {    return $CSSParser = $p;
581      print STDOUT qq[  } # get_css_parser
 <div id="document-tree" class="section">  
 <h2>Document Tree</h2>  
 ];  
     push @nav, ['#document-tree' => 'Tree'];  
582    
583      print_document_tree ($el || $doc);  sub print_syntax_error_css_section ($$) {
584      my ($input, $result) = @_;
585    
586      print STDOUT qq[    print STDOUT qq[
587  </div>  <div id="$input->{id_prefix}parse-errors" class="section">
588    <h2>Parse Errors</h2>
589    
590  <div id="document-errors" class="section">  <dl id="$input->{id_prefix}parse-errors-list">];
591  <h2>Document Errors</h2>    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
592    
593  <dl>];    my $p = get_css_parser ();
594      push @nav, ['#document-errors' => 'Document Error'];    $p->init;
595      $p->{onerror} = sub {
596        my (%opt) = @_;
597        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
598        if ($opt{token}) {
599          print STDOUT qq[<dt class="$cls"><a href="#$input->{id_prefix}line-$opt{token}->{line}">Line $opt{token}->{line}</a> column $opt{token}->{column}];
600        } else {
601          print STDOUT qq[<dt class="$cls">Unknown location];
602        }
603        if (defined $opt{value}) {
604          print STDOUT qq[ (<code>@{[htescape ($opt{value})]}</code>)];
605        } elsif (defined $opt{token}) {
606          print STDOUT qq[ (<code>@{[htescape (Whatpm::CSS::Tokenizer->serialize_token ($opt{token}))]}</code>)];
607        }
608        $type =~ tr/ /-/;
609        $type =~ s/\|/%7C/g;
610        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
611        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
612        print STDOUT qq[$msg</dd>\n];
613    
614      require Whatpm::ContentChecker;      add_error ('syntax', \%opt => $result);
615      my $onerror = sub {    };
616        my %opt = @_;    $p->{href} = $input->{uri};
617        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});    $p->{base_uri} = $input->{base_uri};
       $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";  
     };  
618    
619      $time1 = time;  #  if ($parse_mode eq 'q') {
620      my $elements;  #    $p->{unitless_px} = 1;
621      if ($el) {  #    $p->{hashless_color} = 1;
622        $elements = Whatpm::ContentChecker->check_element ($el, $onerror);  #  }
623    
624    ## TODO: Make $input->{s} a ref.
625    
626      my $s = \$input->{s};
627      my $charset;
628      unless ($input->{is_char_string}) {
629        require Encode;
630        if (defined $input->{charset}) {## TODO: IANA->Perl
631          $charset = $input->{charset};
632          $s = \(Encode::decode ($input->{charset}, $$s));
633      } else {      } else {
634        $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);        ## TODO: charset detection
635          $s = \(Encode::decode ($charset = 'utf-8', $$s));
636      }      }
637      $time2 = time;    }
638      $time{check} = $time2 - $time1;    
639      my $cssom = $p->parse_char_string ($$s);
640      print STDOUT qq[</dl>    $cssom->manakai_input_encoding ($charset) if defined $charset;
 </div>  
 ];  
641    
642      if (@{$elements->{table}}) {    print STDOUT qq[</dl></div>];
       require JSON;  
643    
644        push @nav, ['#tables' => 'Tables'];    return $cssom;
645        print STDOUT qq[  } # print_syntax_error_css_section
 <div id="tables" class="section">  
 <h2>Tables</h2>  
646    
647  <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->  sub print_syntax_error_manifest_section ($$) {
648  <script src="../table-script.js" type="text/javascript"></script>    my ($input, $result) = @_;
 <noscript>  
 <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>  
 </noscript>  
 ];  
649    
650        my $i = 0;    require Whatpm::CacheManifest;
       for my $table_el (@{$elements->{table}}) {  
         $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>];  
     }  
651    
652      if (keys %{$elements->{id}}) {    print STDOUT qq[
653        push @nav, ['#identifiers' => 'IDs'];  <div id="$input->{id_prefix}parse-errors" class="section">
654        print STDOUT qq[  <h2>Parse Errors</h2>
 <div id="identifiers" class="section">  
 <h2>Identifiers</h2>  
655    
656  <dl>  <dl id="$input->{id_prefix}parse-errors-list">];
657  ];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
       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>];  
     }  
658    
659      if (keys %{$elements->{term}}) {    my $onerror = sub {
660        push @nav, ['#terms' => 'Terms'];      my (%opt) = @_;
661        print STDOUT qq[      my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
662  <div id="terms" class="section">      print STDOUT qq[<dt class="$cls">], get_error_label ($input, \%opt),
663  <h2>Terms</h2>          qq[</dt>];
664        $type =~ tr/ /-/;
665        $type =~ s/\|/%7C/g;
666        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
667        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
668        print STDOUT qq[$msg</dd>\n];
669    
670  <dl>      add_error ('syntax', \%opt => $result);
671  ];    };
       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>];  
     }  
672    
673      if (keys %{$elements->{class}}) {    my $m = $input->{is_char_string} ? 'parse_char_string' : 'parse_byte_string';
674        push @nav, ['#classes' => 'Classes'];    my $time1 = time;
675        print STDOUT qq[    my $manifest = Whatpm::CacheManifest->$m
676  <div id="classes" class="section">        ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
677  <h2>Classes</h2>    $time{parse_manifest} = time - $time1;
678    
679  <dl>    print STDOUT qq[</dl></div>];
 ];  
       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>];  
     }  
   }  
680    
681    ## TODO: Show result    return $manifest;
682  } else {  } # print_syntax_error_manifest_section
   print STDOUT qq[  
 </dl>  
 </div>  
683    
684  <div class="section" id="result-summary">  sub print_syntax_error_webidl_section ($$) {
685  <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>    my ($input, $result) = @_;
 </div>  
 ];  
   push @nav, ['#result-summary' => 'Result'];  
686    
687  }    require Whatpm::WebIDL;
688    
689    print STDOUT qq[    print STDOUT qq[
690  <ul class="navigation" id="nav-items">  <div id="$input->{id_prefix}parse-errors" class="section">
691  ];  <h2>Parse Errors</h2>
   for (@nav) {  
     print STDOUT qq[<li><a href="$_->[0]">$_->[1]</a></li>];  
   }  
   print STDOUT qq[  
 </ul>  
 </body>  
 </html>  
 ];  
692    
693    for (qw/decode parse parse_xml check/) {  <dl id="$input->{id_prefix}parse-errors-list">];
694      next unless defined $time{$_};    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
     open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";  
     print $file $char_length, "\t", $time{$_}, "\n";  
   }  
695    
696  exit;    my $onerror = sub {
697        my (%opt) = @_;
698        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
699        print STDOUT qq[<dt class="$cls">], get_error_label ($input, \%opt),
700            qq[</dt>];
701        $type =~ tr/ /-/;
702        $type =~ s/\|/%7C/g;
703        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
704        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
705        print STDOUT qq[$msg</dd>\n];
706    
707  sub print_http_header_section ($) {      add_error ('syntax', \%opt => $result);
708    my $input = shift;    };
   return unless defined $input->{header_status_code} or  
       defined $input->{header_status_text} or  
       @{$input->{header_field}};  
     
   push @nav, ['#source-header' => 'HTTP Header'];  
   print STDOUT qq[<div id="source-header" class="section">  
 <h2>HTTP Header</h2>  
709    
710  <p><strong>Note</strong>: Due to the limitation of the    require Encode;
711  network library in use, the content of this section might    my $s = $input->{is_char_string} ? $input->{s} : Encode::decode ($input->{charset} || 'utf-8', $input->{s}); ## TODO: charset
712  not be the real header.</p>    my $parser = Whatpm::WebIDL::Parser->new;
713      my $idl = $parser->parse_char_string ($input->{s}, $onerror);
714    
715  <table><tbody>    print STDOUT qq[</dl></div>];
 ];  
716    
717    if (defined $input->{header_status_code}) {    return $idl;
718      print STDOUT qq[<tr><th scope="row">Status code</th>];  } # print_syntax_error_webidl_section
     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>];  
   }  
719    
720    print STDOUT qq[</tbody></table></div>];  sub print_source_string_section ($$$) {
721  } # print_http_header_section    my $input = shift;
722      my $s;
723      unless ($input->{is_char_string}) {
724        open my $byte_stream, '<', $_[0];
725        require Message::Charset::Info;
726        my $charset = Message::Charset::Info->get_by_iana_name ($_[1]);
727        my ($char_stream, $e_status) = $charset->get_decode_handle
728            ($byte_stream, allow_error_reporting => 1, allow_fallback => 1);
729        return unless $char_stream;
730    
731        $char_stream->onerror (sub {
732          my (undef, $type, %opt) = @_;
733          if ($opt{octets}) {
734            ${$opt{octets}} = "\x{FFFD}";
735          }
736        });
737    
738  sub print_source_string_section ($$) {      my $t = '';
739    require Encode;      while (1) {
740    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name        my $c = $char_stream->getc;
741    return unless $enc;        last unless defined $c;
742          $t .= $c;
743        }
744        $s = \$t;
745        ## TODO: Output for each line, don't concat all of lines.
746      } else {
747        $s = $_[0];
748      }
749    
   my $s = \($enc->decode (${$_[0]}));  
750    my $i = 1;                                my $i = 1;                            
751    push @nav, ['#source-string' => 'Source'];    push @nav, ['#source-string' => 'Source'] unless $input->{nested};
752    print STDOUT qq[<div id="source-string" class="section">    print STDOUT qq[<div id="$input->{id_prefix}source-string" class="section">
753  <h2>Document Source</h2>  <h2>Document Source</h2>
754  <ol lang="">\n];  <ol lang="">\n];
755    if (length $$s) {    if (length $$s) {
756      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {      while ($$s =~ /\G([^\x0D\x0A]*?)(?>\x0D\x0A?|\x0A)/gc) {
757        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
758              "</li>\n";
759        $i++;        $i++;
760      }      }
761      if ($$s =~ /\G([^\x0A]+)/gc) {      if ($$s =~ /\G([^\x0D\x0A]+)/gc) {
762        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
763              "</li>\n";
764      }      }
765    } else {    } else {
766      print STDOUT q[<li id="line-1"></li>];      print STDOUT q[<li id="$input->{id_prefix}line-1"></li>];
767    }    }
768    print STDOUT "</ol></div>";    print STDOUT "</ol></div>
769    <script>
770      addSourceToParseErrorList ('$input->{id_prefix}', 'parse-errors-list');
771    </script>";
772  } # print_input_string_section  } # print_input_string_section
773    
774  sub print_document_tree ($) {  sub print_document_tree ($$) {
775    my $node = shift;    my ($input, $node) = @_;
776    
777    my $r = '<ol class="xoxo">';    my $r = '<ol class="xoxo">';
778    
779    my @node = ($node);    my @node = ($node);
# Line 446  sub print_document_tree ($) { Line 784  sub print_document_tree ($) {
784        next;        next;
785      }      }
786    
787      my $node_id = 'node-'.refaddr $child;      my $node_id = $input->{id_prefix} . 'node-'.refaddr $child;
788      my $nt = $child->node_type;      my $nt = $child->node_type;
789      if ($nt == $child->ELEMENT_NODE) {      if ($nt == $child->ELEMENT_NODE) {
790        my $child_nsuri = $child->namespace_uri;        my $child_nsuri = $child->namespace_uri;
# Line 457  sub print_document_tree ($) { Line 795  sub print_document_tree ($) {
795          $r .= '<ul class="attributes">';          $r .= '<ul class="attributes">';
796          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 $_] }
797                        @{$child->attributes}) {                        @{$child->attributes}) {
798            $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?
799            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children
800          }          }
801          $r .= '</ul>';          $r .= '</ul>';
# Line 478  sub print_document_tree ($) { Line 816  sub print_document_tree ($) {
816      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
817        $r .= qq'<li id="$node_id" class="tree-document">Document';        $r .= qq'<li id="$node_id" class="tree-document">Document';
818        $r .= qq[<ul class="attributes">];        $r .= qq[<ul class="attributes">];
819          my $cp = $child->manakai_charset;
820          if (defined $cp) {
821            $r .= qq[<li><code>charset</code> parameter = <code>];
822            $r .= htescape ($cp) . qq[</code></li>];
823          }
824          $r .= qq[<li><code>inputEncoding</code> = ];
825          my $ie = $child->input_encoding;
826          if (defined $ie) {
827            $r .= qq[<code>@{[htescape ($ie)]}</code>];
828            if ($child->manakai_has_bom) {
829              $r .= qq[ (with <code class=charname><abbr>BOM</abbr></code>)];
830            }
831          } else {
832            $r .= qq[(<code>null</code>)];
833          }
834        $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>];
835        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];
836        unless ($child->manakai_is_html) {        unless ($child->manakai_is_html) {
# Line 511  sub print_document_tree ($) { Line 864  sub print_document_tree ($) {
864    print STDOUT $r;    print STDOUT $r;
865  } # print_document_tree  } # print_document_tree
866    
867    sub print_structure_dump_dom_section ($$$) {
868      my ($input, $doc, $el) = @_;
869    
870      print STDOUT qq[
871    <div id="$input->{id_prefix}document-tree" class="section">
872    <h2>Document Tree</h2>
873    ];
874      push @nav, [qq[#$input->{id_prefix}document-tree] => 'Tree']
875          unless $input->{nested};
876    
877      print_document_tree ($input, $el || $doc);
878    
879      print STDOUT qq[</div>];
880    } # print_structure_dump_dom_section
881    
882    sub print_structure_dump_cssom_section ($$) {
883      my ($input, $cssom) = @_;
884    
885      print STDOUT qq[
886    <div id="$input->{id_prefix}document-tree" class="section">
887    <h2>Document Tree</h2>
888    ];
889      push @nav, [qq[#$input->{id_prefix}document-tree] => 'Tree']
890          unless $input->{nested};
891    
892      ## TODO:
893      print STDOUT "<pre>".htescape ($cssom->css_text)."</pre>";
894    
895      print STDOUT qq[</div>];
896    } # print_structure_dump_cssom_section
897    
898    sub print_structure_dump_manifest_section ($$) {
899      my ($input, $manifest) = @_;
900    
901      print STDOUT qq[
902    <div id="$input->{id_prefix}dump-manifest" class="section">
903    <h2>Cache Manifest</h2>
904    ];
905      push @nav, [qq[#$input->{id_prefix}dump-manifest] => 'Cache Manifest']
906          unless $input->{nested};
907    
908      print STDOUT qq[<dl><dt>Explicit entries</dt>];
909      my $i = 0;
910      for my $uri (@{$manifest->[0]}) {
911        my $euri = htescape ($uri);
912        print STDOUT qq[<dd id="$input->{id_prefix}index-@{[$i++]}"><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
913      }
914    
915      print STDOUT qq[<dt>Fallback entries</dt><dd>
916          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
917          <th scope=row>Fallback Entry</tr><tbody>];
918      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
919        my $euri = htescape ($uri);
920        my $euri2 = htescape ($manifest->[1]->{$uri});
921        print STDOUT qq[<tr><td id="$input->{id_prefix}index-@{[$i++]}"><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
922            <td id="$input->{id_prefix}index-@{[$i++]}"><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
923      }
924    
925      print STDOUT qq[</table><dt>Online whitelist</dt>];
926      for my $uri (@{$manifest->[2]}) {
927        my $euri = htescape ($uri);
928        print STDOUT qq[<dd id="$input->{id_prefix}index-@{[$i++]}"><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
929      }
930    
931      print STDOUT qq[</dl></div>];
932    } # print_structure_dump_manifest_section
933    
934    sub print_structure_dump_webidl_section ($$) {
935      my ($input, $idl) = @_;
936    
937      print STDOUT qq[
938    <div id="$input->{id_prefix}dump-webidl" class="section">
939    <h2>WebIDL</h2>
940    ];
941      push @nav, [qq[#$input->{id_prefix}dump-webidl] => 'WebIDL']
942          unless $input->{nested};
943    
944      print STDOUT "<pre>";
945      print STDOUT htescape ($idl->idl_text);
946      print STDOUT "</pre>";
947    
948      print STDOUT qq[</div>];
949    } # print_structure_dump_webidl_section
950    
951    sub print_structure_error_dom_section ($$$$$) {
952      my ($input, $doc, $el, $result, $onsubdoc) = @_;
953    
954      print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
955    <h2>Document Errors</h2>
956    
957    <dl id=document-errors-list>];
958      push @nav, [qq[#$input->{id_prefix}document-errors] => 'Document Error']
959          unless $input->{nested};
960    
961      require Whatpm::ContentChecker;
962      my $onerror = sub {
963        my %opt = @_;
964        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
965        $type =~ tr/ /-/;
966        $type =~ s/\|/%7C/g;
967        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
968        print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
969            qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
970        print STDOUT $msg, "</dd>\n";
971        add_error ('structure', \%opt => $result);
972      };
973    
974      my $elements;
975      my $time1 = time;
976      if ($el) {
977        $elements = Whatpm::ContentChecker->check_element
978            ($el, $onerror, $onsubdoc);
979      } else {
980        $elements = Whatpm::ContentChecker->check_document
981            ($doc, $onerror, $onsubdoc);
982      }
983      $time{check} = time - $time1;
984    
985      print STDOUT qq[</dl>
986    <script>
987      addSourceToParseErrorList ('$input->{id_prefix}', 'document-errors-list');
988    </script></div>];
989    
990      return $elements;
991    } # print_structure_error_dom_section
992    
993    sub print_structure_error_manifest_section ($$$) {
994      my ($input, $manifest, $result) = @_;
995    
996      print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
997    <h2>Document Errors</h2>
998    
999    <dl>];
1000      push @nav, [qq[#$input->{id_prefix}document-errors] => 'Document Error']
1001          unless $input->{nested};
1002    
1003      require Whatpm::CacheManifest;
1004      Whatpm::CacheManifest->check_manifest ($manifest, sub {
1005        my %opt = @_;
1006        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
1007        $type =~ tr/ /-/;
1008        $type =~ s/\|/%7C/g;
1009        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
1010        print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
1011            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
1012        add_error ('structure', \%opt => $result);
1013      });
1014    
1015      print STDOUT qq[</div>];
1016    } # print_structure_error_manifest_section
1017    
1018    sub print_structure_error_webidl_section ($$$) {
1019      my ($input, $idl, $result) = @_;
1020    
1021      print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
1022    <h2>Document Errors</h2>
1023    
1024    <dl>];
1025      push @nav, [qq[#$input->{id_prefix}document-errors] => 'Document Error']
1026          unless $input->{nested};
1027    
1028    ## TODO:
1029    
1030      print STDOUT qq[</div>];
1031    } # print_structure_error_webidl_section
1032    
1033    sub print_table_section ($$) {
1034      my ($input, $tables) = @_;
1035      
1036      push @nav, [qq[#$input->{id_prefix}tables] => 'Tables']
1037          unless $input->{nested};
1038      print STDOUT qq[
1039    <div id="$input->{id_prefix}tables" class="section">
1040    <h2>Tables</h2>
1041    
1042    <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
1043    <script src="../table-script.js" type="text/javascript"></script>
1044    <noscript>
1045    <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>
1046    </noscript>
1047    ];
1048      
1049      require JSON;
1050      
1051      my $i = 0;
1052      for my $table (@$tables) {
1053        $i++;
1054        print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .
1055            get_node_link ($input, $table->{element}) . q[</h3>];
1056    
1057        delete $table->{element};
1058    
1059        for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption},
1060             @{$table->{row}}) {
1061          next unless $_;
1062          delete $_->{element};
1063        }
1064        
1065        for (@{$table->{row_group}}) {
1066          next unless $_;
1067          next unless $_->{element};
1068          $_->{type} = $_->{element}->manakai_local_name;
1069          delete $_->{element};
1070        }
1071        
1072        for (@{$table->{cell}}) {
1073          next unless $_;
1074          for (@{$_}) {
1075            next unless $_;
1076            for (@$_) {
1077              $_->{id} = refaddr $_->{element} if defined $_->{element};
1078              delete $_->{element};
1079              $_->{is_header} = $_->{is_header} ? 1 : 0;
1080            }
1081          }
1082        }
1083            
1084        print STDOUT '</div><script type="text/javascript">tableToCanvas (';
1085        print STDOUT JSON::objToJson ($table);
1086        print STDOUT qq[, document.getElementById ('$input->{id_prefix}table-$i')];
1087        print STDOUT qq[, '$input->{id_prefix}');</script>];
1088      }
1089      
1090      print STDOUT qq[</div>];
1091    } # print_table_section
1092    
1093    sub print_listing_section ($$$) {
1094      my ($opt, $input, $ids) = @_;
1095      
1096      push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]
1097          unless $input->{nested};
1098      print STDOUT qq[
1099    <div id="$input->{id_prefix}$opt->{id}" class="section">
1100    <h2>$opt->{heading}</h2>
1101    
1102    <dl>
1103    ];
1104      for my $id (sort {$a cmp $b} keys %$ids) {
1105        print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
1106        for (@{$ids->{$id}}) {
1107          print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
1108        }
1109      }
1110      print STDOUT qq[</dl></div>];
1111    } # print_listing_section
1112    
1113    sub print_uri_section ($$$) {
1114      my ($input, $uris) = @_;
1115    
1116      ## NOTE: URIs contained in the DOM (i.e. in HTML or XML documents),
1117      ## except for those in RDF triples.
1118      ## TODO: URIs in CSS
1119      
1120      push @nav, ['#' . $input->{id_prefix} . 'uris' => 'URIs']
1121          unless $input->{nested};
1122      print STDOUT qq[
1123    <div id="$input->{id_prefix}uris" class="section">
1124    <h2>URIs</h2>
1125    
1126    <dl>];
1127      for my $uri (sort {$a cmp $b} keys %$uris) {
1128        my $euri = htescape ($uri);
1129        print STDOUT qq[<dt><code class=uri>&lt;<a href="$euri">$euri</a>></code>];
1130        my $eccuri = htescape (get_cc_uri ($uri));
1131        print STDOUT qq[<dd><a href="$eccuri">Check conformance of this document</a>];
1132        print STDOUT qq[<dd>Found at: <ul>];
1133        for my $entry (@{$uris->{$uri}}) {
1134          print STDOUT qq[<li>], get_node_link ($input, $entry->{node});
1135          if (keys %{$entry->{type} or {}}) {
1136            print STDOUT ' (';
1137            print STDOUT join ', ', map {
1138              {
1139                hyperlink => 'Hyperlink',
1140                resource => 'Link to an external resource',
1141                namespace => 'Namespace URI',
1142                cite => 'Citation or link to a long description',
1143                embedded => 'Link to an embedded content',
1144                base => 'Base URI',
1145                action => 'Submission URI',
1146              }->{$_}
1147                or
1148              htescape ($_)
1149            } keys %{$entry->{type}};
1150            print STDOUT ')';
1151          }
1152        }
1153        print STDOUT qq[</ul>];
1154      }
1155      print STDOUT qq[</dl></div>];
1156    } # print_uri_section
1157    
1158    sub print_rdf_section ($$$) {
1159      my ($input, $rdfs) = @_;
1160      
1161      push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']
1162          unless $input->{nested};
1163      print STDOUT qq[
1164    <div id="$input->{id_prefix}rdf" class="section">
1165    <h2>RDF Triples</h2>
1166    
1167    <dl>];
1168      my $i = 0;
1169      for my $rdf (@$rdfs) {
1170        print STDOUT qq[<dt id="$input->{id_prefix}rdf-@{[$i++]}">];
1171        print STDOUT get_node_link ($input, $rdf->[0]);
1172        print STDOUT qq[<dd><dl>];
1173        for my $triple (@{$rdf->[1]}) {
1174          print STDOUT '<dt>' . get_node_link ($input, $triple->[0]) . '<dd>';
1175          print STDOUT get_rdf_resource_html ($triple->[1]);
1176          print STDOUT ' ';
1177          print STDOUT get_rdf_resource_html ($triple->[2]);
1178          print STDOUT ' ';
1179          print STDOUT get_rdf_resource_html ($triple->[3]);
1180        }
1181        print STDOUT qq[</dl>];
1182      }
1183      print STDOUT qq[</dl></div>];
1184    } # print_rdf_section
1185    
1186    sub get_rdf_resource_html ($) {
1187      my $resource = shift;
1188      if (defined $resource->{uri}) {
1189        my $euri = htescape ($resource->{uri});
1190        return '<code class=uri>&lt;<a href="' . $euri . '">' . $euri .
1191            '</a>></code>';
1192      } elsif (defined $resource->{bnodeid}) {
1193        return htescape ('_:' . $resource->{bnodeid});
1194      } elsif ($resource->{nodes}) {
1195        return '(rdf:XMLLiteral)';
1196      } elsif (defined $resource->{value}) {
1197        my $elang = htescape (defined $resource->{language}
1198                                  ? $resource->{language} : '');
1199        my $r = qq[<q lang="$elang">] . htescape ($resource->{value}) . '</q>';
1200        if (defined $resource->{datatype}) {
1201          my $euri = htescape ($resource->{datatype});
1202          $r .= '^^<code class=uri>&lt;<a href="' . $euri . '">' . $euri .
1203              '</a>></code>';
1204        } elsif (length $resource->{language}) {
1205          $r .= '@' . htescape ($resource->{language});
1206        }
1207        return $r;
1208      } else {
1209        return '??';
1210      }
1211    } # get_rdf_resource_html
1212    
1213    sub print_result_section ($) {
1214      my $result = shift;
1215    
1216      print STDOUT qq[
1217    <div id="result-summary" class="section">
1218    <h2>Result</h2>];
1219    
1220      if ($result->{unsupported} and $result->{conforming_max}) {  
1221        print STDOUT qq[<p class=uncertain id=result-para>The conformance
1222            checker cannot decide whether the document is conforming or
1223            not, since the document contains one or more unsupported
1224            features.  The document might or might not be conforming.</p>];
1225      } elsif ($result->{conforming_min}) {
1226        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
1227            found in this document.</p>];
1228      } elsif ($result->{conforming_max}) {
1229        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
1230            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
1231            it might be conforming.</p>];
1232      } else {
1233        print STDOUT qq[<p class=FAIL id=result-para>This document is
1234            <strong><em>non</em>-conforming</strong>.</p>];
1235      }
1236    
1237      print STDOUT qq[<table>
1238    <colgroup><col><colgroup><col><col><col><colgroup><col>
1239    <thead>
1240    <tr><th scope=col></th>
1241    <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
1242    Errors</a></th>
1243    <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
1244    Errors</a></th>
1245    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
1246    <th scope=col>Score</th></tr></thead><tbody>];
1247    
1248      my $must_error = 0;
1249      my $should_error = 0;
1250      my $warning = 0;
1251      my $score_min = 0;
1252      my $score_max = 0;
1253      my $score_base = 20;
1254      my $score_unit = $score_base / 100;
1255      for (
1256        [Transfer => 'transfer', ''],
1257        [Character => 'char', ''],
1258        [Syntax => 'syntax', '#parse-errors'],
1259        [Structure => 'structure', '#document-errors'],
1260      ) {
1261        $must_error += ($result->{$_->[1]}->{must} += 0);
1262        $should_error += ($result->{$_->[1]}->{should} += 0);
1263        $warning += ($result->{$_->[1]}->{warning} += 0);
1264        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
1265        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
1266    
1267        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
1268        my $label = $_->[0];
1269        if ($result->{$_->[1]}->{must} or
1270            $result->{$_->[1]}->{should} or
1271            $result->{$_->[1]}->{warning} or
1272            $result->{$_->[1]}->{unsupported}) {
1273          $label = qq[<a href="$_->[2]">$label</a>];
1274        }
1275    
1276        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>];
1277        if ($uncertain) {
1278          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}];
1279        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
1280          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}];
1281        } else {
1282          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}];
1283        }
1284        print qq[ / 20];
1285      }
1286    
1287      $score_max += $score_base;
1288    
1289      print STDOUT qq[
1290    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base / 20
1291    </tbody>
1292    <tfoot><tr class=uncertain><th scope=row>Total</th>
1293    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
1294    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
1295    <td>$warning?</td>
1296    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong> / 100
1297    </table>
1298    
1299    <p><strong>Important</strong>: This conformance checking service
1300    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
1301    </div>];
1302      push @nav, ['#result-summary' => 'Result'];
1303    } # print_result_section
1304    
1305    sub print_result_unknown_type_section ($$) {
1306      my ($input, $result) = @_;
1307    
1308      my $euri = htescape ($input->{uri});
1309      print STDOUT qq[
1310    <div id="$input->{id_prefix}parse-errors" class="section">
1311    <h2>Errors</h2>
1312    
1313    <dl>
1314    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
1315        <dd class=unsupported><strong><a href="../error-description#level-u">Not
1316            supported</a></strong>:
1317        Media type
1318        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
1319        is not supported.</dd>
1320    </dl>
1321    </div>
1322    ];
1323      push @nav, [qq[#$input->{id_prefix}parse-errors] => 'Errors']
1324          unless $input->{nested};
1325      add_error (char => {level => 'u'} => $result);
1326      add_error (syntax => {level => 'u'} => $result);
1327      add_error (structure => {level => 'u'} => $result);
1328    } # print_result_unknown_type_section
1329    
1330    sub print_result_input_error_section ($) {
1331      my $input = shift;
1332      print STDOUT qq[<div class="section" id="result-summary">
1333    <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>
1334    </div>];
1335      push @nav, ['#result-summary' => 'Result'];
1336    } # print_result_input_error_section
1337    
1338    sub get_error_label ($$) {
1339      my ($input, $err) = @_;
1340    
1341      my $r = '';
1342    
1343      my $line;
1344      my $column;
1345        
1346      if (defined $err->{node}) {
1347        $line = $err->{node}->get_user_data ('manakai_source_line');
1348        if (defined $line) {
1349          $column = $err->{node}->get_user_data ('manakai_source_column');
1350        } else {
1351          if ($err->{node}->node_type == $err->{node}->ATTRIBUTE_NODE) {
1352            my $owner = $err->{node}->owner_element;
1353            $line = $owner->get_user_data ('manakai_source_line');
1354            $column = $owner->get_user_data ('manakai_source_column');
1355          } else {
1356            my $parent = $err->{node}->parent_node;
1357            if ($parent) {
1358              $line = $parent->get_user_data ('manakai_source_line');
1359              $column = $parent->get_user_data ('manakai_source_column');
1360            }
1361          }
1362        }
1363      }
1364      unless (defined $line) {
1365        if (defined $err->{token} and defined $err->{token}->{line}) {
1366          $line = $err->{token}->{line};
1367          $column = $err->{token}->{column};
1368        } elsif (defined $err->{line}) {
1369          $line = $err->{line};
1370          $column = $err->{column};
1371        }
1372      }
1373    
1374      if (defined $line) {
1375        if (defined $column and $column > 0) {
1376          $r = qq[<a href="#$input->{id_prefix}line-$line">Line $line</a> column $column];
1377        } else {
1378          $line = $line - 1 || 1;
1379          $r = qq[<a href="#$input->{id_prefix}line-$line">Line $line</a>];
1380        }
1381      }
1382    
1383      if (defined $err->{node}) {
1384        $r .= ' ' if length $r;
1385        $r .= get_node_link ($input, $err->{node});
1386      }
1387    
1388      if (defined $err->{index}) {
1389        if (length $r) {
1390          $r .= ', Index ' . (0+$err->{index});
1391        } else {
1392          $r .= "<a href='#$input->{id_prefix}index-@{[0+$err->{index}]}'>Index "
1393              . (0+$err->{index}) . '</a>';
1394        }
1395      }
1396    
1397      if (defined $err->{value}) {
1398        $r .= ' ' if length $r;
1399        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
1400      }
1401    
1402      return $r;
1403    } # get_error_label
1404    
1405    sub get_error_level_label ($) {
1406      my $err = shift;
1407    
1408      my $r = '';
1409    
1410      if (not defined $err->{level} or $err->{level} eq 'm') {
1411        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
1412            error</a></strong>: ];
1413      } elsif ($err->{level} eq 's') {
1414        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
1415            error</a></strong>: ];
1416      } elsif ($err->{level} eq 'w') {
1417        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
1418            ];
1419      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
1420        $r = qq[<strong><a href="../error-description#level-u">Not
1421            supported</a></strong>: ];
1422      } elsif ($err->{level} eq 'i') {
1423        $r = qq[<strong><a href="../error-description#level-i">Information</a></strong>: ];
1424      } else {
1425        my $elevel = htescape ($err->{level});
1426        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
1427            ];
1428      }
1429    
1430      return $r;
1431    } # get_error_level_label
1432    
1433  sub get_node_path ($) {  sub get_node_path ($) {
1434    my $node = shift;    my $node = shift;
1435    my @r;    my @r;
1436    while (defined $node) {    while (defined $node) {
1437      my $rs;      my $rs;
1438      if ($node->node_type == 1) {      if ($node->node_type == 1) {
1439        $rs = $node->manakai_local_name;        $rs = $node->node_name;
1440        $node = $node->parent_node;        $node = $node->parent_node;
1441      } elsif ($node->node_type == 2) {      } elsif ($node->node_type == 2) {
1442        $rs = '@' . $node->manakai_local_name;        $rs = '@' . $node->node_name;
1443        $node = $node->owner_element;        $node = $node->owner_element;
1444      } elsif ($node->node_type == 3) {      } elsif ($node->node_type == 3) {
1445        $rs = '"' . $node->data . '"';        $rs = '"' . $node->data . '"';
# Line 538  sub get_node_path ($) { Line 1457  sub get_node_path ($) {
1457    return join '/', @r;    return join '/', @r;
1458  } # get_node_path  } # get_node_path
1459    
1460  sub get_node_link ($) {  sub get_node_link ($$) {
1461    return qq[<a href="#node-@{[refaddr $_[0]]}">] .    return qq[<a href="#$_[0]->{id_prefix}node-@{[refaddr $_[1]]}">] .
1462        htescape (get_node_path ($_[0])) . qq[</a>];        htescape (get_node_path ($_[1])) . qq[</a>];
1463  } # get_node_link  } # get_node_link
1464    
1465  {  {
# Line 548  sub get_node_link ($) { Line 1467  sub get_node_link ($) {
1467    
1468  sub load_text_catalog ($) {  sub load_text_catalog ($) {
1469    my $lang = shift; # MUST be a canonical lang name    my $lang = shift; # MUST be a canonical lang name
1470    open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";    open my $file, '<:utf8', "cc-msg.$lang.txt"
1471          or die "$0: cc-msg.$lang.txt: $!";
1472    while (<$file>) {    while (<$file>) {
1473      if (s/^([^;]+);([^;]*);//) {      if (s/^([^;]+);([^;]*);//) {
1474        my ($type, $cls, $msg) = ($1, $2, $_);        my ($type, $cls, $msg) = ($1, $2, $_);
# Line 561  sub load_text_catalog ($) { Line 1481  sub load_text_catalog ($) {
1481  sub get_text ($) {  sub get_text ($) {
1482    my ($type, $level, $node) = @_;    my ($type, $level, $node) = @_;
1483    $type = $level . ':' . $type if defined $level;    $type = $level . ':' . $type if defined $level;
1484      $level = 'm' unless defined $level;
1485    my @arg;    my @arg;
1486    {    {
1487      if (defined $Msg->{$type}) {      if (defined $Msg->{$type}) {
# Line 585  sub get_text ($) { Line 1506  sub get_text ($) {
1506            ? htescape ($node->owner_element->manakai_local_name)            ? htescape ($node->owner_element->manakai_local_name)
1507            : ''            : ''
1508        }ge;        }ge;
1509        return ($type, $Msg->{$type}->[0], $msg);        return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
1510      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
1511        unshift @arg, $1;        unshift @arg, $1;
1512        redo;        redo;
1513      }      }
1514    }    }
1515    return ($type, '', htescape ($_[0]));    return ($type, 'level-'.$level, htescape ($_[0]));
1516  } # get_text  } # get_text
1517    
1518  }  }
1519    
1520    sub encode_uri_component ($) {
1521      require Encode;
1522      my $s = Encode::encode ('utf8', shift);
1523      $s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge;
1524      return $s;
1525    } # encode_uri_component
1526    
1527    sub get_cc_uri ($) {
1528      return './?uri=' . encode_uri_component ($_[0]);
1529    } # get_cc_uri
1530    
1531  sub get_input_document ($$) {  sub get_input_document ($$) {
1532    my ($http, $dom) = @_;    my ($http, $dom) = @_;
1533    
# Line 647  EOH Line 1579  EOH
1579      $ua->protocols_allowed ([qw/http/]);      $ua->protocols_allowed ([qw/http/]);
1580      $ua->max_size (1000_000);      $ua->max_size (1000_000);
1581      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
1582        $req->header ('Accept-Encoding' => 'identity, *; q=0');
1583      my $res = $ua->request ($req);      my $res = $ua->request ($req);
1584      ## TODO: 401 sets |is_success| true.      ## TODO: 401 sets |is_success| true.
1585      if ($res->is_success or $http->get_parameter ('error-page')) {      if ($res->is_success or $http->get_parameter ('error-page')) {
# Line 656  EOH Line 1589  EOH
1589    
1590        ## TODO: More strict parsing...        ## TODO: More strict parsing...
1591        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
1592        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) {  
1593          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1594          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1595            $r->{official_charset} = $r->{charset};
1596        }        }
1597    
1598        my $input_charset = $http->get_parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
# Line 669  EOH Line 1600  EOH
1600          $r->{charset_overridden}          $r->{charset_overridden}
1601              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1602          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
1603        }        }
1604    
1605          ## TODO: Support for HTTP Content-Encoding
1606    
1607        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
1608    
1609          require Whatpm::ContentType;
1610          ($r->{official_type}, $r->{media_type})
1611              = Whatpm::ContentType->get_sniffed_type
1612                  (get_file_head => sub {
1613                     return substr $r->{s}, 0, shift;
1614                   },
1615                   http_content_type_byte => $ct,
1616                   has_http_content_encoding =>
1617                       defined $res->header ('Content-Encoding'),
1618                   supported_image_types => {});
1619      } else {      } else {
1620        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1621        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 692  EOH Line 1636  EOH
1636      $r->{charset} = ''.$http->get_parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
1637      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1638      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1639        $r->{official_charset} = $r->{charset};
1640      $r->{header_field} = [];      $r->{header_field} = [];
1641    
1642        require Whatpm::ContentType;
1643        ($r->{official_type}, $r->{media_type})
1644            = Whatpm::ContentType->get_sniffed_type
1645                (get_file_head => sub {
1646                   return substr $r->{s}, 0, shift;
1647                 },
1648                 http_content_type_byte => undef,
1649                 has_http_content_encoding => 0,
1650                 supported_image_types => {});
1651    }    }
1652    
1653    my $input_format = $http->get_parameter ('i');    my $input_format = $http->get_parameter ('i');
# Line 709  EOH Line 1664  EOH
1664    if ($r->{media_type} eq 'text/xml') {    if ($r->{media_type} eq 'text/xml') {
1665      unless (defined $r->{charset}) {      unless (defined $r->{charset}) {
1666        $r->{charset} = 'us-ascii';        $r->{charset} = 'us-ascii';
1667          $r->{official_charset} = $r->{charset};
1668      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
1669        $r->{charset_overridden} = 0;        $r->{charset_overridden} = 0;
1670      }      }
# Line 720  EOH Line 1676  EOH
1676      return $r;      return $r;
1677    }    }
1678    
1679      $r->{inner_html_element} = $http->get_parameter ('e');
1680    
1681    return $r;    return $r;
1682  } # get_input_document  } # get_input_document
1683    
# Line 752  Wakaba <w@suika.fam.cx>. Line 1710  Wakaba <w@suika.fam.cx>.
1710    
1711  =head1 LICENSE  =head1 LICENSE
1712    
1713  Copyright 2007 Wakaba <w@suika.fam.cx>  Copyright 2007-2008 Wakaba <w@suika.fam.cx>
1714    
1715  This library is free software; you can redistribute it  This library is free software; you can redistribute it
1716  and/or modify it under the same terms as Perl itself.  and/or modify it under the same terms as Perl itself.
Legend:
Removed from v.1.17  
changed lines
  Added in v.1.52
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24