html-webhacc/WebHACC/Input.pm

package WebHACC::Input;
use strict;

sub new ($) {
  return bless {}, shift;
} # new

sub id_prefix ($) { '' }

sub nested ($) { 0 }

sub subdocument_index ($) { 0 }

sub full_subdocument_index ($) { 0 }

sub generate_info_section ($$) {
  my $self = shift;
  
  my $result = shift;
  my $out = $result->output;

  $out->start_section (id => 'document-info', title => 'Information');
  $out->start_tag ('dl');

  $out->dt ('Request URL');
  $out->start_tag ('dd');
  $out->url ($self->{request_uri});

  $out->dt ('Document URL'); ## TODO: HTML5 "document's address"?
  $out->start_tag ('dd');
  $out->url ($self->{uri}, id => 'anchor-document-url');
  $out->script (q[
      document.title = '<'
          + document.getElementById ('anchor-document-url').href + '> \\u2014 '
          + document.title;
  ]);

  if (defined $self->{s}) {
    $out->dt ('Base URL');
    $out->start_tag ('dd');
    $out->url ($self->{base_uri});
    
    $out->dt ('Internet Media Type');
    $out->start_tag ('dd');
    $out->code ($self->{media_type}, class => 'MIME', lang => 'en');
    if ($self->{media_type_overridden}) {
      $out->nl_text ('... overridden');
    } elsif (defined $self->{official_type}) {
      if ($self->{media_type} eq $self->{official_type}) {
        #
      } else {
        $out->nl_text ('... sniffed, official type is #',
                       text => $self->{official_type});
      }
    } else {
      $out->nl_text ( '... sniffed');
    }

    $out->dt ('Character Encoding');
    $out->start_tag ('dd');
    if (defined $self->{charset}) {
      $out->code ($self->{charset}, class => 'charset', lang => 'en');
    } else {
      $out->nl_text ('(unknown)');
    }
    $out->nl_text ('... overridden') if $self->{charset_overridden};

    $out->dt ($self->{is_char_string} ? 'Character Length' : 'Byte Length');
    ## TODO: formatting
    $out->start_tag ('dd');
    my $length = length $self->{s};
    $out->text ($length . ' ');
    $out->nl_text (($self->{is_char_string} ? 'character' : 'byte') .
                   ($length == 1 ? '' : 's'));
  }

  $out->end_tag ('dl');
  $out->end_section;
} # generate_info_section

sub generate_transfer_sections ($$) {
  my $self = shift;
  my $result = shift;
  
  $self->generate_http_header_section ($result);
} # generate_transfer_sections

sub generate_http_header_section ($$) {
  my ($self, $result) = @_;
  
  return unless defined $self->{header_status_code} or
      defined $self->{header_status_text} or
      @{$self->{header_field} or []};

  my $out = $result->output;
  
  $out->start_section (id => 'source-header', title => 'HTTP Header');
  $out->html (qq[<p><strong>Note</strong>: Due to the limitation of the
network library in use, the content of this section might
not be the real header.</p>

<table><tbody>
]);

  if (defined $self->{header_status_code}) {
    $out->html (qq[<tr><th scope="row">Status code</th>]);
    $out->start_tag ('td');
    $out->code ($self->{header_status_code});
  }
  if (defined $self->{header_status_text}) {
    $out->html (qq[<tr><th scope="row">Status text</th>]);
    $out->start_tag ('td');
    $out->code ($self->{header_status_text});
  }
  
  for (@{$self->{header_field}}) {
    $out->start_tag ('tr');
    $out->start_tag ('th', scope => 'row');
    $out->code ($_->[0]);
    $out->start_tag ('td');
    $out->code ($_->[1]);
  }

  $out->end_tag ('table');

  $out->end_section;
} # generate_http_header_section

package WebHACC::Input::Subdocument;
push our @ISA, 'WebHACC::Input';

sub new ($$) {
  my $self = bless {}, shift;
  $self->{subdocument_index} = shift;
  return $self;
} # new

sub id_prefix ($) {
  return 'subdoc-' . shift->full_subdocument_index . '-';
} # id_prefix

sub nested ($) { 1 }

sub subdocument_index ($) {
  return shift->{subdocument_index};
} # subdocument_index

sub full_subdocument_index ($) {
  my $self = shift;
  my $parent = $self->{parent_input}->full_subdocument_index;
  if ($parent) {
    return $parent . '.' . $self->{subdocument_index};
  } else {
    return $self->{subdocument_index};
  }
} # full_subdocument_index

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

  my $result = shift;
  my $out = $result->output;

  my $index = $self->full_subdocument_index;
  $out->start_section (id => $self->id_prefix,
                       title => qq[Subdocument #],
                       short_title => 'Sub #',
                       text => $index);
} # start_section

