| 1 |
package WebHACC::Output; |
package WebHACC::Output; |
| 2 |
use strict; |
use strict; |
| 3 |
|
|
| 4 |
require IO::Handle; |
require IO::Handle; |
| 5 |
|
use Scalar::Util qw/refaddr/; |
| 6 |
|
|
| 7 |
my $htescape = sub ($) { |
my $htescape = sub ($) { |
| 8 |
my $s = $_[0]; |
my $s = $_[0]; |
| 9 |
$s =~ s/&/&/g; |
$s =~ s/&/&/g; |
| 10 |
$s =~ s/</</g; |
$s =~ s/</</g; |
| 11 |
$s =~ s/>/>/g; |
# $s =~ s/>/>/g; |
| 12 |
|
$s =~ s/"/"/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 |
|
my $htescape_value = sub ($) { |
| 20 |
|
my $s = $_[0]; |
| 21 |
|
$s =~ s/&/&/g; |
| 22 |
|
$s =~ s/</</g; |
| 23 |
|
# $s =~ s/>/>/g; |
| 24 |
$s =~ s/"/"/g; |
$s =~ s/"/"/g; |
|
$s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{ |
|
|
sprintf '<var>U+%04X</var>', ord $1; |
|
|
}ge; |
|
| 25 |
return $s; |
return $s; |
| 26 |
}; |
}; |
| 27 |
|
|
| 28 |
sub new ($) { |
sub new ($) { |
| 29 |
return bless {nav => []}, shift; |
require WebHACC::Input; |
| 30 |
|
return bless {nav => [], section_rank => 1, |
| 31 |
|
input => WebHACC::Input->new}, shift; |
| 32 |
} # new |
} # new |
| 33 |
|
|
| 34 |
sub input ($;$) { |
sub input ($;$) { |
| 36 |
if (defined $_[1]) { |
if (defined $_[1]) { |
| 37 |
$_[0]->{input} = $_[1]; |
$_[0]->{input} = $_[1]; |
| 38 |
} else { |
} else { |
| 39 |
delete $_[0]->{input}; |
$_[0]->{input} = WebHACC::Input->new; |
| 40 |
} |
} |
| 41 |
} |
} |
| 42 |
|
|
| 55 |
return $_[0]->{handle}; |
return $_[0]->{handle}; |
| 56 |
} # handle |
} # handle |
| 57 |
|
|
| 58 |
|
sub has_error ($;$) { |
| 59 |
|
if (@_ > 1) { |
| 60 |
|
if (defined $_[1]) { |
| 61 |
|
$_[0]->{has_error} = 1; |
| 62 |
|
} else { |
| 63 |
|
delete $_[0]->{has_error}; |
| 64 |
|
} |
| 65 |
|
} |
| 66 |
|
|
| 67 |
|
return $_[0]->{has_error}; |
| 68 |
|
} # has_error |
| 69 |
|
|
| 70 |
sub set_utf8 ($) { |
sub set_utf8 ($) { |
| 71 |
binmode shift->{handle}, ':utf8'; |
binmode $_[0]->{handle}, ':utf8'; |
| 72 |
} # set_utf8 |
} # set_utf8 |
| 73 |
|
|
| 74 |
sub set_flush ($) { |
sub set_flush ($) { |
| 75 |
shift->{handle}->autoflush (1); |
$_[0]->{handle}->autoflush (1); |
| 76 |
} # set_flush |
} # set_flush |
| 77 |
|
|
| 78 |
sub unset_flush ($) { |
sub unset_flush ($) { |
| 79 |
shift->{handle}->autoflush (0); |
$_[0]->{handle}->autoflush (0); |
| 80 |
} # unset_flush |
} # unset_flush |
| 81 |
|
|
| 82 |
sub html ($$) { |
sub html ($$) { |
| 83 |
shift->{handle}->print (shift); |
$_[0]->{handle}->print ($_[1]); |
| 84 |
} # html |
} # html |
| 85 |
|
|
| 86 |
sub text ($$) { |
sub text ($$) { |
| 87 |
shift->html ($htescape->(shift)); |
$_[0]->{handle}->print ($htescape->($_[1])); |
| 88 |
} # text |
} # text |
| 89 |
|
|
| 90 |
sub url ($$%) { |
sub url ($$%) { |
| 91 |
my ($self, $url, %opt) = @_; |
my ($self, $url, %opt) = @_; |
| 92 |
$self->html (q[<code class=uri><]); |
$self->{handle}->print (q[<code class=uri><]); |
| 93 |
$self->link ($url, %opt, url => $url); |
$self->link ($url, %opt, url => $url); |
| 94 |
$self->html (q[></code>]); |
$self->{handle}->print (q[></code>]); |
| 95 |
} # url |
} # url |
| 96 |
|
|
| 97 |
sub start_tag ($$%) { |
sub start_tag ($$%) { |
| 98 |
my ($self, $tag_name, %opt) = @_; |
my ($self, $tag_name, %opt) = @_; |
| 99 |
$self->html ('<' . $htescape->($tag_name)); # escape for safety |
$self->{handle}->print ('<' . $tag_name); |
| 100 |
if (exists $opt{id}) { |
if (exists $opt{id}) { |
| 101 |
my $id = $self->input->id_prefix . $opt{id}; |
my $id = $self->input->id_prefix . $opt{id}; |
| 102 |
$self->html (' id="' . $htescape->($id) . '"'); |
$self->{handle}->print (' id="' . $htescape_value->($id) . '"'); |
| 103 |
delete $opt{id}; |
delete $opt{id}; |
| 104 |
} |
} |
| 105 |
for (keys %opt) { # for safety |
for (keys %opt) { |
| 106 |
$self->html (' ' . $htescape->($_) . '="' . $htescape->($opt{$_}) . '"'); |
$self->{handle}->print |
| 107 |
|
(' ' . $_ . '="' . $htescape_value->($opt{$_}) . '"'); |
| 108 |
} |
} |
| 109 |
$self->html ('>'); |
$self->{handle}->print ('>'); |
| 110 |
} # start_tag |
} # start_tag |
| 111 |
|
|
| 112 |
sub end_tag ($$) { |
sub end_tag ($$) { |
| 113 |
shift->html ('</' . $htescape->(shift) . '>'); |
$_[0]->{handle}->print ('</' . $_[1] . '>'); |
| 114 |
} # end_tag |
} # end_tag |
| 115 |
|
|
| 116 |
sub start_section ($%) { |
sub start_section ($%) { |
| 117 |
my ($self, %opt) = @_; |
my ($self, %opt) = @_; |
| 118 |
$self->html ('<div class=section'); |
|
| 119 |
|
my $class = 'section'; |
| 120 |
|
if (defined $opt{role}) { |
| 121 |
|
if ($opt{role} eq 'parse-errors') { |
| 122 |
|
$opt{id} ||= 'parse-errors'; |
| 123 |
|
$opt{title} ||= 'Parse Errors Section'; |
| 124 |
|
$opt{short_title} ||= 'Parse Errors'; |
| 125 |
|
$class .= ' errors'; |
| 126 |
|
delete $opt{role}; |
| 127 |
|
} elsif ($opt{role} eq 'structure-errors') { |
| 128 |
|
$opt{id} ||= 'document-errors'; |
| 129 |
|
$opt{title} ||= 'Structural Errors'; |
| 130 |
|
$opt{short_title} ||= 'Struct. Errors'; |
| 131 |
|
$class .= ' errors'; |
| 132 |
|
delete $opt{role}; |
| 133 |
|
} elsif ($opt{role} eq 'transfer-errors') { |
| 134 |
|
$opt{id} ||= 'transfer-errors'; |
| 135 |
|
$opt{title} ||= 'Transfer Errors'; |
| 136 |
|
$opt{short_title} ||= 'Trans. Errors'; |
| 137 |
|
$class .= ' errors'; |
| 138 |
|
delete $opt{role}; |
| 139 |
|
} elsif ($opt{role} eq 'reformatted') { |
| 140 |
|
$opt{id} ||= 'document-tree'; |
| 141 |
|
$opt{title} ||= 'Reformatted Document Source'; |
| 142 |
|
$opt{short_title} ||= 'Reformatted'; |
| 143 |
|
$class .= ' dump'; |
| 144 |
|
delete $opt{role} |
| 145 |
|
} elsif ($opt{role} eq 'tree') { |
| 146 |
|
$opt{id} ||= 'document-tree'; |
| 147 |
|
$opt{title} ||= 'Document Tree'; |
| 148 |
|
$opt{short_title} ||= 'Tree'; |
| 149 |
|
$class .= ' dump'; |
| 150 |
|
delete $opt{role}; |
| 151 |
|
} elsif ($opt{role} eq 'structure') { |
| 152 |
|
$opt{id} ||= 'document-structure'; |
| 153 |
|
$opt{title} ||= 'Document Structure'; |
| 154 |
|
$opt{short_title} ||= 'Structure'; |
| 155 |
|
$class .= ' dump'; |
| 156 |
|
delete $opt{role}; |
| 157 |
|
} elsif ($opt{role} eq 'subdoc') { |
| 158 |
|
$class .= ' subdoc'; |
| 159 |
|
delete $opt{role}; |
| 160 |
|
} elsif ($opt{role} eq 'source') { |
| 161 |
|
$opt{id} ||= 'source-string'; |
| 162 |
|
$opt{title} ||= 'Document Source'; |
| 163 |
|
$opt{short_title} ||= 'Source'; |
| 164 |
|
$class .= ' source'; |
| 165 |
|
delete $opt{role}; |
| 166 |
|
} elsif ($opt{role} eq 'result') { |
| 167 |
|
$opt{id} ||= 'result-summary'; |
| 168 |
|
$opt{title} ||= 'Result'; |
| 169 |
|
$class .= ' result'; |
| 170 |
|
delete $opt{role}; |
| 171 |
|
} |
| 172 |
|
} |
| 173 |
|
|
| 174 |
|
$self->{section_rank}++; |
| 175 |
|
$self->html (qq[<div class="$class"]); |
| 176 |
if (defined $opt{id}) { |
if (defined $opt{id}) { |
| 177 |
my $id = $self->input->id_prefix . $opt{id}; |
my $prefix = $self->input->id_prefix; |
| 178 |
$self->html (' id="' . $htescape->($id) . '"'); |
$opt{parent_id} ||= $prefix; |
| 179 |
push @{$self->{nav}}, [$id => $opt{short_title} || $opt{title}] |
my $id = $prefix . $opt{id}; |
| 180 |
unless $self->input->nested; |
$self->html (' id="' . $htescape->($id) . '">'); |
| 181 |
|
if ($self->{section_rank} == 2 or length $opt{parent_id}) { |
| 182 |
|
my $st = $opt{short_title} || $opt{title}; |
| 183 |
|
push @{$self->{nav}}, |
| 184 |
|
[$id => $st => $opt{text}] if $self->{section_rank} == 2; |
| 185 |
|
|
| 186 |
|
unless ($opt{notab}) { |
| 187 |
|
$self->start_tag ('script'); |
| 188 |
|
$self->html (qq[ addSectionLink ('$id', ']); |
| 189 |
|
$self->nl_text ($st, text => $opt{text}); |
| 190 |
|
if (defined $opt{parent_id}) { |
| 191 |
|
$self->html (q[', '] . $opt{parent_id}); |
| 192 |
|
} |
| 193 |
|
$self->html (q[') ]); |
| 194 |
|
$self->end_tag ('script'); |
| 195 |
|
} |
| 196 |
|
} |
| 197 |
|
} else { |
| 198 |
|
$self->html ('>'); |
| 199 |
} |
} |
| 200 |
$self->html ('><h2>' . $htescape->($opt{title}) . '</h2>'); |
my $section_rank = $self->{section_rank}; |
| 201 |
|
$section_rank = 6 if $section_rank > 6; |
| 202 |
|
$self->html ('<h' . $section_rank . '>'); |
| 203 |
|
$self->nl_text ($opt{title}, text => $opt{text}); |
| 204 |
|
$self->html ('</h' . $section_rank . '>'); |
| 205 |
} # start_section |
} # start_section |
| 206 |
|
|
| 207 |
sub end_section ($) { |
sub end_section ($) { |
| 208 |
my $self = shift; |
my $self = shift; |
| 209 |
$self->html ('</div>'); |
$self->html ('</div>'); |
| 210 |
$self->{handle}->flush; |
$self->{handle}->flush; |
| 211 |
|
$self->{section_rank}--; |
| 212 |
} # end_section |
} # end_section |
| 213 |
|
|
| 214 |
|
sub start_error_list ($%) { |
| 215 |
|
my ($self, %opt) = @_; |
| 216 |
|
|
| 217 |
|
if (defined $opt{role}) { |
| 218 |
|
if ($opt{role} eq 'parse-errors') { |
| 219 |
|
$opt{id} ||= 'parse-errors-list'; |
| 220 |
|
delete $opt{role}; |
| 221 |
|
} elsif ($opt{role} eq 'structure-errors') { |
| 222 |
|
$opt{id} ||= 'document-errors-list'; |
| 223 |
|
delete $opt{role}; |
| 224 |
|
} elsif ($opt{role} eq 'transfer-errors') { |
| 225 |
|
$opt{id} ||= 'transfer-errors-list'; |
| 226 |
|
delete $opt{role}; |
| 227 |
|
} |
| 228 |
|
} |
| 229 |
|
|
| 230 |
|
$self->start_tag ('dl', %opt); |
| 231 |
|
|
| 232 |
|
delete $self->{has_error}; # reset |
| 233 |
|
} # start_error_list |
| 234 |
|
|
| 235 |
|
sub end_error_list ($%) { |
| 236 |
|
my ($self, %opt) = @_; |
| 237 |
|
|
| 238 |
|
my $no_error_message = 'No error found.'; |
| 239 |
|
|
| 240 |
|
if (defined $opt{role}) { |
| 241 |
|
if ($opt{role} eq 'parse-errors') { |
| 242 |
|
$self->end_tag ('dl'); |
| 243 |
|
## NOTE: For parse error list, the |add_source_to_parse_error_list| |
| 244 |
|
## method is invoked at the end of |generate_source_string_section|, |
| 245 |
|
## since that generation method is invoked after the error list |
| 246 |
|
## is generated. |
| 247 |
|
$no_error_message = 'No parse error found.'; |
| 248 |
|
} elsif ($opt{role} eq 'structure-errors') { |
| 249 |
|
$self->end_tag ('dl'); |
| 250 |
|
$self->add_source_to_parse_error_list ('document-errors-list'); |
| 251 |
|
$no_error_message = 'No structural error found.'; |
| 252 |
|
} elsif ($opt{role} eq 'transfer-errors') { |
| 253 |
|
$self->end_tag ('dl'); |
| 254 |
|
$no_error_message = 'No transfer error found.'; |
| 255 |
|
} else { |
| 256 |
|
$self->end_tag ('dl'); |
| 257 |
|
} |
| 258 |
|
} else { |
| 259 |
|
$self->end_tag ('dl'); |
| 260 |
|
} |
| 261 |
|
|
| 262 |
|
unless ($self->{has_error}) { |
| 263 |
|
$self->start_tag ('p', class => 'no-errors'); |
| 264 |
|
$self->nl_text ($no_error_message); |
| 265 |
|
} |
| 266 |
|
} # end_error_list |
| 267 |
|
|
| 268 |
|
sub add_source_to_parse_error_list ($$) { |
| 269 |
|
my $self = shift; |
| 270 |
|
|
| 271 |
|
$self->script (q[addSourceToParseErrorList ('] . $self->input->id_prefix . |
| 272 |
|
q[', '] . shift () . q[')]); |
| 273 |
|
} # add_source_to_parse_error_list |
| 274 |
|
|
| 275 |
sub start_code_block ($) { |
sub start_code_block ($) { |
| 276 |
shift->html ('<pre><code>'); |
$_[0]->{handle}->print ('<pre><code>'); |
| 277 |
} # start_code_block |
} # start_code_block |
| 278 |
|
|
| 279 |
sub end_code_block ($) { |
sub end_code_block ($) { |
| 280 |
shift->html ('</code></pre>'); |
$_[0]->{handle}->print ('</code></pre>'); |
| 281 |
} # end_code_block |
} # end_code_block |
| 282 |
|
|
| 283 |
sub code ($$) { |
sub code ($$;%) { |
| 284 |
shift->html ('<code>' . $htescape->(shift) . '</code>'); |
my ($self, $content, %opt) = @_; |
| 285 |
|
$self->start_tag ('code', %opt); |
| 286 |
|
$self->text ($content); |
| 287 |
|
$self->{handle}->print ('</code>'); |
| 288 |
} # code |
} # code |
| 289 |
|
|
| 290 |
|
sub script ($$;%) { |
| 291 |
|
my ($self, $content, %opt) = @_; |
| 292 |
|
$self->start_tag ('script', %opt); |
| 293 |
|
$self->{handle}->print ($content . '</script>'); |
| 294 |
|
} # script |
| 295 |
|
|
| 296 |
|
sub dt ($$;%) { |
| 297 |
|
my ($self, $content, %opt) = @_; |
| 298 |
|
$self->start_tag ('dt', %opt); |
| 299 |
|
$self->nl_text ($content, text => $opt{text}); |
| 300 |
|
} # dt |
| 301 |
|
|
| 302 |
|
sub select ($$%) { |
| 303 |
|
my ($self, $options, %opt) = @_; |
| 304 |
|
|
| 305 |
|
my $selected = $opt{selected}; |
| 306 |
|
delete $opt{selected}; |
| 307 |
|
|
| 308 |
|
$self->start_tag ('select', %opt); |
| 309 |
|
|
| 310 |
|
my @options = @$options; |
| 311 |
|
while (@options) { |
| 312 |
|
my $opt = shift @options; |
| 313 |
|
if ($opt->{options}) { |
| 314 |
|
$self->{handle}->print ('<optgroup label="'); |
| 315 |
|
$self->nl_text ($opt->{label}); |
| 316 |
|
$self->{handle}->print ('">'); |
| 317 |
|
unshift @options, @{$opt->{options}}, {end_options => 1}; |
| 318 |
|
} elsif ($opt->{end_options}) { |
| 319 |
|
$self->end_tag ('optgroup'); |
| 320 |
|
} else { |
| 321 |
|
$self->start_tag ('option', value => $opt->{value}, |
| 322 |
|
((defined $selected and $opt->{value} eq $selected) |
| 323 |
|
? (selected => '') : ())); |
| 324 |
|
$self->nl_text (defined $opt->{label} ? $opt->{label} : $opt->{value}); |
| 325 |
|
} |
| 326 |
|
} |
| 327 |
|
|
| 328 |
|
$self->end_tag ('select'); |
| 329 |
|
} # select |
| 330 |
|
|
| 331 |
sub link ($$%) { |
sub link ($$%) { |
| 332 |
my ($self, $content, %opt) = @_; |
my ($self, $content, %opt) = @_; |
| 333 |
$self->html ('<a href="' . $htescape->($opt{url}) . '">'); |
$self->start_tag ('a', %opt, href => $opt{url}); |
| 334 |
$self->text ($content); |
$self->{handle}->print ($htescape->($content) . '</a>'); |
|
$self->html ('</a>'); |
|
| 335 |
} # link |
} # link |
| 336 |
|
|
| 337 |
sub xref ($$%) { |
sub xref ($$%) { |
| 338 |
my ($self, $content, %opt) = @_; |
my ($self, $content, %opt) = @_; |
| 339 |
|
$self->{handle}->print |
| 340 |
|
('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">'); |
| 341 |
|
$self->nl_text ($content, text => $opt{text}); |
| 342 |
|
$self->{handle}->print ('</a>'); |
| 343 |
|
} # xref |
| 344 |
|
|
| 345 |
|
sub xref_text ($$%) { |
| 346 |
|
my ($self, $content, %opt) = @_; |
| 347 |
$self->html ('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">'); |
$self->html ('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">'); |
| 348 |
$self->text ($content); |
$self->{handle}->print ($htescape->($content) . '</a>'); |
|
$self->html ('</a>'); |
|
| 349 |
} # xref |
} # xref |
| 350 |
|
|
| 351 |
sub nav_list ($) { |
sub link_to_webhacc ($$%) { |
| 352 |
|
my ($self, $content, %opt) = @_; |
| 353 |
|
$opt{url} = './?uri=' . $self->encode_url_component ($opt{url}); |
| 354 |
|
$self->link ($content, %opt); |
| 355 |
|
} # link_to_webhacc |
| 356 |
|
|
| 357 |
|
my $get_node_path = sub ($) { |
| 358 |
|
my $node = shift; |
| 359 |
|
my @r; |
| 360 |
|
while (defined $node) { |
| 361 |
|
my $rs; |
| 362 |
|
if ($node->node_type == 1) { |
| 363 |
|
$rs = $node->node_name; |
| 364 |
|
$node = $node->parent_node; |
| 365 |
|
} elsif ($node->node_type == 2) { |
| 366 |
|
$rs = '@' . $node->node_name; |
| 367 |
|
$node = $node->owner_element; |
| 368 |
|
} elsif ($node->node_type == 3) { |
| 369 |
|
$rs = '"' . $node->data . '"'; |
| 370 |
|
$node = $node->parent_node; |
| 371 |
|
} elsif ($node->node_type == 9) { |
| 372 |
|
@r = ('') unless @r; |
| 373 |
|
$rs = ''; |
| 374 |
|
$node = $node->parent_node; |
| 375 |
|
} else { |
| 376 |
|
$rs = '#' . $node->node_type; |
| 377 |
|
$node = $node->parent_node; |
| 378 |
|
} |
| 379 |
|
unshift @r, $rs; |
| 380 |
|
} |
| 381 |
|
return join '/', @r; |
| 382 |
|
}; # $get_node_path |
| 383 |
|
|
| 384 |
|
my $get_object_path = sub ($) { |
| 385 |
|
my $node = shift; |
| 386 |
|
my @r; |
| 387 |
|
while (defined $node) { |
| 388 |
|
my $ref = ref $node; |
| 389 |
|
$ref =~ /([^:]+)$/; |
| 390 |
|
my $rs = $1; |
| 391 |
|
my $node_name = $node->node_name; |
| 392 |
|
if (defined $node_name) { |
| 393 |
|
$rs .= ' <code>' . $htescape->($node_name) . '</code>'; |
| 394 |
|
} |
| 395 |
|
$node = undef; |
| 396 |
|
unshift @r, $rs; |
| 397 |
|
} |
| 398 |
|
return join '/', @r; |
| 399 |
|
}; # $get_object_path |
| 400 |
|
|
| 401 |
|
sub node_link ($$) { |
| 402 |
|
my ($self, $node) = @_; |
| 403 |
|
if ($node->isa ('Message::IF::Node')) { |
| 404 |
|
$self->xref_text ($get_node_path->($node), |
| 405 |
|
target => 'node-' . refaddr $node); |
| 406 |
|
} else { |
| 407 |
|
$self->{handle}->print ($get_object_path->($node)); |
| 408 |
|
} |
| 409 |
|
} # node_link |
| 410 |
|
|
| 411 |
|
{ |
| 412 |
|
my $Msg = {}; |
| 413 |
|
|
| 414 |
|
sub load_text_catalog ($$) { |
| 415 |
my $self = shift; |
my $self = shift; |
| 416 |
$self->html (q[<ul class="navigation" id="nav-items">]); |
|
| 417 |
for (@{$self->{nav}}) { |
my $lang = shift; # MUST be a canonical lang name |
| 418 |
$self->html (qq[<li><a href="@{[$htescape->($_->[0])]}">@{[$htescape->($_->[1])]}</a>]); |
my $file_name = qq[cc-msg.$lang.txt]; |
| 419 |
|
$lang = 'en' unless -f $file_name; |
| 420 |
|
$self->{primary_language} = $lang; |
| 421 |
|
|
| 422 |
|
open my $file, '<:utf8', $file_name or die "$0: $file_name: $!"; |
| 423 |
|
while (<$file>) { |
| 424 |
|
if (s/^([^;]+);([^;]*);//) { |
| 425 |
|
my ($type, $cls, $msg) = ($1, $2, $_); |
| 426 |
|
$msg =~ tr/\x0D\x0A//d; |
| 427 |
|
$Msg->{$type} = [$cls, $msg]; |
| 428 |
|
} |
| 429 |
|
} |
| 430 |
|
} # load_text_catalog |
| 431 |
|
|
| 432 |
|
sub nl_text ($$;%) { |
| 433 |
|
my ($self, $type, %opt) = @_; |
| 434 |
|
my $node = $opt{node}; |
| 435 |
|
|
| 436 |
|
if (defined $Msg->{$type}) { |
| 437 |
|
my $msg = $Msg->{$type}->[1]; |
| 438 |
|
if ($msg =~ /<var>/) { |
| 439 |
|
$msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{ |
| 440 |
|
UNIVERSAL::can ($node, 'get_attribute_ns') |
| 441 |
|
? $htescape->($node->get_attribute_ns (undef, $1)) : '' |
| 442 |
|
}ge; |
| 443 |
|
$msg =~ s{<var>{\@}</var>}{ |
| 444 |
|
UNIVERSAL::can ($node, 'value') ? $htescape->($node->value) : '' |
| 445 |
|
}ge; |
| 446 |
|
$msg =~ s{<var>{text}</var>}{ |
| 447 |
|
defined $opt{text} ? $htescape->($opt{text}) : '' |
| 448 |
|
}ge; |
| 449 |
|
$msg =~ s{<var>{value}</var>}{ |
| 450 |
|
defined $opt{value} ? $htescape->($opt{value}) : '' |
| 451 |
|
}ge; |
| 452 |
|
$msg =~ s{<var>{octets}</var>}{ |
| 453 |
|
if (defined $opt{octets}) { |
| 454 |
|
join ', ', map {sprintf '0x%02X', ord $_} split //, ${$opt{octets}}; |
| 455 |
|
} else { |
| 456 |
|
''; |
| 457 |
|
} |
| 458 |
|
}ge; |
| 459 |
|
$msg =~ s{<var>{char}</var>}{ |
| 460 |
|
defined $opt{char} ? $htescape->(${$opt{char}}) : '' |
| 461 |
|
}ge; |
| 462 |
|
$msg =~ s{<var>{char:hexref}</var>}{ |
| 463 |
|
if (defined $opt{char}) { |
| 464 |
|
join '', map {sprintf '&#x%02X;', ord $_} split //, ${$opt{char}}; |
| 465 |
|
} else { |
| 466 |
|
''; |
| 467 |
|
} |
| 468 |
|
}ge; |
| 469 |
|
$msg =~ s{<var>{local-name}</var>}{ |
| 470 |
|
UNIVERSAL::can ($node, 'manakai_local_name') |
| 471 |
|
? $htescape->($node->manakai_local_name) : '' |
| 472 |
|
}ge; |
| 473 |
|
$msg =~ s{<var>{element-local-name}</var>}{ |
| 474 |
|
(UNIVERSAL::can ($node, 'owner_element') and $node->owner_element) |
| 475 |
|
? $htescape->($node->owner_element->manakai_local_name) : '' |
| 476 |
|
}ge; |
| 477 |
|
} |
| 478 |
|
$self->{handle}->print ($msg); |
| 479 |
|
} else { |
| 480 |
|
$self->{handle}->print ($htescape->($type)); |
| 481 |
} |
} |
| 482 |
$self->html ('</ul>'); |
} # nl_text |
| 483 |
|
|
| 484 |
|
} |
| 485 |
|
|
| 486 |
|
sub nav_list ($) { |
| 487 |
|
# my $self = shift; |
| 488 |
|
# $self->html (q[<ul class="navigation" id="nav-items">]); |
| 489 |
|
# for (@{$self->{nav}}) { |
| 490 |
|
# $self->html (qq[<li><a href="#@{[$htescape->($_->[0])]}">]); |
| 491 |
|
# $self->nl_text ($_->[1], text => $_->[2]); |
| 492 |
|
# $self->html ('</a>'); |
| 493 |
|
# } |
| 494 |
|
# $self->html ('</ul>'); |
| 495 |
} # nav_list |
} # nav_list |
| 496 |
|
|
| 497 |
|
sub http_header ($) { |
| 498 |
|
$_[0]->{handle}->print (qq[Content-Type: text/html; charset=utf-8\n\n]); |
| 499 |
|
} # http_header |
| 500 |
|
|
| 501 |
|
sub http_error ($$) { |
| 502 |
|
my $self = shift; |
| 503 |
|
my $code = 0+shift; |
| 504 |
|
my $text = { |
| 505 |
|
404 => 'Not Found', |
| 506 |
|
}->{$code}; |
| 507 |
|
$self->{handle}->print |
| 508 |
|
(qq[Status: $code $text\nContent-Type: text/html ; charset=us-ascii\n\n$code $text]); |
| 509 |
|
} # http_error |
| 510 |
|
|
| 511 |
|
sub html_header ($) { |
| 512 |
|
my $self = shift; |
| 513 |
|
$self->{handle}->print (q[<!DOCTYPE html>]); |
| 514 |
|
$self->start_tag ('html', lang => $self->{primary_language}); |
| 515 |
|
$self->{handle}->print (q[<head><title>]); |
| 516 |
|
$self->nl_text (q[WebHACC:Title]); |
| 517 |
|
$self->{handle}->print (q[</title> |
| 518 |
|
<link rel="stylesheet" href="../cc-style.css" type="text/css"> |
| 519 |
|
<script src="../cc-script.js"></script> |
| 520 |
|
</head> |
| 521 |
|
<body onclick=" return onbodyclick (event) " onload=" onbodyload () "> |
| 522 |
|
<h1>]); |
| 523 |
|
$self->nl_text (q[WebHACC:Heading]); |
| 524 |
|
$self->{handle}->print (q[</h1><script> insertNavSections () </script>]); |
| 525 |
|
} # html_header |
| 526 |
|
|
| 527 |
|
sub generate_input_section ($$) { |
| 528 |
|
my ($out, $cgi) = @_; |
| 529 |
|
|
| 530 |
|
require Encode; |
| 531 |
|
my $decode = sub ($) { |
| 532 |
|
if (defined $_[0]) { |
| 533 |
|
return Encode::decode ('utf-8', $_[0]); |
| 534 |
|
} else { |
| 535 |
|
return undef; |
| 536 |
|
} |
| 537 |
|
}; # $decode |
| 538 |
|
|
| 539 |
|
my $options = sub ($) { |
| 540 |
|
my $context = shift; |
| 541 |
|
|
| 542 |
|
$out->{handle}->print (q[<div class="details default"><p class=legend onclick="nextSibling.style.display = nextSibling.style.display == 'block' ? 'none' : 'block'; parentNode.className = nextSibling.style.display == 'none' ? 'details' : 'details open'" tabindex=0>]); |
| 543 |
|
$out->nl_text (q[Options]); |
| 544 |
|
$out->start_tag ('div'); |
| 545 |
|
|
| 546 |
|
if ($context eq 'url') { |
| 547 |
|
$out->start_tag ('p'); |
| 548 |
|
$out->start_tag ('label'); |
| 549 |
|
$out->start_tag ('input', type => 'checkbox', name => 'error-page', |
| 550 |
|
value => 1, |
| 551 |
|
($cgi->get_parameter ('error-page') |
| 552 |
|
? (checked => '') : ())); |
| 553 |
|
$out->nl_text ('Check error page'); |
| 554 |
|
$out->end_tag ('label'); |
| 555 |
|
} |
| 556 |
|
|
| 557 |
|
$out->start_tag ('p'); |
| 558 |
|
$out->start_tag ('label'); |
| 559 |
|
$out->nl_text (q[Content type]); |
| 560 |
|
$out->text (': '); |
| 561 |
|
$out->select ([ |
| 562 |
|
{value => '', label => 'As specified'}, |
| 563 |
|
{value => 'application/atom+xml'}, |
| 564 |
|
{value => 'text/cache-manifest'}, |
| 565 |
|
{value => 'text/css'}, |
| 566 |
|
{value => 'text/x-css-inline'}, |
| 567 |
|
{value => 'text/x-h2h'}, |
| 568 |
|
{value => 'text/html'}, |
| 569 |
|
{value => 'text/x-regexp-js'}, |
| 570 |
|
{value => 'text/x-webidl'}, |
| 571 |
|
{value => 'application/xhtml+xml'}, |
| 572 |
|
{value => 'application/xml'}, |
| 573 |
|
{value => 'text/xml'}, |
| 574 |
|
], name => 'i', selected => scalar $cgi->get_parameter ('i')); |
| 575 |
|
$out->end_tag ('label'); |
| 576 |
|
|
| 577 |
|
if ($context ne 'text') { |
| 578 |
|
$out->start_tag ('p'); |
| 579 |
|
$out->start_tag ('label'); |
| 580 |
|
$out->nl_text (q[Charset]); |
| 581 |
|
$out->text (q[: ]); |
| 582 |
|
$out->select ([ |
| 583 |
|
{value => '', label => 'As specified'}, |
| 584 |
|
{label => 'Japanese charsets', options => [ |
| 585 |
|
{value => 'Windows-31J'}, |
| 586 |
|
{value => 'Shift_JIS'}, |
| 587 |
|
{value => 'x-sjis'}, |
| 588 |
|
{value => 'EUC-JP'}, |
| 589 |
|
{value => 'x-euc-jp'}, |
| 590 |
|
{value => 'ISO-2022-JP'}, |
| 591 |
|
{value => 'ISO-2022-JP-1'}, |
| 592 |
|
{value => 'ISO-2022-JP-2'}, |
| 593 |
|
]}, |
| 594 |
|
{label => 'Latin charsets', options => [ |
| 595 |
|
{value => 'Windows-1250'}, |
| 596 |
|
{value => 'Windows-1252'}, |
| 597 |
|
{value => 'Windows-1254'}, |
| 598 |
|
{value => 'Windows-1257'}, |
| 599 |
|
{value => 'Windows-1258'}, |
| 600 |
|
{value => 'ISO-8859-1'}, |
| 601 |
|
{value => 'ISO-8859-2'}, |
| 602 |
|
{value => 'ISO-8859-3'}, |
| 603 |
|
{value => 'ISO-8859-4'}, |
| 604 |
|
{value => 'ISO-8859-9'}, |
| 605 |
|
{value => 'ISO-8859-10'}, |
| 606 |
|
{value => 'ISO-8859-13'}, |
| 607 |
|
{value => 'ISO-8859-14'}, |
| 608 |
|
{value => 'ISO-8859-15'}, |
| 609 |
|
{value => 'ISO-8859-16'}, |
| 610 |
|
{value => 'US-ASCII'}, |
| 611 |
|
]}, |
| 612 |
|
{label => 'Greek charsets', options => [ |
| 613 |
|
{value => 'Windows-1253'}, |
| 614 |
|
{value => 'ISO-8859-7'}, |
| 615 |
|
]}, |
| 616 |
|
{label => 'Cyrillic charsets', options => [ |
| 617 |
|
{value => 'Windows-1251'}, |
| 618 |
|
{value => 'ISO-8859-5'}, |
| 619 |
|
]}, |
| 620 |
|
{label => 'Arabic charsets', options => [ |
| 621 |
|
{value => 'Windows-1256'}, |
| 622 |
|
{value => 'ISO-8859-6'}, |
| 623 |
|
]}, |
| 624 |
|
{label => 'Hebrew charsets', options => [ |
| 625 |
|
{value => 'Windows-1255'}, |
| 626 |
|
{value => 'ISO-8859-8'}, |
| 627 |
|
]}, |
| 628 |
|
{label => 'Thai charsets', options => [ |
| 629 |
|
{value => 'Windows-874'}, |
| 630 |
|
{value => 'ISO-8859-11'}, |
| 631 |
|
{value => 'TIS-620'}, |
| 632 |
|
]}, |
| 633 |
|
{label => 'Chinese charsets', options => [ |
| 634 |
|
{value => 'Big5'}, |
| 635 |
|
{value => 'x-x-big5'}, |
| 636 |
|
{value => 'Big5-HKSCS'}, |
| 637 |
|
{value => 'GBK'}, |
| 638 |
|
{value => 'GB2312'}, |
| 639 |
|
{value => 'GB_2312-80'}, |
| 640 |
|
{value => 'ISO-2022-CN'}, |
| 641 |
|
{value => 'ISO-2022-CN-EXT'}, |
| 642 |
|
]}, |
| 643 |
|
{label => 'Korean charsets', options => [ |
| 644 |
|
{value => 'Windows-949'}, |
| 645 |
|
{value => 'EUC-KR'}, |
| 646 |
|
{value => 'KS_C_5601-1987'}, |
| 647 |
|
{value => 'ISO-2022-KR'}, |
| 648 |
|
]}, |
| 649 |
|
{label => 'Unicode charsets', options => [ |
| 650 |
|
{value => 'UTF-8'}, |
| 651 |
|
{value => 'UTF-8n'}, |
| 652 |
|
{value => 'UTF-16'}, |
| 653 |
|
{value => 'UTF-16BE'}, |
| 654 |
|
{value => 'UTF-16LE'}, |
| 655 |
|
]}, |
| 656 |
|
], name => 'charset', |
| 657 |
|
selected => scalar $cgi->get_parameter ('charset')); |
| 658 |
|
$out->end_tag ('label'); |
| 659 |
|
} |
| 660 |
|
|
| 661 |
|
if ($context eq 'text') { |
| 662 |
|
$out->start_tag ('p'); |
| 663 |
|
$out->start_tag ('label'); |
| 664 |
|
$out->nl_text ('Setting innerHTML'); |
| 665 |
|
$out->text (': '); |
| 666 |
|
$out->start_tag ('input', name => 'e', |
| 667 |
|
value => $decode->(scalar $cgi->get_parameter ('e'))); |
| 668 |
|
$out->end_tag ('label'); |
| 669 |
|
} |
| 670 |
|
|
| 671 |
|
$out->{handle}->print (q[</div></div>]); |
| 672 |
|
}; # $options |
| 673 |
|
|
| 674 |
|
$out->start_section (id => 'input', title => 'Input'); |
| 675 |
|
$out->html (q[<script> insertNavSections ('input') </script>]); |
| 676 |
|
|
| 677 |
|
$out->start_section (id => 'input-url', title => 'By URL', |
| 678 |
|
parent_id => 'input'); |
| 679 |
|
$out->start_tag ('form', action => './#result-summary', |
| 680 |
|
'accept-charset' => 'utf-8', |
| 681 |
|
method => 'get'); |
| 682 |
|
$out->start_tag ('input', type => 'hidden', name => '_charset_'); |
| 683 |
|
|
| 684 |
|
$out->start_tag ('p'); |
| 685 |
|
$out->start_tag ('label'); |
| 686 |
|
$out->nl_text ('URL'); |
| 687 |
|
$out->text (': '); |
| 688 |
|
$out->start_tag ('input', |
| 689 |
|
name => 'uri', |
| 690 |
|
type => 'url', |
| 691 |
|
value => $decode->(scalar $cgi->get_parameter ('uri'))); |
| 692 |
|
$out->end_tag ('label'); |
| 693 |
|
|
| 694 |
|
$out->start_tag ('p'); |
| 695 |
|
$out->start_tag ('button', type => 'submit'); |
| 696 |
|
$out->nl_text ('Check'); |
| 697 |
|
$out->end_tag ('button'); |
| 698 |
|
|
| 699 |
|
$options->('url'); |
| 700 |
|
|
| 701 |
|
$out->end_tag ('form'); |
| 702 |
|
$out->end_section; |
| 703 |
|
|
| 704 |
|
## TODO: File upload |
| 705 |
|
|
| 706 |
|
$out->start_section (id => 'input-text', title => 'By direct input', |
| 707 |
|
parent_id => 'input'); |
| 708 |
|
$out->start_tag ('form', action => './#result-summary', |
| 709 |
|
'accept-charset' => 'utf-8', |
| 710 |
|
method => 'post'); |
| 711 |
|
$out->start_tag ('input', type => 'hidden', name => '_charset_'); |
| 712 |
|
|
| 713 |
|
$out->start_tag ('p'); |
| 714 |
|
$out->start_tag ('label'); |
| 715 |
|
$out->nl_text ('Document source to check'); |
| 716 |
|
$out->text (': '); |
| 717 |
|
$out->start_tag ('br'); |
| 718 |
|
$out->start_tag ('textarea', |
| 719 |
|
name => 's'); |
| 720 |
|
my $s = $decode->($cgi->get_parameter ('s')); |
| 721 |
|
$out->html ($htescape_value->($s)) if defined $s; |
| 722 |
|
$out->end_tag ('textarea'); |
| 723 |
|
$out->end_tag ('label'); |
| 724 |
|
|
| 725 |
|
$out->start_tag ('p'); |
| 726 |
|
$out->start_tag ('button', type => 'submit', |
| 727 |
|
onclick => 'form.method = form.s.value.length > 512 ? "post" : "get"'); |
| 728 |
|
$out->nl_text ('Check'); |
| 729 |
|
$out->end_tag ('button'); |
| 730 |
|
|
| 731 |
|
$options->('text'); |
| 732 |
|
|
| 733 |
|
$out->end_tag ('form'); |
| 734 |
|
$out->end_section; |
| 735 |
|
|
| 736 |
|
$out->script (q[ |
| 737 |
|
if (!document.webhaccNavigated && |
| 738 |
|
document.getElementsByTagName ('textarea')[0].value.length > 0) { |
| 739 |
|
showTab ('input-text'); |
| 740 |
|
document.webhaccNavigated = false; |
| 741 |
|
} |
| 742 |
|
]); |
| 743 |
|
|
| 744 |
|
$out->end_section; |
| 745 |
|
} # generate_input_section |
| 746 |
|
|
| 747 |
|
sub encode_url_component ($$) { |
| 748 |
|
shift; |
| 749 |
|
require Encode; |
| 750 |
|
my $s = Encode::encode ('utf8', shift); |
| 751 |
|
$s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge; |
| 752 |
|
return $s; |
| 753 |
|
} # encode_url_component |
| 754 |
|
|
| 755 |
1; |
1; |
Parent Directory
| 
Revision Log
| 
Patch