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 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->html (' <em>(overridden)</em>');
    } elsif (defined $self->{official_type}) {
      if ($self->{media_type} eq $self->{official_type}) {
        #
      } else {
        $out->html (' <em>(sniffed; official type is: ');
        $out->code ($self->{official_type}, class => 'MIME', lang => 'en');
        $out->html (')</em>');
      }
    } else {
      $out->html ( '<em>(sniffed)</em>');
    }

    $out->dt ('Character Encoding');
    $out->start_tag ('dd');
    if (defined $self->{charset}) {
      $out->code ($self->{charset}, class => 'charset', lang => 'en');
    } else {
      $out->text ('(none)');
    }
    $out->html (' <em>overridden</em>') 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 . ($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->{subdocument_index} . '-';
} # id_prefix

sub nested ($) { 1 }

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

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

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

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