/[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.53 by wakaba, Sun Jul 20 14:58:24 2008 UTC revision 1.55 by wakaba, Mon Jul 21 05:24:32 2008 UTC
# Line 44  my $out; Line 44  my $out;
44  ]);  ]);
45    
46    my $input = get_input_document ($http, $dom);    my $input = get_input_document ($http, $dom);
47    
48    $out->input ($input);    $out->input ($input);
49    $out->unset_flush;    $out->unset_flush;
50    
51    my $char_length = 0;    my $result = WebHACC::Result->new;
52      $result->output ($out);
53    $out->start_section (id => 'document-info', title => 'Information');    $result->{conforming_min} = 1;
54    $out->html (qq[<dl>    $result->{conforming_max} = 1;
 <dt>Request URL</dt>  
     <dd>]);  
   $out->url ($input->{request_uri});  
   $out->html (q[<dt>Document URL<!-- HTML5 document's address? -->  
     <dd>]);  
   $out->url ($input->{uri}, id => 'anchor-document-url');  
   $out->html (q[  
     <script>  
       document.title = '<'  
           + document.getElementById ('anchor-document-url').href + '> \\u2014 '  
           + document.title;  
     </script>]);  
   ## NOTE: no </dl> yet  
   
   if (defined $input->{s}) {  
     $char_length = length $input->{s};  
   
     $out->html (qq[<dt>Base URI<dd>]);  
     $out->url ($input->{base_uri});  
     $out->html (qq[<dt>Internet Media Type</dt>  
     <dd><code class="MIME" lang="en">]);  
     $out->text ($input->{media_type});  
     $out->html (qq[</code> ]);  
     if ($input->{media_type_overridden}) {  
       $out->html ('<em>(overridden)</em>');  
     } elsif (defined $input->{official_type}) {  
       if ($input->{media_type} eq $input->{official_type}) {  
         #  
       } else {  
         $out->html ('<em>(sniffed; official type is: <code class=MIME lang=en>');  
         $out->text ($input->{official_type});  
         $out->html ('</code>)');  
       }  
     } else {  
       $out->html ('<em>(sniffed)</em>');  
     }  
     $out->html (q[<dt>Character Encoding<dd>]);  
     if (defined $input->{charset}) {  
       $out->html ('<code class="charset" lang="en">');  
       $out->text ($input->{charset});  
       $out->html ('</code>');  
     } else {  
       $out->text ('(none)');  
     }  
     $out->html (' <em>overridden</em>') if $input->{charset_overridden};  
     $out->html (qq[  
 <dt>Length</dt>  
     <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>  
 </dl>  
55    
56  <script src="../cc-script.js"></script>    $out->html ('<script src="../cc-script.js"></script>');
 ]);  
     $out->end_section;  
57    
58      my $result = WebHACC::Result->new;    check_and_print ($input => $result => $out);
59      $result->{conforming_min} = 1;    
60      $result->{conforming_max} = 1;    $result->generate_result_section;
     check_and_print ($input => $result => $out);  
     print_result_section ($result);  
   } else {  
     $out->html ('</dl>');  
     $out->end_section;  
     print_result_input_error_section ($input);  
   }  
61    
62    $out->nav_list;    $out->nav_list;
63    
64    exit;    exit;
65  }  }
66    
 sub add_error ($$$) {  
   my ($layer, $err, $result) = @_;  
   if (defined $err->{level}) {  
     if ($err->{level} eq 's') {  
       $result->{$layer}->{should}++;  
       $result->{$layer}->{score_min} -= 2;  
       $result->{conforming_min} = 0;  
     } elsif ($err->{level} eq 'w' or $err->{level} eq 'g') {  
       $result->{$layer}->{warning}++;  
     } elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') {  
       $result->{$layer}->{unsupported}++;  
       $result->{unsupported} = 1;  
     } elsif ($err->{level} eq 'i') {  
       #  
     } else {  
       $result->{$layer}->{must}++;  
       $result->{$layer}->{score_max} -= 2;  
       $result->{$layer}->{score_min} -= 2;  
       $result->{conforming_min} = 0;  
       $result->{conforming_max} = 0;  
     }  
   } else {  
     $result->{$layer}->{must}++;  
     $result->{$layer}->{score_max} -= 2;  
     $result->{$layer}->{score_min} -= 2;  
     $result->{conforming_min} = 0;  
     $result->{conforming_max} = 0;  
   }  
 } # add_error  
   
