WebHACC/Language/Base.pm

package WebHACC::Language::Base;
use strict;

sub new ($) {
  die "$0: No constructor is defined for " . ref $_[0];
} # new

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

  return $_[0]->{input};
} # input

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

  return $_[0]->{output};
} # output

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

  return $_[0]->{result};
} # result

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

  return $_[0]->{onsubdoc} || sub { };
} # onsubdoc

sub generate_syntax_error_section ($) {
  die "$0: Syntactical checking for " . ref $_[0] . " is not supported";
} # generate_syntax_error_section

sub generate_structure_dump_section ($) {
  #
} # generate_structure_dump_section

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

  my $out = $self->output;
  
  $out->start_section (id => 'document-errors', title => 'Document Errors');
  $out->html ('<p>Not supported for this kind of contents.');
  ## TODO: class="???"
  $out->end_section;
} # generate_structure_error_section

sub source_charset ($) {
  return 'utf-8';
} # source_charset

sub generate_source_string_section ($) {
  my $self = shift;
  my $input = $self->input;

  my $s;
  unless ($input->{is_char_string}) {
    open my $byte_stream, '<', \($input->{s});
    require Message::Charset::Info;
    my $charset = Message::Charset::Info->get_by_iana_name
        ($self->source_charset);
    my ($char_stream, $e_status) = $charset->get_decode_handle
        ($byte_stream, allow_error_reporting => 1, allow_fallback => 1);
    return unless $char_stream;

    $char_stream->onerror (sub {
      my (undef, $type, %opt) = @_;
      if ($opt{octets}) {
        ${$opt{octets}} = "\x{FFFD}";
      }
    });

    my $t = '';
    while (1) {
      my $c = $char_stream->getc;
      last unless defined $c;
      $t .= $c;
    }
    $s = \$t;
    ## TODO: Output for each line, don't concat all of lines.
  } else {
    $s = \($input->{s});
  }

  my $out = $self->output;
  my $i = 1;
  $out->start_section (id => 'source-string', title => 'Document Source',
                       short_title => 'Source');
  $out->start_tag ('ol', lang => '');

  if (length $$s) {
    while ($$s =~ /\G([^\x0D\x0A]*?)(?>\x0D\x0A?|\x0A)/gc) {
      $out->start_tag ('li', id => 'line-' . $i);
      $out->text ($1);
      $i++;
    }
    if ($$s =~ /\G([^\x0D\x0A]+)/gc) {
      $out->start_tag ('li', id => 'line-' . $i);
      $out->text ($1);
    }
  } else {
    $out->start_tag ('li', id => 'line-1');
  }
  $out->end_tag ('ol');
  $out->html (qq[<script>
  addSourceToParseErrorList ('@{[$input->id_prefix]}', 'parse-errors-list');
</script>]);
  $out->end_section
} # generate_source_string_section

sub generate_additional_sections ($) {
  my $self = shift;
  $self->generate_url_section;
} # generate_additional_sections

sub generate_url_section ($) {
  my $self = shift;
  my $urls = $self->{add_info}->{uri} || {};
  return unless keys %$urls;

  ## NOTE: URIs contained in the DOM (i.e. in HTML or XML documents),
  ## except for those in RDF triples.
  ## TODO: URIs in CSS
  
  my $out = $self->output;
  $out->start_section (id => 'urls', title => 'URLs');
  $out->start_tag ('dl');

  my $input = $self->input;
  my $result = $self->result;

  for my $url (sort {$a cmp $b} keys %$urls) {
    $out->start_tag ('dt');
    $out->url ($url);
    $out->start_tag ('dd');
    $out->link ('Check conformance of this document',
                url => _get_cc_url ($url));
    $out->html ('<dd>Found in: <ul>');
    for my $entry (@{$urls->{$url}}) {
      $out->html (qq[<li>] . $result->get_node_link ($input, $entry->{node}));
      if (keys %{$entry->{type} or {}}) {
        $out->text (' (');
        $out->text (join ', ', map {
          {
            hyperlink => 'Hyperlink',
            resource => 'Link to an external resource',
            namespace => 'Namespace URI',
            cite => 'Citation or link to a long description',
            embedded => 'Link to an embedded content',
            base => 'Base URI',
            action => 'Submission URI',
          }->{$_} 
            or
          $_
        } keys %{$entry->{type}});
        $out->text (')');
      }
    }
    $out->end_tag ('ul');
  }
  $out->end_tag ('dl');
  $out->end_section;
} # generate_url_section

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

sub _get_cc_url ($) {
  return './?uri=' . _encode_url_component ($_[0]);
} # _get_cc_url

