/[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.55 by wakaba, Mon Jul 21 05:24:32 2008 UTC revision 1.58 by wakaba, Mon Jul 21 09:40:59 2008 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl  #!/usr/bin/perl
2  use strict;  use strict;
 use utf8;  
3    
4  use lib qw[/home/httpd/html/www/markup/html/whatpm  use lib qw[/home/httpd/html/www/markup/html/whatpm
5             /home/wakaba/work/manakai2/lib];             /home/wakaba/work/manakai2/lib];
6  use CGI::Carp qw[fatalsToBrowser];  use CGI::Carp qw[fatalsToBrowser];
 use Scalar::Util qw[refaddr];  
7    
8    require WebHACC::Input;    require WebHACC::Input;
   require WebHACC::Result;  
   require WebHACC::Output;  
   
 my $out;  
9    
   require Message::DOM::DOMImplementation;  
   my $dom = Message::DOM::DOMImplementation->new;  
10  {  {
11    use Message::CGI::HTTP;    require Message::CGI::HTTP;
12    my $http = Message::CGI::HTTP->new;    my $http = Message::CGI::HTTP->new;
13    
14      require WebHACC::Output;
15      my $out = WebHACC::Output->new;
16      $out->handle (*STDOUT);
17      $out->set_utf8;
18    
19    if ($http->get_meta_variable ('PATH_INFO') ne '/') {    if ($http->get_meta_variable ('PATH_INFO') ne '/') {
20      print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";      $out->http_error (404);
21      exit;      exit;
22    }    }
23        
24    load_text_catalog ('en'); ## TODO: conneg    load_text_catalog ('en'); ## TODO: conneg
25    
   $out = WebHACC::Output->new;  
   $out->handle (*STDOUT);  
   $out->set_utf8;  
26    $out->set_flush;    $out->set_flush;
27    $out->html (qq[Content-Type: text/html; charset=utf-8    $out->http_header;
28      $out->html_header;
29  <!DOCTYPE html>    $out->unset_flush;
 <html lang="en">  
 <head>  
 <title>Web Document Conformance Checker (BETA)</title>  
 <link rel="stylesheet" href="../cc-style.css" type="text/css">  
 </head>  
 <body>  
 <h1><a href="../cc-interface">Web Document Conformance Checker</a>  
 (<em>beta</em>)</h1>  
 ]);  
   
   my $input = get_input_document ($http, $dom);  
30    
31      my $input = get_input_document ($http);
32    $out->input ($input);    $out->input ($input);
   $out->unset_flush;  
33    
34      require WebHACC::Result;
35    my $result = WebHACC::Result->new;    my $result = WebHACC::Result->new;
36    $result->output ($out);    $result->output ($out);
37    $result->{conforming_min} = 1;    $result->{conforming_min} = 1;
# Line 118  sub check_and_print ($$$) { Line 102  sub check_and_print ($$$) {
102    $checker->generate_structure_error_section;    $checker->generate_structure_error_section;
103    $checker->generate_additional_sections;    $checker->generate_additional_sections;
104    
 =pod  
   
   if (defined $doc or defined $el) {  
   
     print_table_section ($input, $elements->{table}) if @{$elements->{table}};  
     print_listing_section ({  
       id => 'identifiers', label => 'IDs', heading => 'Identifiers',  
     }, $input, $elements->{id}) if keys %{$elements->{id}};  
     print_listing_section ({  
       id => 'terms', label => 'Terms', heading => 'Terms',  
     }, $input, $elements->{term}) if keys %{$elements->{term}};  
     print_listing_section ({  
       id => 'classes', label => 'Classes', heading => 'Classes',  
     }, $input, $elements->{class}) if keys %{$elements->{class}};  
     
     print_rdf_section ($input, $elements->{rdf}) if @{$elements->{rdf}};  
   }  
   
 =cut  
   
105    my $id_prefix = 0;    my $id_prefix = 0;
106    for my $_subinput (@subdoc) {    for my $_subinput (@subdoc) {
107      my $subinput = WebHACC::Input::Subdocument->new (++$id_prefix);      my $subinput = WebHACC::Input::Subdocument->new (++$id_prefix);
# Line 154  sub check_and_print ($$$) { Line 118  sub check_and_print ($$$) {
118    $out->input ($original_input);    $out->input ($original_input);
119  } # check_and_print  } # check_and_print
120    
 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  
121    
122  {  {
123    my $Msg = {};    my $Msg = {};
# Line 348  sub get_text ($;$$) { Line 177  sub get_text ($;$$) {
177    
178  }  }
179    
180  sub get_input_document ($$) {  sub get_input_document ($) {
181    my ($http, $dom) = @_;    my $http = shift;
182    
183      require Message::DOM::DOMImplementation;
184      my $dom = Message::DOM::DOMImplementation->new;
185    
186    require Encode;    require Encode;
187    my $request_uri = Encode::decode ('utf-8', $http->get_parameter ('uri'));    my $request_uri = Encode::decode ('utf-8', $http->get_parameter ('uri'));
Legend:
Removed from v.1.55  
changed lines
  Added in v.1.58
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24