/[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.19 by wakaba, Mon Sep 10 11:51:09 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;  
57    
58    print qq[    print qq[
59  <div id="document-info" class="section">  <div id="document-info" class="section">
# Line 61  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 73  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 81  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    my $result = {};  <script src="../cc-script.js"></script>
91    print_http_header_section ($input, $result);  ];
   
   my $doc;  
   my $el;  
   
   if ($input->{media_type} eq 'text/html') {  
     ($doc, $el) = print_syntax_error_html_section ($input, $result);  
     print_source_string_section (\($input->{s}), $input->{charset});  
   } elsif ({  
             '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}}) {  
     ($doc, $el) = print_syntax_error_xml_section ($input, $result);  
     print_source_string_section (\($input->{s}), $doc->input_encoding);  
   } else {  
     ## TODO: Change HTTP status code??  
     print_result_unknown_type_section ($input);  
   }  
   
   if (defined $doc or defined $el) {  
     print_structure_dump_section ($doc, $el);  
     my $elements = print_structure_error_section ($doc, $el, $result);  
     print_table_section ($elements->{table}) if @{$elements->{table}};  
     print_id_section ($elements->{id}) if keys %{$elements->{id}};  
     print_term_section ($elements->{term}) if keys %{$elements->{term}};  
     print_class_section ($elements->{class}) if keys %{$elements->{class}};  
   }  
92    
93      $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);    print_result_section ($result);
98  } else {  } else {
99    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
# Line 134  if (defined $input->{s}) { Line 112  if (defined $input->{s}) {
112  </html>  </html>
113  ];  ];
114    
115    for (qw/decode parse parse_xml check/) {    for (qw/decode parse parse_html parse_xml parse_manifest
116              check check_manifest/) {
117      next unless defined $time{$_};      next unless defined $time{$_};
118      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
119      print $file $char_length, "\t", $time{$_}, "\n";      print $file $char_length, "\t", $time{$_}, "\n";
120    }    }
121    
122  exit;  exit;
123    }
124    
125  sub add_error ($$$) {  sub add_error ($$$) {
126    my ($layer, $err, $result) = @_;    my ($layer, $err, $result) = @_;
# Line 151  sub add_error ($$$) { Line 131  sub add_error ($$$) {
131        $result->{conforming_min} = 0;        $result->{conforming_min} = 0;
132      } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {      } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
133        $result->{$layer}->{warning}++;        $result->{$layer}->{warning}++;
134      } elsif ($err->{level} eq 'unsupported') {      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
135        $result->{$layer}->{unsupported}++;        $result->{$layer}->{unsupported}++;
136        $result->{unsupported} = 1;        $result->{unsupported} = 1;
137        } elsif ($err->{level} eq 'i') {
138          #
139      } else {      } else {
140        $result->{$layer}->{must}++;        $result->{$layer}->{must}++;
141        $result->{$layer}->{score_max} -= 2;        $result->{$layer}->{score_max} -= 2;
# Line 170  sub add_error ($$$) { Line 152  sub add_error ($$$) {
152    }    }
153  } # add_error  } # add_error
154    
155    sub check_and_print ($$) {
156      my ($input, $result) = @_;
157    
158      print_http_header_section ($input, $result);
159    
160      my $doc;
161      my $el;
162      my $cssom;
163      my $manifest;
164      my $idl;
165      my @subdoc;
166    
167      if ($input->{media_type} eq 'text/html') {
168        ($doc, $el) = print_syntax_error_html_section ($input, $result);
169        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      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        print STDOUT qq[</div>];
264      }
265    } # check_and_print
266    
267  sub print_http_header_section ($$) {  sub print_http_header_section ($$) {
268    my ($input, $result) = @_;    my ($input, $result) = @_;
269    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
270        defined $input->{header_status_text} or        defined $input->{header_status_text} or
271        @{$input->{header_field}};        @{$input->{header_field} or []};
272        
273    push @nav, ['#source-header' => 'HTTP Header'];    push @nav, ['#source-header' => 'HTTP Header'] unless $input->{nested};
274    print STDOUT qq[<div id="source-header" class="section">    print STDOUT qq[<div id="$input->{id_prefix}source-header" class="section">
275  <h2>HTTP Header</h2>  <h2>HTTP Header</h2>
276    
277  <p><strong>Note</strong>: Due to the limitation of the  <p><strong>Note</strong>: Due to the limitation of the
# Line 209  sub print_syntax_error_html_section ($$) Line 303  sub print_syntax_error_html_section ($$)
303        
304    require Encode;    require Encode;
305    require Whatpm::HTML;    require Whatpm::HTML;
   
   $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.  
306        
   my $time1 = time;  
   my $t = Encode::decode ($input->{charset}, $input->{s});  
   $time{decode} = time - $time1;  
   
307    print STDOUT qq[    print STDOUT qq[
308  <div id="parse-errors" class="section">  <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);      add_error ('syntax', \%opt => $result);
326    };    };
327    
328    my $doc = $dom->create_document;    my $doc = $dom->create_document;
329    my $el;    my $el;
330    $time1 = time;    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    $time{parse} = time - $time1;    $doc->manakai_charset ($input->{official_charset})
356          if defined $input->{official_charset};
357      
358    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
359    
360    return ($doc, $el);    return ($doc, $el);
# Line 263  sub print_syntax_error_xml_section ($$) Line 366  sub print_syntax_error_xml_section ($$)
366    require Message::DOM::XMLParserTemp;    require Message::DOM::XMLParserTemp;
367        
368    print STDOUT qq[    print STDOUT qq[
369  <div id="parse-errors" class="section">  <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";
381    
# Line 286  sub print_syntax_error_xml_section ($$) Line 389  sub print_syntax_error_xml_section ($$)
389      return 1;      return 1;
390    };    };
391    
392      my $t = \($input->{s});
393      if ($input->{is_char_string}) {
394        require Encode;
395        $t = \(Encode::encode ('utf8', $$t));
396        $input->{charset} = 'utf-8';
397      }
398    
399    my $time1 = time;    my $time1 = time;
400    open my $fh, '<', \($input->{s});    open my $fh, '<', $t;
401    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
402        ($fh => $dom, $onerror, charset => $input->{charset});        ($fh => $dom, $onerror, charset => $input->{charset});
403    $time{parse_xml} = time - $time1;    $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>];    print STDOUT qq[</dl></div>];
408    
409    return ($doc, undef);    return ($doc, undef);
410  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
411    
412  sub print_source_string_section ($$) {  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      return $CSSParser = $p;
581    } # get_css_parser
582    
583    sub print_syntax_error_css_section ($$) {
584      my ($input, $result) = @_;
585    
586      print STDOUT qq[
587    <div id="$input->{id_prefix}parse-errors" class="section">
588    <h2>Parse Errors</h2>
589    
590    <dl id="$input->{id_prefix}parse-errors-list">];
591      push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
592    
593      my $p = get_css_parser ();
594      $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        add_error ('syntax', \%opt => $result);
615      };
616      $p->{href} = $input->{uri};
617      $p->{base_uri} = $input->{base_uri};
618    
619    #  if ($parse_mode eq 'q') {
620    #    $p->{unitless_px} = 1;
621    #    $p->{hashless_color} = 1;
622    #  }
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 {
634          ## TODO: charset detection
635          $s = \(Encode::decode ($charset = 'utf-8', $$s));
636        }
637      }
638      
639      my $cssom = $p->parse_char_string ($$s);
640      $cssom->manakai_input_encoding ($charset) if defined $charset;
641    
642      print STDOUT qq[</dl></div>];
643    
644      return $cssom;
645    } # print_syntax_error_css_section
646    
647    sub print_syntax_error_manifest_section ($$) {
648      my ($input, $result) = @_;
649    
650      require Whatpm::CacheManifest;
651    
652      print STDOUT qq[
653    <div id="$input->{id_prefix}parse-errors" class="section">
654    <h2>Parse Errors</h2>
655    
656    <dl id="$input->{id_prefix}parse-errors-list">];
657      push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
658    
659      my $onerror = sub {
660        my (%opt) = @_;
661        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
662        print STDOUT qq[<dt class="$cls">], get_error_label ($input, \%opt),
663            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        add_error ('syntax', \%opt => $result);
671      };
672    
673      my $m = $input->{is_char_string} ? 'parse_char_string' : 'parse_byte_string';
674      my $time1 = time;
675      my $manifest = Whatpm::CacheManifest->$m
676          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
677      $time{parse_manifest} = time - $time1;
678    
679      print STDOUT qq[</dl></div>];
680    
681      return $manifest;
682    } # print_syntax_error_manifest_section
683    
684    sub print_syntax_error_webidl_section ($$) {
685      my ($input, $result) = @_;
686    
687      require Whatpm::WebIDL;
688    
689      print STDOUT qq[
690    <div id="$input->{id_prefix}parse-errors" class="section">
691    <h2>Parse Errors</h2>
692    
693    <dl id="$input->{id_prefix}parse-errors-list">];
694      push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
695    
696      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        add_error ('syntax', \%opt => $result);
708      };
709    
710    require Encode;    require Encode;
711    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name    my $s = $input->{is_char_string} ? $input->{s} : Encode::decode ($input->{charset} || 'utf-8', $input->{s}); ## TODO: charset
712    return unless $enc;    my $parser = Whatpm::WebIDL::Parser->new;
713      my $idl = $parser->parse_char_string ($input->{s}, $onerror);
714    
715      print STDOUT qq[</dl></div>];
716    
717      return $idl;
718    } # print_syntax_error_webidl_section
719    
720    sub print_source_string_section ($$$) {
721      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        my $t = '';
739        while (1) {
740          my $c = $char_stream->getc;
741          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 334  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 345  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 366  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 399  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_section ($$) {  sub print_structure_dump_dom_section ($$$) {
868    my ($doc, $el) = @_;    my ($input, $doc, $el) = @_;
869    
870    print STDOUT qq[    print STDOUT qq[
871  <div id="document-tree" class="section">  <div id="$input->{id_prefix}document-tree" class="section">
872  <h2>Document Tree</h2>  <h2>Document Tree</h2>
873  ];  ];
874    push @nav, ['#document-tree' => 'Tree'];    push @nav, [qq[#$input->{id_prefix}document-tree] => 'Tree']
875          unless $input->{nested};
876    
877    print_document_tree ($el || $doc);    print_document_tree ($input, $el || $doc);
878    
879    print STDOUT qq[</div>];    print STDOUT qq[</div>];
880  } # print_structure_dump_section  } # 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  sub print_structure_error_section ($$$) {    ## TODO:
893    my ($doc, $el, $result) = @_;    print STDOUT "<pre>".htescape ($cssom->css_text)."</pre>";
894    
895    print STDOUT qq[<div id="document-errors" class="section">    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>  <h2>Document Errors</h2>
956    
957  <dl>];  <dl id=document-errors-list>];
958    push @nav, ['#document-errors' => 'Document Error'];    push @nav, [qq[#$input->{id_prefix}document-errors] => 'Document Error']
959          unless $input->{nested};
960    
961    require Whatpm::ContentChecker;    require Whatpm::ContentChecker;
962    my $onerror = sub {    my $onerror = sub {
# Line 429  sub print_structure_error_section ($$$) Line 965  sub print_structure_error_section ($$$)
965      $type =~ tr/ /-/;      $type =~ tr/ /-/;
966      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
967      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
968      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
969          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
970        print STDOUT $msg, "</dd>\n";
971      add_error ('structure', \%opt => $result);      add_error ('structure', \%opt => $result);
972    };    };
973    
974    my $elements;    my $elements;
975    my $time1 = time;    my $time1 = time;
976    if ($el) {    if ($el) {
977      $elements = Whatpm::ContentChecker->check_element ($el, $onerror);      $elements = Whatpm::ContentChecker->check_element
978            ($el, $onerror, $onsubdoc);
979    } else {    } else {
980      $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);      $elements = Whatpm::ContentChecker->check_document
981            ($doc, $onerror, $onsubdoc);
982    }    }
983    $time{check} = time - $time1;    $time{check} = time - $time1;
984    
985    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl>
986    <script>
987      addSourceToParseErrorList ('$input->{id_prefix}', 'document-errors-list');
988    </script></div>];
989    
990    return $elements;    return $elements;
991  } # print_structure_error_section  } # 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  sub print_table_section ($) {  ## TODO:
1029    my $tables = shift;  
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, ['#tables' => 'Tables'];    push @nav, [qq[#$input->{id_prefix}tables] => 'Tables']
1037          unless $input->{nested};
1038    print STDOUT qq[    print STDOUT qq[
1039  <div id="tables" class="section">  <div id="$input->{id_prefix}tables" class="section">
1040  <h2>Tables</h2>  <h2>Tables</h2>
1041    
1042  <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->  <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
# Line 466  sub print_table_section ($) { Line 1049  sub print_table_section ($) {
1049    require JSON;    require JSON;
1050        
1051    my $i = 0;    my $i = 0;
1052    for my $table_el (@$tables) {    for my $table (@$tables) {
1053      $i++;      $i++;
1054      print STDOUT qq[<div class="section" id="table-$i"><h3>] .      print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .
1055          get_node_link ($table_el) . q[</h3>];          get_node_link ($input, $table->{element}) . q[</h3>];
1056    
1057      ## TODO: Make |ContentChecker| return |form_table| result      delete $table->{element};
1058      ## so that this script don't have to run the algorithm twice.  
1059      my $table = Whatpm::HTMLTable->form_table ($table_el);      for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption},
1060                 @{$table->{row}}) {
     for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption}) {  
1061        next unless $_;        next unless $_;
1062        delete $_->{element};        delete $_->{element};
1063      }      }
# Line 501  sub print_table_section ($) { Line 1083  sub print_table_section ($) {
1083                    
1084      print STDOUT '</div><script type="text/javascript">tableToCanvas (';      print STDOUT '</div><script type="text/javascript">tableToCanvas (';
1085      print STDOUT JSON::objToJson ($table);      print STDOUT JSON::objToJson ($table);
1086      print STDOUT qq[, document.getElementById ('table-$i'));</script>];      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>];    print STDOUT qq[</div>];
1091  } # print_table_section  } # print_table_section
1092    
1093  sub print_id_section ($) {  sub print_listing_section ($$$) {
1094    my $ids = shift;    my ($opt, $input, $ids) = @_;
1095        
1096    push @nav, ['#identifiers' => 'IDs'];    push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]
1097          unless $input->{nested};
1098    print STDOUT qq[    print STDOUT qq[
1099  <div id="identifiers" class="section">  <div id="$input->{id_prefix}$opt->{id}" class="section">
1100  <h2>Identifiers</h2>  <h2>$opt->{heading}</h2>
1101    
1102  <dl>  <dl>
1103  ];  ];
1104    for my $id (sort {$a cmp $b} keys %$ids) {    for my $id (sort {$a cmp $b} keys %$ids) {
1105      print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];      print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
1106      for (@{$ids->{$id}}) {      for (@{$ids->{$id}}) {
1107        print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];        print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
1108      }      }
1109    }    }
1110    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
1111  } # print_id_section  } # print_listing_section
1112    
1113  sub print_term_section ($) {  sub print_uri_section ($$$) {
1114    my $terms = shift;    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, ['#terms' => 'Terms'];    push @nav, ['#' . $input->{id_prefix} . 'uris' => 'URIs']
1121          unless $input->{nested};
1122    print STDOUT qq[    print STDOUT qq[
1123  <div id="terms" class="section">  <div id="$input->{id_prefix}uris" class="section">
1124  <h2>Terms</h2>  <h2>URIs</h2>
1125    
1126  <dl>  <dl>];
1127  ];    for my $uri (sort {$a cmp $b} keys %$uris) {
1128    for my $term (sort {$a cmp $b} keys %$terms) {      my $euri = htescape ($uri);
1129      print STDOUT qq[<dt>@{[htescape $term]}</dt>];      print STDOUT qq[<dt><code class=uri>&lt;<a href="$euri">$euri</a>></code>];
1130      for (@{$terms->{$term}}) {      my $eccuri = htescape (get_cc_uri ($uri));
1131        print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];      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>];    print STDOUT qq[</dl></div>];
1156  } # print_term_section  } # print_uri_section
1157    
1158  sub print_class_section ($) {  sub print_rdf_section ($$$) {
1159    my $classes = shift;    my ($input, $rdfs) = @_;
1160        
1161    push @nav, ['#classes' => 'Classes'];    push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']
1162          unless $input->{nested};
1163    print STDOUT qq[    print STDOUT qq[
1164  <div id="classes" class="section">  <div id="$input->{id_prefix}rdf" class="section">
1165  <h2>Classes</h2>  <h2>RDF Triples</h2>
1166    
1167  <dl>  <dl>];
1168  ];    my $i = 0;
1169    for my $class (sort {$a cmp $b} keys %$classes) {    for my $rdf (@$rdfs) {
1170      print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];      print STDOUT qq[<dt id="$input->{id_prefix}rdf-@{[$i++]}">];
1171      for (@{$classes->{$class}}) {      print STDOUT get_node_link ($input, $rdf->[0]);
1172        print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];      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>];    print STDOUT qq[</dl></div>];
1184  } # print_class_section  } # 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 ($) {  sub print_result_section ($) {
1214    my $result = shift;    my $result = shift;
# Line 571  sub print_result_section ($) { Line 1217  sub print_result_section ($) {
1217  <div id="result-summary" class="section">  <div id="result-summary" class="section">
1218  <h2>Result</h2>];  <h2>Result</h2>];
1219    
1220    if ($result->{unsupported}) {      if ($result->{unsupported} and $result->{conforming_max}) {  
1221      print STDOUT qq[<p class=uncertain id=result-para>The conformance      print STDOUT qq[<p class=uncertain id=result-para>The conformance
1222          checker cannot decide whether the document is conforming or          checker cannot decide whether the document is conforming or
1223          not, since the document contains one or more unsupported          not, since the document contains one or more unsupported
1224          features.</p>];          features.  The document might or might not be conforming.</p>];
1225    } elsif ($result->{conforming_min}) {    } elsif ($result->{conforming_min}) {
1226      print STDOUT qq[<p class=PASS id=result-para>No conformance-error is      print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
1227          found in this document.</p>];          found in this document.</p>];
# Line 591  sub print_result_section ($) { Line 1237  sub print_result_section ($) {
1237    print STDOUT qq[<table>    print STDOUT qq[<table>
1238  <colgroup><col><colgroup><col><col><col><colgroup><col>  <colgroup><col><colgroup><col><col><col><colgroup><col>
1239  <thead>  <thead>
1240  <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level  <tr><th scope=col></th>
1241  Errors</th><th scope=col><em class=rfc2119>SHOULD</em>-level  <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
1242  Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>  Errors</a></th>
1243  </thead><tbody>];  <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;    my $must_error = 0;
1249    my $should_error = 0;    my $should_error = 0;
# Line 602  Errors</th><th scope=col>Warnings</th><t Line 1251  Errors</th><th scope=col>Warnings</th><t
1251    my $score_min = 0;    my $score_min = 0;
1252    my $score_max = 0;    my $score_max = 0;
1253    my $score_base = 20;    my $score_base = 20;
1254      my $score_unit = $score_base / 100;
1255    for (    for (
1256      [Transfer => 'transfer', ''],      [Transfer => 'transfer', ''],
1257      [Character => 'char', ''],      [Character => 'char', ''],
# Line 611  Errors</th><th scope=col>Warnings</th><t Line 1261  Errors</th><th scope=col>Warnings</th><t
1261      $must_error += ($result->{$_->[1]}->{must} += 0);      $must_error += ($result->{$_->[1]}->{must} += 0);
1262      $should_error += ($result->{$_->[1]}->{should} += 0);      $should_error += ($result->{$_->[1]}->{should} += 0);
1263      $warning += ($result->{$_->[1]}->{warning} += 0);      $warning += ($result->{$_->[1]}->{warning} += 0);
1264      $score_min += ($result->{$_->[1]}->{score_min} += $score_base);      $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
1265      $score_max += ($result->{$_->[1]}->{score_max} += $score_base);      $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
1266    
1267      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
1268      my $label = $_->[0];      my $label = $_->[0];
# Line 625  Errors</th><th scope=col>Warnings</th><t Line 1275  Errors</th><th scope=col>Warnings</th><t
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>];      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) {      if ($uncertain) {
1278        print qq[<td class="@{[$score_max < $score_base ? $score_min < $score_max ? 'FAIL' : 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}];
1279      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
1280        print qq[<td class="@{[$score_max < $score_base ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max} + $score_base</td></tr>];        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}];
1281      } else {      } else {
1282        print qq[<td class="@{[$score_max < $score_base ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];        print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}];
1283      }      }
1284        print qq[ / 20];
1285    }    }
1286    
1287    $score_max += $score_base;    $score_max += $score_base;
1288    
1289    print STDOUT qq[    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</td></tr>  <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base / 20
1291  </tbody>  </tbody>
1292  <tfoot><tr class=uncertain><th scope=row>Total</th><td>$must_error?</td><td>$should_error?</td><td>$warning?</td><td><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>  <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>  </table>
1298    
1299  <p><strong>Important</strong>: This conformance checking service  <p><strong>Important</strong>: This conformance checking service
# Line 647  is <em>under development</em>.  The resu Line 1302  is <em>under development</em>.  The resu
1302    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
1303  } # print_result_section  } # print_result_section
1304    
1305  sub print_result_unknown_type_section ($) {  sub print_result_unknown_type_section ($$) {
1306    my $input = shift;    my ($input, $result) = @_;
1307    
1308      my $euri = htescape ($input->{uri});
1309    print STDOUT qq[    print STDOUT qq[
1310  <div id="result-summary" class="section">  <div id="$input->{id_prefix}parse-errors" class="section">
1311  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  <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>  </div>
1322  ];  ];
1323    push @nav, ['#result-summary' => 'Result'];    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  } # print_result_unknown_type_section
1329    
1330  sub print_result_input_error_section ($) {  sub print_result_input_error_section ($) {
# Line 664  sub print_result_input_error_section ($) Line 1333  sub print_result_input_error_section ($)
1333  <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>  <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>
1334  </div>];  </div>];
1335    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
1336  } # print_Result_input_error_section  } # 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;
# Line 672  sub get_node_path ($) { Line 1436  sub get_node_path ($) {
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 693  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 703  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 716  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 740  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 802  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 811  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 824  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 847  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 864  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 875  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 907  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.19  
changed lines
  Added in v.1.52
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24