/[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.8 by wakaba, Sat Jul 26 11:27:25 2008 UTC
# Line 95  sub start_section ($%) { Line 95  sub start_section ($%) {
95    if (defined $opt{role}) {    if (defined $opt{role}) {
96      if ($opt{role} eq 'parse-errors') {      if ($opt{role} eq 'parse-errors') {
97        $opt{id} ||= 'parse-errors';        $opt{id} ||= 'parse-errors';
98        $opt{title} ||= 'Parse Errors';        $opt{title} ||= 'Parse Errors Section';
99          $opt{short_title} ||= 'Parse Errors';
100        delete $opt{role};        delete $opt{role};
101      } elsif ($opt{role} eq 'structure-errors') {      } elsif ($opt{role} eq 'structure-errors') {
102        $opt{id} ||= 'document-errors';        $opt{id} ||= 'document-errors';
# Line 125  sub start_section ($%) { Line 126  sub start_section ($%) {
126    if (defined $opt{id}) {    if (defined $opt{id}) {
127      my $id = $self->input->id_prefix . $opt{id};      my $id = $self->input->id_prefix . $opt{id};
128      $self->html (' id="' . $htescape->($id) . '"');      $self->html (' id="' . $htescape->($id) . '"');
129      push @{$self->{nav}}, [$id => $opt{short_title} || $opt{title}]      push @{$self->{nav}},
130            [$id => $opt{short_title} || $opt{title} => $opt{text}]
131          if $self->{section_rank} == 2;          if $self->{section_rank} == 2;
132    }    }
133    my $section_rank = $self->{section_rank};    my $section_rank = $self->{section_rank};
134    $section_rank = 6 if $section_rank > 6;    $section_rank = 6 if $section_rank > 6;
135    $self->html ('><h' . $section_rank . '>' .    $self->html ('><h' . $section_rank . '>');
136                 $htescape->($opt{title}) .    $self->nl_text ($opt{title}, text => $opt{text});
137                 '</h' . $section_rank . '>');    $self->html ('</h' . $section_rank . '>');
138  } # start_section  } # start_section
139    
140  sub end_section ($) {  sub end_section ($) {
# Line 213  sub script ($$;%) { Line 215  sub script ($$;%) {
215  sub dt ($$;%) {  sub dt ($$;%) {
216    my ($self, $content, %opt) = @_;    my ($self, $content, %opt) = @_;
217    $self->start_tag ('dt', %opt);    $self->start_tag ('dt', %opt);
218    $self->text ($content);    $self->nl_text ($content, text => $opt{text});
219  } # dt  } # dt
220    
221  sub link ($$%) {  sub link ($$%) {
# Line 226  sub link ($$%) { Line 228  sub link ($$%) {
228  sub xref ($$%) {  sub xref ($$%) {
229    my ($self, $content, %opt) = @_;    my ($self, $content, %opt) = @_;
230    $self->html ('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">');    $self->html ('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">');
231    $self->text ($content);    $self->nl_text ($content, text => $opt{text});
232    $self->html ('</a>');    $self->html ('</a>');
233  } # xref  } # xref
234    
# Line 236  sub link_to_webhacc ($$%) { Line 238  sub link_to_webhacc ($$%) {
238    $self->link ($content, %opt);    $self->link ($content, %opt);
239  } # link_to_webhacc  } # link_to_webhacc
240    
   
241  my $get_node_path = sub ($) {  my $get_node_path = sub ($) {
242    my $node = shift;    my $node = shift;
243    my @r;    my @r;
# Line 269  sub node_link ($$) { Line 270  sub node_link ($$) {
270    $self->xref ($get_node_path->($node), target => 'node-' . refaddr $node);    $self->xref ($get_node_path->($node), target => 'node-' . refaddr $node);
271  } # node_link  } # 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 ($) {  sub nav_list ($) {
339    my $self = shift;    my $self = shift;
340    $self->html (q[<ul class="navigation" id="nav-items">]);    $self->html (q[<ul class="navigation" id="nav-items">]);
341    for (@{$self->{nav}}) {    for (@{$self->{nav}}) {
342      $self->html (qq[<li><a href="#@{[$htescape->($_->[0])]}">@{[$htescape->($_->[1])]}</a>]);      $self->html (qq[<li><a href="#@{[$htescape->($_->[0])]}">]);
343        $self->nl_text ($_->[1], text => $_->[2]);
344        $self->html ('</a>');
345    }    }
346    $self->html ('</ul>');    $self->html ('</ul>');
347  } # nav_list  } # nav_list
# Line 293  sub http_error ($$) { Line 361  sub http_error ($$) {
361    
362  sub html_header ($) {  sub html_header ($) {
363    my $self = shift;    my $self = shift;
364    $self->html (q[<!DOCTYPE html>    $self->html (q[<!DOCTYPE html>]);
365  <html lang="en">    $self->start_tag ('html', lang => $self->{primary_language});
366  <head>    $self->html (q[<head><title>]);
367  <title>WebHACC (BETA) Result</title>    $self->nl_text (q[WebHACC:Title]);
368      $self->html (q[</title>
369  <link rel="stylesheet" href="../cc-style.css" type="text/css">  <link rel="stylesheet" href="../cc-style.css" type="text/css">
370    <script src="../cc-script.js"></script>
371  </head>  </head>
372  <body>  <body>
373  <h1><a href="../cc-interface"><abbr title="Web Hypertext Application Conformance Checker (BETA)"><img src="../icons/title" alt="WebHACC"></abbr></a></h1>  <h1>]);
374  ]);    $self->nl_text (q[WebHACC:Heading]);
375      $self->html ('</h1>');
376  } # html_header  } # html_header
377    
378  sub encode_url_component ($$) {  sub encode_url_component ($$) {
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.8
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24