/[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.6 by wakaba, Mon Jul 21 09:54:59 2008 UTC revision 1.9 by wakaba, Sun Jul 27 10:33:46 2008 UTC
# Line 17  my $htescape = sub ($) { Line 17  my $htescape = sub ($) {
17  };  };
18    
19  sub new ($) {  sub new ($) {
20    return bless {nav => [], section_rank => 1}, 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 25  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 95  sub start_section ($%) { Line 97  sub start_section ($%) {
97    if (defined $opt{role}) {    if (defined $opt{role}) {
98      if ($opt{role} eq 'parse-errors') {      if ($opt{role} eq 'parse-errors') {
99        $opt{id} ||= 'parse-errors';        $opt{id} ||= 'parse-errors';
100        $opt{title} ||= 'Parse Errors';        $opt{title} ||= 'Parse Errors Section';
101          $opt{short_title} ||= 'Parse Errors';
102        delete $opt{role};        delete $opt{role};
103      } elsif ($opt{role} eq 'structure-errors') {      } elsif ($opt{role} eq 'structure-errors') {
104        $opt{id} ||= 'document-errors';        $opt{id} ||= 'document-errors';
# Line 125  sub start_section ($%) { Line 128  sub start_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            [$id => $opt{short_title} || $opt{title} => $opt{text}]
133          if $self->{section_rank} == 2;          if $self->{section_rank} == 2;
134    }    }
135    my $section_rank = $self->{section_rank};    my $section_rank = $self->{section_rank};
136    $section_rank = 6 if $section_rank > 6;    $section_rank = 6 if $section_rank > 6;
137    $self->html ('><h' . $section_rank . '>' .    $self->html ('><h' . $section_rank . '>');
138                 $htescape->($opt{title}) .    $self->nl_text ($opt{title}, text => $opt{text});
139                 '</h' . $section_rank . '>');    $self->html ('</h' . $section_rank . '>');
140  } # start_section  } # start_section
141    
142  sub end_section ($) {  sub end_section ($) {
# Line 185  sub add_source_to_parse_error_list ($$) Line 189  sub add_source_to_parse_error_list ($$)
189    my $self = shift;    my $self = shift;
190    
191    $self->script (q[addSourceToParseErrorList ('] . $self->input->id_prefix .    $self->script (q[addSourceToParseErrorList ('] . $self->input->id_prefix .
192                   q[', '] . shift . q[')]);                   q[', '] . shift () . q[')]);
193  } # add_source_to_parse_error_list  } # add_source_to_parse_error_list
194    
195  sub start_code_block ($) {  sub start_code_block ($) {
# Line 213  sub script ($$;%) { Line 217  sub script ($$;%) {
217  sub dt ($$;%) {  sub dt ($$;%) {
218    my ($self, $content, %opt) = @_;    my ($self, $content, %opt) = @_;
219    $self->start_tag ('dt', %opt);    $self->start_tag ('dt', %opt);
220    $self->text ($content);    $self->nl_text ($content, text => $opt{text});
221  } # dt  } # 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->start_tag ('a', %opt, href => $opt{url});    $self->start_tag ('a', %opt, href => $opt{url});
# Line 226  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    
# Line 236  sub link_to_webhacc ($$%) { Line 269  sub link_to_webhacc ($$%) {
269    $self->link ($content, %opt);    $self->link ($content, %opt);
270  } # link_to_webhacc  } # link_to_webhacc
271    
   
272  my $get_node_path = sub ($) {  my $get_node_path = sub ($) {
273    my $node = shift;    my $node = shift;
274    my @r;    my @r;
# Line 269  sub node_link ($$) { Line 301  sub node_link ($$) {
301    $self->xref ($get_node_path->($node), target => 'node-' . refaddr $node);    $self->xref ($get_node_path->($node), target => 'node-' . refaddr $node);
302  } # node_link  } # 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
# Line 293  sub http_error ($$) { Line 392  sub http_error ($$) {
392    
393  sub html_header ($) {  sub html_header ($) {
394    my $self = shift;    my $self = shift;
395    $self->html (q[<!DOCTYPE html>    $self->html (q[<!DOCTYPE html>]);
396  <html lang="en">    $self->start_tag ('html', lang => $self->{primary_language});
397  <head>    $self->html (q[<head><title>]);
398  <title>WebHACC (BETA) Result</title>    $self->nl_text (q[WebHACC:Title]);
399      $self->html (q[</title>
400  <link rel="stylesheet" href="../cc-style.css" type="text/css">  <link rel="stylesheet" href="../cc-style.css" type="text/css">
401    <script src="../cc-script.js"></script>
402  </head>  </head>
403  <body>  <body>
404  <h1><a href="../cc-interface"><abbr title="Web Hypertext Application Conformance Checker (BETA)"><img src="../icons/title" alt="WebHACC"></abbr></a></h1>  <h1>]);
405  ]);    $self->nl_text (q[WebHACC:Heading]);
406      $self->html ('</h1>');
407  } # html_header  } # 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 ($$) {  sub encode_url_component ($$) {
554    shift;    shift;
555    require Encode;    require Encode;
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.9
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24