1;
1	package WebHACC::Language::Base;
2	use strict;
3
4	sub new ($) {
5	die "$0: No constructor is defined for " . ref $_[0];
6	} # new
7
8	sub input ($;$) {
9	if (@_ > 1) {
10	if (defined $_[1]) {
11	$_[0]->{input} = $_[1];
12	} else {
13	delete $_[0]->{input};
14	}
15	}
16
17	return $_[0]->{input};
18	} # input
19
20	sub output ($;$) {
21	if (@_ > 1) {
22	if (defined $_[1]) {
23	$_[0]->{output} = $_[1];
24	} else {
25	delete $_[0]->{output};
26	}
27	}
28
29	return $_[0]->{output};
30	} # output
31
32	sub result ($;$) {
33	if (@_ > 1) {
34	if (defined $_[1]) {
35	$_[0]->{result} = $_[1];
36	} else {
37	delete $_[0]->{result};
38	}
39	}
40
41	return $_[0]->{result};
42	} # result
43
44	sub onsubdoc ($;$) {
45	if (@_ > 1) {
46	if (defined $_[1]) {
47	$_[0]->{onsubdoc} = $_[1];
48	} else {
49	delete $_[0]->{onsubdoc};
50	}
51	}
52
53	return $_[0]->{onsubdoc} \|\| sub { };
54	} # onsubdoc
55
56	sub generate_syntax_error_section ($) {
57	die "$0: Syntactical checking for " . ref $_[0] . " is not supported";
58	} # generate_syntax_error_section
59
60	sub generate_structure_dump_section ($) {
61	#
62	} # generate_structure_dump_section
63
64	sub generate_structure_error_section ($) {
65	my $self = shift;
66
67	my $out = $self->output;
68
69	$out->start_section (id => 'document-errors', title => 'Document Errors');
70	$out->html ('<p>Not supported for this kind of contents.');
71	## TODO: class="???"
72	$out->end_section;
73	} # generate_structure_error_section
74
75	sub source_charset ($) {
76	return 'utf-8';
77	} # source_charset
78
79	sub generate_source_string_section ($) {
80	my $self = shift;
81	my $input = $self->input;
82
83	my $s;
84	unless ($input->{is_char_string}) {
85	open my $byte_stream, '<', \($input->{s});
86	require Message::Charset::Info;
87	my $charset = Message::Charset::Info->get_by_iana_name
88	($self->source_charset);
89	my ($char_stream, $e_status) = $charset->get_decode_handle
90	($byte_stream, allow_error_reporting => 1, allow_fallback => 1);
91	return unless $char_stream;
92
93	$char_stream->onerror (sub {
94	my (undef, $type, %opt) = @_;
95	if ($opt{octets}) {
96	${$opt{octets}} = "\x{FFFD}";
97	}
98	});
99
100	my $t = '';
101	while (1) {
102	my $c = $char_stream->getc;
103	last unless defined $c;
104	$t .= $c;
105	}
106	$s = \$t;
107	## TODO: Output for each line, don't concat all of lines.
108	} else {
109	$s = \($input->{s});
110	}
111
112	my $out = $self->output;
113	my $i = 1;
114	$out->start_section (id => 'source-string', title => 'Document Source',
115	short_title => 'Source');
116	$out->start_tag ('ol', lang => '');
117
118	if (length $$s) {
119	while ($$s =~ /\G([^\x0D\x0A]*?)(?>\x0D\x0A?\|\x0A)/gc) {
120	$out->start_tag ('li', id => 'line-' . $i);
121	$out->text ($1);
122	$i++;
123	}
124	if ($$s =~ /\G([^\x0D\x0A]+)/gc) {
125	$out->start_tag ('li', id => 'line-' . $i);
126	$out->text ($1);
127	}
128	} else {
129	$out->start_tag ('li', id => 'line-1');
130	}
131	$out->end_tag ('ol');
132	$out->html (qq[<script>
133	addSourceToParseErrorList ('@{[$input->id_prefix]}', 'parse-errors-list');
134	</script>]);
135	$out->end_section
136	} # generate_source_string_section
137
138	sub generate_additional_sections ($) {
139	my $self = shift;
140	$self->generate_url_section;
141	} # generate_additional_sections
142
143	sub generate_url_section ($) {
144	my $self = shift;
145	my $urls = $self->{add_info}->{uri} \|\| {};
146	return unless keys %$urls;
147
148	## NOTE: URIs contained in the DOM (i.e. in HTML or XML documents),
149	## except for those in RDF triples.
150	## TODO: URIs in CSS
151
152	my $out = $self->output;
153	$out->start_section (id => 'urls', title => 'URLs');
154	$out->start_tag ('dl');
155
156	my $input = $self->input;
157	my $result = $self->result;
158
159	for my $url (sort {$a cmp $b} keys %$urls) {
160	$out->start_tag ('dt');
161	$out->url ($url);
162	$out->start_tag ('dd');
163	$out->link ('Check conformance of this document',
164	url => _get_cc_url ($url));
165	$out->html ('<dd>Found in: <ul>');
166	for my $entry (@{$urls->{$url}}) {
167	$out->html (qq[<li>] . $result->get_node_link ($input, $entry->{node}));
168	if (keys %{$entry->{type} or {}}) {
169	$out->text (' (');
170	$out->text (join ', ', map {
171	{
172	hyperlink => 'Hyperlink',
173	resource => 'Link to an external resource',
174	namespace => 'Namespace URI',
175	cite => 'Citation or link to a long description',
176	embedded => 'Link to an embedded content',
177	base => 'Base URI',
178	action => 'Submission URI',
179	}->{$_}
180	or
181	$_
182	} keys %{$entry->{type}});
183	$out->text (')');
184	}
185	}
186	$out->end_tag ('ul');
187	}
188	$out->end_tag ('dl');
189	$out->end_section;
190	} # generate_url_section
191
192	sub _encode_url_component ($) {
193	require Encode;
194	my $s = Encode::encode ('utf8', shift);
195	$s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge;
196	return $s;
197	} # _encode_url_component
198
199	sub _get_cc_url ($) {
200	return './?uri=' . _encode_url_component ($_[0]);
201	} # _get_cc_url
202
203	1;