test/html-webhacc/cc.cgi

#!/usr/bin/perl
# -d:DProf
use strict;

use lib qw[/home/httpd/html/www/markup/html/whatpm
           /home/wakaba/work/manakai2/lib];
use CGI::Carp qw[fatalsToBrowser];

  require WebHACC::Input;

{
  require Message::CGI::HTTP;
  my $http = Message::CGI::HTTP->new;

  require WebHACC::Output;
  my $out = WebHACC::Output->new;
  $out->handle (*STDOUT);
  $out->set_utf8;

  if ($http->get_meta_variable ('PATH_INFO') ne '/') {
    $out->http_error (404);
    exit;
  }

  ## TODO: We need real conneg support...
  my $primary_language = 'en';
  if ($ENV{HTTP_ACCEPT_LANGUAGE} =~ /ja/) {
    $primary_language = 'ja';
  }
  $out->load_text_catalog ($primary_language);
  
  $out->set_flush;
  $out->http_header;
  $out->html_header;
  $out->unset_flush;

  $out->generate_input_section ($http);

  my $u = $http->get_parameter ('uri');
  my $s = $http->get_parameter ('s');
  if ((not defined $u or not length $u) and
      (not defined $s or not length $s)) {
    exit;
  }

  require WebHACC::Result;
  my $result = WebHACC::Result->new;
  $result->output ($out);

  require WebHACC::Input;
  my $input = WebHACC::Input->get_document ($http => $result => $out);

  check_and_print ($input => $result => $out);
  
  $out->nav_list;

  exit;
}

sub check_and_print ($$$) {
  my ($input, $result, $out) = @_;
  my $original_input = $out->input;
  $out->input ($input);

  $input->generate_info_section ($result);

  $input->generate_transfer_sections ($result);

  unless (defined $input->{s}) {
    ## NOTE: This is an error of the implementation.
    $result->layer_uncertain ('transfer');
    $result->generate_result_section;
 
    $out->input ($original_input);
    return;
  }

  my $checker_class = {
    'text/cache-manifest' => 'WebHACC::Language::CacheManifest',
    'text/css' => 'WebHACC::Language::CSS',
    'text/html' => 'WebHACC::Language::HTML',
    'text/x-h2h' => 'WebHACC::Language::H2H',
    'text/x-webidl' => 'WebHACC::Language::WebIDL',

    'text/xml' => 'WebHACC::Language::XML',
    'application/atom+xml' => 'WebHACC::Language::XML',
    'application/rss+xml' => 'WebHACC::Language::XML',
    'image/svg+xml' => 'WebHACC::Language::XML',
    'application/xhtml+xml' => 'WebHACC::Language::XML',
    'application/xml' => 'WebHACC::Language::XML',
    ## TODO: Should we make all XML MIME Types fall
    ## into this category?

    ## NOTE: This type has different model from normal XML types.
    'application/rdf+xml' => 'WebHACC::Language::XML',
  }->{$input->{media_type}} || 'WebHACC::Language::Default';

  eval qq{ require $checker_class } or die "$0: Loading $checker_class: $@";
  my $checker = $checker_class->new;
  $checker->input ($input);
  $checker->output ($out);
  $checker->result ($result);

  ## TODO: A cache manifest MUST be text/cache-manifest
  ## TODO: WebIDL media type "text/x-webidl"

  $checker->generate_syntax_error_section;
  $checker->generate_source_string_section;

  my @subdoc;
  $checker->onsubdoc (sub {
    push @subdoc, shift;
  });

  $checker->generate_structure_dump_section;
  $checker->generate_structure_error_section;
  $checker->generate_additional_sections;

  my $id_prefix = 0;
  for my $_subinput (@subdoc) {
    my $subinput = WebHACC::Input::Subdocument->new (++$id_prefix);
    $subinput->{$_} = $_subinput->{$_} for keys %$_subinput;
    $subinput->{base_uri} = $subinput->{container_node}->base_uri
        unless defined $subinput->{base_uri};
    $subinput->{parent_input} = $input;

    my $subresult = WebHACC::Result->new;
    $subresult->output ($out);
    $subresult->parent_result ($result);

    $subinput->start_section ($subresult);
    check_and_print ($subinput => $subresult => $out);
    $subinput->end_section ($subresult);
  }

  $result->generate_result_section;

  $out->input ($original_input);
} # check_and_print

=head1 AUTHOR

Wakaba <w@suika.fam.cx>.

=head1 LICENSE

Copyright 2007-2008 Wakaba <w@suika.fam.cx>

This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=cut

