/[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.25 by wakaba, Sun Nov 18 05:30:03 2007 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 61  sub htescape ($) { Line 62  sub htescape ($) {
62  <dt>Request URI</dt>  <dt>Request URI</dt>
63      <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>
64  <dt>Document URI</dt>  <dt>Document URI</dt>
65      <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>
66        <script>
67          document.title = '<'
68              + document.getElementById ('anchor-document-uri').href + '> \\u2014 '
69              + document.title;
70        </script></dd>
71  ]; # no </dl> yet  ]; # no </dl> yet
72    push @nav, ['#document-info' => 'Information'];    push @nav, ['#document-info' => 'Information'];
73    
# Line 73  if (defined $input->{s}) { Line 79  if (defined $input->{s}) {
79      <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>
80  <dt>Internet Media Type</dt>  <dt>Internet Media Type</dt>
81      <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>      <dd><code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
82      @{[$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>
83  <dt>Character Encoding</dt>  <dt>Character Encoding</dt>
84      <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)']}
85      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>      @{[$input->{charset_overridden} ? '<em>(overridden)</em>' : '']}</dd>
# Line 88  if (defined $input->{s}) { Line 94  if (defined $input->{s}) {
94    
95    my $doc;    my $doc;
96    my $el;    my $el;
97      my $manifest;
98    
99    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
100      ($doc, $el) = print_syntax_error_html_section ($input, $result);      ($doc, $el) = print_syntax_error_html_section ($input, $result);
101      print_source_string_section (\($input->{s}), $input->{charset});      print_source_string_section
102            (\($input->{s}), $input->{charset} || $doc->input_encoding);
103    } elsif ({    } elsif ({
104              'text/xml' => 1,              'text/xml' => 1,
105              'application/atom+xml' => 1,              'application/atom+xml' => 1,
# Line 102  if (defined $input->{s}) { Line 110  if (defined $input->{s}) {
110             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
111      ($doc, $el) = print_syntax_error_xml_section ($input, $result);      ($doc, $el) = print_syntax_error_xml_section ($input, $result);
112      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
113      } elsif ($input->{media_type} eq 'text/cache-manifest') {
114    ## TODO: MUST be text/cache-manifest
115        $manifest = print_syntax_error_manifest_section ($input, $result);
116        print_source_string_section (\($input->{s}), 'utf-8');
117    } else {    } else {
118      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
119      print_result_unknown_type_section ($input);      print_result_unknown_type_section ($input, $result);
120    }    }
121    
122    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
123      print_structure_dump_section ($doc, $el);      print_structure_dump_dom_section ($doc, $el);
124      my $elements = print_structure_error_section ($doc, $el, $result);      my $elements = print_structure_error_dom_section ($doc, $el, $result);
125      print_table_section ($elements->{table}) if @{$elements->{table}};      print_table_section ($elements->{table}) if @{$elements->{table}};
126      print_id_section ($elements->{id}) if keys %{$elements->{id}};      print_id_section ($elements->{id}) if keys %{$elements->{id}};
127      print_term_section ($elements->{term}) if keys %{$elements->{term}};      print_term_section ($elements->{term}) if keys %{$elements->{term}};
128      print_class_section ($elements->{class}) if keys %{$elements->{class}};      print_class_section ($elements->{class}) if keys %{$elements->{class}};
129      } elsif (defined $manifest) {
130        print_structure_dump_manifest_section ($manifest);
131        print_structure_error_manifest_section ($manifest, $result);
132    }    }
133    
134    print_result_section ($result);    print_result_section ($result);
# Line 134  if (defined $input->{s}) { Line 149  if (defined $input->{s}) {
149  </html>  </html>
150  ];  ];
151    
152    for (qw/decode parse parse_xml check/) {    for (qw/decode parse parse_html parse_xml parse_manifest
153              check check_manifest/) {
154      next unless defined $time{$_};      next unless defined $time{$_};
155      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
156      print $file $char_length, "\t", $time{$_}, "\n";      print $file $char_length, "\t", $time{$_}, "\n";
# Line 209  sub print_syntax_error_html_section ($$) Line 225  sub print_syntax_error_html_section ($$)
225        
226    require Encode;    require Encode;
227    require Whatpm::HTML;    require Whatpm::HTML;
   
   $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.  
228        
   my $time1 = time;  
   my $t = Encode::decode ($input->{charset}, $input->{s});  
   $time{decode} = time - $time1;  
   
229    print STDOUT qq[    print STDOUT qq[
230  <div id="parse-errors" class="section">  <div id="parse-errors" class="section">
231  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
# Line 235  sub print_syntax_error_html_section ($$) Line 245  sub print_syntax_error_html_section ($$)
245      $type =~ tr/ /-/;      $type =~ tr/ /-/;
246      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
247      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
248      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
249        print STDOUT qq[$msg</dd>\n];
250    
251      add_error ('syntax', \%opt => $result);      add_error ('syntax', \%opt => $result);
252    };    };
253    
254    my $doc = $dom->create_document;    my $doc = $dom->create_document;
255    my $el;    my $el;
   $time1 = time;  
256    if (defined $inner_html_element and length $inner_html_element) {    if (defined $inner_html_element and length $inner_html_element) {
257        $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.
258        my $time1 = time;
259        my $t = Encode::decode ($input->{charset}, $input->{s});
260        $time{decode} = time - $time1;
261        
262      $el = $doc->create_element_ns      $el = $doc->create_element_ns
263          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
264        $time1 = time;
265      Whatpm::HTML->set_inner_html ($el, $t, $onerror);      Whatpm::HTML->set_inner_html ($el, $t, $onerror);
266        $time{parse} = time - $time1;
267    } else {    } else {
268      Whatpm::HTML->parse_string ($t => $doc, $onerror);      my $time1 = time;
269        Whatpm::HTML->parse_byte_string
270            ($input->{charset}, $input->{s} => $doc, $onerror);
271        $time{parse_html} = time - $time1;
272    }    }
273    $time{parse} = time - $time1;    
   
274    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
275    
276    return ($doc, $el);    return ($doc, $el);
# Line 297  sub print_syntax_error_xml_section ($$) Line 316  sub print_syntax_error_xml_section ($$)
316    return ($doc, undef);    return ($doc, undef);
317  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
318    
319    sub print_syntax_error_manifest_section ($$) {
320      my ($input, $result) = @_;
321    
322      require Whatpm::CacheManifest;
323    
324      print STDOUT qq[
325    <div id="parse-errors" class="section">
326    <h2>Parse Errors</h2>
327    
328    <dl>];
329      push @nav, ['#parse-errors' => 'Parse Error'];
330    
331      my $onerror = sub {
332        my (%opt) = @_;
333        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
334        print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];
335        $type =~ tr/ /-/;
336        $type =~ s/\|/%7C/g;
337        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
338        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
339        print STDOUT qq[$msg</dd>\n];
340    
341        add_error ('syntax', \%opt => $result);
342      };
343    
344      my $time1 = time;
345      my $manifest = Whatpm::CacheManifest->parse_byte_string
346          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
347      $time{parse_manifest} = time - $time1;
348    
349      print STDOUT qq[</dl></div>];
350    
351      return $manifest;
352    } # print_syntax_error_manifest_section
353    
354  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
355    require Encode;    require Encode;
356    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name
# Line 399  sub print_document_tree ($) { Line 453  sub print_document_tree ($) {
453    print STDOUT $r;    print STDOUT $r;
454  } # print_document_tree  } # print_document_tree
455    
456  sub print_structure_dump_section ($$) {  sub print_structure_dump_dom_section ($$) {
457    my ($doc, $el) = @_;    my ($doc, $el) = @_;
458    
459    print STDOUT qq[    print STDOUT qq[
# Line 411  sub print_structure_dump_section ($$) { Line 465  sub print_structure_dump_section ($$) {
465    print_document_tree ($el || $doc);    print_document_tree ($el || $doc);
466    
467    print STDOUT qq[</div>];    print STDOUT qq[</div>];
468  } # print_structure_dump_section  } # print_structure_dump_dom_section
469    
470    sub print_structure_dump_manifest_section ($) {
471      my $manifest = shift;
472    
473      print STDOUT qq[
474    <div id="dump-manifest" class="section">
475    <h2>Cache Manifest</h2>
476    ];
477      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
478    
479      print STDOUT qq[<dl><dt>Explicit entries</dt>];
480      for my $uri (@{$manifest->[0]}) {
481        my $euri = htescape ($uri);
482        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
483      }
484    
485      print STDOUT qq[<dt>Fallback entries</dt><dd>
486          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
487          <th scope=row>Fallback Entry</tr><tbody>];
488      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
489        my $euri = htescape ($uri);
490        my $euri2 = htescape ($manifest->[1]->{$uri});
491        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
492            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
493      }
494    
495      print STDOUT qq[</table><dt>Online whitelist</dt>];
496      for my $uri (@{$manifest->[2]}) {
497        my $euri = htescape ($uri);
498        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
499      }
500    
501  sub print_structure_error_section ($$$) {    print STDOUT qq[</dl></div>];
502    } # print_structure_dump_manifest_section
503    
504    sub print_structure_error_dom_section ($$$) {
505    my ($doc, $el, $result) = @_;    my ($doc, $el, $result) = @_;
506    
507    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="document-errors" class="section">
# Line 429  sub print_structure_error_section ($$$) Line 517  sub print_structure_error_section ($$$)
517      $type =~ tr/ /-/;      $type =~ tr/ /-/;
518      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
519      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
520      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
521          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
522        print STDOUT $msg, "</dd>\n";
523      add_error ('structure', \%opt => $result);      add_error ('structure', \%opt => $result);
524    };    };
525    
# Line 446  sub print_structure_error_section ($$$) Line 535  sub print_structure_error_section ($$$)
535    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
536    
537    return $elements;    return $elements;
538  } # print_structure_error_section  } # print_structure_error_dom_section
539    
540    sub print_structure_error_manifest_section ($$$) {
541      my ($manifest, $result) = @_;
542    
543      print STDOUT qq[<div id="document-errors" class="section">
544    <h2>Document Errors</h2>
545    
546    <dl>];
547      push @nav, ['#document-errors' => 'Document Error'];
548    
549      require Whatpm::CacheManifest;
550      Whatpm::CacheManifest->check_manifest ($manifest, sub {
551        my %opt = @_;
552        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
553        $type =~ tr/ /-/;
554        $type =~ s/\|/%7C/g;
555        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
556        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
557            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
558        add_error ('structure', \%opt => $result);
559      });
560    
561      print STDOUT qq[</div>];
562    } # print_structure_error_manifest_section
563    
564  sub print_table_section ($) {  sub print_table_section ($) {
565    my $tables = shift;    my $tables = shift;
# Line 571  sub print_result_section ($) { Line 684  sub print_result_section ($) {
684  <div id="result-summary" class="section">  <div id="result-summary" class="section">
685  <h2>Result</h2>];  <h2>Result</h2>];
686    
687    if ($result->{unsupported}) {      if ($result->{unsupported} and $result->{conforming_max}) {  
688      print STDOUT qq[<p class=uncertain id=result-para>The conformance      print STDOUT qq[<p class=uncertain id=result-para>The conformance
689          checker cannot decide whether the document is conforming or          checker cannot decide whether the document is conforming or
690          not, since the document contains one or more unsupported          not, since the document contains one or more unsupported
691          features.</p>];          features.  The document might or might not be conforming.</p>];
692    } elsif ($result->{conforming_min}) {    } elsif ($result->{conforming_min}) {
693      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
694          found in this document.</p>];          found in this document.</p>];
# Line 591  sub print_result_section ($) { Line 704  sub print_result_section ($) {
704    print STDOUT qq[<table>    print STDOUT qq[<table>
705  <colgroup><col><colgroup><col><col><col><colgroup><col>  <colgroup><col><colgroup><col><col><col><colgroup><col>
706  <thead>  <thead>
707  <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level  <tr><th scope=col></th>
708  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
709  Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>  Errors</a></th>
710  </thead><tbody>];  <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
711    Errors</a></th>
712    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
713    <th scope=col>Score</th></tr></thead><tbody>];
714    
715    my $must_error = 0;    my $must_error = 0;
716    my $should_error = 0;    my $should_error = 0;
# Line 602  Errors</th><th scope=col>Warnings</th><t Line 718  Errors</th><th scope=col>Warnings</th><t
718    my $score_min = 0;    my $score_min = 0;
719    my $score_max = 0;    my $score_max = 0;
720    my $score_base = 20;    my $score_base = 20;
721      my $score_unit = $score_base / 100;
722    for (    for (
723      [Transfer => 'transfer', ''],      [Transfer => 'transfer', ''],
724      [Character => 'char', ''],      [Character => 'char', ''],
# Line 611  Errors</th><th scope=col>Warnings</th><t Line 728  Errors</th><th scope=col>Warnings</th><t
728      $must_error += ($result->{$_->[1]}->{must} += 0);      $must_error += ($result->{$_->[1]}->{must} += 0);
729      $should_error += ($result->{$_->[1]}->{should} += 0);      $should_error += ($result->{$_->[1]}->{should} += 0);
730      $warning += ($result->{$_->[1]}->{warning} += 0);      $warning += ($result->{$_->[1]}->{warning} += 0);
731      $score_min += ($result->{$_->[1]}->{score_min} += $score_base);      $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
732      $score_max += ($result->{$_->[1]}->{score_max} += $score_base);      $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
733    
734      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';      my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
735      my $label = $_->[0];      my $label = $_->[0];
# Line 625  Errors</th><th scope=col>Warnings</th><t Line 742  Errors</th><th scope=col>Warnings</th><t
742    
743      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>];
744      if ($uncertain) {      if ($uncertain) {
745        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>];
746      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {      } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
747        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>];
748      } else {      } else {
749        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>];
750      }      }
751    }    }
752    
# Line 638  Errors</th><th scope=col>Warnings</th><t Line 755  Errors</th><th scope=col>Warnings</th><t
755    print STDOUT qq[    print STDOUT qq[
756  <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>
757  </tbody>  </tbody>
758  <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>
759    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
760    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
761    <td>$warning?</td>
762    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
763  </table>  </table>
764    
765  <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 768  is <em>under development</em>.  The resu
768    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
769  } # print_result_section  } # print_result_section
770    
771  sub print_result_unknown_type_section ($) {  sub print_result_unknown_type_section ($$) {
772    my $input = shift;    my ($input, $result) = @_;
773    
774      my $euri = htescape ($input->{uri});
775    print STDOUT qq[    print STDOUT qq[
776  <div id="result-summary" class="section">  <div id="parse-errors" class="section">
777  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  <h2>Errors</h2>
778    
779    <dl>
780    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
781        <dd class=unsupported><strong><a href="../error-description#level-u">Not
782            supported</a></strong>:
783        Media type
784        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
785        is not supported.</dd>
786    </dl>
787  </div>  </div>
788  ];  ];
789    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#parse-errors' => 'Errors'];
790      add_error (char => {level => 'unsupported'} => $result);
791      add_error (syntax => {level => 'unsupported'} => $result);
792      add_error (structure => {level => 'unsupported'} => $result);
793  } # print_result_unknown_type_section  } # print_result_unknown_type_section
794    
795  sub print_result_input_error_section ($) {  sub print_result_input_error_section ($) {
# Line 666  sub print_result_input_error_section ($) Line 800  sub print_result_input_error_section ($)
800    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
801  } # print_Result_input_error_section  } # print_Result_input_error_section
802    
803    sub get_error_label ($) {
804      my $err = shift;
805    
806      my $r = '';
807    
808      if (defined $err->{line}) {
809        if ($err->{column} > 0) {
810          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
811        } else {
812          $err->{line} = $err->{line} - 1 || 1;
813          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
814        }
815      }
816    
817      if (defined $err->{node}) {
818        $r .= ' ' if length $r;
819        $r = get_node_link ($err->{node});
820      }
821    
822      if (defined $err->{index}) {
823        $r .= ' ' if length $r;
824        $r .= 'Index ' . (0+$err->{index});
825      }
826    
827      if (defined $err->{value}) {
828        $r .= ' ' if length $r;
829        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
830      }
831    
832      return $r;
833    } # get_error_label
834    
835    sub get_error_level_label ($) {
836      my $err = shift;
837    
838      my $r = '';
839    
840      if (not defined $err->{level} or $err->{level} eq 'm') {
841        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
842            error</a></strong>: ];
843      } elsif ($err->{level} eq 's') {
844        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
845            error</a></strong>: ];
846      } elsif ($err->{level} eq 'w') {
847        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
848            ];
849      } elsif ($err->{level} eq 'unsupported') {
850        $r = qq[<strong><a href="../error-description#level-u">Not
851            supported</a></strong>: ];
852      } else {
853        my $elevel = htescape ($err->{level});
854        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
855            ];
856      }
857    
858      return $r;
859    } # get_error_level_label
860    
861  sub get_node_path ($) {  sub get_node_path ($) {
862    my $node = shift;    my $node = shift;
863    my @r;    my @r;
# Line 811  EOH Line 1003  EOH
1003    
1004        ## TODO: More strict parsing...        ## TODO: More strict parsing...
1005        my $ct = $res->header ('Content-Type');        my $ct = $res->header ('Content-Type');
1006        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) {  
1007          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1008          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1009        }        }
# Line 824  EOH Line 1013  EOH
1013          $r->{charset_overridden}          $r->{charset_overridden}
1014              = (not defined $r->{charset} or $r->{charset} ne $input_charset);              = (not defined $r->{charset} or $r->{charset} ne $input_charset);
1015          $r->{charset} = $input_charset;          $r->{charset} = $input_charset;
1016        }        }
1017    
1018          ## TODO: Support for HTTP Content-Encoding
1019    
1020        $r->{s} = ''.$res->content;        $r->{s} = ''.$res->content;
1021    
1022          require Whatpm::ContentType;
1023          ($r->{official_type}, $r->{media_type})
1024              = Whatpm::ContentType->get_sniffed_type
1025                  (get_file_head => sub {
1026                     return substr $r->{s}, 0, shift;
1027                   },
1028                   http_content_type_byte => $ct,
1029                   has_http_content_encoding =>
1030                       defined $res->header ('Content-Encoding'),
1031                   supported_image_types => {});
1032      } else {      } else {
1033        $r->{uri} = $res->request->uri;        $r->{uri} = $res->request->uri;
1034        $r->{request_uri} = $request_uri;        $r->{request_uri} = $request_uri;
# Line 848  EOH Line 1050  EOH
1050      $r->{charset} =~ s/\s+//g;      $r->{charset} =~ s/\s+//g;
1051      $r->{charset} = 'utf-8' if $r->{charset} eq '';      $r->{charset} = 'utf-8' if $r->{charset} eq '';
1052      $r->{header_field} = [];      $r->{header_field} = [];
1053    
1054        require Whatpm::ContentType;
1055        ($r->{official_type}, $r->{media_type})
1056            = Whatpm::ContentType->get_sniffed_type
1057                (get_file_head => sub {
1058                   return substr $r->{s}, 0, shift;
1059                 },
1060                 http_content_type_byte => undef,
1061                 has_http_content_encoding => 0,
1062                 supported_image_types => {});
1063    }    }
1064    
1065    my $input_format = $http->get_parameter ('i');    my $input_format = $http->get_parameter ('i');
Legend:
Removed from v.1.20  
changed lines
  Added in v.1.25
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24