html-webhacc/WebHACC/Output.pm

package WebHACC::Output;
use strict;

require IO::Handle;
use Scalar::Util qw/refaddr/;

my $htescape = sub ($) {
  my $s = $_[0];
  $s =~ s/&/&amp;/g;
  $s =~ s/</&lt;/g;
  $s =~ s/>/&gt;/g;
  $s =~ s/"/&quot;/g;
  $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{
    sprintf '<var>U+%04X</var>', ord $1;
  }ge;
  return $s;
};

sub new ($) {
  return bless {nav => [], section_rank => 1}, shift;
} # new

sub input ($;$) {
  if (@_ > 1) {
    if (defined $_[1]) {
      $_[0]->{input} = $_[1];
    } else {
      delete $_[0]->{input};
    }
  }
  
  return $_[0]->{input};
} # input

sub handle ($;$) {
  if (@_ > 1) {
    if (defined $_[1]) {
      $_[0]->{handle} = $_[1];
    } else {
      delete $_[0]->{handle};
    }
  }
  
  return $_[0]->{handle};
} # handle

sub set_utf8 ($) {
  binmode shift->{handle}, ':utf8';
} # set_utf8

sub set_flush ($) {
  shift->{handle}->autoflush (1);
} # set_flush

sub unset_flush ($) {
  shift->{handle}->autoflush (0);
} # unset_flush

sub html ($$) {
  shift->{handle}->print (shift);
} # html

sub text ($$) {
  shift->html ($htescape->(shift));
} # text

sub url ($$%) {
  my ($self, $url, %opt) = @_;
  $self->html (q[<code class=uri>&lt;]);
  $self->link ($url, %opt, url => $url);
  $self->html (q[></code>]);
} # url

sub start_tag ($$%) {
  my ($self, $tag_name, %opt) = @_;
  $self->html ('<' . $htescape->($tag_name)); # escape for safety
  if (exists $opt{id}) {
    my $id = $self->input->id_prefix . $opt{id};
    $self->html (' id="' . $htescape->($id) . '"');
    delete $opt{id};
  }
  for (keys %opt) {    # for safety
    $self->html (' ' . $htescape->($_) . '="' . $htescape->($opt{$_}) . '"');
  }
  $self->html ('>');
} # start_tag

sub end_tag ($$) {
  shift->html ('</' . $htescape->(shift) . '>');
} # end_tag

sub start_section ($%) {
  my ($self, %opt) = @_;

  if (defined $opt{role}) {
    if ($opt{role} eq 'parse-errors') {
      $opt{id} ||= 'parse-errors';
      $opt{title} ||= 'Parse Errors';
      delete $opt{role};
    } elsif ($opt{role} eq 'structure-errors') {
      $opt{id} ||= 'document-errors';
      $opt{title} ||= 'Structural Errors';
      $opt{short_title} ||= 'Struct. Errors';
      delete $opt{role};
    } elsif ($opt{role} eq 'reformatted') {
      $opt{id} ||= 'document-tree';
      $opt{title} ||= 'Reformatted Document Source';
      $opt{short_title} ||= 'Reformatted';
      delete $opt{role}
    } elsif ($opt{role} eq 'tree') {
      $opt{id} ||= 'document-tree';
      $opt{title} ||= 'Document Tree';
      $opt{short_title} ||= 'Tree';
      delete $opt{role};
    } elsif ($opt{role} eq 'structure') {
      $opt{id} ||= 'document-structure';
      $opt{title} ||= 'Document Structure';
      $opt{short_title} ||= 'Structure';
      delete $opt{role};
    }
  }

  $self->{section_rank}++;
  $self->html ('<div class=section');
  if (defined $opt{id}) {
    my $id = $self->input->id_prefix . $opt{id};
    $self->html (' id="' . $htescape->($id) . '"');
    push @{$self->{nav}}, [$id => $opt{short_title} || $opt{title}] 
        if $self->{section_rank} == 2;
  }
  my $section_rank = $self->{section_rank};
  $section_rank = 6 if $section_rank > 6;
  $self->html ('><h' . $section_rank . '>' .
               $htescape->($opt{title}) .
               '</h' . $section_rank . '>');
} # start_section

