/[suikacvs]/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.22 by wakaba, Sun Nov 4 09:15:02 2007 UTC
# Line 88  if (defined $input->{s}) { Line 88  if (defined $input->{s}) {
88    
89    my $doc;    my $doc;
90    my $el;    my $el;
91      my $manifest;
92    
93    if ($input->{media_type} eq 'text/html') {    if ($input->{media_type} eq 'text/html') {
94      ($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 103  if (defined $input->{s}) {
103             }->{$input->{media_type}}) {             }->{$input->{media_type}}) {
104      ($doc, $el) = print_syntax_error_xml_section ($input, $result);      ($doc, $el) = print_syntax_error_xml_section ($input, $result);
105      print_source_string_section (\($input->{s}), $doc->input_encoding);      print_source_string_section (\($input->{s}), $doc->input_encoding);
106      } elsif ($input->{media_type} eq 'text/cache-manifest') {
107    ## TODO: MUST be text/cache-manifest
108        $manifest = print_syntax_error_manifest_section ($input, $result);
109        print_source_string_section (\($input->{s}), 'utf-8');
110    } else {    } else {
111      ## TODO: Change HTTP status code??      ## TODO: Change HTTP status code??
112      print_result_unknown_type_section ($input);      print_result_unknown_type_section ($input);
113    }    }
114    
115    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
116      print_structure_dump_section ($doc, $el);      print_structure_dump_dom_section ($doc, $el);
117      my $elements = print_structure_error_section ($doc, $el, $result);      my $elements = print_structure_error_dom_section ($doc, $el, $result);
118      print_table_section ($elements->{table}) if @{$elements->{table}};      print_table_section ($elements->{table}) if @{$elements->{table}};
119      print_id_section ($elements->{id}) if keys %{$elements->{id}};      print_id_section ($elements->{id}) if keys %{$elements->{id}};
120      print_term_section ($elements->{term}) if keys %{$elements->{term}};      print_term_section ($elements->{term}) if keys %{$elements->{term}};
121      print_class_section ($elements->{class}) if keys %{$elements->{class}};      print_class_section ($elements->{class}) if keys %{$elements->{class}};
122      } elsif (defined $manifest) {
123        print_structure_dump_manifest_section ($manifest);
124        print_structure_error_manifest_section ($manifest, $result);
125    }    }
126    
127    print_result_section ($result);    print_result_section ($result);
# Line 134  if (defined $input->{s}) { Line 142  if (defined $input->{s}) {
142  </html>  </html>
143  ];  ];
144    
145    for (qw/decode parse parse_xml check/) {    for (qw/decode parse parse_xml parse_manifest check check_manifest/) {
146      next unless defined $time{$_};      next unless defined $time{$_};
147      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";      open my $file, '>>', ".cc-$_.txt" or die ".cc-$_.txt: $!";
148      print $file $char_length, "\t", $time{$_}, "\n";      print $file $char_length, "\t", $time{$_}, "\n";
# Line 297  sub print_syntax_error_xml_section ($$) Line 305  sub print_syntax_error_xml_section ($$)
305    return ($doc, undef);    return ($doc, undef);
306  } # print_syntax_error_xml_section  } # print_syntax_error_xml_section
307    
308    sub print_syntax_error_manifest_section ($$) {
309      my ($input, $result) = @_;
310    
311      require Whatpm::CacheManifest;
312    
313      print STDOUT qq[
314    <div id="parse-errors" class="section">
315    <h2>Parse Errors</h2>
316    
317    <dl>];
318      push @nav, ['#parse-errors' => 'Parse Error'];
319    
320      my $onerror = sub {
321        my (%opt) = @_;
322        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level});
323        print STDOUT qq[<dt class="$cls">], get_error_label (\%opt), qq[</dt>];
324        $type =~ tr/ /-/;
325        $type =~ s/\|/%7C/g;
326        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
327        print STDOUT qq[<dd class="$cls">$msg</dd>\n];
328    
329        add_error ('syntax', \%opt => $result);
330      };
331    
332      my $time1 = time;
333      my $manifest = Whatpm::CacheManifest->parse_byte_string
334          ($input->{s}, $input->{uri}, $input->{base_uri}, $onerror);
335      $time{parse_manifest} = time - $time1;
336    
337      print STDOUT qq[</dl></div>];
338    
339      return $manifest;
340    } # print_syntax_error_manifest_section
341    
342  sub print_source_string_section ($$) {  sub print_source_string_section ($$) {
343    require Encode;    require Encode;
344    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 441  sub print_document_tree ($) {
441    print STDOUT $r;    print STDOUT $r;
442  } # print_document_tree  } # print_document_tree
443    
444  sub print_structure_dump_section ($$) {  sub print_structure_dump_dom_section ($$) {
445    my ($doc, $el) = @_;    my ($doc, $el) = @_;
446    
447    print STDOUT qq[    print STDOUT qq[
# Line 411  sub print_structure_dump_section ($$) { Line 453  sub print_structure_dump_section ($$) {
453    print_document_tree ($el || $doc);    print_document_tree ($el || $doc);
454    
455    print STDOUT qq[</div>];    print STDOUT qq[</div>];
456  } # print_structure_dump_section  } # print_structure_dump_dom_section
457    
458    sub print_structure_dump_manifest_section ($) {
459      my $manifest = shift;
460    
461      print STDOUT qq[
462    <div id="dump-manifest" class="section">
463    <h2>Cache Manifest</h2>
464    ];
465      push @nav, ['#dump-manifest' => 'Caceh Manifest'];
466    
467      print STDOUT qq[<dl><dt>Explicit entries</dt>];
468      for my $uri (@{$manifest->[0]}) {
469        my $euri = htescape ($uri);
470        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
471      }
472    
473      print STDOUT qq[<dt>Fallback entries</dt><dd>
474          <table><thead><tr><th scope=row>Oppotunistic Caching Namespace</th>
475          <th scope=row>Fallback Entry</tr><tbody>];
476      for my $uri (sort {$a cmp $b} keys %{$manifest->[1]}) {
477        my $euri = htescape ($uri);
478        my $euri2 = htescape ($manifest->[1]->{$uri});
479        print STDOUT qq[<tr><td><code class=uri>&lt;<a href="$euri">$euri</a>></code></td>
480            <td><code class=uri>&lt;<a href="$euri2">$euri2</a>></code></td>];
481      }
482    
483      print STDOUT qq[</table><dt>Online whitelist</dt>];
484      for my $uri (@{$manifest->[2]}) {
485        my $euri = htescape ($uri);
486        print STDOUT qq[<dd><code class=uri>&lt;<a href="$euri">$euri</a>></code></dd>];
487      }
488    
489  sub print_structure_error_section ($$$) {    print STDOUT qq[</dl></div>];
490    } # print_structure_dump_manifest_section
491    
492    sub print_structure_error_dom_section ($$$) {
493    my ($doc, $el, $result) = @_;    my ($doc, $el, $result) = @_;
494    
495    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 505  sub print_structure_error_section ($$$)
505      $type =~ tr/ /-/;      $type =~ tr/ /-/;
506      $type =~ s/\|/%7C/g;      $type =~ s/\|/%7C/g;
507      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];      $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
508      print STDOUT qq[<dt class="$cls">] . get_node_link ($opt{node}) .      print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
509          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";          qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
510      add_error ('structure', \%opt => $result);      add_error ('structure', \%opt => $result);
511    };    };
# Line 446  sub print_structure_error_section ($$$) Line 522  sub print_structure_error_section ($$$)
522    print STDOUT qq[</dl></div>];    print STDOUT qq[</dl></div>];
523    
524    return $elements;    return $elements;
525  } # print_structure_error_section  } # print_structure_error_dom_section
526    
527    sub print_structure_error_manifest_section ($$$) {
528      my ($manifest, $result) = @_;
529    
530      print STDOUT qq[<div id="document-errors" class="section">
531    <h2>Document Errors</h2>
532    
533    <dl>];
534      push @nav, ['#document-errors' => 'Document Error'];
535    
536      require Whatpm::CacheManifest;
537      Whatpm::CacheManifest->check_manifest ($manifest, sub {
538        my %opt = @_;
539        my ($type, $cls, $msg) = get_text ($opt{type}, $opt{level}, $opt{node});
540        $type =~ tr/ /-/;
541        $type =~ s/\|/%7C/g;
542        $msg .= qq[ [<a href="../error-description#@{[htescape ($type)]}">Description</a>]];
543        print STDOUT qq[<dt class="$cls">] . get_error_label (\%opt) .
544            qq[</dt>\n<dd class="$cls">], $msg, "</dd>\n";
545        add_error ('structure', \%opt => $result);
546      });
547    
548      print STDOUT qq[</div>];
549    } # print_structure_error_manifest_section
550    
551  sub print_table_section ($) {  sub print_table_section ($) {
552    my $tables = shift;    my $tables = shift;
# Line 671  sub print_result_input_error_section ($) Line 771  sub print_result_input_error_section ($)
771    push @nav, ['#result-summary' => 'Result'];    push @nav, ['#result-summary' => 'Result'];
772  } # print_Result_input_error_section  } # print_Result_input_error_section
773    
774    sub get_error_label ($) {
775      my $err = shift;
776    
777      my $r = '';
778    
779      if (defined $err->{line}) {
780        if ($err->{column} > 0) {
781          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a> column $err->{column}];
782        } else {
783          $err->{line} = $err->{line} - 1 || 1;
784          $r = qq[<a href="#line-$err->{line}">Line $err->{line}</a>];
785        }
786      }
787    
788      if (defined $err->{node}) {
789        $r .= ' ' if length $r;
790        $r = get_node_path ($err->{node});
791      }
792    
793      if (defined $err->{index}) {
794        $r .= ' ' if length $r;
795        $r .= 'Index ' . (0+$err->{index});
796      }
797    
798      if (defined $err->{value}) {
799        $r .= ' ' if length $r;
800        $r .= '<q><code>' . htescape ($err->{value}) . '</code></q>';
801      }
802    
803      return $r;
804    } # get_error_label
805    
806  sub get_node_path ($) {  sub get_node_path ($) {
807    my $node = shift;    my $node = shift;
808    my @r;    my @r;
# Line 819  EOH Line 951  EOH
951        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._+-]+)#) {
952          $r->{media_type} = lc $1;          $r->{media_type} = lc $1;
953        }        }
954        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?(\S+)"?/i) {        if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
955          $r->{charset} = lc $1;          $r->{charset} = lc $1;
956          $r->{charset} =~ tr/\\//d;          $r->{charset} =~ tr/\\//d;
957        }        }
Legend:
Removed from v.1.21  
changed lines
  Added in v.1.22
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24