/[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.8 by wakaba, Sat Jul 26 11:27:25 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;    return bless {nav => [], section_rank => 1}, shift;
21  } # new  } # new
22    
23  sub input ($;$) {  sub input ($;$) {
# Line 89  sub end_tag ($$) { Line 91  sub end_tag ($$) {
91    
92  sub start_section ($%) {  sub start_section ($%) {
93    my ($self, %opt) = @_;    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');    $self->html ('<div class=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          unless $self->input->nested;          [$id => $opt{short_title} || $opt{title} => $opt{text}]
131            if $self->{section_rank} == 2;
132    }    }
133    $self->html ('><h2>' . $htescape->($opt{title}) . '</h2>');    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  } # start_section
139    
140  sub end_section ($) {  sub end_section ($) {
141    my $self = shift;    my $self = shift;
142    $self->html ('</div>');    $self->html ('</div>');
143    $self->{handle}->flush;    $self->{handle}->flush;
144      $self->{section_rank}--;
145  } # end_section  } # 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 ($) {  sub start_code_block ($) {
194    shift->html ('<pre><code>');    shift->html ('<pre><code>');
195  } # start_code_block  } # start_code_block
# Line 113  sub end_code_block ($) { Line 198  sub end_code_block ($) {
198    shift->html ('</code></pre>');    shift->html ('</code></pre>');
199  } # end_code_block  } # end_code_block
200    
201  sub code ($$) {  sub code ($$;%) {
202    shift->html ('<code>' . $htescape->(shift) . '</code>');    my ($self, $content, %opt) = @_;
203      $self->start_tag ('code', %opt);
204      $self->text ($content);
205      $self->html ('</code>');
206  } # code  } # 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 ($$%) {  sub link ($$%) {
222    my ($self, $content, %opt) = @_;    my ($self, $content, %opt) = @_;
223    $self->html ('<a href="' . $htescape->($opt{url}) . '">');    $self->start_tag ('a', %opt, href => $opt{url});
224    $self->text ($content);    $self->text ($content);
225    $self->html ('</a>');    $self->html ('</a>');
226  } # link  } # link
# Line 127  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    
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 ($) {  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
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;  1;
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.8
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24