sub end_section ($) {
  my $self = shift;
  $self->html ('</div>');
  $self->{handle}->flush;
  $self->{section_rank}--;
} # end_section

sub start_error_list ($%) {
  my ($self, %opt) = @_;

  if (defined $opt{role}) {
    if ($opt{role} eq 'parse-errors') {
      $opt{id} ||= 'parse-errors-list';
      delete $opt{role};
    } elsif ($opt{role} eq 'structure-errors') {
      $opt{id} ||= 'document-errors-list';
      delete $opt{role};
    }
  }

  $self->start_tag ('dl', %opt);
} # start_error_list

sub end_error_list ($%) {
  my ($self, %opt) = @_;

  if (defined $opt{role}) {
    if ($opt{role} eq 'parse-errors') {
      delete $opt{role};
      $self->end_tag ('dl');
      ## NOTE: For parse error list, the |add_source_to_parse_error_list|
      ## method is invoked at the end of |generate_source_string_section|,
      ## since that generation method is invoked after the error list
      ## is generated.
    } elsif ($opt{role} eq 'structure-errors') {
      delete $opt{role};
      $self->end_tag ('dl');
      $self->add_source_to_parse_error_list ('document-errors-list');
    } else {
      $self->end_tag ('dl');
    }
  } else {
    $self->end_tag ('dl');
  }
} # end_error_list