## $Date: 2008/09/15 02:55:12 $
1	#!/usr/bin/perl
2	# -d:DProf
3	use strict;
4
5	use lib qw[/home/httpd/html/www/markup/html/whatpm
6	/home/wakaba/work/manakai2/lib];
7	use CGI::Carp qw[fatalsToBrowser];
8
9	require WebHACC::Input;
10
11	{
12	require Message::CGI::HTTP;
13	my $http = Message::CGI::HTTP->new;
14
15	require WebHACC::Output;
16	my $out = WebHACC::Output->new;
17	$out->handle (*STDOUT);
18	$out->set_utf8;
19
20	if ($http->get_meta_variable ('PATH_INFO') ne '/') {
21	$out->http_error (404);
22	exit;
23	}
24
25	## TODO: We need real conneg support...
26	my $primary_language = 'en';
27	if ($ENV{HTTP_ACCEPT_LANGUAGE} =~ /ja/) {
28	$primary_language = 'ja';
29	}
30	$out->load_text_catalog ($primary_language);
31
32	$out->set_flush;
33	$out->http_header;
34	$out->html_header;
35	$out->unset_flush;
36
37	$out->generate_input_section ($http);
38
39	my $u = $http->get_parameter ('uri');
40	my $s = $http->get_parameter ('s');
41	if ((not defined $u or not length $u) and
42	(not defined $s or not length $s)) {
43	exit;
44	}
45
46	require WebHACC::Result;
47	my $result = WebHACC::Result->new;
48	$result->output ($out);
49
50	require WebHACC::Input;
51	my $input = WebHACC::Input->get_document ($http => $result => $out);
52
53	check_and_print ($input => $result => $out);
54
55	$out->nav_list;
56
57	exit;
58	}
59
60	sub check_and_print ($$$) {
61	my ($input, $result, $out) = @_;
62	my $original_input = $out->input;
63	$out->input ($input);
64
65	$input->generate_info_section ($result);
66
67	$input->generate_transfer_sections ($result);
68
69	unless (defined $input->{s}) {
70	## NOTE: This is an error of the implementation.
71	$result->layer_uncertain ('transfer');
72	$result->generate_result_section;
73
74	$out->input ($original_input);
75	return;
76	}
77
78	my $checker_class = {
79	'text/cache-manifest' => 'WebHACC::Language::CacheManifest',
80	'text/css' => 'WebHACC::Language::CSS',
81	'text/html' => 'WebHACC::Language::HTML',
82	'text/x-h2h' => 'WebHACC::Language::H2H',
83	'text/x-webidl' => 'WebHACC::Language::WebIDL',
84
85	'text/xml' => 'WebHACC::Language::XML',
86	'application/atom+xml' => 'WebHACC::Language::XML',
87	'application/rss+xml' => 'WebHACC::Language::XML',
88	'image/svg+xml' => 'WebHACC::Language::XML',
89	'application/xhtml+xml' => 'WebHACC::Language::XML',
90	'application/xml' => 'WebHACC::Language::XML',
91	## TODO: Should we make all XML MIME Types fall
92	## into this category?
93
94	## NOTE: This type has different model from normal XML types.
95	'application/rdf+xml' => 'WebHACC::Language::XML',
96	}->{$input->{media_type}} \|\| 'WebHACC::Language::Default';
97
98	eval qq{ require $checker_class } or die "$0: Loading $checker_class: $@";
99	my $checker = $checker_class->new;
100	$checker->input ($input);
101	$checker->output ($out);
102	$checker->result ($result);
103
104	## TODO: A cache manifest MUST be text/cache-manifest
105	## TODO: WebIDL media type "text/x-webidl"
106
107	$checker->generate_syntax_error_section;
108	$checker->generate_source_string_section;
109
110	my @subdoc;
111	$checker->onsubdoc (sub {
112	push @subdoc, shift;
113	});
114
115	$checker->generate_structure_dump_section;
116	$checker->generate_structure_error_section;
117	$checker->generate_additional_sections;
118
119	my $id_prefix = 0;
120	for my $_subinput (@subdoc) {
121	my $subinput = WebHACC::Input::Subdocument->new (++$id_prefix);
122	$subinput->{$_} = $_subinput->{$_} for keys %$_subinput;
123	$subinput->{base_uri} = $subinput->{container_node}->base_uri
124	unless defined $subinput->{base_uri};
125	$subinput->{parent_input} = $input;
126
127	my $subresult = WebHACC::Result->new;
128	$subresult->output ($out);
129	$subresult->parent_result ($result);
130
131	$subinput->start_section ($subresult);
132	check_and_print ($subinput => $subresult => $out);
133	$subinput->end_section ($subresult);
134	}
135
136	$result->generate_result_section;
137
138	$out->input ($original_input);
139	} # check_and_print
140
141	=head1 AUTHOR
142
143	Wakaba <w@suika.fam.cx>.
144
145	=head1 LICENSE
146
147	Copyright 2007-2008 Wakaba <w@suika.fam.cx>
148
149	This library is free software; you can redistribute it
150	and/or modify it under the same terms as Perl itself.
151
152	=cut
153
154	## $Date: 2008/09/15 02:55:12 $