html-webhacc/WebHACC/Input.pm

package WebHACC::Input;
use strict;

sub new ($) {
  return bless {urls => []}, shift;
} # new

sub id_prefix ($) { '' }

sub nested ($) { 0 }

sub subdocument_index ($) { 0 }

sub full_subdocument_index ($) { 0 }

sub url ($) {
  my $self = shift;
  if (@{$self->{urls}}) {
    return $self->{urls}->[-1];
  } else {
    return undef;
  }
} # url

sub add_url ($$) {
  my ($self, $url) = @_;
  push @{$self->{urls}}, ''.$url;
} # add_url

sub urls ($) {
  my $self = shift;
  return [@{$self->{urls}}];
} # urls

sub get_document ($$$$) {
  my $self = shift->new;

  my ($cgi => $result => $out) = @_;

  $out->input ($self);

  require Encode;
  my $url_s = Encode::decode ('utf-8', $cgi->get_parameter ('uri'));
  my $url_o;
  if (defined $url_s and length $url_s) {
    require Message::DOM::DOMImplementation;
    my $dom = Message::DOM::DOMImplementation->new;
    
    $url_o = $dom->create_uri_reference ($url_s);
    $url_o->uri_fragment (undef);

    $self->add_url ($url_o->uri_reference);

    my $url_scheme = lc $url_o->uri_scheme; ## TODO: html5_url_scheme
    my $class = {
      http => 'WebHACC::Input::HTTP',
    }->{$url_scheme} || 'WebHACC::Input::UnsupportedURLSchemeError';
    bless $self, $class;
  } else {
    bless $self, 'WebHACC::Input::Text';
  }

  $self->_get_document ($cgi => $result => $out, $url_o);

  return $self unless defined $self->{s};

  if (length $self->{s} > 1000_000) {
    $self->{error_status_text} = 'Entity-body too large';
    delete $self->{s};
    bless $self, 'WebHACC::Input::Error';
    return $self;
  }

  require Whatpm::ContentType;
  ($self->{official_type}, $self->{media_type})
        = Whatpm::ContentType->get_sniffed_type
            (get_file_head => sub {
               return substr $self->{s}, 0, shift;
             },
             http_content_type_byte => $self->{http_content_type_bytes},
             supported_image_types => {});

  my $input_format = $cgi->get_parameter ('i');
  if (defined $input_format and length $input_format) {
    $self->{media_type_overridden}
        = (not defined $self->{media_type} or
           $input_format ne $self->{media_type});
    $self->{media_type} = $input_format;
  }
  if (defined $self->{s} and not defined $self->{media_type}) {
    $self->{media_type} = 'text/html';
    $self->{media_type_overridden} = 1;
  }

  if ($self->{media_type} eq 'text/xml') {
    unless (defined $self->{charset}) {
      $self->{charset} = 'us-ascii';
      $self->{official_charset} = $self->{charset};
    } elsif ($self->{charset_overridden} and $self->{charset} eq 'us-ascii') {
      $self->{charset_overridden} = 0;
    }
  }

  $self->{inner_html_element} = $cgi->get_parameter ('e');

  return $self;
} # get_document