sub add_source_to_parse_error_list ($$) {
  my $self = shift;

  $self->script (q[addSourceToParseErrorList ('] . $self->input->id_prefix .
                 q[', '] . shift . q[')]);
} # add_source_to_parse_error_list

sub start_code_block ($) {
  shift->html ('<pre><code>');
} # start_code_block

sub end_code_block ($) {
  shift->html ('</code></pre>');
} # end_code_block

sub code ($$;%) {
  my ($self, $content, %opt) = @_;
  $self->start_tag ('code', %opt);
  $self->text ($content);
  $self->html ('</code>');
} # code

sub script ($$;%) {
  my ($self, $content, %opt) = @_;
  $self->start_tag ('script', %opt);
  $self->html ($content);
  $self->html ('</script>');
} # script

sub dt ($$;%) {
  my ($self, $content, %opt) = @_;
  $self->start_tag ('dt', %opt);
  $self->text ($content);
} # dt

sub link ($$%) {
  my ($self, $content, %opt) = @_;
  $self->start_tag ('a', %opt, href => $opt{url});
  $self->text ($content);
  $self->html ('</a>');
} # link

sub xref ($$%) {
  my ($self, $content, %opt) = @_;
  $self->html ('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">');
  $self->text ($content);
  $self->html ('</a>');
} # xref

sub link_to_webhacc ($$%) {
  my ($self, $content, %opt) = @_;
  $opt{url} = './?uri=' . $self->encode_url_component ($opt{url});
  $self->link ($content, %opt);
} # link_to_webhacc


my $get_node_path = sub ($) {
  my $node = shift;
  my @r;
  while (defined $node) {
    my $rs;
    if ($node->node_type == 1) {
      $rs = $node->node_name;
      $node = $node->parent_node;
    } elsif ($node->node_type == 2) {
      $rs = '@' . $node->node_name;
      $node = $node->owner_element;
    } elsif ($node->node_type == 3) {
      $rs = '"' . $node->data . '"';
      $node = $node->parent_node;
    } elsif ($node->node_type == 9) {
      @r = ('') unless @r;
      $rs = '';
      $node = $node->parent_node;
    } else {
      $rs = '#' . $node->node_type;
      $node = $node->parent_node;
    }
    unshift @r, $rs;
  }
  return join '/', @r;
}; # $get_node_path

sub node_link ($$) {
  my ($self, $node) = @_;
  $self->xref ($get_node_path->($node), target => 'node-' . refaddr $node);
} # node_link

sub nav_list ($) {
  my $self = shift;
  $self->html (q[<ul class="navigation" id="nav-items">]);
  for (@{$self->{nav}}) {
    $self->html (qq[<li><a href="#@{[$htescape->($_->[0])]}">@{[$htescape->($_->[1])]}</a>]);
  }
  $self->html ('</ul>');
} # nav_list

sub http_header ($) {
  shift->html (qq[Content-Type: text/html; charset=utf-8\n\n]);
} # http_header

sub http_error ($$) {
  my $self = shift;
  my $code = 0+shift;
  my $text = {
    404 => 'Not Found',
  }->{$code};
  $self->html (qq[Status: $code $text\nContent-Type: text/html ; charset=us-ascii\n\n$code $text]);
} # http_error

sub html_header ($) {
  my $self = shift;
  $self->html (q[<!DOCTYPE html>
<html lang="en">
<head>
<title>WebHACC (BETA) Result</title>
<link rel="stylesheet" href="../cc-style.css" type="text/css">
</head>
<body>
<h1><a href="../cc-interface"><abbr title="Web Hypertext Application Conformance Checker (BETA)"><img src="../icons/title" alt="WebHACC"></abbr></a></h1>
]);
} # html_header

sub encode_url_component ($$) {
  shift;
  require Encode;
  my $s = Encode::encode ('utf8', shift);
  $s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge;
  return $s;
} # encode_url_component

1;
1	wakaba	1.1	package WebHACC::Output;
2			use strict;
3	wakaba	1.3
4	wakaba	1.1	require IO::Handle;
5	wakaba	1.3	use Scalar::Util qw/refaddr/;
6	wakaba	1.1
7			my $htescape = sub ($) {
8			my $s = $_[0];
9			$s =~ s/&/&/g;
10			$s =~ s/</</g;
11			$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			sub new ($) {
20	wakaba	1.4	return bless {nav => [], section_rank => 1}, shift;
21	wakaba	1.1	} # new
22
23			sub input ($;$) {
24			if (@_ > 1) {
25			if (defined $_[1]) {
26			$_[0]->{input} = $_[1];
27			} else {
28			delete $_[0]->{input};
29			}
30			}
31
32			return $_[0]->{input};
33			} # input
34
35			sub handle ($;$) {
36			if (@_ > 1) {
37			if (defined $_[1]) {
38			$_[0]->{handle} = $_[1];
39			} else {
40			delete $_[0]->{handle};
41			}
42			}
43
44			return $_[0]->{handle};
45			} # handle
46
47			sub set_utf8 ($) {
48			binmode shift->{handle}, ':utf8';
49			} # set_utf8
50
51			sub set_flush ($) {
52			shift->{handle}->autoflush (1);
53			} # set_flush
54
55			sub unset_flush ($) {
56			shift->{handle}->autoflush (0);
57			} # unset_flush
58
59			sub html ($$) {
60			shift->{handle}->print (shift);
61			} # html
62
63			sub text ($$) {
64			shift->html ($htescape->(shift));
65			} # text
66
67			sub url ($$%) {
68			my ($self, $url, %opt) = @_;
69			$self->html (q[<code class=uri><]);
70			$self->link ($url, %opt, url => $url);
71			$self->html (q[></code>]);
72			} # url
73
74			sub start_tag ($$%) {
75			my ($self, $tag_name, %opt) = @_;
76			$self->html ('<' . $htescape->($tag_name)); # escape for safety
77			if (exists $opt{id}) {
78			my $id = $self->input->id_prefix . $opt{id};
79			$self->html (' id="' . $htescape->($id) . '"');
80			delete $opt{id};
81			}
82			for (keys %opt) { # for safety
83			$self->html (' ' . $htescape->($_) . '="' . $htescape->($opt{$_}) . '"');
84			}
85			$self->html ('>');
86			} # start_tag
87
88			sub end_tag ($$) {
89			shift->html ('</' . $htescape->(shift) . '>');
90			} # end_tag
91
92			sub start_section ($%) {
93			my ($self, %opt) = @_;
94	wakaba	1.4
95			if (defined $opt{role}) {
96			if ($opt{role} eq 'parse-errors') {
97			$opt{id} \|\|= 'parse-errors';
98			$opt{title} \|\|= 'Parse Errors';
99			delete $opt{role};
100			} elsif ($opt{role} eq 'structure-errors') {
101			$opt{id} \|\|= 'document-errors';
102			$opt{title} \|\|= 'Structural Errors';
103			$opt{short_title} \|\|= 'Struct. Errors';
104			delete $opt{role};
105			} elsif ($opt{role} eq 'reformatted') {
106			$opt{id} \|\|= 'document-tree';
107			$opt{title} \|\|= 'Reformatted Document Source';
108			$opt{short_title} \|\|= 'Reformatted';
109			delete $opt{role}
110			} elsif ($opt{role} eq 'tree') {
111			$opt{id} \|\|= 'document-tree';
112			$opt{title} \|\|= 'Document Tree';
113			$opt{short_title} \|\|= 'Tree';
114			delete $opt{role};
115			} elsif ($opt{role} eq 'structure') {
116			$opt{id} \|\|= 'document-structure';
117			$opt{title} \|\|= 'Document Structure';
118			$opt{short_title} \|\|= 'Structure';
119			delete $opt{role};
120			}
121			}
122
123			$self->{section_rank}++;
124	wakaba	1.1	$self->html ('<div class=section');
125			if (defined $opt{id}) {
126			my $id = $self->input->id_prefix . $opt{id};
127			$self->html (' id="' . $htescape->($id) . '"');
128			push @{$self->{nav}}, [$id => $opt{short_title} \|\| $opt{title}]
129	wakaba	1.4	if $self->{section_rank} == 2;
130	wakaba	1.1	}
131	wakaba	1.4	my $section_rank = $self->{section_rank};
132			$section_rank = 6 if $section_rank > 6;
133			$self->html ('><h' . $section_rank . '>' .
134			$htescape->($opt{title}) .
135			'</h' . $section_rank . '>');
136	wakaba	1.1	} # start_section
137
138			sub end_section ($) {
139			my $self = shift;
140			$self->html ('</div>');
141			$self->{handle}->flush;
142	wakaba	1.4	$self->{section_rank}--;
143	wakaba	1.1	} # end_section
144	wakaba	1.4
145			sub start_error_list ($%) {
146			my ($self, %opt) = @_;
147
148			if (defined $opt{role}) {
149			if ($opt{role} eq 'parse-errors') {
150			$opt{id} \|\|= 'parse-errors-list';
151			delete $opt{role};
152			} elsif ($opt{role} eq 'structure-errors') {
153			$opt{id} \|\|= 'document-errors-list';
154			delete $opt{role};
155			}
156			}
157
158			$self->start_tag ('dl', %opt);
159			} # start_error_list
160
161			sub end_error_list ($%) {
162			my ($self, %opt) = @_;
163
164			if (defined $opt{role}) {
165			if ($opt{role} eq 'parse-errors') {
166			delete $opt{role};
167			$self->end_tag ('dl');
168			## NOTE: For parse error list, the \|add_source_to_parse_error_list\|
169			## method is invoked at the end of \|generate_source_string_section\|,
170			## since that generation method is invoked after the error list
171			## is generated.
172			} elsif ($opt{role} eq 'structure-errors') {
173			delete $opt{role};
174			$self->end_tag ('dl');
175			$self->add_source_to_parse_error_list ('document-errors-list');
176			} else {
177			$self->end_tag ('dl');
178			}
179			} else {
180			$self->end_tag ('dl');
181			}
182			} # end_error_list
183
184			sub add_source_to_parse_error_list ($$) {
185			my $self = shift;
186
187			$self->script (q[addSourceToParseErrorList ('] . $self->input->id_prefix .
188			q[', '] . shift . q[')]);
189			} # add_source_to_parse_error_list
190	wakaba	1.1
191			sub start_code_block ($) {
192			shift->html ('<pre><code>');
193			} # start_code_block
194
195			sub end_code_block ($) {
196			shift->html ('</code></pre>');
197			} # end_code_block
198
199	wakaba	1.3	sub code ($$;%) {
200			my ($self, $content, %opt) = @_;
201			$self->start_tag ('code', %opt);
202			$self->text ($content);
203			$self->html ('</code>');
204	wakaba	1.1	} # code
205
206	wakaba	1.3	sub script ($$;%) {
207			my ($self, $content, %opt) = @_;
208			$self->start_tag ('script', %opt);
209			$self->html ($content);
210			$self->html ('</script>');
211			} # script
212
213			sub dt ($$;%) {
214			my ($self, $content, %opt) = @_;
215			$self->start_tag ('dt', %opt);
216			$self->text ($content);
217			} # dt
218
219	wakaba	1.1	sub link ($$%) {
220			my ($self, $content, %opt) = @_;
221	wakaba	1.2	$self->start_tag ('a', %opt, href => $opt{url});
222	wakaba	1.1	$self->text ($content);
223			$self->html ('</a>');
224			} # link
225
226			sub xref ($$%) {
227			my ($self, $content, %opt) = @_;
228			$self->html ('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">');
229			$self->text ($content);
230			$self->html ('</a>');
231			} # xref
232
233	wakaba	1.2	sub link_to_webhacc ($$%) {
234			my ($self, $content, %opt) = @_;
235			$opt{url} = './?uri=' . $self->encode_url_component ($opt{url});
236			$self->link ($content, %opt);
237			} # link_to_webhacc
238
239	wakaba	1.3
240			my $get_node_path = sub ($) {
241			my $node = shift;
242			my @r;
243			while (defined $node) {
244			my $rs;
245			if ($node->node_type == 1) {
246			$rs = $node->node_name;
247			$node = $node->parent_node;
248			} elsif ($node->node_type == 2) {
249			$rs = '@' . $node->node_name;
250			$node = $node->owner_element;
251			} elsif ($node->node_type == 3) {
252			$rs = '"' . $node->data . '"';
253			$node = $node->parent_node;
254			} elsif ($node->node_type == 9) {
255			@r = ('') unless @r;
256			$rs = '';
257			$node = $node->parent_node;
258			} else {
259			$rs = '#' . $node->node_type;
260			$node = $node->parent_node;
261			}
262			unshift @r, $rs;
263			}
264			return join '/', @r;
265			}; # $get_node_path
266
267			sub node_link ($$) {
268			my ($self, $node) = @_;
269			$self->xref ($get_node_path->($node), target => 'node-' . refaddr $node);
270			} # node_link
271
272	wakaba	1.1	sub nav_list ($) {
273			my $self = shift;
274			$self->html (q[<ul class="navigation" id="nav-items">]);
275			for (@{$self->{nav}}) {
276	wakaba	1.3	$self->html (qq[<li><a href="#@{[$htescape->($_->[0])]}">@{[$htescape->($_->[1])]}</a>]);
277	wakaba	1.1	}
278			$self->html ('</ul>');
279			} # nav_list
280	wakaba	1.2
281	wakaba	1.5	sub http_header ($) {
282			shift->html (qq[Content-Type: text/html; charset=utf-8\n\n]);
283			} # http_header
284
285			sub http_error ($$) {
286			my $self = shift;
287			my $code = 0+shift;
288			my $text = {
289			404 => 'Not Found',
290			}->{$code};
291			$self->html (qq[Status: $code $text\nContent-Type: text/html ; charset=us-ascii\n\n$code $text]);
292			} # http_error
293
294			sub html_header ($) {
295			my $self = shift;
296			$self->html (q[<!DOCTYPE html>
297			<html lang="en">
298			<head>
299	wakaba	1.6	<title>WebHACC (BETA) Result</title>
300	wakaba	1.5	<link rel="stylesheet" href="../cc-style.css" type="text/css">
301			</head>
302			<body>
303	wakaba	1.6	<h1><a href="../cc-interface"><abbr title="Web Hypertext Application Conformance Checker (BETA)"><img src="../icons/title" alt="WebHACC"></abbr></a></h1>
304	wakaba	1.5	]);
305			} # html_header
306	wakaba	1.2
307			sub encode_url_component ($$) {
308			shift;
309			require Encode;
310			my $s = Encode::encode ('utf8', shift);
311			$s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge;
312			return $s;
313			} # encode_url_component
314	wakaba	1.1
315			1;