1 |
package WebHACC::Language::Base; |
2 |
use strict; |
3 |
|
4 |
sub new ($) { |
5 |
die "$0: No constructor is defined for " . ref $_[0]; |
6 |
} # new |
7 |
|
8 |
## NOTE: |
9 |
## Language ->input, ->output, ->result |
10 |
## Input |
11 |
## Output ->input |
12 |
## Result ->output |
13 |
|
14 |
sub input ($;$) { |
15 |
if (@_ > 1) { |
16 |
if (defined $_[1]) { |
17 |
$_[0]->{input} = $_[1]; |
18 |
} else { |
19 |
delete $_[0]->{input}; |
20 |
} |
21 |
} |
22 |
|
23 |
return $_[0]->{input}; |
24 |
} # input |
25 |
|
26 |
sub output ($;$) { |
27 |
if (@_ > 1) { |
28 |
if (defined $_[1]) { |
29 |
$_[0]->{output} = $_[1]; |
30 |
} else { |
31 |
delete $_[0]->{output}; |
32 |
} |
33 |
} |
34 |
|
35 |
return $_[0]->{output}; |
36 |
} # output |
37 |
|
38 |
sub result ($;$) { |
39 |
if (@_ > 1) { |
40 |
if (defined $_[1]) { |
41 |
$_[0]->{result} = $_[1]; |
42 |
} else { |
43 |
delete $_[0]->{result}; |
44 |
} |
45 |
} |
46 |
|
47 |
return $_[0]->{result}; |
48 |
} # result |
49 |
|
50 |
sub onsubdoc ($;$) { |
51 |
if (@_ > 1) { |
52 |
if (defined $_[1]) { |
53 |
$_[0]->{onsubdoc} = $_[1]; |
54 |
} else { |
55 |
delete $_[0]->{onsubdoc}; |
56 |
} |
57 |
} |
58 |
|
59 |
return $_[0]->{onsubdoc} || sub { }; |
60 |
} # onsubdoc |
61 |
|
62 |
sub generate_syntax_error_section ($) { |
63 |
die "$0: Syntactical checking for " . (ref $_[0]) . " is not supported"; |
64 |
} # generate_syntax_error_section |
65 |
|
66 |
sub generate_structure_dump_section ($) { |
67 |
# |
68 |
} # generate_structure_dump_section |
69 |
|
70 |
sub generate_structure_error_section ($) { |
71 |
my $self = shift; |
72 |
|
73 |
my $out = $self->output; |
74 |
|
75 |
$out->start_section (role => 'structure-errors'); |
76 |
$out->start_error_list (role => 'structure-errors'); |
77 |
$self->result->layer_applicable ('structure'); |
78 |
|
79 |
$self->result->add_error (input => $self->input, |
80 |
level => 'u', |
81 |
layer => 'structure', |
82 |
type => 'media type not supported:structure', |
83 |
text => $self->input->{media_type}); |
84 |
|
85 |
$out->end_error_list (role => 'structure-errors'); |
86 |
$out->end_section; |
87 |
|
88 |
$self->result->layer_uncertain ('semantics'); |
89 |
} # generate_structure_error_section |
90 |
|
91 |
sub source_charset ($) { |
92 |
return 'utf-8'; |
93 |
} # source_charset |
94 |
|
95 |
sub generate_source_string_section ($) { |
96 |
my $self = shift; |
97 |
my $input = $self->input; |
98 |
|
99 |
my $s; |
100 |
unless ($input->{is_char_string}) { |
101 |
open my $byte_stream, '<', \($input->{s}); |
102 |
require Message::Charset::Info; |
103 |
my $charset = Message::Charset::Info->get_by_iana_name |
104 |
($self->source_charset); |
105 |
my ($char_stream, $e_status) = $charset->get_decode_handle |
106 |
($byte_stream, allow_error_reporting => 1, allow_fallback => 1); |
107 |
return unless $char_stream; |
108 |
|
109 |
$char_stream->onerror (sub { |
110 |
my (undef, $type, %opt) = @_; |
111 |
if ($opt{octets}) { |
112 |
${$opt{octets}} = "\x{FFFD}"; |
113 |
} |
114 |
}); |
115 |
|
116 |
my $t = ''; |
117 |
while (1) { |
118 |
if ($char_stream->read ($t, 1024, length $t)) { |
119 |
# |
120 |
} else { |
121 |
last; |
122 |
} |
123 |
} |
124 |
$s = \$t; |
125 |
## TODO: Output for each line, don't concat all of lines. |
126 |
} else { |
127 |
$s = \($input->{s}); |
128 |
} |
129 |
|
130 |
my $out = $self->output; |
131 |
my $i = 1; |
132 |
$out->start_section (role => 'source'); |
133 |
$out->start_tag ('ol', lang => ''); |
134 |
|
135 |
if (length $$s) { |
136 |
while ($$s =~ /\G([^\x0D\x0A]*?)(?>\x0D\x0A?|\x0A)/gc) { |
137 |
$out->start_tag ('li', id => 'line-' . $i); |
138 |
$out->text ($1); |
139 |
$i++; |
140 |
} |
141 |
if ($$s =~ /\G([^\x0D\x0A]+)/gc) { |
142 |
$out->start_tag ('li', id => 'line-' . $i); |
143 |
$out->text ($1); |
144 |
} |
145 |
} else { |
146 |
$out->start_tag ('li', id => 'line-1'); |
147 |
} |
148 |
$out->end_tag ('ol'); |
149 |
$out->add_source_to_parse_error_list ('parse-errors-list'); |
150 |
$out->end_section; |
151 |
} # generate_source_string_section |
152 |
|
153 |
sub generate_additional_sections ($) { |
154 |
my $self = shift; |
155 |
$self->generate_url_section; |
156 |
} # generate_additional_sections |
157 |
|
158 |
sub generate_url_section ($) { |
159 |
my $self = shift; |
160 |
my $urls = $self->{add_info}->{uri} || {}; |
161 |
return unless keys %$urls; |
162 |
|
163 |
## NOTE: URIs contained in the DOM (i.e. in HTML or XML documents), |
164 |
## except for those in RDF triples. |
165 |
## TODO: URIs in CSS |
166 |
|
167 |
my $out = $self->output; |
168 |
$out->start_section (id => 'urls', title => 'URLs'); |
169 |
$out->start_tag ('dl'); |
170 |
|
171 |
my $input = $self->input; |
172 |
my $result = $self->result; |
173 |
|
174 |
for my $url (sort {$a cmp $b} keys %$urls) { |
175 |
$out->start_tag ('dt'); |
176 |
$out->url ($url); |
177 |
$out->start_tag ('dd'); |
178 |
$out->link_to_webhacc ('Check conformance of this document', url => $url); |
179 |
$out->html ('<dd>Found in: <ul>'); |
180 |
for my $entry (@{$urls->{$url}}) { |
181 |
$out->start_tag ('li'); |
182 |
$out->node_link ($entry->{node}); |
183 |
if (keys %{$entry->{type} or {}}) { |
184 |
$out->text (' ('); |
185 |
$out->text (join ', ', map { |
186 |
{ |
187 |
hyperlink => 'Hyperlink', |
188 |
resource => 'Link to an external resource', |
189 |
namespace => 'Namespace URI', |
190 |
cite => 'Citation or link to a long description', |
191 |
embedded => 'Link to an embedded content', |
192 |
base => 'Base URI', |
193 |
action => 'Submission URI', |
194 |
}->{$_} |
195 |
or |
196 |
$_ |
197 |
} keys %{$entry->{type}}); |
198 |
$out->text (')'); |
199 |
} |
200 |
} |
201 |
$out->end_tag ('ul'); |
202 |
} |
203 |
$out->end_tag ('dl'); |
204 |
$out->end_section; |
205 |
} # generate_url_section |
206 |
|
207 |
1; |