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