67  sub check_and_print ($$$) {  sub check_and_print ($$$) {
68    my ($input, $result, $out) = @_;    my ($input, $result, $out) = @_;
69    my $original_input = $out->input;    my $original_input = $out->input;
70    $out->input ($input);    $out->input ($input);
71    
72    print_http_header_section ($input, $result);    $input->generate_info_section ($result);
73    
74    my @subdoc;    $input->generate_transfer_sections ($result);
75    
76      unless (defined $input->{s}) {
77        $result->{conforming_min} = 0;
78        return;
79      }
80    
81    my $checker_class = {    my $checker_class = {
82      'text/cache-manifest' => 'WebHACC::Language::CacheManifest',      'text/cache-manifest' => 'WebHACC::Language::CacheManifest',
# Line 191  sub check_and_print ($$$) { Line 109  sub check_and_print ($$$) {
109    $checker->generate_syntax_error_section;    $checker->generate_syntax_error_section;
110    $checker->generate_source_string_section;    $checker->generate_source_string_section;
111    
112      my @subdoc;
113    $checker->onsubdoc (sub {    $checker->onsubdoc (sub {
114      push @subdoc, shift;      push @subdoc, shift;
115    });    });
# Line 221  sub check_and_print ($$$) { Line 140  sub check_and_print ($$$) {
140    
141    my $id_prefix = 0;    my $id_prefix = 0;
142    for my $_subinput (@subdoc) {    for my $_subinput (@subdoc) {
143      my $subinput = WebHACC::Input->new;      my $subinput = WebHACC::Input::Subdocument->new (++$id_prefix);
144      $subinput->{$_} = $_subinput->{$_} for keys %$_subinput;      $subinput->{$_} = $_subinput->{$_} for keys %$_subinput;
     $subinput->id_prefix ('subdoc-' . ++$id_prefix);  
     $subinput->nested (1);  
145      $subinput->{base_uri} = $subinput->{container_node}->base_uri      $subinput->{base_uri} = $subinput->{container_node}->base_uri
146          unless defined $subinput->{base_uri};          unless defined $subinput->{base_uri};
147      my $ebaseuri = htescape ($subinput->{base_uri});      $subinput->{parent_input} = $input;
     $out->start_section (id => $subinput->id_prefix,  
                          title => qq[Subdocument #$id_prefix]);  
     print STDOUT qq[  
       <dl>  
       <dt>Internet Media Type</dt>  
         <dd><code class="MIME" lang="en">@{[htescape $subinput->{media_type}]}</code>  
       <dt>Container Node</dt>  
         <dd>@{[get_node_link ($input, $subinput->{container_node})]}</dd>  
       <dt>Base <abbr title="Uniform Resource Identifiers">URI</abbr></dt>  
         <dd><code class=URI>&lt;<a href="$ebaseuri">$ebaseuri</a>></code></dd>  
       </dl>];                
148    
149      $subinput->{id_prefix} .= '-';      $subinput->start_section ($result);
150      check_and_print ($subinput => $result => $out);      check_and_print ($subinput => $result => $out);
151        $subinput->end_section ($result);
     $out->end_section;  
152    }    }
153    
154    $out->input ($original_input);    $out->input ($original_input);
155  } # check_and_print  } # check_and_print
156    
 sub print_http_header_section ($$) {  
   my ($input, $result) = @_;  
   return unless defined $input->{header_status_code} or  
       defined $input->{header_status_text} or  
       @{$input->{header_field} or []};  
     
   $out->start_section (id => 'source-header', title => 'HTTP Header');  
   print STDOUT qq[<p><strong>Note</strong>: Due to the limitation of the  
 network library in use, the content of this section might  
 not be the real header.</p>  
   
 <table><tbody>  
 ];  
   
   if (defined $input->{header_status_code}) {  
     print STDOUT qq[<tr><th scope="row">Status code</th>];  
     print STDOUT qq[<td>];  
     $out->code ($input->{header_status_code});  
   }  
   if (defined $input->{header_status_text}) {  
     print STDOUT qq[<tr><th scope="row">Status text</th>];  
     print STDOUT qq[<td>];  
     $out->code ($input->{header_status_text});  
   }  
     
   for (@{$input->{header_field}}) {  
     print STDOUT qq[<tr><th scope="row">];  
     $out->code ($_->[0]);  
     print STDOUT qq[<td>];  
     $out->code ($_->[1]);  
   }  
   
   print STDOUT qq[</tbody></table>];  
   
   $out->end_section;  
 } # print_http_header_section  
   
157  sub print_table_section ($$) {  sub print_table_section ($$) {
158    my ($input, $tables) = @_;    my ($input, $tables) = @_;
159        
# Line 422  sub get_rdf_resource_html ($) { Line 290  sub get_rdf_resource_html ($) {
290    }    }
291  } # get_rdf_resource_html  } # get_rdf_resource_html
292    
 sub print_result_section ($) {  
   my $result = shift;  
   
   $out->start_section (id => 'result-summary',  
                        title => 'Result');  
   
   if ($result->{unsupported} and $result->{conforming_max}) {    
     print STDOUT qq[<p class=uncertain id=result-para>The conformance  
         checker cannot decide whether the document is conforming or  
         not, since the document contains one or more unsupported  
         features.  The document might or might not be conforming.</p>];  
   } elsif ($result->{conforming_min}) {  
     print STDOUT qq[<p class=PASS id=result-para>No conformance-error is  
         found in this document.</p>];  
   } elsif ($result->{conforming_max}) {  
     print STDOUT qq[<p class=SEE-RESULT id=result-para>This document  
         is <strong>likely <em>non</em>-conforming</strong>, but in rare case  
         it might be conforming.</p>];  
   } else {  
     print STDOUT qq[<p class=FAIL id=result-para>This document is  
         <strong><em>non</em>-conforming</strong>.</p>];  
   }  
   
   print STDOUT qq[<table>  
 <colgroup><col><colgroup><col><col><col><colgroup><col>  
 <thead>  
 <tr><th scope=col></th>  
 <th scope=col><a href="../error-description#level-m"><em class=rfc2119>MUST</em>‐level  
 Errors</a></th>  
 <th scope=col><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>‐level  
 Errors</a></th>  
 <th scope=col><a href="../error-description#level-w">Warnings</a></th>  
 <th scope=col>Score</th></tr></thead><tbody>];  
   
   my $must_error = 0;  
   my $should_error = 0;  
   my $warning = 0;  
   my $score_min = 0;  
   my $score_max = 0;  
   my $score_base = 20;  
   my $score_unit = $score_base / 100;  
   for (  
     [Transfer => 'transfer', ''],  
     [Character => 'char', ''],  
     [Syntax => 'syntax', '#parse-errors'],  
     [Structure => 'structure', '#document-errors'],  
   ) {  
     $must_error += ($result->{$_->[1]}->{must} += 0);  
     $should_error += ($result->{$_->[1]}->{should} += 0);  
     $warning += ($result->{$_->[1]}->{warning} += 0);  
     $score_min += (($result->{$_->[1]}->{score_min} *= $score_unit) += $score_base);  
     $score_max += (($result->{$_->[1]}->{score_max} *= $score_unit) += $score_base);  
   
     my $uncertain = $result->{$_->[1]}->{unsupported} ? '?' : '';  
     my $label = $_->[0];  
     if ($result->{$_->[1]}->{must} or  
         $result->{$_->[1]}->{should} or  
         $result->{$_->[1]}->{warning} or  
         $result->{$_->[1]}->{unsupported}) {  
       $label = qq[<a href="$_->[2]">$label</a>];  
     }  
   
     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>];  
     if ($uncertain) {  
       print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : $result->{$_->[1]}->{should} ? 'SEE-RESULT' : '']}">&#x2212;&#x221E;..$result->{$_->[1]}->{score_max}];  
     } elsif ($result->{$_->[1]}->{score_min} != $result->{$_->[1]}->{score_max}) {  
       print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : 'SEE-RESULT']}">$result->{$_->[1]}->{score_min}..$result->{$_->[1]}->{score_max}];  
     } else {  
       print qq[<td class="@{[$result->{$_->[1]}->{must} ? 'FAIL' : '']}">$result->{$_->[1]}->{score_min}];  
     }  
     print qq[ / 20];  
   }  
   
   $score_max += $score_base;  
   
   print STDOUT qq[  
 <tr class=uncertain><th scope=row>Semantics</th><td>0?</td><td>0?</td><td>0?</td><td>&#x2212;&#x221E;..$score_base / 20  
 </tbody>  
 <tfoot><tr class=uncertain><th scope=row>Total</th>  
 <td class="@{[$must_error ? 'FAIL' : '']}">$must_error?</td>  
 <td class="@{[$should_error ? 'SEE-RESULT' : '']}">$should_error?</td>  
 <td>$warning?</td>  
 <td class="@{[$must_error ? 'FAIL' : $should_error ? 'SEE-RESULT' : '']}"><strong>&#x2212;&#x221E;..$score_max</strong> / 100  
 </table>  
   
 <p><strong>Important</strong>: This conformance checking service  
 is <em>under development</em>.  The result above might be <em>wrong</em>.</p>];  
   $out->end_section;  
 } # print_result_section  
   
 sub print_result_input_error_section ($) {  
   my $input = shift;  
   $out->start_section (id => 'result-summary', title => 'Result');  
   print STDOUT qq[  
 <p><em><strong>Input Error</strong>: @{[htescape ($input->{error_status_text})]}</em></p>];  
   $out->end_section;  
 } # print_result_input_error_section  
   
