/[suikacvs]/test/html-webhacc/WebHACC/Output.pm
Suika

Contents of /test/html-webhacc/WebHACC/Output.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations) (download)
Sat Jul 26 11:27:25 2008 UTC (16 years, 4 months ago) by wakaba
Branch: MAIN
Changes since 1.7: +1 -0 lines
++ ChangeLog	26 Jul 2008 11:26:00 -0000
2008-07-26  Wakaba  <wakaba@suika.fam.cx>

	* cc.cgi: get_input_document function is now handled
	by WebHACC::Input classes.  |cc-script| reference
	is now generated by |html_header| in WebHACC::Output.

	* error-description-source.xml: Document URL and Request URL
	are now just "URLs".

++ html/WebHACC/ChangeLog	26 Jul 2008 11:27:20 -0000
2008-07-26  Wakaba  <wakaba@suika.fam.cx>

	* Input.pod: New.

	* Input.pm (urls, url, add_url): New.  Originally handled
	as |$input->{uri}| and |$input->{request_uri}|.
	(get_document and related methods/classes): New.  Originally
	part of |cc.cgi|.

	* Output.pm (html_header): Link to |cc-script.js|.

1 package WebHACC::Output;
2 use strict;
3
4 require IO::Handle;
5 use Scalar::Util qw/refaddr/;
6
7 my $htescape = sub ($) {
8 my $s = $_[0];
9 $s =~ s/&/&amp;/g;
10 $s =~ s/</&lt;/g;
11 $s =~ s/>/&gt;/g;
12 $s =~ s/"/&quot;/g;
13 $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{
14 sprintf '<var>U+%04X</var>', ord $1;
15 }ge;
16 return $s;
17 };
18
19 sub new ($) {
20 return bless {nav => [], section_rank => 1}, shift;
21 } # new
22
23 sub input ($;$) {
24 if (@_ > 1) {
25 if (defined $_[1]) {
26 $_[0]->{input} = $_[1];
27 } else {
28 delete $_[0]->{input};
29 }
30 }
31
32 return $_[0]->{input};
33 } # input
34
35 sub handle ($;$) {
36 if (@_ > 1) {
37 if (defined $_[1]) {
38 $_[0]->{handle} = $_[1];
39 } else {
40 delete $_[0]->{handle};
41 }
42 }
43
44 return $_[0]->{handle};
45 } # handle
46
47 sub set_utf8 ($) {
48 binmode shift->{handle}, ':utf8';
49 } # set_utf8
50
51 sub set_flush ($) {
52 shift->{handle}->autoflush (1);
53 } # set_flush
54
55 sub unset_flush ($) {
56 shift->{handle}->autoflush (0);
57 } # unset_flush
58
59 sub html ($$) {
60 shift->{handle}->print (shift);
61 } # html
62
63 sub text ($$) {
64 shift->html ($htescape->(shift));
65 } # text
66
67 sub url ($$%) {
68 my ($self, $url, %opt) = @_;
69 $self->html (q[<code class=uri>&lt;]);
70 $self->link ($url, %opt, url => $url);
71 $self->html (q[></code>]);
72 } # url
73
74 sub start_tag ($$%) {
75 my ($self, $tag_name, %opt) = @_;
76 $self->html ('<' . $htescape->($tag_name)); # escape for safety
77 if (exists $opt{id}) {
78 my $id = $self->input->id_prefix . $opt{id};
79 $self->html (' id="' . $htescape->($id) . '"');
80 delete $opt{id};
81 }
82 for (keys %opt) { # for safety
83 $self->html (' ' . $htescape->($_) . '="' . $htescape->($opt{$_}) . '"');
84 }
85 $self->html ('>');
86 } # start_tag
87
88 sub end_tag ($$) {
89 shift->html ('</' . $htescape->(shift) . '>');
90 } # end_tag
91
92 sub start_section ($%) {
93 my ($self, %opt) = @_;
94
95 if (defined $opt{role}) {
96 if ($opt{role} eq 'parse-errors') {
97 $opt{id} ||= 'parse-errors';
98 $opt{title} ||= 'Parse Errors Section';
99 $opt{short_title} ||= 'Parse Errors';
100 delete $opt{role};
101 } elsif ($opt{role} eq 'structure-errors') {
102 $opt{id} ||= 'document-errors';
103 $opt{title} ||= 'Structural Errors';
104 $opt{short_title} ||= 'Struct. Errors';
105 delete $opt{role};
106 } elsif ($opt{role} eq 'reformatted') {
107 $opt{id} ||= 'document-tree';
108 $opt{title} ||= 'Reformatted Document Source';
109 $opt{short_title} ||= 'Reformatted';
110 delete $opt{role}
111 } elsif ($opt{role} eq 'tree') {
112 $opt{id} ||= 'document-tree';
113 $opt{title} ||= 'Document Tree';
114 $opt{short_title} ||= 'Tree';
115 delete $opt{role};
116 } elsif ($opt{role} eq 'structure') {
117 $opt{id} ||= 'document-structure';
118 $opt{title} ||= 'Document Structure';
119 $opt{short_title} ||= 'Structure';
120 delete $opt{role};
121 }
122 }
123
124 $self->{section_rank}++;
125 $self->html ('<div class=section');
126 if (defined $opt{id}) {
127 my $id = $self->input->id_prefix . $opt{id};
128 $self->html (' id="' . $htescape->($id) . '"');
129 push @{$self->{nav}},
130 [$id => $opt{short_title} || $opt{title} => $opt{text}]
131 if $self->{section_rank} == 2;
132 }
133 my $section_rank = $self->{section_rank};
134 $section_rank = 6 if $section_rank > 6;
135 $self->html ('><h' . $section_rank . '>');
136 $self->nl_text ($opt{title}, text => $opt{text});
137 $self->html ('</h' . $section_rank . '>');
138 } # start_section
139
140 sub end_section ($) {
141 my $self = shift;
142 $self->html ('</div>');
143 $self->{handle}->flush;
144 $self->{section_rank}--;
145 } # end_section
146
147 sub start_error_list ($%) {
148 my ($self, %opt) = @_;
149
150 if (defined $opt{role}) {
151 if ($opt{role} eq 'parse-errors') {
152 $opt{id} ||= 'parse-errors-list';
153 delete $opt{role};
154 } elsif ($opt{role} eq 'structure-errors') {
155 $opt{id} ||= 'document-errors-list';
156 delete $opt{role};
157 }
158 }
159
160 $self->start_tag ('dl', %opt);
161 } # start_error_list
162
163 sub end_error_list ($%) {
164 my ($self, %opt) = @_;
165
166 if (defined $opt{role}) {
167 if ($opt{role} eq 'parse-errors') {
168 delete $opt{role};
169 $self->end_tag ('dl');
170 ## NOTE: For parse error list, the |add_source_to_parse_error_list|
171 ## method is invoked at the end of |generate_source_string_section|,
172 ## since that generation method is invoked after the error list
173 ## is generated.
174 } elsif ($opt{role} eq 'structure-errors') {
175 delete $opt{role};
176 $self->end_tag ('dl');
177 $self->add_source_to_parse_error_list ('document-errors-list');
178 } else {
179 $self->end_tag ('dl');
180 }
181 } else {
182 $self->end_tag ('dl');
183 }
184 } # end_error_list
185
186 sub add_source_to_parse_error_list ($$) {
187 my $self = shift;
188
189 $self->script (q[addSourceToParseErrorList ('] . $self->input->id_prefix .
190 q[', '] . shift . q[')]);
191 } # add_source_to_parse_error_list
192
193 sub start_code_block ($) {
194 shift->html ('<pre><code>');
195 } # start_code_block
196
197 sub end_code_block ($) {
198 shift->html ('</code></pre>');
199 } # end_code_block
200
201 sub code ($$;%) {
202 my ($self, $content, %opt) = @_;
203 $self->start_tag ('code', %opt);
204 $self->text ($content);
205 $self->html ('</code>');
206 } # code
207
208 sub script ($$;%) {
209 my ($self, $content, %opt) = @_;
210 $self->start_tag ('script', %opt);
211 $self->html ($content);
212 $self->html ('</script>');
213 } # script
214
215 sub dt ($$;%) {
216 my ($self, $content, %opt) = @_;
217 $self->start_tag ('dt', %opt);
218 $self->nl_text ($content, text => $opt{text});
219 } # dt
220
221 sub link ($$%) {
222 my ($self, $content, %opt) = @_;
223 $self->start_tag ('a', %opt, href => $opt{url});
224 $self->text ($content);
225 $self->html ('</a>');
226 } # link
227
228 sub xref ($$%) {
229 my ($self, $content, %opt) = @_;
230 $self->html ('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">');
231 $self->nl_text ($content, text => $opt{text});
232 $self->html ('</a>');
233 } # xref
234
235 sub link_to_webhacc ($$%) {
236 my ($self, $content, %opt) = @_;
237 $opt{url} = './?uri=' . $self->encode_url_component ($opt{url});
238 $self->link ($content, %opt);
239 } # link_to_webhacc
240
241 my $get_node_path = sub ($) {
242 my $node = shift;
243 my @r;
244 while (defined $node) {
245 my $rs;
246 if ($node->node_type == 1) {
247 $rs = $node->node_name;
248 $node = $node->parent_node;
249 } elsif ($node->node_type == 2) {
250 $rs = '@' . $node->node_name;
251 $node = $node->owner_element;
252 } elsif ($node->node_type == 3) {
253 $rs = '"' . $node->data . '"';
254 $node = $node->parent_node;
255 } elsif ($node->node_type == 9) {
256 @r = ('') unless @r;
257 $rs = '';
258 $node = $node->parent_node;
259 } else {
260 $rs = '#' . $node->node_type;
261 $node = $node->parent_node;
262 }
263 unshift @r, $rs;
264 }
265 return join '/', @r;
266 }; # $get_node_path
267
268 sub node_link ($$) {
269 my ($self, $node) = @_;
270 $self->xref ($get_node_path->($node), target => 'node-' . refaddr $node);
271 } # node_link
272
273 {
274 my $Msg = {};
275
276 sub load_text_catalog ($$) {
277 my $self = shift;
278
279 my $lang = shift; # MUST be a canonical lang name
280 my $file_name = qq[cc-msg.$lang.txt];
281 $lang = 'en' unless -f $file_name;
282 $self->{primary_language} = $lang;
283
284 open my $file, '<:utf8', $file_name or die "$0: $file_name: $!";
285 while (<$file>) {
286 if (s/^([^;]+);([^;]*);//) {
287 my ($type, $cls, $msg) = ($1, $2, $_);
288 $msg =~ tr/\x0D\x0A//d;
289 $Msg->{$type} = [$cls, $msg];
290 }
291 }
292 } # load_text_catalog
293
294 sub nl_text ($$;%) {
295 my ($self, $type, %opt) = @_;
296 my $node = $opt{node};
297
298 my @arg;
299 {
300 if (defined $Msg->{$type}) {
301 my $msg = $Msg->{$type}->[1];
302 if ($msg =~ /<var>/) {
303 $msg =~ s{<var>\$([0-9]+)</var>}{
304 defined $arg[$1] ? $htescape->($arg[$1]) : '(undef)';
305 }ge;
306 $msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{
307 UNIVERSAL::can ($node, 'get_attribute_ns')
308 ? $htescape->($node->get_attribute_ns (undef, $1)) : ''
309 }ge;
310 $msg =~ s{<var>{\@}</var>}{
311 UNIVERSAL::can ($node, 'value') ? $htescape->($node->value) : ''
312 }ge;
313 $msg =~ s{<var>{text}</var>}{
314 defined $opt{text} ? $htescape->($opt{text}) : ''
315 }ge;
316 $msg =~ s{<var>{local-name}</var>}{
317 UNIVERSAL::can ($node, 'manakai_local_name')
318 ? $htescape->($node->manakai_local_name) : ''
319 }ge;
320 $msg =~ s{<var>{element-local-name}</var>}{
321 (UNIVERSAL::can ($node, 'owner_element') and
322 $node->owner_element)
323 ? $htescape->($node->owner_element->manakai_local_name) : ''
324 }ge;
325 }
326 $self->html ($msg);
327 return;
328 } elsif ($type =~ s/:([^:]*)$//) {
329 unshift @arg, $1;
330 redo;
331 }
332 }
333 $self->text ($type);
334 } # nl_text
335
336 }
337
338 sub nav_list ($) {
339 my $self = shift;
340 $self->html (q[<ul class="navigation" id="nav-items">]);
341 for (@{$self->{nav}}) {
342 $self->html (qq[<li><a href="#@{[$htescape->($_->[0])]}">]);
343 $self->nl_text ($_->[1], text => $_->[2]);
344 $self->html ('</a>');
345 }
346 $self->html ('</ul>');
347 } # nav_list
348
349 sub http_header ($) {
350 shift->html (qq[Content-Type: text/html; charset=utf-8\n\n]);
351 } # http_header
352
353 sub http_error ($$) {
354 my $self = shift;
355 my $code = 0+shift;
356 my $text = {
357 404 => 'Not Found',
358 }->{$code};
359 $self->html (qq[Status: $code $text\nContent-Type: text/html ; charset=us-ascii\n\n$code $text]);
360 } # http_error
361
362 sub html_header ($) {
363 my $self = shift;
364 $self->html (q[<!DOCTYPE html>]);
365 $self->start_tag ('html', lang => $self->{primary_language});
366 $self->html (q[<head><title>]);
367 $self->nl_text (q[WebHACC:Title]);
368 $self->html (q[</title>
369 <link rel="stylesheet" href="../cc-style.css" type="text/css">
370 <script src="../cc-script.js"></script>
371 </head>
372 <body>
373 <h1>]);
374 $self->nl_text (q[WebHACC:Heading]);
375 $self->html ('</h1>');
376 } # html_header
377
378 sub encode_url_component ($$) {
379 shift;
380 require Encode;
381 my $s = Encode::encode ('utf8', shift);
382 $s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge;
383 return $s;
384 } # encode_url_component
385
386 1;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24