/[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.20 by wakaba, Mon Sep 10 12:09:34 2007 UTC revision 1.37 by wakaba, Sun Feb 24 02:17:51 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 83  if (defined $input->{s}) { Line 88  if (defined $input->{s}) {
88  </div>  </div>
89  ];  ];
90    
91      $input->{id_prefix} = '';
92      #$input->{nested} = 0;
93    my $result = {conforming_min => 1, conforming_max => 1};    my $result = {conforming_min => 1, conforming_max => 1};
94    print_http_header_section ($input, $result);    check_and_print ($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}};  
   }  
   
95    print_result_section ($result);    print_result_section ($result);
96  } else {  } else {
97    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
# Line 134  if (defined $input->{s}) { Line 110  if (defined $input->{s}) {
110  </html>  </html>
111  ];  ];
112    
113    for (qw/decode parse parse_xml check/) {    for (qw/decode parse parse_html parse_xml parse_manifest
114              check check_manifest/) {
115      next unless defined $time{$_};      next unless defined $time{$_};
116      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
117      print $file $char_length, "\t", $time{$_}, "\n";      print $file $char_length, "\t", $time{$_}, "\n";
118    }    }
119    
120  exit;  exit;
121    }
122    
123  sub add_error ($$$) {  sub add_error ($$$) {
124    my ($layer, $err, $result) = @_;    my ($layer, $err, $result) = @_;
# Line 151  sub add_error ($$$) { Line 129  sub add_error ($$$) {
129        $result->{conforming_min} = 0;        $result->{conforming_min} = 0;
130      } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {      } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
131        $result->{$layer}->{warning}++;        $result->{$layer}->{warning}++;
132      } elsif ($err->{level} eq 'unsupported') {      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
133        $result->{$layer}->{unsupported}++;        $result->{$layer}->{unsupported}++;
134        $result->{unsupported} = 1;        $result->{unsupported} = 1;
135        } elsif ($err->{level} eq 'i') {
136          #
137      } else {      } else {
138        $result->{$layer}->{must}++;        $result->{$layer}->{must}++;
139        $result->{$layer}->{score_max} -= 2;        $result->{$layer}->{score_max} -= 2;
# Line 170  sub add_error ($$$) { Line 150  sub add_error ($$$) {
150    }    }
151  } # add_error  } # add_error
152    
153    sub check_and_print ($$) {
154      my ($input, $result) = @_;
155    
156      print_http_header_section ($input, $result);
157    
158      my $doc;
159      my $el;
160      my $cssom;
161      my $manifest;
162      my @subdoc;
163    
164      if ($input->{media_type} eq 'text/html') {
165        ($doc, $el) = print_syntax_error_html_section ($input, $result);
166        print_source_string_section
167            ($input,
168             \($input->{s}),
169             $input->{charset} || $doc->input_encoding);
170      } elsif ({
171                'text/xml' => 1,
172                'application/atom+xml' => 1,
173                'application/rss+xml' => 1,
174                'application/svg+xml' => 1,
175                'application/xhtml+xml' => 1,
176                'application/xml' => 1,
177               }->{$input->{media_type}}) {
178        ($doc, $el) = print_syntax_error_xml_section ($input, $result);
179        print_source_string_section ($input,
180                                     \($input->{s}),
181                                     $doc->input_encoding);
182      } elsif ($input->{media_type} eq 'text/css') {
183        $cssom = print_syntax_error_css_section ($input, $result);
184        print_source_string_section
185            ($input, \($input->{s}),
186             $cssom->manakai_input_encoding);
187      } elsif ($input->{media_type} eq 'text/cache-manifest') {
188    ## TODO: MUST be text/cache-manifest
189        $manifest = print_syntax_error_manifest_section ($input, $result);
190        print_source_string_section ($input, \($input->{s}),
191                                     'utf-8');
192      } else {
193        ## TODO: Change HTTP status code??
194        print_result_unknown_type_section ($input, $result);
195      }
196    
197      if (defined $doc or defined $el) {
198        $doc->document_uri ($input->{uri});
199        $doc->manakai_entity_base_uri ($input->{base_uri});
200        print_structure_dump_dom_section ($input, $doc, $el);
201        my $elements = print_structure_error_dom_section
202            ($input, $doc, $el, $result, sub {
203              push @subdoc, shift;
204            });
205        print_table_section ($input, $elements->{table}) if @{$elements->{table}};
206        print_listing_section ({
207          id => 'identifiers', label => 'IDs', heading => 'Identifiers',
208        }, $input, $elements->{id}) if keys %{$elements->{id}};
209        print_listing_section ({
210          id => 'terms', label => 'Terms', heading => 'Terms',
211        }, $input, $elements->{term}) if keys %{$elements->{term}};
212        print_listing_section ({
213          id => 'classes', label => 'Classes', heading => 'Classes',
214        }, $input, $elements->{class}) if keys %{$elements->{class}};
215      } elsif (defined $cssom) {
216        print_structure_dump_cssom_section ($input, $cssom);
217        ## TODO: CSSOM validation
218        add_error ('structure', {level => 'u'} => $result);
219      } elsif (defined $manifest) {
220        print_structure_dump_manifest_section ($input, $manifest);
221        print_structure_error_manifest_section ($input, $manifest, $result);
222      }
223    
224      my $id_prefix = 0;
225      for my $subinput (@subdoc) {
226        $subinput->{id_prefix} = 'subdoc-' . ++$id_prefix;
227        $subinput->{nested} = 1;
228        $subinput->{base_uri} = $subinput->{container_node}->base_uri
229            unless defined $subinput->{base_uri};
230        my $ebaseuri = htescape ($subinput->{base_uri});
231        push @nav, ['#' . $subinput->{id_prefix} => 'Sub #' . $id_prefix];
232        print STDOUT qq[<div id="$subinput->{id_prefix}" class=section>
233          <h2>Subdocument #$id_prefix</h2>
234    
235          <dl>
236          <dt>Internet Media Type</dt>
237            <dd><code class="MIME" lang="en">@{[htescape $subinput->{media_type}]}</code>
238          <dt>Container Node</dt>
239            <dd>@{[get_node_link ($input, $subinput->{container_node})]}</dd>
240          <dt>Base <abbr title="Uniform Resource Identifiers">URI</abbr></dt>
241            <dd><code class=URI>&lt;<a href="$ebaseuri">$ebaseuri</a>></code></dd>
242          </dl>];              
243    
244        $subinput->{id_prefix} .= '-';
245        check_and_print ($subinput => $result);
246    
247        print STDOUT qq[</div>];
248      }
249    } # check_and_print
250    
251  sub print_http_header_section ($$) {  sub print_http_header_section ($$) {
252    my ($input, $result) = @_;    my ($input, $result) = @_;
253    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
254        defined $input->{header_status_text} or        defined $input->{header_status_text} or
255        @{$input->{header_field}};        @{$input->{header_field} or []};
256        
257    push @nav, ['#source-header' => 'HTTP Header'];    push @nav, ['#source-header' => 'HTTP Header'] unless $input->{nested};
258    print STDOUT qq[<div id="source-header" class="section">    print STDOUT qq[<div id="$input->{id_prefix}source-header" class="section">
259  <h2>HTTP Header</h2>  <h2>HTTP Header</h2>
260    
261  <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 287  sub print_syntax_error_html_section ($$)
287        
288    require Encode;    require Encode;
289    require Whatpm::HTML;    require Whatpm::HTML;
   
   $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.  
290        
   my $time1 = time;  
   my $t = Encode::decode ($input->{charset}, $input->{s});  
   $time{decode} = time - $time1;  
   
291    print STDOUT qq[    print STDOUT qq[
292  <div id="parse-errors" class="section">  <div id="$input->{id_prefix}parse-errors" class="section">
293  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
294    
295  <dl>];  <dl>];
296    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
297    
298    my $onerror = sub {    my $onerror = sub {
299      my (%opt) = @_;      my (%opt) = @_;
300      my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});      my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
301      if ($opt{column} > 0) {      if ($opt{column} > 0) {
302        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];        print STDOUT qq[<dt class="$cls"><a href="#$input->{id_prefix}line-$opt{line}">Line $opt{line}</a> column $opt{column}</dt>\n];
303      } else {      } else {
304        $opt{line} = $opt{line} - 1 || 1;        $opt{line} = $opt{line} - 1 || 1;
305        print STDOUT qq[<dt class="$cls"><a href="#line-$opt{line}">Line $opt{line}</a></dt>\n];        print STDOUT qq[<dt class="$cls"><a href="#$input->{id_prefix}line-$opt{line}">Line $opt{line}</a></dt>\n];
306      }      }
307      $type =~ tr/ /-/;      $type =~ tr/ /-/;
308      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
309      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
310      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
311        print STDOUT qq[$msg</dd>\n];
312    
313      add_error ('syntax', \%opt => $result);      add_error ('syntax', \%opt => $result);
314    };    };
315    
316    my $doc = $dom->create_document;    my $doc = $dom->create_document;
317    my $el;    my $el;
318    $time1 = time;    my $inner_html_element = $input->{inner_html_element};
319    if (defined $inner_html_element and length $inner_html_element) {    if (defined $inner_html_element and length $inner_html_element) {
320        $input->{charset} ||= 'windows-1252'; ## TODO: for now.
321        my $time1 = time;
322        my $t = Encode::decode ($input->{charset}, $input->{s});
323        $time{decode} = time - $time1;
324        
325      $el = $doc->create_element_ns      $el = $doc->create_element_ns
326          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
327        $time1 = time;
328      Whatpm::HTML->set_inner_html ($el, $t, $onerror);      Whatpm::HTML->set_inner_html ($el, $t, $onerror);
329        $time{parse} = time - $time1;
330    } else {    } else {
331      Whatpm::HTML->parse_string ($t => $doc, $onerror);      my $time1 = time;
332        Whatpm::HTML->parse_byte_string
333            ($input->{charset}, $input->{s} => $doc, $onerror);
334        $time{parse_html} = time - $time1;
335    }    }
336    $time{parse} = time - $time1;    $doc->manakai_charset ($input->{official_charset})
337          if defined $input->{official_charset};
338      
339    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
340    
341    return ($doc, $el);    return ($doc, $el);
# Line 263  sub print_syntax_error_xml_section ($$) Line 347  sub print_syntax_error_xml_section ($$)
347    require Message::DOM::XMLParserTemp;    require Message::DOM::XMLParserTemp;
348        
349    print STDOUT qq[    print STDOUT qq[
350  <div id="parse-errors" class="section">  <div id="$input->{id_prefix}parse-errors" class="section">
351  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
352    
353  <dl>];  <dl>];
354    push @nav, ['#parse-errors' => 'Parse Error'];    push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{prefix};
355    
356    my $onerror = sub {    my $onerror = sub {
357      my $err = shift;      my $err = shift;
358      my $line = $err->location->line_number;      my $line = $err->location->line_number;
359      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 ];
360      print STDOUT $err->location->column_number, "</dt><dd>";      print STDOUT $err->location->column_number, "</dt><dd>";
361      print STDOUT htescape $err->text, "</dd>\n";      print STDOUT htescape $err->text, "</dd>\n";
362    
# Line 291  sub print_syntax_error_xml_section ($$) Line 375  sub print_syntax_error_xml_section ($$)
375    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream    my $doc = Message::DOM::XMLParserTemp->parse_byte_stream
376        ($fh => $dom, $onerror, charset => $input->{charset});        ($fh => $dom, $onerror, charset => $input->{charset});
377    $time{parse_xml} = time - $time1;    $time{parse_xml} = time - $time1;
378      $doc->manakai_charset ($input->{official_charset})
379          if defined $input->{official_charset};
380    
381    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
382    
383    return ($doc, undef);    return ($doc, undef);
384  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
385    
386  sub print_source_string_section ($$) {  sub get_css_parser () {
387    require Encode;    our $CSSParser;
388    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name    return $CSSParser if $CSSParser;
389    return unless $enc;  
390      require Whatpm::CSS::Parser;
391      my $p = Whatpm::CSS::Parser->new;
392    
393      $p->{prop}->{$_} = 1 for qw/
394        alignment-baseline
395        background background-attachment background-color background-image
396        background-position background-position-x background-position-y
397        background-repeat border border-bottom border-bottom-color
398        border-bottom-style border-bottom-width border-collapse border-color
399        border-left border-left-color
400        border-left-style border-left-width border-right border-right-color
401        border-right-style border-right-width
402        border-spacing -manakai-border-spacing-x -manakai-border-spacing-y
403        border-style border-top border-top-color border-top-style border-top-width
404        border-width bottom
405        caption-side clear clip color content counter-increment counter-reset
406        cursor direction display dominant-baseline empty-cells float font
407        font-family font-size font-size-adjust font-stretch
408        font-style font-variant font-weight height left
409        letter-spacing line-height
410        list-style list-style-image list-style-position list-style-type
411        margin margin-bottom margin-left margin-right margin-top marker-offset
412        marks max-height max-width min-height min-width opacity -moz-opacity
413        orphans outline outline-color outline-style outline-width overflow
414        overflow-x overflow-y
415        padding padding-bottom padding-left padding-right padding-top
416        page page-break-after page-break-before page-break-inside
417        position quotes right size table-layout
418        text-align text-anchor text-decoration text-indent text-transform
419        top unicode-bidi vertical-align visibility white-space width widows
420        word-spacing writing-mode z-index
421      /;
422      $p->{prop_value}->{display}->{$_} = 1 for qw/
423        block clip inline inline-block inline-table list-item none
424        table table-caption table-cell table-column table-column-group
425        table-header-group table-footer-group table-row table-row-group
426        compact marker
427      /;
428      $p->{prop_value}->{position}->{$_} = 1 for qw/
429        absolute fixed relative static
430      /;
431      $p->{prop_value}->{float}->{$_} = 1 for qw/
432        left right none
433      /;
434      $p->{prop_value}->{clear}->{$_} = 1 for qw/
435        left right none both
436      /;
437      $p->{prop_value}->{direction}->{ltr} = 1;
438      $p->{prop_value}->{direction}->{rtl} = 1;
439      $p->{prop_value}->{marks}->{crop} = 1;
440      $p->{prop_value}->{marks}->{cross} = 1;
441      $p->{prop_value}->{'unicode-bidi'}->{$_} = 1 for qw/
442        normal bidi-override embed
443      /;
444      for my $prop_name (qw/overflow overflow-x overflow-y/) {
445        $p->{prop_value}->{$prop_name}->{$_} = 1 for qw/
446          visible hidden scroll auto -webkit-marquee -moz-hidden-unscrollable
447        /;
448      }
449      $p->{prop_value}->{visibility}->{$_} = 1 for qw/
450        visible hidden collapse
451      /;
452      $p->{prop_value}->{'list-style-type'}->{$_} = 1 for qw/
453        disc circle square decimal decimal-leading-zero
454        lower-roman upper-roman lower-greek lower-latin
455        upper-latin armenian georgian lower-alpha upper-alpha none
456        hebrew cjk-ideographic hiragana katakana hiragana-iroha
457        katakana-iroha
458      /;
459      $p->{prop_value}->{'list-style-position'}->{outside} = 1;
460      $p->{prop_value}->{'list-style-position'}->{inside} = 1;
461      $p->{prop_value}->{'page-break-before'}->{$_} = 1 for qw/
462        auto always avoid left right
463      /;
464      $p->{prop_value}->{'page-break-after'}->{$_} = 1 for qw/
465        auto always avoid left right
466      /;
467      $p->{prop_value}->{'page-break-inside'}->{auto} = 1;
468      $p->{prop_value}->{'page-break-inside'}->{avoid} = 1;
469      $p->{prop_value}->{'background-repeat'}->{$_} = 1 for qw/
470        repeat repeat-x repeat-y no-repeat
471      /;
472      $p->{prop_value}->{'background-attachment'}->{scroll} = 1;
473      $p->{prop_value}->{'background-attachment'}->{fixed} = 1;
474      $p->{prop_value}->{'font-size'}->{$_} = 1 for qw/
475        xx-small x-small small medium large x-large xx-large
476        -manakai-xxx-large -webkit-xxx-large
477        larger smaller
478      /;
479      $p->{prop_value}->{'font-style'}->{normal} = 1;
480      $p->{prop_value}->{'font-style'}->{italic} = 1;
481      $p->{prop_value}->{'font-style'}->{oblique} = 1;
482      $p->{prop_value}->{'font-variant'}->{normal} = 1;
483      $p->{prop_value}->{'font-variant'}->{'small-caps'} = 1;
484      $p->{prop_value}->{'font-stretch'}->{$_} = 1 for
485          qw/normal wider narrower ultra-condensed extra-condensed
486            condensed semi-condensed semi-expanded expanded
487            extra-expanded ultra-expanded/;
488      $p->{prop_value}->{'text-align'}->{$_} = 1 for qw/
489        left right center justify begin end
490      /;
491      $p->{prop_value}->{'text-transform'}->{$_} = 1 for qw/
492        capitalize uppercase lowercase none
493      /;
494      $p->{prop_value}->{'white-space'}->{$_} = 1 for qw/
495        normal pre nowrap pre-line pre-wrap -moz-pre-wrap
496      /;
497      $p->{prop_value}->{'writing-mode'}->{$_} = 1 for qw/
498        lr rl tb lr-tb rl-tb tb-rl
499      /;
500      $p->{prop_value}->{'text-anchor'}->{$_} = 1 for qw/
501        start middle end
502      /;
503      $p->{prop_value}->{'dominant-baseline'}->{$_} = 1 for qw/
504        auto use-script no-change reset-size ideographic alphabetic
505        hanging mathematical central middle text-after-edge text-before-edge
506      /;
507      $p->{prop_value}->{'alignment-baseline'}->{$_} = 1 for qw/
508        auto baseline before-edge text-before-edge middle central
509        after-edge text-after-edge ideographic alphabetic hanging
510        mathematical
511      /;
512      $p->{prop_value}->{'text-decoration'}->{$_} = 1 for qw/
513        none blink underline overline line-through
514      /;
515      $p->{prop_value}->{'caption-side'}->{$_} = 1 for qw/
516        top bottom left right
517      /;
518      $p->{prop_value}->{'table-layout'}->{auto} = 1;
519      $p->{prop_value}->{'table-layout'}->{fixed} = 1;
520      $p->{prop_value}->{'border-collapse'}->{collapse} = 1;
521      $p->{prop_value}->{'border-collapse'}->{separate} = 1;
522      $p->{prop_value}->{'empty-cells'}->{show} = 1;
523      $p->{prop_value}->{'empty-cells'}->{hide} = 1;
524      $p->{prop_value}->{cursor}->{$_} = 1 for qw/
525        auto crosshair default pointer move e-resize ne-resize nw-resize n-resize
526        se-resize sw-resize s-resize w-resize text wait help progress
527      /;
528      for my $prop (qw/border-top-style border-left-style
529                       border-bottom-style border-right-style outline-style/) {
530        $p->{prop_value}->{$prop}->{$_} = 1 for qw/
531          none hidden dotted dashed solid double groove ridge inset outset
532        /;
533      }
534      for my $prop (qw/color background-color
535                       border-bottom-color border-left-color border-right-color
536                       border-top-color border-color/) {
537        $p->{prop_value}->{$prop}->{transparent} = 1;
538        $p->{prop_value}->{$prop}->{flavor} = 1;
539        $p->{prop_value}->{$prop}->{'-manakai-default'} = 1;
540      }
541      $p->{prop_value}->{'outline-color'}->{invert} = 1;
542      $p->{prop_value}->{'outline-color'}->{'-manakai-invert-or-currentcolor'} = 1;
543      $p->{pseudo_class}->{$_} = 1 for qw/
544        active checked disabled empty enabled first-child first-of-type
545        focus hover indeterminate last-child last-of-type link only-child
546        only-of-type root target visited
547        lang nth-child nth-last-child nth-of-type nth-last-of-type not
548        -manakai-contains -manakai-current
549      /;
550      $p->{pseudo_element}->{$_} = 1 for qw/
551        after before first-letter first-line
552      /;
553    
554      return $CSSParser = $p;
555    } # get_css_parser
556    
557    sub print_syntax_error_css_section ($$) {
558      my ($input, $result) = @_;
559    
560      print STDOUT qq[
561    <div id="$input->{id_prefix}parse-errors" class="section">
562    <h2>Parse Errors</h2>
563    
564    <dl>];
565      push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
566    
567      my $p = get_css_parser ();
568      $p->init;
569      $p->{onerror} = sub {
570        my (%opt) = @_;
571        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
572        if ($opt{token}) {
573          print STDOUT qq[<dt class="$cls"><a href="#$input->{id_prefix}line-$opt{token}->{line}">Line $opt{token}->{line}</a> column $opt{token}->{column}];
574        } else {
575          print STDOUT qq[<dt class="$cls">Unknown location];
576        }
577        if (defined $opt{value}) {
578          print STDOUT qq[ (<code>@{[htescape ($opt{value})]}</code>)];
579        } elsif (defined $opt{token}) {
580          print STDOUT qq[ (<code>@{[htescape (Whatpm::CSS::Tokenizer->serialize_token ($opt{token}))]}</code>)];
581        }
582        $type =~ tr/ /-/;
583        $type =~ s/\|/%7C/g;
584        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
585        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
586        print STDOUT qq[$msg</dd>\n];
587    
588        add_error ('syntax', \%opt => $result);
589      };
590      $p->{href} = $input->{uri};
591      $p->{base_uri} = $input->{base_uri};
592    
593    #  if ($parse_mode eq 'q') {
594    #    $p->{unitless_px} = 1;
595    #    $p->{hashless_color} = 1;
596    #  }
597    
598    ## TODO: Make $input->{s} a ref.
599    
600      my $s = \$input->{s};
601      my $charset;
602      unless ($input->{is_char_string}) {
603        require Encode;
604        if (defined $input->{charset}) {## TODO: IANA->Perl
605          $charset = $input->{charset};
606          $s = \(Encode::decode ($input->{charset}, $$s));
607        } else {
608          ## TODO: charset detection
609          $s = \(Encode::decode ($charset = 'utf-8', $$s));
610        }
611      }
612      
613      my $cssom = $p->parse_char_string ($$s);
614      $cssom->manakai_input_encoding ($charset) if defined $charset;
615    
616      print STDOUT qq[</dl></div>];
617    
618      return $cssom;
619    } # print_syntax_error_css_section
620    
621    sub print_syntax_error_manifest_section ($$) {
622      my ($input, $result) = @_;
623    
624      require Whatpm::CacheManifest;
625    
626      print STDOUT qq[
627    <div id="$input->{id_prefix}parse-errors" class="section">
628    <h2>Parse Errors</h2>
629    
630    <dl>];
631      push @nav, ['#parse-errors' => 'Parse Error'] unless $input->{nested};
632    
633      my $onerror = sub {
634        my (%opt) = @_;
635        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
636        print STDOUT qq[<dt class="$cls">], get_error_label ($input, \%opt),
637            qq[</dt>];
638        $type =~ tr/ /-/;
639        $type =~ s/\|/%7C/g;
640        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
641        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
642        print STDOUT qq[$msg</dd>\n];
643    
644        add_error ('syntax', \%opt => $result);
645      };
646    
647      my $time1 = time;
648      my $manifest = Whatpm::CacheManifest->parse_byte_string
649          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
650      $time{parse_manifest} = time - $time1;
651    
652      print STDOUT qq[</dl></div>];
653    
654      return $manifest;
655    } # print_syntax_error_manifest_section
656    
657    sub print_source_string_section ($$$) {
658      my $input = shift;
659      my $s;
660      unless ($input->{is_char_string}) {
661        require Encode;
662        my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name
663        return unless $enc;
664    
665        $s = \($enc->decode (${$_[0]}));
666      } else {
667        $s = $_[0];
668      }
669    
   my $s = \($enc->decode (${$_[0]}));  
670    my $i = 1;                                my $i = 1;                            
671    push @nav, ['#source-string' => 'Source'];    push @nav, ['#source-string' => 'Source'] unless $input->{nested};
672    print STDOUT qq[<div id="source-string" class="section">    print STDOUT qq[<div id="$input->{id_prefix}source-string" class="section">
673  <h2>Document Source</h2>  <h2>Document Source</h2>
674  <ol lang="">\n];  <ol lang="">\n];
675    if (length $$s) {    if (length $$s) {
676      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {      while ($$s =~ /\G([^\x0A]*?)\x0D?\x0A/gc) {
677        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
678              "</li>\n";
679        $i++;        $i++;
680      }      }
681      if ($$s =~ /\G([^\x0A]+)/gc) {      if ($$s =~ /\G([^\x0A]+)/gc) {
682        print STDOUT qq[<li id="line-$i">], htescape $1, "</li>\n";        print STDOUT qq[<li id="$input->{id_prefix}line-$i">], htescape $1,
683              "</li>\n";
684      }      }
685    } else {    } else {
686      print STDOUT q[<li id="line-1"></li>];      print STDOUT q[<li id="$input->{id_prefix}line-1"></li>];
687    }    }
688    print STDOUT "</ol></div>";    print STDOUT "</ol></div>";
689  } # print_input_string_section  } # print_input_string_section
690    
691  sub print_document_tree ($) {  sub print_document_tree ($$) {
692    my $node = shift;    my ($input, $node) = @_;
693    
694    my $r = '<ol class="xoxo">';    my $r = '<ol class="xoxo">';
695    
696    my @node = ($node);    my @node = ($node);
# Line 334  sub print_document_tree ($) { Line 701  sub print_document_tree ($) {
701        next;        next;
702      }      }
703    
704      my $node_id = 'node-'.refaddr $child;      my $node_id = $input->{id_prefix} . 'node-'.refaddr $child;
705      my $nt = $child->node_type;      my $nt = $child->node_type;
706      if ($nt == $child->ELEMENT_NODE) {      if ($nt == $child->ELEMENT_NODE) {
707        my $child_nsuri = $child->namespace_uri;        my $child_nsuri = $child->namespace_uri;
# Line 345  sub print_document_tree ($) { Line 712  sub print_document_tree ($) {
712          $r .= '<ul class="attributes">';          $r .= '<ul class="attributes">';
713          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 $_] }
714                        @{$child->attributes}) {                        @{$child->attributes}) {
715            $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?
716            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children            $r .= '<q>' . htescape ($attr->[1]) . '</q></li>'; ## TODO: children
717          }          }
718          $r .= '</ul>';          $r .= '</ul>';
# Line 366  sub print_document_tree ($) { Line 733  sub print_document_tree ($) {
733      } elsif ($nt == $child->DOCUMENT_NODE) {      } elsif ($nt == $child->DOCUMENT_NODE) {
734        $r .= qq'<li id="$node_id" class="tree-document">Document';        $r .= qq'<li id="$node_id" class="tree-document">Document';
735        $r .= qq[<ul class="attributes">];        $r .= qq[<ul class="attributes">];
736          my $cp = $child->manakai_charset;
737          if (defined $cp) {
738            $r .= qq[<li><code>charset</code> parameter = <code>];
739            $r .= htescape ($cp) . qq[</code></li>];
740          }
741          $r .= qq[<li><code>inputEncoding</code> = ];
742          my $ie = $child->input_encoding;
743          if (defined $ie) {
744            $r .= qq[<code>@{[htescape ($ie)]}</code>];
745            if ($child->manakai_has_bom) {
746              $r .= qq[ (with <code class=charname><abbr>BOM</abbr></code>)];
747            }
748          } else {
749            $r .= qq[(<code>null</code>)];
750          }
751        $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>];
752        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];        $r .= qq[<li>@{[scalar get_text ('manakaiCompatMode:'.$child->manakai_compat_mode)]}</li>];
753        unless ($child->manakai_is_html) {        unless ($child->manakai_is_html) {
# Line 399  sub print_document_tree ($) { Line 781  sub print_document_tree ($) {
781    print STDOUT $r;    print STDOUT $r;
782  } # print_document_tree  } # print_document_tree
783    
784  sub print_structure_dump_section ($$) {  sub print_structure_dump_dom_section ($$$) {
785    my ($doc, $el) = @_;    my ($input, $doc, $el) = @_;
786    
787      print STDOUT qq[
788    <div id="$input->{id_prefix}document-tree" class="section">
789    <h2>Document Tree</h2>
790    ];
791      push @nav, [qq[#$input->{id_prefix}document-tree] => 'Tree']
792          unless $input->{nested};
793    
794      print_document_tree ($input, $el || $doc);
795    
796      print STDOUT qq[</div>];
797    } # print_structure_dump_dom_section
798    
799    sub print_structure_dump_cssom_section ($$) {
800      my ($input, $cssom) = @_;
801    
802    print STDOUT qq[    print STDOUT qq[
803  <div id="document-tree" class="section">  <div id="$input->{id_prefix}document-tree" class="section">
804  <h2>Document Tree</h2>  <h2>Document Tree</h2>
805  ];  ];
806    push @nav, ['#document-tree' => 'Tree'];    push @nav, [qq[#$input->{id_prefix}document-tree] => 'Tree']
807          unless $input->{nested};
808    
809    print_document_tree ($el || $doc);    ## TODO:
810      print STDOUT "<pre>".htescape ($cssom->css_text)."</pre>";
811    
812    print STDOUT qq[</div>];    print STDOUT qq[</div>];
813  } # print_structure_dump_section  } # print_structure_dump_cssom_section
814    
815    sub print_structure_dump_manifest_section ($$) {
816      my ($input, $manifest) = @_;
817    
818      print STDOUT qq[
819    <div id="$input->{id_prefix}dump-manifest" class="section">
820    <h2>Cache Manifest</h2>
821    ];
822      push @nav, [qq[#$input->{id_prefix}dump-manifest] => 'Cache Manifest']
823          unless $input->{nested};
824    
825      print STDOUT qq[<dl><dt>Explicit entries</dt>];
826      my $i = 0;
827      for my $uri (@{$manifest->[0]}) {
828        my $euri = htescape ($uri);
829        print STDOUT qq[<dd id="$input->{id_prefix}index-@{[$i++]}"><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
830      }
831    
832      print STDOUT qq[<dt>Fallback entries</dt><dd>
833          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
834          <th scope=row>Fallback Entry</tr><tbody>];
835      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
836        my $euri = htescape ($uri);
837        my $euri2 = htescape ($manifest->[1]->{$uri});
838        print STDOUT qq[<tr><td id="$input->{id_prefix}index-@{[$i++]}"><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
839            <td id="$input->{id_prefix}index-@{[$i++]}"><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
840      }
841    
842      print STDOUT qq[</table><dt>Online whitelist</dt>];
843      for my $uri (@{$manifest->[2]}) {
844        my $euri = htescape ($uri);
845        print STDOUT qq[<dd id="$input->{id_prefix}index-@{[$i++]}"><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
846      }
847    
848      print STDOUT qq[</dl></div>];
849    } # print_structure_dump_manifest_section
850    
851  sub print_structure_error_section ($$$) {  sub print_structure_error_dom_section ($$$$$) {
852    my ($doc, $el, $result) = @_;    my ($input, $doc, $el, $result, $onsubdoc) = @_;
853    
854    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
855  <h2>Document Errors</h2>  <h2>Document Errors</h2>
856    
857  <dl>];  <dl>];
858    push @nav, ['#document-errors' => 'Document Error'];    push @nav, [qq[#$input->{id_prefix}document-errors] => 'Document Error']
859          unless $input->{nested};
860    
861    require Whatpm::ContentChecker;    require Whatpm::ContentChecker;
862    my $onerror = sub {    my $onerror = sub {
# Line 429  sub print_structure_error_section ($$$) Line 865  sub print_structure_error_section ($$$)
865      $type =~ tr/ /-/;      $type =~ tr/ /-/;
866      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
867      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
868      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
869          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
870        print STDOUT $msg, "</dd>\n";
871      add_error ('structure', \%opt => $result);      add_error ('structure', \%opt => $result);
872    };    };
873    
874    my $elements;    my $elements;
875    my $time1 = time;    my $time1 = time;
876    if ($el) {    if ($el) {
877      $elements = Whatpm::ContentChecker->check_element ($el, $onerror);      $elements = Whatpm::ContentChecker->check_element
878            ($el, $onerror, $onsubdoc);
879    } else {    } else {
880      $elements = Whatpm::ContentChecker->check_document ($doc, $onerror);      $elements = Whatpm::ContentChecker->check_document
881            ($doc, $onerror, $onsubdoc);
882    }    }
883    $time{check} = time - $time1;    $time{check} = time - $time1;
884    
885    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
886    
887    return $elements;    return $elements;
888  } # print_structure_error_section  } # print_structure_error_dom_section
889    
890    sub print_structure_error_manifest_section ($$$) {
891      my ($input, $manifest, $result) = @_;
892    
893      print STDOUT qq[<div id="$input->{id_prefix}document-errors" class="section">
894    <h2>Document Errors</h2>
895    
896    <dl>];
897      push @nav, [qq[#$input->{id_prefix}document-errors] => 'Document Error']
898          unless $input->{nested};
899    
900      require Whatpm::CacheManifest;
901      Whatpm::CacheManifest->check_manifest ($manifest, sub {
902        my %opt = @_;
903        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
904        $type =~ tr/ /-/;
905        $type =~ s/\|/%7C/g;
906        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
907        print STDOUT qq[<dt class="$cls">] . get_error_label ($input, \%opt) .
908            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
909        add_error ('structure', \%opt => $result);
910      });
911    
912      print STDOUT qq[</div>];
913    } # print_structure_error_manifest_section
914    
915  sub print_table_section ($) {  sub print_table_section ($$) {
916    my $tables = shift;    my ($input, $tables) = @_;
917        
918    push @nav, ['#tables' => 'Tables'];    push @nav, [qq[#$input->{id_prefix}tables] => 'Tables']
919          unless $input->{nested};
920    print STDOUT qq[    print STDOUT qq[
921  <div id="tables" class="section">  <div id="$input->{id_prefix}tables" class="section">
922  <h2>Tables</h2>  <h2>Tables</h2>
923    
924  <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->  <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->
# Line 468  sub print_table_section ($) { Line 933  sub print_table_section ($) {
933    my $i = 0;    my $i = 0;
934    for my $table_el (@$tables) {    for my $table_el (@$tables) {
935      $i++;      $i++;
936      print STDOUT qq[<div class="section" id="table-$i"><h3>] .      print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .
937          get_node_link ($table_el) . q[</h3>];          get_node_link ($input, $table_el) . q[</h3>];
938    
939      ## TODO: Make |ContentChecker| return |form_table| result      ## TODO: Make |ContentChecker| return |form_table| result
940      ## so that this script don't have to run the algorithm twice.      ## so that this script don't have to run the algorithm twice.
# Line 501  sub print_table_section ($) { Line 966  sub print_table_section ($) {
966                    
967      print STDOUT '</div><script type="text/javascript">tableToCanvas (';      print STDOUT '</div><script type="text/javascript">tableToCanvas (';
968      print STDOUT JSON::objToJson ($table);      print STDOUT JSON::objToJson ($table);
969      print STDOUT qq[, document.getElementById ('table-$i'));</script>];      print STDOUT qq[, document.getElementById ('$input->{id_prefix}table-$i')];
970        print STDOUT qq[, '$input->{id_prefix}');</script>];
971    }    }
972        
973    print STDOUT qq[</div>];    print STDOUT qq[</div>];
974  } # print_table_section  } # print_table_section
975    
976  sub print_id_section ($) {  sub print_listing_section ($$$) {
977    my $ids = shift;    my ($opt, $input, $ids) = @_;
978        
979    push @nav, ['#identifiers' => 'IDs'];    push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]
980          unless $input->{nested};
981    print STDOUT qq[    print STDOUT qq[
982  <div id="identifiers" class="section">  <div id="$input->{id_prefix}$opt->{id}" class="section">
983  <h2>Identifiers</h2>  <h2>$opt->{heading}</h2>
984    
985  <dl>  <dl>
986  ];  ];
987    for my $id (sort {$a cmp $b} keys %$ids) {    for my $id (sort {$a cmp $b} keys %$ids) {
988      print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];      print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];
989      for (@{$ids->{$id}}) {      for (@{$ids->{$id}}) {
990        print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];        print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];
991      }      }
992    }    }
993    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
994  } # print_id_section  } # print_listing_section
   
 sub print_term_section ($) {  
   my $terms = shift;  
     
   push @nav, ['#terms' => 'Terms'];  
   print STDOUT qq[  
 <div id="terms" class="section">  
 <h2>Terms</h2>  
   
 <dl>  
 ];  
   for my $term (sort {$a cmp $b} keys %$terms) {  
     print STDOUT qq[<dt>@{[htescape $term]}</dt>];  
     for (@{$terms->{$term}}) {  
       print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];  
     }  
   }  
   print STDOUT qq[</dl></div>];  
 } # print_term_section  
   
 sub print_class_section ($) {  
   my $classes = shift;  
     
   push @nav, ['#classes' => 'Classes'];  
   print STDOUT qq[  
 <div id="classes" class="section">  
 <h2>Classes</h2>  
   
 <dl>  
 ];  
   for my $class (sort {$a cmp $b} keys %$classes) {  
     print STDOUT qq[<dt><code>@{[htescape $class]}</code></dt>];  
     for (@{$classes->{$class}}) {  
       print STDOUT qq[<dd>].get_node_link ($_).qq[</dd>];  
     }  
   }  
   print STDOUT qq[</dl></div>];  
 } # print_class_section  
995    
996  sub print_result_section ($) {  sub print_result_section ($) {
997    my $result = shift;    my $result = shift;
# Line 571  sub print_result_section ($) { Line 1000  sub print_result_section ($) {
1000  <div id="result-summary" class="section">  <div id="result-summary" class="section">
1001  <h2>Result</h2>];  <h2>Result</h2>];
1002    
1003    if ($result->{unsupported}) {      if ($result->{unsupported} and $result->{conforming_max}) {  
1004      print STDOUT qq[<p class=uncertain id=result-para>The conformance      print STDOUT qq[<p class=uncertain id=result-para>The conformance
1005          checker cannot decide whether the document is conforming or          checker cannot decide whether the document is conforming or
1006          not, since the document contains one or more unsupported          not, since the document contains one or more unsupported
1007          features.</p>];          features.  The document might or might not be conforming.</p>];
1008    } elsif ($result->{conforming_min}) {    } elsif ($result->{conforming_min}) {
1009      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
1010          found in this document.</p>];          found in this document.</p>];
# Line 591  sub print_result_section ($) { Line 1020  sub print_result_section ($) {
1020    print STDOUT qq[<table>    print STDOUT qq[<table>
1021  <colgroup><col><colgroup><col><col><col><colgroup><col>  <colgroup><col><colgroup><col><col><col><colgroup><col>
1022  <thead>  <thead>
1023  <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level  <tr><th scope=col></th>
1024  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
1025  Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>  Errors</a></th>
1026  </thead><tbody>];  <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
1027    Errors</a></th>
1028    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
1029    <th scope=col>Score</th></tr></thead><tbody>];
1030    
1031    my $must_error = 0;    my $must_error = 0;
1032    my $should_error = 0;    my $should_error = 0;
# Line 602  Errors</th><th scope=col>Warnings</th><t Line 1034  Errors</th><th scope=col>Warnings</th><t
1034    my $score_min = 0;    my $score_min = 0;
1035    my $score_max = 0;    my $score_max = 0;
1036    my $score_base = 20;    my $score_base = 20;
1037      my $score_unit = $score_base / 100;
1038    for (    for (
1039      [Transfer => 'transfer', ''],      [Transfer => 'transfer', ''],
1040      [Character => 'char', ''],      [Character => 'char', ''],
# Line 611  Errors</th><th scope=col>Warnings</th><t Line 1044  Errors</th><th scope=col>Warnings</th><t
1044      $must_error += ($result->{$_->[1]}->{must} += 0);      $must_error += ($result->{$_->[1]}->{must} += 0);
1045      $should_error += ($result->{$_->[1]}->{should} += 0);      $should_error += ($result->{$_->[1]}->{should} += 0);
1046      $warning += ($result->{$_->[1]}->{warning} += 0);      $warning += ($result->{$_->[1]}->{warning} += 0);
1047      $score_min += ($result->{$_->[1]}->{score_min} += $score_base);      $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
1048      $score_max += ($result->{$_->[1]}->{score_max} += $score_base);      $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
1049    
1050      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
1051      my $label = $_->[0];      my $label = $_->[0];
# Line 625  Errors</th><th scope=col>Warnings</th><t Line 1058  Errors</th><th scope=col>Warnings</th><t
1058    
1059      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>];
1060      if ($uncertain) {      if ($uncertain) {
1061        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}</td>];
1062      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
1063        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}</td></tr>];
1064      } else {      } else {
1065        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}</td></tr>];
1066      }      }
1067    }    }
1068    
# Line 638  Errors</th><th scope=col>Warnings</th><t Line 1071  Errors</th><th scope=col>Warnings</th><t
1071    print STDOUT qq[    print STDOUT qq[
1072  <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</td></tr>
1073  </tbody>  </tbody>
1074  <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>
1075    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
1076    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
1077    <td>$warning?</td>
1078    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
1079  </table>  </table>
1080    
1081  <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 1084  is <em>under development</em>.  The resu
1084    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
1085  } # print_result_section  } # print_result_section
1086    
1087  sub print_result_unknown_type_section ($) {  sub print_result_unknown_type_section ($$) {
1088    my $input = shift;    my ($input, $result) = @_;
1089    
1090      my $euri = htescape ($input->{uri});
1091    print STDOUT qq[    print STDOUT qq[
1092  <div id="result-summary" class="section">  <div id="$input->{id_prefix}parse-errors" class="section">
1093  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  <h2>Errors</h2>
1094    
1095    <dl>
1096    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
1097        <dd class=unsupported><strong><a href="../error-description#level-u">Not
1098            supported</a></strong>:
1099        Media type
1100        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
1101        is not supported.</dd>
1102    </dl>
1103  </div>  </div>
1104  ];  ];
1105    push @nav, ['#result-summary' => 'Result'];    push @nav, [qq[#$input->{id_prefix}parse-errors] => 'Errors']
1106          unless $input->{nested};
1107      add_error (char => {level => 'u'} => $result);
1108      add_error (syntax => {level => 'u'} => $result);
1109      add_error (structure => {level => 'u'} => $result);
1110  } # print_result_unknown_type_section  } # print_result_unknown_type_section
1111    
1112  sub print_result_input_error_section ($) {  sub print_result_input_error_section ($) {
# Line 664  sub print_result_input_error_section ($) Line 1115  sub print_result_input_error_section ($)
1115  <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>
1116  </div>];  </div>];
1117    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
1118  } # print_Result_input_error_section  } # print_result_input_error_section
1119    
1120    sub get_error_label ($$) {
1121      my ($input, $err) = @_;
1122    
1123      my $r = '';
1124    
1125      if (defined $err->{line}) {
1126        if ($err->{column} > 0) {
1127          $r = qq[<a href="#$input->{id_prefix}line-$err->{line}">Line $err->{line}</a> column $err->{column}];
1128        } else {
1129          $err->{line} = $err->{line} - 1 || 1;
1130          $r = qq[<a href="#$input->{id_prefix}line-$err->{line}">Line $err->{line}</a>];
1131        }
1132      }
1133    
1134      if (defined $err->{node}) {
1135        $r .= ' ' if length $r;
1136        $r = get_node_link ($input, $err->{node});
1137      }
1138    
1139      if (defined $err->{index}) {
1140        if (length $r) {
1141          $r .= ', Index ' . (0+$err->{index});
1142        } else {
1143          $r .= "<a href='#$input->{id_prefix}index-@{[0+$err->{index}]}'>Index "
1144              . (0+$err->{index}) . '</a>';
1145        }
1146      }
1147    
1148      if (defined $err->{value}) {
1149        $r .= ' ' if length $r;
1150        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
1151      }
1152    
1153      return $r;
1154    } # get_error_label
1155    
1156    sub get_error_level_label ($) {
1157      my $err = shift;
1158    
1159      my $r = '';
1160    
1161      if (not defined $err->{level} or $err->{level} eq 'm') {
1162        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
1163            error</a></strong>: ];
1164      } elsif ($err->{level} eq 's') {
1165        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
1166            error</a></strong>: ];
1167      } elsif ($err->{level} eq 'w') {
1168        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
1169            ];
1170      } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {
1171        $r = qq[<strong><a href="../error-description#level-u">Not
1172            supported</a></strong>: ];
1173      } elsif ($err->{level} eq 'i') {
1174        $r = qq[<strong><a href="../error-description#level-i">Information</a></strong>: ];
1175      } else {
1176        my $elevel = htescape ($err->{level});
1177        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
1178            ];
1179      }
1180    
1181      return $r;
1182    } # get_error_level_label
1183    
1184  sub get_node_path ($) {  sub get_node_path ($) {
1185    my $node = shift;    my $node = shift;
# Line 693  sub get_node_path ($) { Line 1208  sub get_node_path ($) {
1208    return join '/', @r;    return join '/', @r;
1209  } # get_node_path  } # get_node_path
1210    
1211  sub get_node_link ($) {  sub get_node_link ($$) {
1212    return qq[<a href="#node-@{[refaddr $_[0]]}">] .    return qq[<a href="#$_[0]->{id_prefix}node-@{[refaddr $_[1]]}">] .
1213        htescape (get_node_path ($_[0])) . qq[</a>];        htescape (get_node_path ($_[1])) . qq[</a>];
1214  } # get_node_link  } # get_node_link
1215    
1216  {  {
# Line 703  sub get_node_link ($) { Line 1218  sub get_node_link ($) {
1218    
1219  sub load_text_catalog ($) {  sub load_text_catalog ($) {
1220    my $lang = shift; # MUST be a canonical lang name    my $lang = shift; # MUST be a canonical lang name
1221    open my $file, '<', "cc-msg.$lang.txt" or die "$0: cc-msg.$lang.txt: $!";    open my $file, '<:utf8', "cc-msg.$lang.txt"
1222          or die "$0: cc-msg.$lang.txt: $!";
1223    while (<$file>) {    while (<$file>) {
1224      if (s/^([^;]+);([^;]*);//) {      if (s/^([^;]+);([^;]*);//) {
1225        my ($type, $cls, $msg) = ($1, $2, $_);        my ($type, $cls, $msg) = ($1, $2, $_);
# Line 716  sub load_text_catalog ($) { Line 1232  sub load_text_catalog ($) {
1232  sub get_text ($) {  sub get_text ($) {
1233    my ($type, $level, $node) = @_;    my ($type, $level, $node) = @_;
1234    $type = $level . ':' . $type if defined $level;    $type = $level . ':' . $type if defined $level;
1235      $level = 'm' unless defined $level;
1236    my @arg;    my @arg;
1237    {    {
1238      if (defined $Msg->{$type}) {      if (defined $Msg->{$type}) {
# Line 740  sub get_text ($) { Line 1257  sub get_text ($) {
1257            ? htescape ($node->owner_element->manakai_local_name)            ? htescape ($node->owner_element->manakai_local_name)
1258            : ''            : ''
1259        }ge;        }ge;
1260        return ($type, $Msg->{$type}->[0], $msg);        return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);
1261      } elsif ($type =~ s/:([^:]*)$//) {      } elsif ($type =~ s/:([^:]*)$//) {
1262        unshift @arg, $1;        unshift @arg, $1;
1263        redo;        redo;
1264      }      }
1265    }    }
1266    return ($type, '', htescape ($_[0]));    return ($type, 'level-'.$level, htescape ($_[0]));
1267  } # get_text  } # get_text
1268    
1269  }  }
# Line 802  EOH Line 1319  EOH
1319      $ua->protocols_allowed ([qw/http/]);      $ua->protocols_allowed ([qw/http/]);
1320      $ua->max_size (1000_000);      $ua->max_size (1000_000);
1321      my $req = HTTP::Request->new (GET => $request_uri);      my $req = HTTP::Request->new (GET => $request_uri);
1322        $req->header ('Accept-Encoding' => 'identity, *; q=0');
1323      my $res = $ua->request ($req);      my $res = $ua->request ($req);
1324      ## TODO: 401 sets |is_success| true.      ## TODO: 401 sets |is_success| true.
1325      if ($res->is_success or $http->get_parameter ('error-page')) {      if ($res->is_success or $http->get_parameter ('error-page')) {
# Line 811  EOH Line 1329  EOH
1329    
1330        ## TODO: More strict parsing...        ## TODO: More strict parsing...
1331        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
1332        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) {  
1333          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1334          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1335            $r->{official_charset} = $r->{charset};
1336        }        }
1337    
1338        my $input_charset = $http->get_parameter ('charset');        my $input_charset = $http->get_parameter ('charset');
# Line 824  EOH Line 1340  EOH
1340          $r->{charset_overridden}          $r->{charset_overridden}
1341              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1342          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
1343        }        }
1344    
1345          ## TODO: Support for HTTP Content-Encoding
1346    
1347        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
1348    
1349          require Whatpm::ContentType;
1350          ($r->{official_type}, $r->{media_type})
1351              = Whatpm::ContentType->get_sniffed_type
1352                  (get_file_head => sub {
1353                     return substr $r->{s}, 0, shift;
1354                   },
1355                   http_content_type_byte => $ct,
1356                   has_http_content_encoding =>
1357                       defined $res->header ('Content-Encoding'),
1358                   supported_image_types => {});
1359      } else {      } else {
1360        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1361        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 847  EOH Line 1376  EOH
1376      $r->{charset} = ''.$http->get_parameter ('_charset_');      $r->{charset} = ''.$http->get_parameter ('_charset_');
1377      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1378      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1379        $r->{official_charset} = $r->{charset};
1380      $r->{header_field} = [];      $r->{header_field} = [];
1381    
1382        require Whatpm::ContentType;
1383        ($r->{official_type}, $r->{media_type})
1384            = Whatpm::ContentType->get_sniffed_type
1385                (get_file_head => sub {
1386                   return substr $r->{s}, 0, shift;
1387                 },
1388                 http_content_type_byte => undef,
1389                 has_http_content_encoding => 0,
1390                 supported_image_types => {});
1391    }    }
1392    
1393    my $input_format = $http->get_parameter ('i');    my $input_format = $http->get_parameter ('i');
# Line 864  EOH Line 1404  EOH
1404    if ($r->{media_type} eq 'text/xml') {    if ($r->{media_type} eq 'text/xml') {
1405      unless (defined $r->{charset}) {      unless (defined $r->{charset}) {
1406        $r->{charset} = 'us-ascii';        $r->{charset} = 'us-ascii';
1407          $r->{official_charset} = $r->{charset};
1408      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {      } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {
1409        $r->{charset_overridden} = 0;        $r->{charset_overridden} = 0;
1410      }      }
# Line 875  EOH Line 1416  EOH
1416      return $r;      return $r;
1417    }    }
1418    
1419      $r->{inner_html_element} = $http->get_parameter ('e');
1420    
1421    return $r;    return $r;
1422  } # get_input_document  } # get_input_document
1423    
# Line 907  Wakaba <w@suika.fam.cx>. Line 1450  Wakaba <w@suika.fam.cx>.
1450    
1451  =head1 LICENSE  =head1 LICENSE
1452    
1453  Copyright 2007 Wakaba <w@suika.fam.cx>  Copyright 2007-2008 Wakaba <w@suika.fam.cx>
1454    
1455  This library is free software; you can redistribute it  This library is free software; you can redistribute it
1456  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.20  
changed lines
  Added in v.1.37
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24