293  {  {
294    my $Msg = {};    my $Msg = {};
295    
# Line 581  sub get_text ($;$$) { Line 351  sub get_text ($;$$) {
351  sub get_input_document ($$) {  sub get_input_document ($$) {
352    my ($http, $dom) = @_;    my ($http, $dom) = @_;
353    
354    my $request_uri = $http->get_parameter ('uri');    require Encode;
355      my $request_uri = Encode::decode ('utf-8', $http->get_parameter ('uri'));
356    my $r = WebHACC::Input->new;    my $r = WebHACC::Input->new;
357    if (defined $request_uri and length $request_uri) {    if (defined $request_uri and length $request_uri) {
358      my $uri = $dom->create_uri_reference ($request_uri);      my $uri = $dom->create_uri_reference ($request_uri);
359      unless ({      unless ({
360               http => 1,               http => 1,
361              }->{lc $uri->uri_scheme}) {              }->{lc $uri->uri_scheme}) {
362        return {uri => $request_uri, request_uri => $request_uri,        $r = WebHACC::Input::Error->new;
363                error_status_text => 'URI scheme not allowed'};        $r->{uri} = $request_uri;
364          $r->{request_uri} = $request_uri;
365          $r->{error_status_text} = 'URL scheme not allowed';
366      }      }
367    
368      require Message::Util::HostPermit;      require Message::Util::HostPermit;
# Line 616  Deny ipv6=0::0/0 Line 389  Deny ipv6=0::0/0
389  Allow host=*  Allow host=*
390  EOH  EOH
391      unless ($host_permit->check ($uri->uri_host, $uri->uri_port || 80)) {      unless ($host_permit->check ($uri->uri_host, $uri->uri_port || 80)) {
392        return {uri => $request_uri, request_uri => $request_uri,        my $r = WebHACC::Input::Error->new;
393                error_status_text => 'Connection to the host is forbidden'};        $r->{uri} = $request_uri;
394          $r->{request_uri} = $request_uri;
395          $r->{error_status_text} = 'Connection to the host is forbidden';
396          return $r;
397      }      }
398    
399      require LWP::UserAgent;      require LWP::UserAgent;
Legend:
Removed from v.1.53  
changed lines
  Added in v.1.55
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24