sub end_section ($$) {
  $_[1]->output->end_section;
} # end_section

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

  my $result = shift;
  my $out = $result->output;

  $out->start_section (id => 'document-info', title => 'Information');
  $out->start_tag ('dl');

  $out->dt ('Internet Media Type');
  $out->start_tag ('dd');
  $out->code ($self->{media_type}, code => 'MIME', lang => 'en');

  if (defined $self->{container_node}) {
    $out->dt ('Container Node');
    $out->start_tag ('dd');
    my $original_input = $out->input;
    $out->input ($self->{parent_input});
    $out->node_link ($self->{container_node});
    $out->input ($original_input);
  }

  $out->dt ('Base URL');
  $out->start_tag ('dd');
  $out->url ($self->{base_uri});

  $out->end_tag ('dl');
  $out->end_section;
} # generate_info_section

package WebHACC::Input::Error;
push our @ISA, 'WebHACC::Input';

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

  $self->SUPER::generate_transfer_sections (@_);
  
  my $result = shift;
  my $out = $result->output;

  $out->start_section (id => 'transfer-errors', title => 'Transfer Errors');

  $out->start_tag ('dl');
  $result->add_error (layer => 'transfer',
                      level => 'u',
                      type => 'resource retrieval error',
                      url => $self->{request_uri},
                      text => $self->{error_status_text});
  $out->end_tag ('dl');

  $out->end_section;
} # generate_transfer_sections

