test/html-webhacc/cc.cgi

#!/usr/bin/perl
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;

  require WebHACC::Result;
  my $result = WebHACC::Result->new;
  $result->{conforming_min} = 1;
  $result->{conforming_max} = 1;
  $result->output ($out);

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

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

  $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}) {
    $result->{conforming_min} = 0;
    return;
  }

  my $checker_class = {
    'text/cache-manifest' => 'WebHACC::Language::CacheManifest',
    'text/css' => 'WebHACC::Language::CSS',
    'text/html' => 'WebHACC::Language::HTML',
    '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;

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

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