sub _get_document ($$$$) {
  die "$0: _get_document of " . ref $_[0];
} # _get_document

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');

  my $urls = $self->urls;

  $out->dt (@$urls == 1 ? 'URL' : 'URLs');
  my $url = pop @$urls;
  for (@$urls) {
    $out->start_tag ('dd');
    $out->url ($_);
  }
  $out->start_tag ('dd');
  $out->url ($url, 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::HTTP;
push our @ISA, 'WebHACC::Input';

{
my $HostPermit;
sub host_permit ($) {
  return $HostPermit if $HostPermit;
  
  require Message::Util::HostPermit;
  $HostPermit = new Message::Util::HostPermit;
  $HostPermit->add_rule (<<'EOH');
Allow host=suika port=80
Deny host=suika
Allow host=suika.fam.cx port=80
Deny host=suika.fam.cx
Deny host=localhost
Deny host=*.localdomain
Deny ipv4=0.0.0.0/8
Deny ipv4=10.0.0.0/8
Deny ipv4=127.0.0.0/8
Deny ipv4=169.254.0.0/16
Deny ipv4=172.0.0.0/11
Deny ipv4=192.0.2.0/24
Deny ipv4=192.88.99.0/24
Deny ipv4=192.168.0.0/16
Deny ipv4=198.18.0.0/15
Deny ipv4=224.0.0.0/4
Deny ipv4=255.255.255.255/32
Deny ipv6=0::0/0
Allow host=*
EOH
  return $HostPermit;
} # host_permit
}

sub _get_document ($$$$$) {
  my ($self, $cgi => $result => $out, $url_o) = @_;

  unless ($self->host_permit->check ($url_o->uri_host, $url_o->uri_port || 80)) {
    $self->{error_status_text} = 'Connection to the host is forbidden';
    return $self;
  }

  my $ua = WDCC::LWPUA->new;
  $ua->{wdcc_dom} = Message::DOM::DOMImplementation->new;
  $ua->{wdcc_host_permit} = $self->host_permit;
  $ua->agent ('Mozilla'); ## TODO: for now.
  $ua->parse_head (0);
  $ua->protocols_allowed ([qw/http/]);
  $ua->max_size (1000_000);
  my $req = HTTP::Request->new (GET => $url_o->uri_reference);
  $req->header ('Accept-Encoding' => 'identity, *; q=0');
  my $res = $ua->request ($req);
  ## TODO: 401 sets |is_success| true.
  ## TODO: Don't follow redirect if error-page=true
  if ($res->is_success or $cgi->get_parameter ('error-page')) {
    $self->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and <base>. ## TODO: Use our own code!
    my $new_url = $res->request->uri;
    $self->add_url ($new_url) if $new_url ne $self->url;
    
    ## TODO: More strict parsing...
    my $ct = $self->{http_content_type_bytes} = $res->header ('Content-Type');
    if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {
      $self->{charset} = lc $1;
      $self->{charset} =~ tr/\\//d;
      $self->{official_charset} = $self->{charset};
    }
    
    my $input_charset = $cgi->get_parameter ('charset');
    if (defined $input_charset and length $input_charset) {
      $self->{charset_overridden}
          = (not defined $self->{charset} or $self->{charset} ne $input_charset);
      $self->{charset} = $input_charset;
    }

    ## TODO: Support for HTTP Content-Encoding
    
    $self->{s} = ''.$res->content;
  } else {
    $self->add_url ($res->request->uri);
    $self->{error_status_text} = $res->status_line;
    bless $self, 'WebHACC::Input::HTTPError';
  }
               
  $self->{header_field} = [];
  $res->scan (sub {
    push @{$self->{header_field}}, [$_[0], $_[1]];
  });
  $self->{header_status_code} = $res->code;
  $self->{header_status_text} = $res->message;

  return $self;
} # _get_document

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

sub _get_document ($$$$) {
  my ($self, $cgi => $result => $out) = @_;
  
  $self->add_url (q<thismessage:/>);
  $self->{base_uri} = q<thismessage:/>;
    
  $self->{s} = ''.$cgi->get_parameter ('s');
  $self->{charset} = ''.$cgi->get_parameter ('_charset_');
  $self->{charset} =~ s/\s+//g;
  $self->{charset} = 'utf-8' if $self->{charset} eq '';
  $self->{official_charset} = $self->{charset};
  $self->{header_field} = [];

  return $self;
} # _get_document

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 ($) {
  my $self = shift;
  return $self->{parent_input}->id_prefix .
      'subdoc-' . $self->{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->subdocument_index;
  $out->start_section (id => my $id = 'subdoc-' . $index . '-',
                       title => qq[Subdocument #],
                       short_title => 'Sub #',
                       role => 'subdoc',
                       text => $self->full_subdocument_index);
  $out->script (q[ insertNavSections ('] . $out->input->id_prefix . $id . q[') ]);
} # 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

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

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

sub _get_document ($$$$) {
  my ($self, $cgi => $result => $out) = @_;
  
  $self->{error_status_text} = 'URL scheme not allowed';

  return $self;
} # _get_document

package WDCC::LWPUA;
require LWP::UserAgent;
push our @ISA, 'LWP::UserAgent';

sub redirect_ok {
  my $ua = shift;
  unless ($ua->SUPER::redirect_ok (@_)) {
    return 0;
  }

  my $uris = $_[1]->header ('Location');
  return 0 unless $uris;
  my $uri = $ua->{wdcc_dom}->create_uri_reference ($uris);
  unless ({
           http => 1,
          }->{lc $uri->uri_scheme}) { ## TODO: html5_url_scheme
    return 0;
  }
  unless ($ua->{wdcc_host_permit}->check ($uri->uri_host, $uri->uri_port || 80)) {
    return 0;
  }
  return 1;
} # redirect_ok

1;
1	wakaba	1.1	package WebHACC::Input;
2			use strict;
3
4			sub new ($) {
5	wakaba	1.6	return bless {urls => []}, 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.6	sub url ($) {
17			my $self = shift;
18			if (@{$self->{urls}}) {
19			return $self->{urls}->[-1];
20			} else {
21			return undef;
22			}
23			} # url
24
25			sub add_url ($$) {
26			my ($self, $url) = @_;
27			push @{$self->{urls}}, ''.$url;
28			} # add_url
29
30			sub urls ($) {
31			my $self = shift;
32			return [@{$self->{urls}}];
33			} # urls
34
35			sub get_document ($$$$) {
36			my $self = shift->new;
37
38			my ($cgi => $result => $out) = @_;
39
40			$out->input ($self);
41
42			require Encode;
43			my $url_s = Encode::decode ('utf-8', $cgi->get_parameter ('uri'));
44			my $url_o;
45			if (defined $url_s and length $url_s) {
46			require Message::DOM::DOMImplementation;
47			my $dom = Message::DOM::DOMImplementation->new;
48
49			$url_o = $dom->create_uri_reference ($url_s);
50			$url_o->uri_fragment (undef);
51
52			$self->add_url ($url_o->uri_reference);
53
54			my $url_scheme = lc $url_o->uri_scheme; ## TODO: html5_url_scheme
55			my $class = {
56			http => 'WebHACC::Input::HTTP',
57			}->{$url_scheme} \|\| 'WebHACC::Input::UnsupportedURLSchemeError';
58			bless $self, $class;
59			} else {
60			bless $self, 'WebHACC::Input::Text';
61			}
62
63			$self->_get_document ($cgi => $result => $out, $url_o);
64
65			return $self unless defined $self->{s};
66
67			if (length $self->{s} > 1000_000) {
68			$self->{error_status_text} = 'Entity-body too large';
69			delete $self->{s};
70			bless $self, 'WebHACC::Input::Error';
71			return $self;
72			}
73
74			require Whatpm::ContentType;
75			($self->{official_type}, $self->{media_type})
76			= Whatpm::ContentType->get_sniffed_type
77			(get_file_head => sub {
78			return substr $self->{s}, 0, shift;
79			},
80			http_content_type_byte => $self->{http_content_type_bytes},
81			supported_image_types => {});
82
83			my $input_format = $cgi->get_parameter ('i');
84			if (defined $input_format and length $input_format) {
85			$self->{media_type_overridden}
86			= (not defined $self->{media_type} or
87			$input_format ne $self->{media_type});
88			$self->{media_type} = $input_format;
89			}
90			if (defined $self->{s} and not defined $self->{media_type}) {
91			$self->{media_type} = 'text/html';
92			$self->{media_type_overridden} = 1;
93			}
94
95			if ($self->{media_type} eq 'text/xml') {
96			unless (defined $self->{charset}) {
97			$self->{charset} = 'us-ascii';
98			$self->{official_charset} = $self->{charset};
99			} elsif ($self->{charset_overridden} and $self->{charset} eq 'us-ascii') {
100			$self->{charset_overridden} = 0;
101			}
102			}
103
104			$self->{inner_html_element} = $cgi->get_parameter ('e');
105
106			return $self;
107			} # get_document
108
109			sub _get_document ($$$$) {
110			die "$0: _get_document of " . ref $_[0];
111			} # _get_document
112
113	wakaba	1.3	sub generate_info_section ($$) {
114			my $self = shift;
115
116			my $result = shift;
117			my $out = $result->output;
118
119			$out->start_section (id => 'document-info', title => 'Information');
120			$out->start_tag ('dl');
121
122	wakaba	1.6	my $urls = $self->urls;
123	wakaba	1.3
124	wakaba	1.6	$out->dt (@$urls == 1 ? 'URL' : 'URLs');
125			my $url = pop @$urls;
126			for (@$urls) {
127			$out->start_tag ('dd');
128			$out->url ($_);
129			}
130	wakaba	1.3	$out->start_tag ('dd');
131	wakaba	1.6	$out->url ($url, id => 'anchor-document-url');
132	wakaba	1.3	$out->script (q[
133			document.title = '<'
134			+ document.getElementById ('anchor-document-url').href + '> \\u2014 '
135			+ document.title;
136			]);
137
138			if (defined $self->{s}) {
139			$out->dt ('Base URL');
140			$out->start_tag ('dd');
141			$out->url ($self->{base_uri});
142
143			$out->dt ('Internet Media Type');
144			$out->start_tag ('dd');
145			$out->code ($self->{media_type}, class => 'MIME', lang => 'en');
146			if ($self->{media_type_overridden}) {
147	wakaba	1.5	$out->nl_text ('... overridden');
148	wakaba	1.3	} elsif (defined $self->{official_type}) {
149			if ($self->{media_type} eq $self->{official_type}) {
150			#
151			} else {
152	wakaba	1.5	$out->nl_text ('... sniffed, official type is #',
153			text => $self->{official_type});
154	wakaba	1.3	}
155	wakaba	1.1	} else {
156	wakaba	1.5	$out->nl_text ( '... sniffed');
157	wakaba	1.1	}
158
159	wakaba	1.3	$out->dt ('Character Encoding');
160			$out->start_tag ('dd');
161			if (defined $self->{charset}) {
162			$out->code ($self->{charset}, class => 'charset', lang => 'en');
163	wakaba	1.1	} else {
164	wakaba	1.5	$out->nl_text ('(unknown)');
165	wakaba	1.1	}
166	wakaba	1.5	$out->nl_text ('... overridden') if $self->{charset_overridden};
167	wakaba	1.3
168			$out->dt ($self->{is_char_string} ? 'Character Length' : 'Byte Length');
169			## TODO: formatting
170			$out->start_tag ('dd');
171			my $length = length $self->{s};
172	wakaba	1.5	$out->text ($length . ' ');
173			$out->nl_text (($self->{is_char_string} ? 'character' : 'byte') .
174			($length == 1 ? '' : 's'));
175	wakaba	1.1	}
176
177	wakaba	1.3	$out->end_tag ('dl');
178			$out->end_section;
179			} # generate_info_section
180	wakaba	1.1
181	wakaba	1.2	sub generate_transfer_sections ($$) {
182			my $self = shift;
183			my $result = shift;
184
185			$self->generate_http_header_section ($result);
186			} # generate_transfer_sections
187
188			sub generate_http_header_section ($$) {
189			my ($self, $result) = @_;
190
191			return unless defined $self->{header_status_code} or
192			defined $self->{header_status_text} or
193			@{$self->{header_field} or []};
194
195			my $out = $result->output;
196
197			$out->start_section (id => 'source-header', title => 'HTTP Header');
198			$out->html (qq[<p><strong>Note</strong>: Due to the limitation of the
199			network library in use, the content of this section might
200			not be the real header.</p>
201
202			<table><tbody>
203			]);
204
205			if (defined $self->{header_status_code}) {
206			$out->html (qq[<tr><th scope="row">Status code</th>]);
207			$out->start_tag ('td');
208			$out->code ($self->{header_status_code});
209			}
210			if (defined $self->{header_status_text}) {
211			$out->html (qq[<tr><th scope="row">Status text</th>]);
212			$out->start_tag ('td');
213			$out->code ($self->{header_status_text});
214			}
215
216			for (@{$self->{header_field}}) {
217			$out->start_tag ('tr');
218			$out->start_tag ('th', scope => 'row');
219			$out->code ($_->[0]);
220			$out->start_tag ('td');
221			$out->code ($_->[1]);
222			}
223
224			$out->end_tag ('table');
225
226			$out->end_section;
227			} # generate_http_header_section
228	wakaba	1.3
229	wakaba	1.6	package WebHACC::Input::HTTP;
230			push our @ISA, 'WebHACC::Input';
231
232			{
233			my $HostPermit;
234			sub host_permit ($) {
235			return $HostPermit if $HostPermit;
236
237			require Message::Util::HostPermit;
238			$HostPermit = new Message::Util::HostPermit;
239			$HostPermit->add_rule (<<'EOH');
240			Allow host=suika port=80
241			Deny host=suika
242			Allow host=suika.fam.cx port=80
243			Deny host=suika.fam.cx
244			Deny host=localhost
245			Deny host=*.localdomain
246			Deny ipv4=0.0.0.0/8
247			Deny ipv4=10.0.0.0/8
248			Deny ipv4=127.0.0.0/8
249			Deny ipv4=169.254.0.0/16
250			Deny ipv4=172.0.0.0/11
251			Deny ipv4=192.0.2.0/24
252			Deny ipv4=192.88.99.0/24
253			Deny ipv4=192.168.0.0/16
254			Deny ipv4=198.18.0.0/15
255			Deny ipv4=224.0.0.0/4
256			Deny ipv4=255.255.255.255/32
257			Deny ipv6=0::0/0
258			Allow host=*
259			EOH
260			return $HostPermit;
261			} # host_permit
262			}
263
264			sub _get_document ($$$$$) {
265			my ($self, $cgi => $result => $out, $url_o) = @_;
266
267			unless ($self->host_permit->check ($url_o->uri_host, $url_o->uri_port \|\| 80)) {
268			$self->{error_status_text} = 'Connection to the host is forbidden';
269			return $self;
270			}
271
272			my $ua = WDCC::LWPUA->new;
273			$ua->{wdcc_dom} = Message::DOM::DOMImplementation->new;
274			$ua->{wdcc_host_permit} = $self->host_permit;
275			$ua->agent ('Mozilla'); ## TODO: for now.
276			$ua->parse_head (0);
277			$ua->protocols_allowed ([qw/http/]);
278			$ua->max_size (1000_000);
279			my $req = HTTP::Request->new (GET => $url_o->uri_reference);
280			$req->header ('Accept-Encoding' => 'identity, *; q=0');
281			my $res = $ua->request ($req);
282			## TODO: 401 sets \|is_success\| true.
283			## TODO: Don't follow redirect if error-page=true
284			if ($res->is_success or $cgi->get_parameter ('error-page')) {
285			$self->{base_uri} = $res->base; ## NOTE: It does check \|Content-Base\|, \|Content-Location\|, and <base>. ## TODO: Use our own code!
286			my $new_url = $res->request->uri;
287			$self->add_url ($new_url) if $new_url ne $self->url;
288
289			## TODO: More strict parsing...
290			my $ct = $self->{http_content_type_bytes} = $res->header ('Content-Type');
291			if (defined $ct and $ct =~ /;\scharset\s=\s*"?([^\s;"]+)"?/i) {
292			$self->{charset} = lc $1;
293			$self->{charset} =~ tr/\\//d;
294			$self->{official_charset} = $self->{charset};
295			}
296
297			my $input_charset = $cgi->get_parameter ('charset');
298			if (defined $input_charset and length $input_charset) {
299			$self->{charset_overridden}
300			= (not defined $self->{charset} or $self->{charset} ne $input_charset);
301			$self->{charset} = $input_charset;
302			}
303
304			## TODO: Support for HTTP Content-Encoding
305
306			$self->{s} = ''.$res->content;
307			} else {
308			$self->add_url ($res->request->uri);
309			$self->{error_status_text} = $res->status_line;
310			bless $self, 'WebHACC::Input::HTTPError';
311			}
312
313			$self->{header_field} = [];
314			$res->scan (sub {
315			push @{$self->{header_field}}, [$_[0], $_[1]];
316			});
317			$self->{header_status_code} = $res->code;
318			$self->{header_status_text} = $res->message;
319
320			return $self;
321			} # _get_document
322
323			package WebHACC::Input::Text;
324			push our @ISA, 'WebHACC::Input';
325
326			sub _get_document ($$$$) {
327			my ($self, $cgi => $result => $out) = @_;
328
329			$self->add_url (q<thismessage:/>);
330			$self->{base_uri} = q<thismessage:/>;
331
332			$self->{s} = ''.$cgi->get_parameter ('s');
333			$self->{charset} = ''.$cgi->get_parameter ('_charset_');
334			$self->{charset} =~ s/\s+//g;
335			$self->{charset} = 'utf-8' if $self->{charset} eq '';
336			$self->{official_charset} = $self->{charset};
337			$self->{header_field} = [];
338
339			return $self;
340			} # _get_document
341
342	wakaba	1.3	package WebHACC::Input::Subdocument;
343			push our @ISA, 'WebHACC::Input';
344
345			sub new ($$) {
346			my $self = bless {}, shift;
347			$self->{subdocument_index} = shift;
348			return $self;
349			} # new
350
351			sub id_prefix ($) {
352	wakaba	1.7	my $self = shift;
353			return $self->{parent_input}->id_prefix .
354			'subdoc-' . $self->{subdocument_index} . '-';
355	wakaba	1.3	} # id_prefix
356
357			sub nested ($) { 1 }
358
359			sub subdocument_index ($) {
360			return shift->{subdocument_index};
361			} # subdocument_index
362
363	wakaba	1.4	sub full_subdocument_index ($) {
364			my $self = shift;
365			my $parent = $self->{parent_input}->full_subdocument_index;
366			if ($parent) {
367			return $parent . '.' . $self->{subdocument_index};
368			} else {
369			return $self->{subdocument_index};
370			}
371			} # full_subdocument_index
372
373	wakaba	1.3	sub start_section ($$) {
374			my $self = shift;
375
376			my $result = shift;
377			my $out = $result->output;
378
379	wakaba	1.7	my $index = $self->subdocument_index;
380			$out->start_section (id => my $id = 'subdoc-' . $index . '-',
381	wakaba	1.5	title => qq[Subdocument #],
382			short_title => 'Sub #',
383	wakaba	1.7	role => 'subdoc',
384			text => $self->full_subdocument_index);
385			$out->script (q[ insertNavSections ('] . $out->input->id_prefix . $id . q[') ]);
386	wakaba	1.3	} # start_section
387
388			sub end_section ($$) {
389			$_[1]->output->end_section;
390			} # end_section
391
392			sub generate_info_section ($$) {
393			my $self = shift;
394
395			my $result = shift;
396			my $out = $result->output;
397
398			$out->start_section (id => 'document-info', title => 'Information');
399			$out->start_tag ('dl');
400
401			$out->dt ('Internet Media Type');
402			$out->start_tag ('dd');
403			$out->code ($self->{media_type}, code => 'MIME', lang => 'en');
404
405			if (defined $self->{container_node}) {
406			$out->dt ('Container Node');
407			$out->start_tag ('dd');
408			my $original_input = $out->input;
409			$out->input ($self->{parent_input});
410			$out->node_link ($self->{container_node});
411			$out->input ($original_input);
412			}
413
414			$out->dt ('Base URL');
415			$out->start_tag ('dd');
416			$out->url ($self->{base_uri});
417
418			$out->end_tag ('dl');
419			$out->end_section;
420			} # generate_info_section
421	wakaba	1.2
422			package WebHACC::Input::Error;
423			push our @ISA, 'WebHACC::Input';
424
425			sub generate_transfer_sections ($$) {
426			my $self = shift;
427
428			$self->SUPER::generate_transfer_sections (@_);
429
430			my $result = shift;
431			my $out = $result->output;
432
433			$out->start_section (id => 'transfer-errors', title => 'Transfer Errors');
434
435			$out->start_tag ('dl');
436			$result->add_error (layer => 'transfer',
437			level => 'u',
438			type => 'resource retrieval error',
439			url => $self->{request_uri},
440			text => $self->{error_status_text});
441			$out->end_tag ('dl');
442
443			$out->end_section;
444			} # generate_transfer_sections
445	wakaba	1.6
446			package WebHACC::Input::HTTPError;
447			push our @ISA, 'WebHACC::Input::Error', 'WebHACC::Input::HTTP';
448
449			package WebHACC::Input::UnsupportedURLSchemeError;
450			push our @ISA, 'WebHACC::Input::Error';
451
452			sub _get_document ($$$$) {
453			my ($self, $cgi => $result => $out) = @_;
454
455			$self->{error_status_text} = 'URL scheme not allowed';
456
457			return $self;
458			} # _get_document
459
460			package WDCC::LWPUA;
461			require LWP::UserAgent;
462			push our @ISA, 'LWP::UserAgent';
463
464			sub redirect_ok {
465			my $ua = shift;
466			unless ($ua->SUPER::redirect_ok (@_)) {
467			return 0;
468			}
469
470			my $uris = $_[1]->header ('Location');
471			return 0 unless $uris;
472			my $uri = $ua->{wdcc_dom}->create_uri_reference ($uris);
473			unless ({
474			http => 1,
475			}->{lc $uri->uri_scheme}) { ## TODO: html5_url_scheme
476			return 0;
477			}
478			unless ($ua->{wdcc_host_permit}->check ($uri->uri_host, $uri->uri_port \|\| 80)) {
479			return 0;
480			}
481			return 1;
482			} # redirect_ok
483	wakaba	1.2
484	wakaba	1.1	1;