/[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.18 by wakaba, Sun Sep 2 08:40:49 2007 UTC revision 1.24 by wakaba, Sun Nov 11 06:57:16 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 83  if (defined $input->{s}) { Line 84  if (defined $input->{s}) {
84  </div>  </div>
85  ];  ];
86    
87    print_http_header_section ($input);    my $result = {conforming_min => 1, conforming_max => 1};
88      print_http_header_section ($input, $result);
89    
90    my $doc;    my $doc;
91    my $el;    my $el;
92      my $manifest;
93    
94    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
95      ($doc, $el) = print_syntax_error_html_section ($input);      ($doc, $el) = print_syntax_error_html_section ($input, $result);
96      print_source_string_section (\($input->{s}), $input->{charset});      print_source_string_section (\($input->{s}), $input->{charset});
97    } elsif ({    } elsif ({
98              'text/xml' => 1,              'text/xml' => 1,
# Line 99  if (defined $input->{s}) { Line 102  if (defined $input->{s}) {
102              'application/xhtml+xml' => 1,              'application/xhtml+xml' => 1,
103              'application/xml' => 1,              'application/xml' => 1,
104             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
105      ($doc, $el) = print_syntax_error_xml_section ($input);      ($doc, $el) = print_syntax_error_xml_section ($input, $result);
106      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
107      } elsif ($input->{media_type} eq 'text/cache-manifest') {
108    ## TODO: MUST be text/cache-manifest
109        $manifest = print_syntax_error_manifest_section ($input, $result);
110        print_source_string_section (\($input->{s}), 'utf-8');
111    } else {    } else {
112      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
113      print_result_unknown_type_section ($input);      print_result_unknown_type_section ($input, $result);
114    }    }
115    
116    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
117      print_structure_dump_section ($doc, $el);      print_structure_dump_dom_section ($doc, $el);
118      my $elements = print_structure_error_section ($doc, $el);      my $elements = print_structure_error_dom_section ($doc, $el, $result);
119      print_table_section ($elements->{table}) if @{$elements->{table}};      print_table_section ($elements->{table}) if @{$elements->{table}};
120      print_id_section ($elements->{id}) if keys %{$elements->{id}};      print_id_section ($elements->{id}) if keys %{$elements->{id}};
121      print_term_section ($elements->{term}) if keys %{$elements->{term}};      print_term_section ($elements->{term}) if keys %{$elements->{term}};
122      print_class_section ($elements->{class}) if keys %{$elements->{class}};      print_class_section ($elements->{class}) if keys %{$elements->{class}};
123      } elsif (defined $manifest) {
124        print_structure_dump_manifest_section ($manifest);
125        print_structure_error_manifest_section ($manifest, $result);
126    }    }
127    
128    ## TODO: Show result    print_result_section ($result);
129  } else {  } else {
130    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
131    print_result_input_error_section ($input);    print_result_input_error_section ($input);
# Line 133  if (defined $input->{s}) { Line 143  if (defined $input->{s}) {
143  </html>  </html>
144  ];  ];
145    
146    for (qw/decode parse parse_xml check/) {    for (qw/decode parse parse_html parse_xml parse_manifest
147              check check_manifest/) {
148      next unless defined $time{$_};      next unless defined $time{$_};
149      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
150      print $file $char_length, "\t", $time{$_}, "\n";      print $file $char_length, "\t", $time{$_}, "\n";
# Line 141  if (defined $input->{s}) { Line 152  if (defined $input->{s}) {
152    
153  exit;  exit;
154    
155  sub print_http_header_section ($) {  sub add_error ($$$) {
156    my $input = shift;    my ($layer, $err, $result) = @_;
157      if (defined $err->{level}) {
158        if ($err->{level} eq 's') {
159          $result->{$layer}->{should}++;
160          $result->{$layer}->{score_min} -= 2;
161          $result->{conforming_min} = 0;
162        } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {
163          $result->{$layer}->{warning}++;
164        } elsif ($err->{level} eq 'unsupported') {
165          $result->{$layer}->{unsupported}++;
166          $result->{unsupported} = 1;
167        } else {
168          $result->{$layer}->{must}++;
169          $result->{$layer}->{score_max} -= 2;
170          $result->{$layer}->{score_min} -= 2;
171          $result->{conforming_min} = 0;
172          $result->{conforming_max} = 0;
173        }
174      } else {
175        $result->{$layer}->{must}++;
176        $result->{$layer}->{score_max} -= 2;
177        $result->{$layer}->{score_min} -= 2;
178        $result->{conforming_min} = 0;
179        $result->{conforming_max} = 0;
180      }
181    } # add_error
182    
183    sub print_http_header_section ($$) {
184      my ($input, $result) = @_;
185    return unless defined $input->{header_status_code} or    return unless defined $input->{header_status_code} or
186        defined $input->{header_status_text} or        defined $input->{header_status_text} or
187        @{$input->{header_field}};        @{$input->{header_field}};
# Line 175  not be the real header.</p> Line 214  not be the real header.</p>
214    print STDOUT qq[</tbody></table></div>];    print STDOUT qq[</tbody></table></div>];
215  } # print_http_header_section  } # print_http_header_section
216    
217  sub print_syntax_error_html_section ($) {  sub print_syntax_error_html_section ($$) {
218    my $input = shift;    my ($input, $result) = @_;
219        
220    require Encode;    require Encode;
221    require Whatpm::HTML;    require Whatpm::HTML;
   
   $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.  
222        
   my $time1 = time;  
   my $t = Encode::decode ($input->{charset}, $input->{s});  
   $time{decode} = time - $time1;  
   
223    print STDOUT qq[    print STDOUT qq[
224  <div id="parse-errors" class="section">  <div id="parse-errors" class="section">
225  <h2>Parse Errors</h2>  <h2>Parse Errors</h2>
# Line 206  sub print_syntax_error_html_section ($) Line 239  sub print_syntax_error_html_section ($)
239      $type =~ tr/ /-/;      $type =~ tr/ /-/;
240      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
241      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
242      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
243        print STDOUT qq[$msg</dd>\n];
244    
245        add_error ('syntax', \%opt => $result);
246    };    };
247    
248    my $doc = $dom->create_document;    my $doc = $dom->create_document;
249    my $el;    my $el;
   $time1 = time;  
250    if (defined $inner_html_element and length $inner_html_element) {    if (defined $inner_html_element and length $inner_html_element) {
251        $input->{charset} ||= 'ISO-8859-1'; ## TODO: for now.
252        my $time1 = time;
253        my $t = Encode::decode ($input->{charset}, $input->{s});
254        $time{decode} = time - $time1;
255        
256      $el = $doc->create_element_ns      $el = $doc->create_element_ns
257          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);          ('http://www.w3.org/1999/xhtml', [undef, $inner_html_element]);
258        $time1 = time;
259      Whatpm::HTML->set_inner_html ($el, $t, $onerror);      Whatpm::HTML->set_inner_html ($el, $t, $onerror);
260        $time{parse} = time - $time1;
261    } else {    } else {
262      Whatpm::HTML->parse_string ($t => $doc, $onerror);      my $time1 = time;
263        Whatpm::HTML->parse_byte_string
264            ($input->{charset}, $input->{s} => $doc, $onerror);
265        $time{parse_html} = time - $time1;
266    }    }
267    $time{parse} = time - $time1;    
   
268    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
269    
270    return ($doc, $el);    return ($doc, $el);
271  } # print_syntax_error_html_section  } # print_syntax_error_html_section
272    
273  sub print_syntax_error_xml_section ($) {  sub print_syntax_error_xml_section ($$) {
274    my $input = shift;    my ($input, $result) = @_;
275        
276    require Message::DOM::XMLParserTemp;    require Message::DOM::XMLParserTemp;
277        
# Line 244  sub print_syntax_error_xml_section ($) { Line 288  sub print_syntax_error_xml_section ($) {
288      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];      print STDOUT qq[<dt><a href="#line-$line">Line $line</a> column ];
289      print STDOUT $err->location->column_number, "</dt><dd>";      print STDOUT $err->location->column_number, "</dt><dd>";
290      print STDOUT htescape $err->text, "</dd>\n";      print STDOUT htescape $err->text, "</dd>\n";
291    
292        add_error ('syntax', {type => $err->text,
293                    level => [
294                              $err->SEVERITY_FATAL_ERROR => 'm',
295                              $err->SEVERITY_ERROR => 'm',
296                              $err->SEVERITY_WARNING => 's',
297                             ]->[$err->severity]} => $result);
298    
299      return 1;      return 1;
300    };    };
301    
# Line 258  sub print_syntax_error_xml_section ($) { Line 310  sub print_syntax_error_xml_section ($) {
310    return ($doc, undef);    return ($doc, undef);
311  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
312    
313    sub print_syntax_error_manifest_section ($$) {
314      my ($input, $result) = @_;
315    
316      require Whatpm::CacheManifest;
317    
318      print STDOUT qq[
319    <div id="parse-errors" class="section">
320    <h2>Parse Errors</h2>
321    
322    <dl>];
323      push @nav, ['#parse-errors' => 'Parse Error'];
324    
325      my $onerror = sub {
326        my (%opt) = @_;
327        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
328        print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];
329        $type =~ tr/ /-/;
330        $type =~ s/\|/%7C/g;
331        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
332        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
333        print STDOUT qq[$msg</dd>\n];
334    
335        add_error ('syntax', \%opt => $result);
336      };
337    
338      my $time1 = time;
339      my $manifest = Whatpm::CacheManifest->parse_byte_string
340          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
341      $time{parse_manifest} = time - $time1;
342    
343      print STDOUT qq[</dl></div>];
344    
345      return $manifest;
346    } # print_syntax_error_manifest_section
347    
348  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
349    require Encode;    require Encode;
350    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name    my $enc = Encode::find_encoding ($_[1]); ## TODO: charset name -> Perl name
# Line 360  sub print_document_tree ($) { Line 447  sub print_document_tree ($) {
447    print STDOUT $r;    print STDOUT $r;
448  } # print_document_tree  } # print_document_tree
449    
450  sub print_structure_dump_section ($$) {  sub print_structure_dump_dom_section ($$) {
451    my ($doc, $el) = @_;    my ($doc, $el) = @_;
452    
453    print STDOUT qq[    print STDOUT qq[
# Line 372  sub print_structure_dump_section ($$) { Line 459  sub print_structure_dump_section ($$) {
459    print_document_tree ($el || $doc);    print_document_tree ($el || $doc);
460    
461    print STDOUT qq[</div>];    print STDOUT qq[</div>];
462  } # print_structure_dump_section  } # print_structure_dump_dom_section
463    
464  sub print_structure_error_section ($$) {  sub print_structure_dump_manifest_section ($) {
465    my ($doc, $el) = @_;    my $manifest = shift;
466    
467      print STDOUT qq[
468    <div id="dump-manifest" class="section">
469    <h2>Cache Manifest</h2>
470    ];
471      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
472    
473      print STDOUT qq[<dl><dt>Explicit entries</dt>];
474      for my $uri (@{$manifest->[0]}) {
475        my $euri = htescape ($uri);
476        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
477      }
478    
479      print STDOUT qq[<dt>Fallback entries</dt><dd>
480          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
481          <th scope=row>Fallback Entry</tr><tbody>];
482      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
483        my $euri = htescape ($uri);
484        my $euri2 = htescape ($manifest->[1]->{$uri});
485        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
486            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
487      }
488    
489      print STDOUT qq[</table><dt>Online whitelist</dt>];
490      for my $uri (@{$manifest->[2]}) {
491        my $euri = htescape ($uri);
492        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
493      }
494    
495      print STDOUT qq[</dl></div>];
496    } # print_structure_dump_manifest_section
497    
498    sub print_structure_error_dom_section ($$$) {
499      my ($doc, $el, $result) = @_;
500    
501    print STDOUT qq[<div id="document-errors" class="section">    print STDOUT qq[<div id="document-errors" class="section">
502  <h2>Document Errors</h2>  <h2>Document Errors</h2>
# Line 390  sub print_structure_error_section ($$) { Line 511  sub print_structure_error_section ($$) {
511      $type =~ tr/ /-/;      $type =~ tr/ /-/;
512      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
513      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
514      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
515          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
516        print STDOUT $msg, "</dd>\n";
517        add_error ('structure', \%opt => $result);
518    };    };
519    
520    my $elements;    my $elements;
# Line 406  sub print_structure_error_section ($$) { Line 529  sub print_structure_error_section ($$) {
529    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
530    
531    return $elements;    return $elements;
532  } # print_structure_error_section  } # print_structure_error_dom_section
533    
534    sub print_structure_error_manifest_section ($$$) {
535      my ($manifest, $result) = @_;
536    
537      print STDOUT qq[<div id="document-errors" class="section">
538    <h2>Document Errors</h2>
539    
540    <dl>];
541      push @nav, ['#document-errors' => 'Document Error'];
542    
543      require Whatpm::CacheManifest;
544      Whatpm::CacheManifest->check_manifest ($manifest, sub {
545        my %opt = @_;
546        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
547        $type =~ tr/ /-/;
548        $type =~ s/\|/%7C/g;
549        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
550        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
551            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
552        add_error ('structure', \%opt => $result);
553      });
554    
555      print STDOUT qq[</div>];
556    } # print_structure_error_manifest_section
557    
558  sub print_table_section ($) {  sub print_table_section ($) {
559    my $tables = shift;    my $tables = shift;
# Line 524  sub print_class_section ($) { Line 671  sub print_class_section ($) {
671    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
672  } # print_class_section  } # print_class_section
673    
674  sub print_result_unknown_type_section ($) {  sub print_result_section ($) {
675    my $input = shift;    my $result = shift;
676    
677    print STDOUT qq[    print STDOUT qq[
678  <div id="result-summary" class="section">  <div id="result-summary" class="section">
679  <p><em>Media type <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code> is not supported!</em></p>  <h2>Result</h2>];
680    
681      if ($result->{unsupported} and $result->{conforming_max}) {  
682        print STDOUT qq[<p class=uncertain id=result-para>The conformance
683            checker cannot decide whether the document is conforming or
684            not, since the document contains one or more unsupported
685            features.  The document might or might not be conforming.</p>];
686      } elsif ($result->{conforming_min}) {
687        print STDOUT qq[<p class=PASS id=result-para>No conformance-error is
688            found in this document.</p>];
689      } elsif ($result->{conforming_max}) {
690        print STDOUT qq[<p class=SEE-RESULT id=result-para>This document
691            is <strong>likely <em>non</em>-conforming</strong>, but in rare case
692            it might be conforming.</p>];
693      } else {
694        print STDOUT qq[<p class=FAIL id=result-para>This document is
695            <strong><em>non</em>-conforming</strong>.</p>];
696      }
697    
698      print STDOUT qq[<table>
699    <colgroup><col><colgroup><col><col><col><colgroup><col>
700    <thead>
701    <tr><th scope=col></th>
702    <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
703    Errors</a></th>
704    <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
705    Errors</a></th>
706    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
707    <th scope=col>Score</th></tr></thead><tbody>];
708    
709      my $must_error = 0;
710      my $should_error = 0;
711      my $warning = 0;
712      my $score_min = 0;
713      my $score_max = 0;
714      my $score_base = 20;
715      my $score_unit = $score_base / 100;
716      for (
717        [Transfer => 'transfer', ''],
718        [Character => 'char', ''],
719        [Syntax => 'syntax', '#parse-errors'],
720        [Structure => 'structure', '#document-errors'],
721      ) {
722        $must_error += ($result->{$_->[1]}->{must} += 0);
723        $should_error += ($result->{$_->[1]}->{should} += 0);
724        $warning += ($result->{$_->[1]}->{warning} += 0);
725        $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);
726        $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);
727    
728        my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';
729        my $label = $_->[0];
730        if ($result->{$_->[1]}->{must} or
731            $result->{$_->[1]}->{should} or
732            $result->{$_->[1]}->{warning} or
733            $result->{$_->[1]}->{unsupported}) {
734          $label = qq[<a href="$_->[2]">$label</a>];
735        }
736    
737        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>];
738        if ($uncertain) {
739          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}</td>];
740        } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {
741          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}</td></tr>];
742        } else {
743          print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}</td></tr>];
744        }
745      }
746    
747      $score_max += $score_base;
748    
749      print STDOUT qq[
750    <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base</td></tr>
751    </tbody>
752    <tfoot><tr class=uncertain><th scope=row>Total</th>
753    <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>
754    <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>
755    <td>$warning?</td>
756    <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong></td></tr></tfoot>
757    </table>
758    
759    <p><strong>Important</strong>: This conformance checking service
760    is <em>under development</em>.  The result above might be <em>wrong</em>.</p>
761    </div>];
762      push @nav, ['#result-summary' => 'Result'];
763    } # print_result_section
764    
765    sub print_result_unknown_type_section ($$) {
766      my ($input, $result) = @_;
767    
768      my $euri = htescape ($input->{uri});
769      print STDOUT qq[
770    <div id="parse-errors" class="section">
771    <h2>Errors</h2>
772    
773    <dl>
774    <dt class=unsupported><code>&lt;<a href="$euri">$euri</a>&gt;</code></dt>
775        <dd class=unsupported><strong><a href="../error-description#level-u">Not
776            supported</a></strong>:
777        Media type
778        <code class="MIME" lang="en">@{[htescape $input->{media_type}]}</code>
779        is not supported.</dd>
780    </dl>
781  </div>  </div>
782  ];  ];
783    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#parse-errors' => 'Errors'];
784      add_error (char => {level => 'unsupported'} => $result);
785      add_error (syntax => {level => 'unsupported'} => $result);
786      add_error (structure => {level => 'unsupported'} => $result);
787  } # print_result_unknown_type_section  } # print_result_unknown_type_section
788    
789  sub print_result_input_error_section ($) {  sub print_result_input_error_section ($) {
# Line 543  sub print_result_input_error_section ($) Line 794  sub print_result_input_error_section ($)
794    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
795  } # print_Result_input_error_section  } # print_Result_input_error_section
796    
797    sub get_error_label ($) {
798      my $err = shift;
799    
800      my $r = '';
801    
802      if (defined $err->{line}) {
803        if ($err->{column} > 0) {
804          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
805        } else {
806          $err->{line} = $err->{line} - 1 || 1;
807          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
808        }
809      }
810    
811      if (defined $err->{node}) {
812        $r .= ' ' if length $r;
813        $r = get_node_link ($err->{node});
814      }
815    
816      if (defined $err->{index}) {
817        $r .= ' ' if length $r;
818        $r .= 'Index ' . (0+$err->{index});
819      }
820    
821      if (defined $err->{value}) {
822        $r .= ' ' if length $r;
823        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
824      }
825    
826      return $r;
827    } # get_error_label
828    
829    sub get_error_level_label ($) {
830      my $err = shift;
831    
832      my $r = '';
833    
834      if (not defined $err->{level} or $err->{level} eq 'm') {
835        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
836            error</a></strong>: ];
837      } elsif ($err->{level} eq 's') {
838        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
839            error</a></strong>: ];
840      } elsif ($err->{level} eq 'w') {
841        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
842            ];
843      } elsif ($err->{level} eq 'unsupported') {
844        $r = qq[<strong><a href="../error-description#level-u">Not
845            supported</a></strong>: ];
846      } else {
847        my $elevel = htescape ($err->{level});
848        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
849            ];
850      }
851    
852      return $r;
853    } # get_error_level_label
854    
855  sub get_node_path ($) {  sub get_node_path ($) {
856    my $node = shift;    my $node = shift;
857    my @r;    my @r;
# Line 691  EOH Line 1000  EOH
1000        if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {        if (defined $ct and $ct =~ m#^([0-9A-Za-z._+-]+/[0-9A-Za-z._+-]+)#) {
1001          $r->{media_type} = lc $1;          $r->{media_type} = lc $1;
1002        }        }
1003        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?(\S+)"?/i) {        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
1004          $r->{charset} = lc $1;          $r->{charset} = lc $1;
1005          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
1006        }        }
Legend:
Removed from v.1.18  
changed lines
  Added in v.1.24
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24