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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by wakaba, Sun Jul 20 14:58:24 2008 UTC revision 1.9 by wakaba, Sun Jul 27 10:33:46 2008 UTC
# Line 1  Line 1 
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];
# Line 15  my $htescape = sub ($) { Line 17  my $htescape = sub ($) {
17  };  };
18    
19  sub new ($) {  sub new ($) {
20    return bless {nav => []}, shift;    require WebHACC::Input;
21      return bless {nav => [], section_rank => 1,
22                    input => WebHACC::Input->new}, shift;
23  } # new  } # new
24    
25  sub input ($;$) {  sub input ($;$) {
# Line 23  sub input ($;$) { Line 27  sub input ($;$) {
27      if (defined $_[1]) {      if (defined $_[1]) {
28        $_[0]->{input} = $_[1];        $_[0]->{input} = $_[1];
29      } else {      } else {
30        delete $_[0]->{input};        $_[0]->{input} = WebHACC::Input->new;
31      }      }
32    }    }
33        
# Line 89  sub end_tag ($$) { Line 93  sub end_tag ($$) {
93    
94  sub start_section ($%) {  sub start_section ($%) {
95    my ($self, %opt) = @_;    my ($self, %opt) = @_;
96    
97      if (defined $opt{role}) {
98        if ($opt{role} eq 'parse-errors') {
99          $opt{id} ||= 'parse-errors';
100          $opt{title} ||= 'Parse Errors Section';
101          $opt{short_title} ||= 'Parse Errors';
102          delete $opt{role};
103        } elsif ($opt{role} eq 'structure-errors') {
104          $opt{id} ||= 'document-errors';
105          $opt{title} ||= 'Structural Errors';
106          $opt{short_title} ||= 'Struct. Errors';
107          delete $opt{role};
108        } elsif ($opt{role} eq 'reformatted') {
109          $opt{id} ||= 'document-tree';
110          $opt{title} ||= 'Reformatted Document Source';
111          $opt{short_title} ||= 'Reformatted';
112          delete $opt{role}
113        } elsif ($opt{role} eq 'tree') {
114          $opt{id} ||= 'document-tree';
115          $opt{title} ||= 'Document Tree';
116          $opt{short_title} ||= 'Tree';
117          delete $opt{role};
118        } elsif ($opt{role} eq 'structure') {
119          $opt{id} ||= 'document-structure';
120          $opt{title} ||= 'Document Structure';
121          $opt{short_title} ||= 'Structure';
122          delete $opt{role};
123        }
124      }
125    
126      $self->{section_rank}++;
127    $self->html ('<div class=section');    $self->html ('<div class=section');
128    if (defined $opt{id}) {    if (defined $opt{id}) {
129      my $id = $self->input->id_prefix . $opt{id};      my $id = $self->input->id_prefix . $opt{id};
130      $self->html (' id="' . $htescape->($id) . '"');      $self->html (' id="' . $htescape->($id) . '"');
131      push @{$self->{nav}}, [$id => $opt{short_title} || $opt{title}]      push @{$self->{nav}},
132          unless $self->input->nested;          [$id => $opt{short_title} || $opt{title} => $opt{text}]
133            if $self->{section_rank} == 2;
134    }    }
135    $self->html ('><h2>' . $htescape->($opt{title}) . '</h2>');    my $section_rank = $self->{section_rank};
136      $section_rank = 6 if $section_rank > 6;
137      $self->html ('><h' . $section_rank . '>');
138      $self->nl_text ($opt{title}, text => $opt{text});
139      $self->html ('</h' . $section_rank . '>');
140  } # start_section  } # start_section
141    
142  sub end_section ($) {  sub end_section ($) {
143    my $self = shift;    my $self = shift;
144    $self->html ('</div>');    $self->html ('</div>');
145    $self->{handle}->flush;    $self->{handle}->flush;
146      $self->{section_rank}--;
147  } # end_section  } # end_section
148    
149    sub start_error_list ($%) {
150      my ($self, %opt) = @_;
151    
152      if (defined $opt{role}) {
153        if ($opt{role} eq 'parse-errors') {
154          $opt{id} ||= 'parse-errors-list';
155          delete $opt{role};
156        } elsif ($opt{role} eq 'structure-errors') {
157          $opt{id} ||= 'document-errors-list';
158          delete $opt{role};
159        }
160      }
161    
162      $self->start_tag ('dl', %opt);
163    } # start_error_list
164    
165    sub end_error_list ($%) {
166      my ($self, %opt) = @_;
167    
168      if (defined $opt{role}) {
169        if ($opt{role} eq 'parse-errors') {
170          delete $opt{role};
171          $self->end_tag ('dl');
172          ## NOTE: For parse error list, the |add_source_to_parse_error_list|
173          ## method is invoked at the end of |generate_source_string_section|,
174          ## since that generation method is invoked after the error list
175          ## is generated.
176        } elsif ($opt{role} eq 'structure-errors') {
177          delete $opt{role};
178          $self->end_tag ('dl');
179          $self->add_source_to_parse_error_list ('document-errors-list');
180        } else {
181          $self->end_tag ('dl');
182        }
183      } else {
184        $self->end_tag ('dl');
185      }
186    } # end_error_list
187    
188    sub add_source_to_parse_error_list ($$) {
189      my $self = shift;
190    
191      $self->script (q[addSourceToParseErrorList ('] . $self->input->id_prefix .
192                     q[', '] . shift () . q[')]);
193    } # add_source_to_parse_error_list
194    
195  sub start_code_block ($) {  sub start_code_block ($) {
196    shift->html ('<pre><code>');    shift->html ('<pre><code>');
197  } # start_code_block  } # start_code_block
# Line 113  sub end_code_block ($) { Line 200  sub end_code_block ($) {
200    shift->html ('</code></pre>');    shift->html ('</code></pre>');
201  } # end_code_block  } # end_code_block
202    
203  sub code ($$) {  sub code ($$;%) {
204    shift->html ('<code>' . $htescape->(shift) . '</code>');    my ($self, $content, %opt) = @_;
205      $self->start_tag ('code', %opt);
206      $self->text ($content);
207      $self->html ('</code>');
208  } # code  } # code
209    
210    sub script ($$;%) {
211      my ($self, $content, %opt) = @_;
212      $self->start_tag ('script', %opt);
213      $self->html ($content);
214      $self->html ('</script>');
215    } # script
216    
217    sub dt ($$;%) {
218      my ($self, $content, %opt) = @_;
219      $self->start_tag ('dt', %opt);
220      $self->nl_text ($content, text => $opt{text});
221    } # dt
222    
223    sub select ($$%) {
224      my ($self, $options, %opt) = @_;
225    
226      my $selected = $opt{selected};
227      delete $opt{selected};
228    
229      $self->start_tag ('select', %opt);
230      
231      my @options = @$options;
232      while (@options) {
233        my $opt = shift @options;
234        if ($opt->{options}) {
235          $self->html ('<optgroup label="');
236          $self->nl_text ($opt->{label});
237          $self->html ('">');
238          unshift @options, @{$opt->{options}}, {end_options => 1};
239        } elsif ($opt->{end_options}) {
240          $self->end_tag ('optgroup');
241        } else {
242          $self->start_tag ('option', value => $opt->{value},
243                            ((defined $selected and $opt->{value} eq $selected)
244                                 ? (selected => '') : ()));
245          $self->nl_text (defined $opt->{label} ? $opt->{label} : $opt->{value});
246        }
247      }
248    
249      $self->end_tag ('select');
250    } # select
251    
252  sub link ($$%) {  sub link ($$%) {
253    my ($self, $content, %opt) = @_;    my ($self, $content, %opt) = @_;
254    $self->html ('<a href="' . $htescape->($opt{url}) . '">');    $self->start_tag ('a', %opt, href => $opt{url});
255    $self->text ($content);    $self->text ($content);
256    $self->html ('</a>');    $self->html ('</a>');
257  } # link  } # link
# Line 127  sub link ($$%) { Line 259  sub link ($$%) {
259  sub xref ($$%) {  sub xref ($$%) {
260    my ($self, $content, %opt) = @_;    my ($self, $content, %opt) = @_;
261    $self->html ('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">');    $self->html ('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">');
262    $self->text ($content);    $self->nl_text ($content, text => $opt{text});
263    $self->html ('</a>');    $self->html ('</a>');
264  } # xref  } # xref
265    
266    sub link_to_webhacc ($$%) {
267      my ($self, $content, %opt) = @_;
268      $opt{url} = './?uri=' . $self->encode_url_component ($opt{url});
269      $self->link ($content, %opt);
270    } # link_to_webhacc
271    
272    my $get_node_path = sub ($) {
273      my $node = shift;
274      my @r;
275      while (defined $node) {
276        my $rs;
277        if ($node->node_type == 1) {
278          $rs = $node->node_name;
279          $node = $node->parent_node;
280        } elsif ($node->node_type == 2) {
281          $rs = '@' . $node->node_name;
282          $node = $node->owner_element;
283        } elsif ($node->node_type == 3) {
284          $rs = '"' . $node->data . '"';
285          $node = $node->parent_node;
286        } elsif ($node->node_type == 9) {
287          @r = ('') unless @r;
288          $rs = '';
289          $node = $node->parent_node;
290        } else {
291          $rs = '#' . $node->node_type;
292          $node = $node->parent_node;
293        }
294        unshift @r, $rs;
295      }
296      return join '/', @r;
297    }; # $get_node_path
298    
299    sub node_link ($$) {
300      my ($self, $node) = @_;
301      $self->xref ($get_node_path->($node), target => 'node-' . refaddr $node);
302    } # node_link
303    
304    {
305      my $Msg = {};
306    
307    sub load_text_catalog ($$) {
308      my $self = shift;
309    
310      my $lang = shift; # MUST be a canonical lang name
311      my $file_name = qq[cc-msg.$lang.txt];
312      $lang = 'en' unless -f $file_name;
313      $self->{primary_language} = $lang;
314      
315      open my $file, '<:utf8', $file_name or die "$0: $file_name: $!";
316      while (<$file>) {
317        if (s/^([^;]+);([^;]*);//) {
318          my ($type, $cls, $msg) = ($1, $2, $_);
319          $msg =~ tr/\x0D\x0A//d;
320          $Msg->{$type} = [$cls, $msg];
321        }
322      }
323    } # load_text_catalog
324    
325    sub nl_text ($$;%) {
326      my ($self, $type, %opt) = @_;
327      my $node = $opt{node};
328    
329      my @arg;
330      {
331        if (defined $Msg->{$type}) {
332          my $msg = $Msg->{$type}->[1];
333          if ($msg =~ /<var>/) {
334            $msg =~ s{<var>\$([0-9]+)</var>}{
335              defined $arg[$1] ? $htescape->($arg[$1]) : '(undef)';
336            }ge;
337            $msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{
338              UNIVERSAL::can ($node, 'get_attribute_ns')
339                  ? $htescape->($node->get_attribute_ns (undef, $1)) : ''
340            }ge;
341            $msg =~ s{<var>{\@}</var>}{
342              UNIVERSAL::can ($node, 'value') ? $htescape->($node->value) : ''
343            }ge;
344            $msg =~ s{<var>{text}</var>}{
345              defined $opt{text} ? $htescape->($opt{text}) : ''
346            }ge;
347            $msg =~ s{<var>{local-name}</var>}{
348              UNIVERSAL::can ($node, 'manakai_local_name')
349                ? $htescape->($node->manakai_local_name) : ''
350            }ge;
351            $msg =~ s{<var>{element-local-name}</var>}{
352              (UNIVERSAL::can ($node, 'owner_element') and
353               $node->owner_element)
354                ? $htescape->($node->owner_element->manakai_local_name) : ''
355            }ge;
356          }
357          $self->html ($msg);
358          return;
359        } elsif ($type =~ s/:([^:]*)$//) {
360          unshift @arg, $1;
361          redo;
362        }
363      }
364      $self->text ($type);
365    } # nl_text
366    
367    }
368    
369  sub nav_list ($) {  sub nav_list ($) {
370    my $self = shift;    my $self = shift;
371    $self->html (q[<ul class="navigation" id="nav-items">]);    $self->html (q[<ul class="navigation" id="nav-items">]);
372    for (@{$self->{nav}}) {    for (@{$self->{nav}}) {
373      $self->html (qq[<li><a href="@{[$htescape->($_->[0])]}">@{[$htescape->($_->[1])]}</a>]);      $self->html (qq[<li><a href="#@{[$htescape->($_->[0])]}">]);
374        $self->nl_text ($_->[1], text => $_->[2]);
375        $self->html ('</a>');
376    }    }
377    $self->html ('</ul>');    $self->html ('</ul>');
378  } # nav_list  } # nav_list
379    
380    sub http_header ($) {
381      shift->html (qq[Content-Type: text/html; charset=utf-8\n\n]);
382    } # http_header
383    
384    sub http_error ($$) {
385      my $self = shift;
386      my $code = 0+shift;
387      my $text = {
388        404 => 'Not Found',
389      }->{$code};
390      $self->html (qq[Status: $code $text\nContent-Type: text/html ; charset=us-ascii\n\n$code $text]);
391    } # http_error
392    
393    sub html_header ($) {
394      my $self = shift;
395      $self->html (q[<!DOCTYPE html>]);
396      $self->start_tag ('html', lang => $self->{primary_language});
397      $self->html (q[<head><title>]);
398      $self->nl_text (q[WebHACC:Title]);
399      $self->html (q[</title>
400    <link rel="stylesheet" href="../cc-style.css" type="text/css">
401    <script src="../cc-script.js"></script>
402    </head>
403    <body>
404    <h1>]);
405      $self->nl_text (q[WebHACC:Heading]);
406      $self->html ('</h1>');
407    } # html_header
408    
409    sub generate_input_section ($$) {
410      my ($out, $cgi) = @_;
411    
412      my $options = sub ($) {
413        my $context = shift;
414    
415        $out->html (q[<div class=details><p class=legend onclick="nextSibling.style.display = nextSibling.style.display == 'none' ? 'block' : 'none'">]);
416        $out->nl_text (q[Options]);
417        $out->start_tag ('div');
418    
419        if ($context eq 'url') {
420          $out->start_tag ('p');
421          $out->start_tag ('label');
422          $out->start_tag ('input', type => 'checkbox', name => 'error-page',
423                           value => 1,
424                           ($cgi->get_parameter ('error-page')
425                                ? (checked => '') : ()));
426          $out->nl_text ('Check error page');
427          $out->end_tag ('label');
428        }
429    
430        $out->start_tag ('p');
431        $out->start_tag ('label');
432        $out->nl_text (q[Content type]);
433        $out->text (': ');
434        $out->select ([
435          {value => '', label => 'As specified'},
436          {value => 'application/atom+xml'},
437          {value => 'application/xhtml+xml'},
438          {value => 'application/xml'},
439          {value => 'text/html'},
440          {value => 'text/xml'},
441          {value => 'text/css'},
442          {value => 'text/cache-manifest'},
443          {value => 'text/x-webidl'},
444        ], name => 'i', selected => scalar $cgi->get_parameter ('i'));
445        $out->end_tag ('label');
446    
447        if ($context ne 'text') {
448          $out->start_tag ('p');
449          $out->start_tag ('label');
450          $out->nl_text (q[Charset]);
451          $out->text (q[: ]);
452          $out->select ([
453            {value => '', label => 'As specified'},
454            {label => 'Japanese charsets', options => [
455              {value => 'Windows-31J'},
456              {value => 'Shift_JIS'},
457              {value => 'EUC-JP'},
458              {value => 'ISO-2022-JP'},
459            ]},
460            {label => 'European charsets', options => [
461              {value => 'Windows-1252'},
462              {value => 'ISO-8859-1'},
463              {value => 'US-ASCII'},
464            ]},
465            {label => 'Asian charsets', options => [
466              {value => 'Windows-874'},
467              {value => 'ISO-8859-11'},
468              {value => 'TIS-620'},
469            ]},
470            {label => 'Unicode charsets', options => [
471              {value => 'UTF-8'},
472              {value => 'UTF-8n'},
473            ]},
474          ], name => 'charset',
475          selected => scalar $cgi->get_parameter ('charset'));
476          $out->end_tag ('label');
477        }
478    
479        if ($context eq 'text') {
480          $out->start_tag ('p');
481          $out->start_tag ('label');
482          $out->nl_text ('Setting innerHTML');
483          $out->text (': ');
484          $out->start_tag ('input', name => 'e',
485                           value => scalar $cgi->get_parameter ('e'));
486          $out->end_tag ('label');
487        }
488    
489        $out->html (q[</div></div>]);
490      }; # $options
491    
492      $out->start_section (id => 'input', title => 'Input');
493    
494      $out->start_section (id => 'input-url', title => 'By URL');
495      $out->start_tag ('form', action => './', 'accept-charset' => 'utf-8',
496                       method => 'get');
497      $out->start_tag ('input', type => 'hidden', name => '_charset_');
498    
499      $out->start_tag ('p');
500      $out->start_tag ('label');
501      $out->nl_text ('URL');
502      $out->text (': ');
503      $out->start_tag ('input',
504                       name => 'uri',
505                       type => 'url',
506                       value => $cgi->get_parameter ('uri'));
507      $out->end_tag ('label');
508    
509      $options->('url');
510    
511      $out->start_tag ('p');
512      $out->start_tag ('button', type => 'submit');
513      $out->nl_text ('Check');
514    
515      $out->end_tag ('form');
516      $out->end_section;
517    
518      $out->end_tag ('fieldset');
519    
520      ## TODO: File upload
521    
522      $out->start_section (id => 'input-text', title => 'By direct input');
523      $out->start_tag ('form', action => './', 'accept-charset' => 'utf-8',
524                       method => 'post');
525      $out->start_tag ('input', type => 'hidden', name => '_charset_');
526    
527      $out->start_tag ('p');
528      $out->start_tag ('label');
529      $out->nl_text ('Document source to check');
530      $out->text (': ');
531      $out->start_tag ('br');
532      $out->start_tag ('textarea',
533                       name => 's');
534      my $s = $cgi->get_parameter ('s');
535      $out->text ($s) if defined $s;
536      $out->end_tag ('textarea');
537      $out->end_tag ('label');
538    
539      $options->('text');
540    
541      $out->start_tag ('p');
542      $out->start_tag ('button', type => 'submit',
543                       onclick => 'form.method = form.s.value.length > 512 ? "post" : "get"');
544      $out->nl_text ('Check');
545      $out->end_tag ('button');
546    
547      $out->end_tag ('form');
548      $out->end_section;
549    
550      $out->end_section;
551    } # generate_input_section
552    
553    sub encode_url_component ($$) {
554      shift;
555      require Encode;
556      my $s = Encode::encode ('utf8', shift);
557      $s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge;
558      return $s;
559    } # encode_url_component
560    
561  1;  1;
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.9
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24