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->layer_applicable ('structure');

  $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;

  $self->result->layer_uncertain ('semantics');
} # 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) {
      if ($char_stream->read ($t, 1024, length $t)) {
        #
      } else {
        last;
      }
    }
    $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 (role => '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	wakaba	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	wakaba	1.2	## NOTE:
9			## Language ->input, ->output, ->result
10			## Input
11			## Output ->input
12			## Result ->output
13
14	wakaba	1.1	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	wakaba	1.2	die "$0: Syntactical checking for " . (ref $_[0]) . " is not supported";
64	wakaba	1.1	} # 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	wakaba	1.5	$out->start_section (role => 'structure-errors');
76			$out->start_error_list (role => 'structure-errors');
77	wakaba	1.7	$self->result->layer_applicable ('structure');
78	wakaba	1.5
79			$self->result->add_error (input => $self->input,
80			level => 'u',
81			layer => 'structure',
82			type => 'media type not supported:structure',
83			text => $self->input->{media_type});
84
85			$out->end_error_list (role => 'structure-errors');
86	wakaba	1.1	$out->end_section;
87	wakaba	1.7
88			$self->result->layer_uncertain ('semantics');
89	wakaba	1.1	} # generate_structure_error_section
90
91			sub source_charset ($) {
92			return 'utf-8';
93			} # source_charset
94
95			sub generate_source_string_section ($) {
96			my $self = shift;
97			my $input = $self->input;
98
99			my $s;
100			unless ($input->{is_char_string}) {
101			open my $byte_stream, '<', \($input->{s});
102			require Message::Charset::Info;
103			my $charset = Message::Charset::Info->get_by_iana_name
104			($self->source_charset);
105			my ($char_stream, $e_status) = $charset->get_decode_handle
106			($byte_stream, allow_error_reporting => 1, allow_fallback => 1);
107			return unless $char_stream;
108
109			$char_stream->onerror (sub {
110			my (undef, $type, %opt) = @_;
111			if ($opt{octets}) {
112			${$opt{octets}} = "\x{FFFD}";
113			}
114			});
115
116			my $t = '';
117			while (1) {
118	wakaba	1.8	if ($char_stream->read ($t, 1024, length $t)) {
119			#
120			} else {
121			last;
122			}
123	wakaba	1.1	}
124			$s = \$t;
125			## TODO: Output for each line, don't concat all of lines.
126			} else {
127			$s = \($input->{s});
128			}
129
130			my $out = $self->output;
131			my $i = 1;
132	wakaba	1.6	$out->start_section (role => 'source');
133	wakaba	1.1	$out->start_tag ('ol', lang => '');
134
135			if (length $$s) {
136			while ($$s =~ /\G([^\x0D\x0A]*?)(?>\x0D\x0A?\|\x0A)/gc) {
137			$out->start_tag ('li', id => 'line-' . $i);
138			$out->text ($1);
139			$i++;
140			}
141			if ($$s =~ /\G([^\x0D\x0A]+)/gc) {
142			$out->start_tag ('li', id => 'line-' . $i);
143			$out->text ($1);
144			}
145			} else {
146			$out->start_tag ('li', id => 'line-1');
147			}
148			$out->end_tag ('ol');
149	wakaba	1.4	$out->add_source_to_parse_error_list ('parse-errors-list');
150	wakaba	1.6	$out->end_section;
151	wakaba	1.1	} # generate_source_string_section
152
153			sub generate_additional_sections ($) {
154			my $self = shift;
155			$self->generate_url_section;
156			} # generate_additional_sections
157
158			sub generate_url_section ($) {
159			my $self = shift;
160			my $urls = $self->{add_info}->{uri} \|\| {};
161			return unless keys %$urls;
162
163			## NOTE: URIs contained in the DOM (i.e. in HTML or XML documents),
164			## except for those in RDF triples.
165			## TODO: URIs in CSS
166
167			my $out = $self->output;
168			$out->start_section (id => 'urls', title => 'URLs');
169			$out->start_tag ('dl');
170
171			my $input = $self->input;
172			my $result = $self->result;
173
174			for my $url (sort {$a cmp $b} keys %$urls) {
175			$out->start_tag ('dt');
176			$out->url ($url);
177			$out->start_tag ('dd');
178	wakaba	1.2	$out->link_to_webhacc ('Check conformance of this document', url => $url);
179	wakaba	1.1	$out->html ('<dd>Found in: <ul>');
180			for my $entry (@{$urls->{$url}}) {
181	wakaba	1.3	$out->start_tag ('li');
182			$out->node_link ($entry->{node});
183	wakaba	1.1	if (keys %{$entry->{type} or {}}) {
184			$out->text (' (');
185			$out->text (join ', ', map {
186			{
187			hyperlink => 'Hyperlink',
188			resource => 'Link to an external resource',
189			namespace => 'Namespace URI',
190			cite => 'Citation or link to a long description',
191			embedded => 'Link to an embedded content',
192			base => 'Base URI',
193			action => 'Submission URI',
194			}->{$_}
195			or
196			$_
197			} keys %{$entry->{type}});
198			$out->text (')');
199			}
200			}
201			$out->end_tag ('ul');
202			}
203			$out->end_tag ('dl');
204			$out->end_section;
205			} # generate_url_section
206
207			1;