/[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.54 by wakaba, Sun Jul 20 16:53:10 2008 UTC revision 1.56 by wakaba, Mon Jul 21 08:39:12 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>  
   
 <script src="../cc-script.js"></script>  
 ]);  
     $out->end_section;  
55    
56      my $result = WebHACC::Result->new;    $out->html ('<script src="../cc-script.js"></script>');
     $result->output ($out);  
     $result->{conforming_min} = 1;  
     $result->{conforming_max} = 1;  
     check_and_print ($input => $result => $out);  
     $result->generate_result_section;  
   } else {  
     $out->html ('</dl>');  
     $out->end_section;  
57    
58      my $result = WebHACC::Result->new;    check_and_print ($input => $result => $out);
59      $result->output ($out);    
60      $result->{conforming_min} = 0;    $result->generate_result_section;
     $result->{conforming_max} = 1;  
   
     $input->generate_transfer_sections ($result);  
     $result->generate_result_section;  
   }  
61    
62    $out->nav_list;    $out->nav_list;
63    
# Line 134  sub check_and_print ($$$) { Line 69  sub check_and_print ($$$) {
69    my $original_input = $out->input;    my $original_input = $out->input;
70    $out->input ($input);    $out->input ($input);
71    
72      $input->generate_info_section ($result);
73    
74    $input->generate_transfer_sections ($result);    $input->generate_transfer_sections ($result);
75    
76    my @subdoc;    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 169  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 181  sub check_and_print ($$$) { Line 122  sub check_and_print ($$$) {
122    
123    if (defined $doc or defined $el) {    if (defined $doc or defined $el) {
124    
     print_table_section ($input, $elements->{table}) if @{$elements->{table}};  
125      print_listing_section ({      print_listing_section ({
126        id => 'identifiers', label => 'IDs', heading => 'Identifiers',        id => 'identifiers', label => 'IDs', heading => 'Identifiers',
127      }, $input, $elements->{id}) if keys %{$elements->{id}};      }, $input, $elements->{id}) if keys %{$elements->{id}};
# Line 199  sub check_and_print ($$$) { Line 139  sub check_and_print ($$$) {
139    
140    my $id_prefix = 0;    my $id_prefix = 0;
141    for my $_subinput (@subdoc) {    for my $_subinput (@subdoc) {
142      my $subinput = WebHACC::Input->new;      my $subinput = WebHACC::Input::Subdocument->new (++$id_prefix);
143      $subinput->{$_} = $_subinput->{$_} for keys %$_subinput;      $subinput->{$_} = $_subinput->{$_} for keys %$_subinput;
     $subinput->id_prefix ('subdoc-' . ++$id_prefix);  
     $subinput->nested (1);  
144      $subinput->{base_uri} = $subinput->{container_node}->base_uri      $subinput->{base_uri} = $subinput->{container_node}->base_uri
145          unless defined $subinput->{base_uri};          unless defined $subinput->{base_uri};
146      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>];                
147    
148      $subinput->{id_prefix} .= '-';      $subinput->start_section ($result);
149      check_and_print ($subinput => $result => $out);      check_and_print ($subinput => $result => $out);
150        $subinput->end_section ($result);
     $out->end_section;  
151    }    }
152    
153    $out->input ($original_input);    $out->input ($original_input);
154  } # check_and_print  } # check_and_print
155    
 sub print_table_section ($$) {  
   my ($input, $tables) = @_;  
     
 #  push @nav, [qq[#$input->{id_prefix}tables] => 'Tables']  
 #      unless $input->{nested};  
   print STDOUT qq[  
 <div id="$input->{id_prefix}tables" class="section">  
 <h2>Tables</h2>  
   
 <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->  
 <script src="../table-script.js" type="text/javascript"></script>  
 <noscript>  
 <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>  
 </noscript>  
 ];  
     
   require JSON;  
     
   my $i = 0;  
   for my $table (@$tables) {  
     $i++;  
     print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .  
         get_node_link ($input, $table->{element}) . q[</h3>];  
   
     delete $table->{element};  
   
     for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption},  
          @{$table->{row}}) {  
       next unless $_;  
       delete $_->{element};  
     }  
       
     for (@{$table->{row_group}}) {  
       next unless $_;  
       next unless $_->{element};  
       $_->{type} = $_->{element}->manakai_local_name;  
       delete $_->{element};  
     }  
       
     for (@{$table->{cell}}) {  
       next unless $_;  
       for (@{$_}) {  
         next unless $_;  
         for (@$_) {  
           $_->{id} = refaddr $_->{element} if defined $_->{element};  
           delete $_->{element};  
           $_->{is_header} = $_->{is_header} ? 1 : 0;  
         }  
       }  
     }  
           
     print STDOUT '</div><script type="text/javascript">tableToCanvas (';  
     print STDOUT JSON::objToJson ($table);  
     print STDOUT qq[, document.getElementById ('$input->{id_prefix}table-$i')];  
     print STDOUT qq[, '$input->{id_prefix}');</script>];  
   }  
     
   print STDOUT qq[</div>];  
 } # print_table_section  
   
 sub print_listing_section ($$$) {  
   my ($opt, $input, $ids) = @_;  
     
 #  push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]  
 #      unless $input->{nested};  
   print STDOUT qq[  
 <div id="$input->{id_prefix}$opt->{id}" class="section">  
 <h2>$opt->{heading}</h2>  
   
 <dl>  
 ];  
   for my $id (sort {$a cmp $b} keys %$ids) {  
     print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];  
     for (@{$ids->{$id}}) {  
       print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];  
     }  
   }  
   print STDOUT qq[</dl></div>];  
 } # print_listing_section  
   
   
 sub print_rdf_section ($$$) {  
   my ($input, $rdfs) = @_;  
     
 #  push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']  
 #      unless $input->{nested};  
   print STDOUT qq[  
 <div id="$input->{id_prefix}rdf" class="section">  
 <h2>RDF Triples</h2>  
   
 <dl>];  
   my $i = 0;  
   for my $rdf (@$rdfs) {  
     print STDOUT qq[<dt id="$input->{id_prefix}rdf-@{[$i++]}">];  
     print STDOUT get_node_link ($input, $rdf->[0]);  
     print STDOUT qq[<dd><dl>];  
     for my $triple (@{$rdf->[1]}) {  
       print STDOUT '<dt>' . get_node_link ($input, $triple->[0]) . '<dd>';  
       print STDOUT get_rdf_resource_html ($triple->[1]);  
       print STDOUT ' ';  
       print STDOUT get_rdf_resource_html ($triple->[2]);  
       print STDOUT ' ';  
       print STDOUT get_rdf_resource_html ($triple->[3]);  
     }  
     print STDOUT qq[</dl>];  
   }  
   print STDOUT qq[</dl></div>];  
 } # print_rdf_section  
   
 sub get_rdf_resource_html ($) {  
   my $resource = shift;  
   if (defined $resource->{uri}) {  
     my $euri = htescape ($resource->{uri});  
     return '<code class=uri>&lt;<a href="' . $euri . '">' . $euri .  
         '</a>></code>';  
   } elsif (defined $resource->{bnodeid}) {  
     return htescape ('_:' . $resource->{bnodeid});  
   } elsif ($resource->{nodes}) {  
     return '(rdf:XMLLiteral)';  
   } elsif (defined $resource->{value}) {  
     my $elang = htescape (defined $resource->{language}  
                               ? $resource->{language} : '');  
     my $r = qq[<q lang="$elang">] . htescape ($resource->{value}) . '</q>';  
     if (defined $resource->{datatype}) {  
       my $euri = htescape ($resource->{datatype});  
       $r .= '^^<code class=uri>&lt;<a href="' . $euri . '">' . $euri .  
           '</a>></code>';  
     } elsif (length $resource->{language}) {  
       $r .= '@' . htescape ($resource->{language});  
     }  
     return $r;  
   } else {  
     return '??';  
   }  
 } # get_rdf_resource_html  
156    
157  {  {
158    my $Msg = {};    my $Msg = {};
Legend:
Removed from v.1.54  
changed lines
  Added in v.1.56
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24