/[pub]/suikawiki/script/lib/SuikaWiki/Input/HTTP.pm
Suika

Contents of /suikawiki/script/lib/SuikaWiki/Input/HTTP.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations) (download)
Sun Jul 25 06:54:29 2004 UTC (20 years, 11 months ago) by wakaba
Branch: MAIN
CVS Tags: suikawiki3-redirect, HEAD
Branch point for: helowiki, helowiki-2005
Changes since 1.6: +3 -3 lines
Property Editor implemented

1
2 =head1 NAME
3
4 SuikaWiki::Input::HTTP - SuikaWiki: HTTP or HTTP CGI input support
5
6 =head1 DESCRIPTION
7
8 This module provides HTTP or HTTP CGI input support,
9 although current version of this module supports HTTP CGI only.
10
11 This module is part of SuikaWiki.
12
13 =cut
14
15 package SuikaWiki::Input::HTTP;
16 use strict;
17 our $VERSION = do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18
19 =head1 METHODS
20
21 =over 4
22
23 =item $http = SuikaWiki::Input::HTTP->new
24
25 Constructs new instance of HTTP input implementation
26
27 =cut
28
29 sub new ($;%) {
30 my $self = bless {
31 decoder => {
32 '#default' => sub {$_[1]},
33 },
34 }, shift;
35 my %opt = @_;
36 $self->{wiki} = $opt{wiki};
37 $self->{-in_handle} = $opt{input_handle} || *STDIN;
38 $self;
39 }
40
41 =item $value = $http->meta_variable ($name)
42
43 Returns variable value. $name should be a meta-variable name
44 defined by CGI specification, eg. CONTENT_TYPE, HTTP_USER_AGENT and so on.
45
46 =cut
47
48 sub meta_variable ($$) {
49 $main::ENV{ $_[1] };
50 }
51
52 =item @list = $http->meta_variable_list
53
54 Returns list of meta variables. Note that this list might contain
55 other environmental variables than CGI meta variables, since
56 they cannot distinglish unless we know what is CGI meta variable
57 and what is not. Unfortunately, there is no complete list of CGI
58 meta variables, whilst list of standarized meta variables is available.
59
60 Future version of this module, which implements non-CGI HTTP request,
61 will not return non-CGI environmental variable names in non-CGI mode.
62
63 NOTE: Some application might use an environmental variable named
64 'HTTP_HOME', which might make some confusion with CGI meta variable
65 for HTTP 'Home:' header field. Fortunately, such name of HTTP
66 header field is not intoroduced as far as I know.
67
68 =cut
69
70 sub meta_variable_list ($) {
71 keys %main::ENV;
72 }
73
74 =item $value = $http->parameter ($name)
75
76 Returns parameter value if any.
77 Parameter value is set by query-string of Request-URI
78 and/or entity-body value.
79
80 When multiple values with same parameter name is specified,
81 the first one is returned in scalar context or
82 an array reference of all values is returned in array context.
83 (Note that query-string is "earlier" than entity-body.)
84
85 =item @keys = $http->parameter_names
86
87 Returnes a list of parameter names provided.
88
89 =cut
90
91 sub parameter ($$) {
92 my ($self, $name) = @_;
93 $self->__get_parameter unless $self->{param};
94 wantarray ? ( @{$self->{param}->{$name}||[]} ) :
95 ${$self->{param}->{$name}||[]}[0];
96 }
97
98 sub parameter_names ($) {
99 my $self = shift;
100 $self->__get_parameter unless $self->{param};
101 return keys %{$self->{param}};
102 }
103
104 sub __get_parameter ($) {
105 my $self = shift;
106 my @src;
107
108 ## Query-string of Request-URI
109 my $qs = $self->meta_variable ('QUERY_STRING');
110 push @src, $qs if (index ($qs, '=') > -1);
111
112 ## Entity-body
113 if ($self->meta_variable ('REQUEST_METHOD') eq 'POST') {
114 my $mt = $self->meta_variable ('CONTENT_TYPE');
115 if ($mt =~ m<^application/(?:x-www|sgml)-form-urlencoded\b>) {
116 push @src, $self->body_text;
117 }
118 ## TODO: support non-standard "charset" parameter
119 }
120
121 my %temp_params;
122 for my $src (@src) {
123 for (split /[;&]/, $src) {
124 my ($name, $val) = split '=', $_, 2;
125 for ($name, $val) {
126 tr/+/ /;
127 s/%([0-9A-Fa-f][0-9A-Fa-f])/pack 'C', hex $1/ge;
128 }
129 $temp_params{$name} ||= [];
130 push @{$temp_params{$name}}, $val;
131 }
132 }
133 for (keys %temp_params) {
134 my $name = &{$self->{decoder}->{'#name'}
135 ||$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);
136 for (@{$temp_params{$name}}) {
137 push @{$self->{param}->{$name}},
138 &{$self->{decoder}->{$name}
139 ||$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);
140 }
141 }
142 }
143
144 =item $body = $http->body
145
146 Returns entity-body content if any.
147
148 It is expected that in future version of this module,
149 this method returns an object instantiated with body content
150 rather than body text itself.
151
152 =item $body = $http->body_text
153
154 Returnes entity-body context as a string.
155
156 =cut
157
158 sub body ($) {
159 my $self = shift;
160 $self->__get_entity_body unless defined $self->{body};
161 $self->{body};
162 }
163
164 sub body_text ($) {
165 $_[0]->body;
166 }
167
168 sub __get_entity_body ($) {
169 my $self = shift;
170 binmode $self->{-in_handle};
171 read $self->{-in_handle}, $self->{body},
172 $self->meta_variable ('CONTENT_LENGTH');
173 }
174 ## TODO: Entity too large
175
176 =item $uri = $http->request_uri
177
178 Returns Request-URI as a URI object.
179
180 Note that stringified value of returned value might not be same as the
181 URI specified as the Request-URI of HTTP request or (possibly pseudo-)
182 URI entered by the user, since no standarized way to get it is
183 defined by HTTP and CGI/1.1 specifications.
184
185 =cut
186
187 sub request_uri ($;%) {
188 my ($self, %opt) = @_;
189 require URI;
190 my $uri = $opt{no_path_info} ? undef
191 : $self->meta_variable ('REQUEST_URI'); # non-standard
192 if ($uri) {
193 $uri =~ s/\#[^#]*$//; ## Fragment identifier not allowed here
194 $uri =~ s/\?[^?]*$// if $opt{no_query};
195 if ($uri =~ /^[0-9A-Za-z.%+-]+:/) { ## REQUEST_URI is an absolute URI
196 return URI->new ($uri);
197 }
198 } else { ## REQUEST_URI is not provided
199 my $pi = $opt{no_path_info} ? q<>
200 : $self->meta_variable ('PATH_INFO');
201 $uri = $self->__uri_encode ($self->meta_variable ('SCRIPT_NAME').$pi,
202 qr([^0-9A-Za-z_.!~*'();/:\@&=\$,-]));
203 my $qs = $self->meta_variable ('QUERY_STRING');
204 $uri .= '?' . $qs if not $opt{no_query} and defined $qs;
205 }
206
207 ## REQUEST_URI is a relative URI or
208 ## REQUEST_URI is not provided
209 my $scheme = 'http';
210 my $port = ':' . $self->meta_variable ('SERVER_PORT');
211 ## TODO: HTTPS=off
212 if ( $self->meta_variable ('HTTPS')
213 || $self->meta_variable ('CERT_SUBJECT')
214 || $self->meta_variable ('SSL_VERSION')) {
215 $scheme = 'https';
216 $port = '' if $port eq ':443';
217 } else {
218 $port = '' if $port eq ':80';
219 }
220
221 my $host_and_port = $self->meta_variable ('HTTP_HOST');
222 if ($host_and_port) {
223 $uri = $scheme . '://'
224 . $self->__uri_encode ($host_and_port, qr/[^0-9A-Za-z.:-]/)
225 . $uri; ## ISSUE: Should we allow "[" / "]" for IPv6 here?
226 } else {
227 $uri = $scheme . '://'
228 . $self->__uri_encode ($self->meta_variable ('SERVER_NAME'),
229 qr/[^0-9A-Za-z.-]/)
230 . $port . $uri;
231 }
232 return URI->new ($uri);
233 }
234
235
236 sub __uri_encode ($$;$) {
237 my ($self, $s, $char) = @_;
238 $char ||= qr([^0-9A-Za-z_.!~*'();/?:\@&=+\$,-]);
239 require Encode;
240 $s = Encode::decode ('utf8', $s);
241 $s =~ s/($char)/sprintf '%%%02X', ord $1/ge;
242 $s;
243 }
244
245 =item $http->exit
246
247 Declares that user no longer thinks the instance ($http) is interesting.
248 Usually, this method is automatically called.
249
250 =cut
251
252 sub exit ($) {
253 my $self = shift;
254 delete $self->{wiki};
255 $self->{exited} = 1;
256 1;
257 }
258
259 sub DESTORY ($) {
260 my $self = shift;
261 $self->exit unless $self->{exited};
262 }
263
264 =head1 TODO
265
266 =over 4
267
268 =item Use manakai
269
270 =item multipart/form-data support
271
272 =item HTTP (non-CGI) support
273
274 =cut
275
276 =head1 LICENSE
277
278 Copyright 2003 Wakaba <w@suika.fam.cx>
279
280 This program is free software; you can redistribute it and/or
281 modify it under the same terms as Perl itself.
282
283 =cut
284
285 1; # $Date: 2004/02/18 07:20:28 $

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24