WebHACC/Language/Base.pm

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

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

## NOTE:
## Language ->input, ->output, ->result
## Input
## Output ->input
## Result ->output

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 (role => 'structure-errors');
  $out->start_error_list (role => 'structure-errors');

  $self->result->add_error (input => $self->input,
                            level => 'u',
                            layer => 'structure',
                            type => 'media type not supported:structure',
                            text => $self->input->{media_type});

  $out->end_error_list (role => 'structure-errors');
  $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->add_source_to_parse_error_list ('parse-errors-list');
  $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_to_webhacc ('Check conformance of this document', url => $url);
    $out->html ('<dd>Found in: <ul>');
    for my $entry (@{$urls->{$url}}) {
      $out->start_tag ('li');
      $out->node_link ($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

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