/[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.21 by wakaba, Tue Sep 11 08:25:23 2007 UTC revision 1.23 by wakaba, Mon Nov 5 09:33:52 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 88  if (defined $input->{s}) { Line 89  if (defined $input->{s}) {
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, $result);      ($doc, $el) = print_syntax_error_html_section ($input, $result);
# Line 102  if (defined $input->{s}) { Line 104  if (defined $input->{s}) {
104             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
105      ($doc, $el) = print_syntax_error_xml_section ($input, $result);      ($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);
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, $result);      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    print_result_section ($result);    print_result_section ($result);
# Line 134  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_xml parse_manifest check check_manifest/) {
147      next unless defined $time{$_};      next unless defined $time{$_};
148      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
149      print $file $char_length, "\t", $time{$_}, "\n";      print $file $char_length, "\t", $time{$_}, "\n";
# Line 235  sub print_syntax_error_html_section ($$) Line 244  sub print_syntax_error_html_section ($$)
244      $type =~ tr/ /-/;      $type =~ tr/ /-/;
245      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
246      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
247      print STDOUT qq[<dd class="$cls">$msg</dd>\n];      print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
248        print STDOUT qq[$msg</dd>\n];
249    
250      add_error ('syntax', \%opt => $result);      add_error ('syntax', \%opt => $result);
251    };    };
# Line 297  sub print_syntax_error_xml_section ($$) Line 307  sub print_syntax_error_xml_section ($$)
307    return ($doc, undef);    return ($doc, undef);
308  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
309    
310    sub print_syntax_error_manifest_section ($$) {
311      my ($input, $result) = @_;
312    
313      require Whatpm::CacheManifest;
314    
315      print STDOUT qq[
316    <div id="parse-errors" class="section">
317    <h2>Parse Errors</h2>
318    
319    <dl>];
320      push @nav, ['#parse-errors' => 'Parse Error'];
321    
322      my $onerror = sub {
323        my (%opt) = @_;
324        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
325        print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];
326        $type =~ tr/ /-/;
327        $type =~ s/\|/%7C/g;
328        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
329        print STDOUT qq[<dd class="$cls">], get_error_level_label (\%opt);
330        print STDOUT qq[$msg</dd>\n];
331    
332        add_error ('syntax', \%opt => $result);
333      };
334    
335      my $time1 = time;
336      my $manifest = Whatpm::CacheManifest->parse_byte_string
337          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
338      $time{parse_manifest} = time - $time1;
339    
340      print STDOUT qq[</dl></div>];
341    
342      return $manifest;
343    } # print_syntax_error_manifest_section
344    
345  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
346    require Encode;    require Encode;
347    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 444  sub print_document_tree ($) {
444    print STDOUT $r;    print STDOUT $r;
445  } # print_document_tree  } # print_document_tree
446    
447  sub print_structure_dump_section ($$) {  sub print_structure_dump_dom_section ($$) {
448    my ($doc, $el) = @_;    my ($doc, $el) = @_;
449    
450    print STDOUT qq[    print STDOUT qq[
# Line 411  sub print_structure_dump_section ($$) { Line 456  sub print_structure_dump_section ($$) {
456    print_document_tree ($el || $doc);    print_document_tree ($el || $doc);
457    
458    print STDOUT qq[</div>];    print STDOUT qq[</div>];
459  } # print_structure_dump_section  } # print_structure_dump_dom_section
460    
461    sub print_structure_dump_manifest_section ($) {
462      my $manifest = shift;
463    
464      print STDOUT qq[
465    <div id="dump-manifest" class="section">
466    <h2>Cache Manifest</h2>
467    ];
468      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
469    
470      print STDOUT qq[<dl><dt>Explicit entries</dt>];
471      for my $uri (@{$manifest->[0]}) {
472        my $euri = htescape ($uri);
473        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
474      }
475    
476      print STDOUT qq[<dt>Fallback entries</dt><dd>
477          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
478          <th scope=row>Fallback Entry</tr><tbody>];
479      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
480        my $euri = htescape ($uri);
481        my $euri2 = htescape ($manifest->[1]->{$uri});
482        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
483            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
484      }
485    
486      print STDOUT qq[</table><dt>Online whitelist</dt>];
487      for my $uri (@{$manifest->[2]}) {
488        my $euri = htescape ($uri);
489        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
490      }
491    
492      print STDOUT qq[</dl></div>];
493    } # print_structure_dump_manifest_section
494    
495  sub print_structure_error_section ($$$) {  sub print_structure_error_dom_section ($$$) {
496    my ($doc, $el, $result) = @_;    my ($doc, $el, $result) = @_;
497    
498    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 508  sub print_structure_error_section ($$$)
508      $type =~ tr/ /-/;      $type =~ tr/ /-/;
509      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
510      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
511      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
512          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], get_error_level_label (\%opt);
513        print STDOUT $msg, "</dd>\n";
514      add_error ('structure', \%opt => $result);      add_error ('structure', \%opt => $result);
515    };    };
516    
# Line 446  sub print_structure_error_section ($$$) Line 526  sub print_structure_error_section ($$$)
526    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
527    
528    return $elements;    return $elements;
529  } # print_structure_error_section  } # print_structure_error_dom_section
530    
531    sub print_structure_error_manifest_section ($$$) {
532      my ($manifest, $result) = @_;
533    
534      print STDOUT qq[<div id="document-errors" class="section">
535    <h2>Document Errors</h2>
536    
537    <dl>];
538      push @nav, ['#document-errors' => 'Document Error'];
539    
540      require Whatpm::CacheManifest;
541      Whatpm::CacheManifest->check_manifest ($manifest, sub {
542        my %opt = @_;
543        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
544        $type =~ tr/ /-/;
545        $type =~ s/\|/%7C/g;
546        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
547        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
548            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
549        add_error ('structure', \%opt => $result);
550      });
551    
552      print STDOUT qq[</div>];
553    } # print_structure_error_manifest_section
554    
555  sub print_table_section ($) {  sub print_table_section ($) {
556    my $tables = shift;    my $tables = shift;
# Line 591  sub print_result_section ($) { Line 695  sub print_result_section ($) {
695    print STDOUT qq[<table>    print STDOUT qq[<table>
696  <colgroup><col><colgroup><col><col><col><colgroup><col>  <colgroup><col><colgroup><col><col><col><colgroup><col>
697  <thead>  <thead>
698  <tr><th scope=col></th><th scope=col><em class=rfc2119>MUST</em>-level  <tr><th scope=col></th>
699  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
700  Errors</th><th scope=col>Warnings</th><th scope=col>Score</th></tr>  Errors</a></th>
701  </thead><tbody>];  <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
702    Errors</a></th>
703    <th scope=col><a href="../error-description#level-w">Warnings</a></th>
704    <th scope=col>Score</th></tr></thead><tbody>];
705    
706    my $must_error = 0;    my $must_error = 0;
707    my $should_error = 0;    my $should_error = 0;
# Line 671  sub print_result_input_error_section ($) Line 778  sub print_result_input_error_section ($)
778    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
779  } # print_Result_input_error_section  } # print_Result_input_error_section
780    
781    sub get_error_label ($) {
782      my $err = shift;
783    
784      my $r = '';
785    
786      if (defined $err->{line}) {
787        if ($err->{column} > 0) {
788          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
789        } else {
790          $err->{line} = $err->{line} - 1 || 1;
791          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
792        }
793      }
794    
795      if (defined $err->{node}) {
796        $r .= ' ' if length $r;
797        $r = get_node_link ($err->{node});
798      }
799    
800      if (defined $err->{index}) {
801        $r .= ' ' if length $r;
802        $r .= 'Index ' . (0+$err->{index});
803      }
804    
805      if (defined $err->{value}) {
806        $r .= ' ' if length $r;
807        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
808      }
809    
810      return $r;
811    } # get_error_label
812    
813    sub get_error_level_label ($) {
814      my $err = shift;
815    
816      my $r = '';
817    
818      if (not defined $err->{level} or $err->{level} eq 'm') {
819        $r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level
820            error</a></strong>: ];
821      } elsif ($err->{level} eq 's') {
822        $r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level
823            error</a></strong>: ];
824      } elsif ($err->{level} eq 'w') {
825        $r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>:
826            ];
827      } elsif ($err->{level} eq 'unsupported') {
828        $r = qq[<strong><a href="../error-description#level-u">Not
829            supported</a></strong>: ];
830      } else {
831        my $elevel = htescape ($err->{level});
832        $r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>:
833            ];
834      }
835    
836      return $r;
837    } # get_error_level_label
838    
839  sub get_node_path ($) {  sub get_node_path ($) {
840    my $node = shift;    my $node = shift;
841    my @r;    my @r;
# Line 819  EOH Line 984  EOH
984        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._+-]+)#) {
985          $r->{media_type} = lc $1;          $r->{media_type} = lc $1;
986        }        }
987        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?(\S+)"?/i) {        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
988          $r->{charset} = lc $1;          $r->{charset} = lc $1;
989          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
990        }        }
Legend:
Removed from v.1.21  
changed lines
  Added in v.1.23
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24