1;
1	wakaba	1.1	package WebHACC::Input;
2			use strict;
3
4			sub new ($) {
5	wakaba	1.3	return bless {}, shift;
6	wakaba	1.1	} # new
7
8	wakaba	1.3	sub id_prefix ($) { '' }
9
10			sub nested ($) { 0 }
11
12			sub subdocument_index ($) { 0 }
13
14	wakaba	1.4	sub full_subdocument_index ($) { 0 }
15
16	wakaba	1.3	sub generate_info_section ($$) {
17			my $self = shift;
18
19			my $result = shift;
20			my $out = $result->output;
21
22			$out->start_section (id => 'document-info', title => 'Information');
23			$out->start_tag ('dl');
24
25			$out->dt ('Request URL');
26			$out->start_tag ('dd');
27			$out->url ($self->{request_uri});
28
29			$out->dt ('Document URL'); ## TODO: HTML5 "document's address"?
30			$out->start_tag ('dd');
31			$out->url ($self->{uri}, id => 'anchor-document-url');
32			$out->script (q[
33			document.title = '<'
34			+ document.getElementById ('anchor-document-url').href + '> \\u2014 '
35			+ document.title;
36			]);
37
38			if (defined $self->{s}) {
39			$out->dt ('Base URL');
40			$out->start_tag ('dd');
41			$out->url ($self->{base_uri});
42
43			$out->dt ('Internet Media Type');
44			$out->start_tag ('dd');
45			$out->code ($self->{media_type}, class => 'MIME', lang => 'en');
46			if ($self->{media_type_overridden}) {
47	wakaba	1.5	$out->nl_text ('... overridden');
48	wakaba	1.3	} elsif (defined $self->{official_type}) {
49			if ($self->{media_type} eq $self->{official_type}) {
50			#
51			} else {
52	wakaba	1.5	$out->nl_text ('... sniffed, official type is #',
53			text => $self->{official_type});
54	wakaba	1.3	}
55	wakaba	1.1	} else {
56	wakaba	1.5	$out->nl_text ( '... sniffed');
57	wakaba	1.1	}
58
59	wakaba	1.3	$out->dt ('Character Encoding');
60			$out->start_tag ('dd');
61			if (defined $self->{charset}) {
62			$out->code ($self->{charset}, class => 'charset', lang => 'en');
63	wakaba	1.1	} else {
64	wakaba	1.5	$out->nl_text ('(unknown)');
65	wakaba	1.1	}
66	wakaba	1.5	$out->nl_text ('... overridden') if $self->{charset_overridden};
67	wakaba	1.3
68			$out->dt ($self->{is_char_string} ? 'Character Length' : 'Byte Length');
69			## TODO: formatting
70			$out->start_tag ('dd');
71			my $length = length $self->{s};
72	wakaba	1.5	$out->text ($length . ' ');
73			$out->nl_text (($self->{is_char_string} ? 'character' : 'byte') .
74			($length == 1 ? '' : 's'));
75	wakaba	1.1	}
76
77	wakaba	1.3	$out->end_tag ('dl');
78			$out->end_section;
79			} # generate_info_section
80	wakaba	1.1
81	wakaba	1.2	sub generate_transfer_sections ($$) {
82			my $self = shift;
83			my $result = shift;
84
85			$self->generate_http_header_section ($result);
86			} # generate_transfer_sections
87
88			sub generate_http_header_section ($$) {
89			my ($self, $result) = @_;
90
91			return unless defined $self->{header_status_code} or
92			defined $self->{header_status_text} or
93			@{$self->{header_field} or []};
94
95			my $out = $result->output;
96
97			$out->start_section (id => 'source-header', title => 'HTTP Header');
98			$out->html (qq[<p><strong>Note</strong>: Due to the limitation of the
99			network library in use, the content of this section might
100			not be the real header.</p>
101
102			<table><tbody>
103			]);
104
105			if (defined $self->{header_status_code}) {
106			$out->html (qq[<tr><th scope="row">Status code</th>]);
107			$out->start_tag ('td');
108			$out->code ($self->{header_status_code});
109			}
110			if (defined $self->{header_status_text}) {
111			$out->html (qq[<tr><th scope="row">Status text</th>]);
112			$out->start_tag ('td');
113			$out->code ($self->{header_status_text});
114			}
115
116			for (@{$self->{header_field}}) {
117			$out->start_tag ('tr');
118			$out->start_tag ('th', scope => 'row');
119			$out->code ($_->[0]);
120			$out->start_tag ('td');
121			$out->code ($_->[1]);
122			}
123
124			$out->end_tag ('table');
125
126			$out->end_section;
127			} # generate_http_header_section
128	wakaba	1.3
129			package WebHACC::Input::Subdocument;
130			push our @ISA, 'WebHACC::Input';
131
132			sub new ($$) {
133			my $self = bless {}, shift;
134			$self->{subdocument_index} = shift;
135			return $self;
136			} # new
137
138			sub id_prefix ($) {
139	wakaba	1.5	return 'subdoc-' . shift->full_subdocument_index . '-';
140	wakaba	1.3	} # id_prefix
141
142			sub nested ($) { 1 }
143
144			sub subdocument_index ($) {
145			return shift->{subdocument_index};
146			} # subdocument_index
147
148	wakaba	1.4	sub full_subdocument_index ($) {
149			my $self = shift;
150			my $parent = $self->{parent_input}->full_subdocument_index;
151			if ($parent) {
152			return $parent . '.' . $self->{subdocument_index};
153			} else {
154			return $self->{subdocument_index};
155			}
156			} # full_subdocument_index
157
158	wakaba	1.3	sub start_section ($$) {
159			my $self = shift;
160
161			my $result = shift;
162			my $out = $result->output;
163
164	wakaba	1.4	my $index = $self->full_subdocument_index;
165	wakaba	1.3	$out->start_section (id => $self->id_prefix,
166	wakaba	1.5	title => qq[Subdocument #],
167			short_title => 'Sub #',
168			text => $index);
169	wakaba	1.3	} # start_section
170
171			sub end_section ($$) {
172			$_[1]->output->end_section;
173			} # end_section
174
175			sub generate_info_section ($$) {
176			my $self = shift;
177
178			my $result = shift;
179			my $out = $result->output;
180
181			$out->start_section (id => 'document-info', title => 'Information');
182			$out->start_tag ('dl');
183
184			$out->dt ('Internet Media Type');
185			$out->start_tag ('dd');
186			$out->code ($self->{media_type}, code => 'MIME', lang => 'en');
187
188			if (defined $self->{container_node}) {
189			$out->dt ('Container Node');
190			$out->start_tag ('dd');
191			my $original_input = $out->input;
192			$out->input ($self->{parent_input});
193			$out->node_link ($self->{container_node});
194			$out->input ($original_input);
195			}
196
197			$out->dt ('Base URL');
198			$out->start_tag ('dd');
199			$out->url ($self->{base_uri});
200
201			$out->end_tag ('dl');
202			$out->end_section;
203			} # generate_info_section
204	wakaba	1.2
205			package WebHACC::Input::Error;
206			push our @ISA, 'WebHACC::Input';
207
208			sub generate_transfer_sections ($$) {
209			my $self = shift;
210
211			$self->SUPER::generate_transfer_sections (@_);
212
213			my $result = shift;
214			my $out = $result->output;
215
216			$out->start_section (id => 'transfer-errors', title => 'Transfer Errors');
217
218			$out->start_tag ('dl');
219			$result->add_error (layer => 'transfer',
220			level => 'u',
221			type => 'resource retrieval error',
222			url => $self->{request_uri},
223			text => $self->{error_status_text});
224			$out->end_tag ('dl');
225
226			$out->end_section;
227			} # generate_transfer_sections
228
229	wakaba	1.1	1;