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>Web Document Conformance Checker (BETA)</title>
<link rel="stylesheet" href="../cc-style.css" type="text/css">
</head>
<body>
<h1><a href="../cc-interface">Web Document Conformance Checker</a> 
(<em>beta</em>)</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	package WebHACC::Output;
2	use strict;
3
4	require IO::Handle;
5	use Scalar::Util qw/refaddr/;
6
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	return bless {nav => [], section_rank => 1}, shift;
21	} # 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
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	$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	if $self->{section_rank} == 2;
130	}
131	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	} # start_section
137
138	sub end_section ($) {
139	my $self = shift;
140	$self->html ('</div>');
141	$self->{handle}->flush;
142	$self->{section_rank}--;
143	} # end_section
144
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
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	sub code ($$;%) {
200	my ($self, $content, %opt) = @_;
201	$self->start_tag ('code', %opt);
202	$self->text ($content);
203	$self->html ('</code>');
204	} # code
205
206	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	sub link ($$%) {
220	my ($self, $content, %opt) = @_;
221	$self->start_tag ('a', %opt, href => $opt{url});
222	$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	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
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	sub nav_list ($) {
273	my $self = shift;
274	$self->html (q[<ul class="navigation" id="nav-items">]);
275	for (@{$self->{nav}}) {
276	$self->html (qq[<li><a href="#@{[$htescape->($_->[0])]}">@{[$htescape->($_->[1])]}</a>]);
277	}
278	$self->html ('</ul>');
279	} # nav_list
280
281	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	<title>Web Document Conformance Checker (BETA)</title>
300	<link rel="stylesheet" href="../cc-style.css" type="text/css">
301	</head>
302	<body>
303	<h1><a href="../cc-interface">Web Document Conformance Checker</a>
304	(<em>beta</em>)</h1>
305	]);
306	} # html_header
307
308	sub encode_url_component ($$) {
309	shift;
310	require Encode;
311	my $s = Encode::encode ('utf8', shift);
312	$s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge;
313	return $s;
314	} # encode_url_component
315
316	1;