/[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 - (hide annotations) (download)
Sun Jul 25 06:54:29 2004 UTC (20 years, 9 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 wakaba 1.1
2     =head1 NAME
3    
4 wakaba 1.5 SuikaWiki::Input::HTTP - SuikaWiki: HTTP or HTTP CGI input support
5 wakaba 1.1
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 wakaba 1.7 our $VERSION = do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18 wakaba 1.1
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 wakaba 1.5 $self->{-in_handle} = $opt{input_handle} || *STDIN;
38 wakaba 1.1 $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 wakaba 1.6 =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 wakaba 1.1 =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 wakaba 1.2 =item @keys = $http->parameter_names
86    
87     Returnes a list of parameter names provided.
88    
89 wakaba 1.1 =cut
90    
91     sub parameter ($$) {
92     my ($self, $name) = @_;
93 wakaba 1.2 $self->__get_parameter unless $self->{param};
94 wakaba 1.7 wantarray ? ( @{$self->{param}->{$name}||[]} ) :
95 wakaba 1.1 ${$self->{param}->{$name}||[]}[0];
96     }
97    
98 wakaba 1.2 sub parameter_names ($) {
99     my $self = shift;
100     $self->__get_parameter unless $self->{param};
101     return keys %{$self->{param}};
102     }
103    
104 wakaba 1.1 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 wakaba 1.2 push @src, $qs if (index ($qs, '=') > -1);
111 wakaba 1.1
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 wakaba 1.5 ## TODO: support non-standard "charset" parameter
119 wakaba 1.1 }
120    
121 wakaba 1.2 my %temp_params;
122 wakaba 1.1 for my $src (@src) {
123     for (split /[;&]/, $src) {
124     my ($name, $val) = split '=', $_, 2;
125 wakaba 1.2 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 wakaba 1.1 push @{$self->{param}->{$name}},
138     &{$self->{decoder}->{$name}
139 wakaba 1.2 ||$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);
140 wakaba 1.1 }
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 wakaba 1.5 binmode $self->{-in_handle};
171     read $self->{-in_handle}, $self->{body},
172     $self->meta_variable ('CONTENT_LENGTH');
173 wakaba 1.1 }
174 wakaba 1.4 ## TODO: Entity too large
175 wakaba 1.1
176 wakaba 1.2 =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 wakaba 1.4 sub request_uri ($;%) {
188     my ($self, %opt) = @_;
189 wakaba 1.2 require URI;
190 wakaba 1.4 my $uri = $opt{no_path_info} ? undef
191     : $self->meta_variable ('REQUEST_URI'); # non-standard
192 wakaba 1.2 if ($uri) {
193 wakaba 1.4 $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 wakaba 1.2 return URI->new ($uri);
197     }
198     } else { ## REQUEST_URI is not provided
199 wakaba 1.4 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 wakaba 1.2 }
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 wakaba 1.4 ## TODO: HTTPS=off
212 wakaba 1.2 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 wakaba 1.4
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 wakaba 1.2 return URI->new ($uri);
233     }
234    
235    
236     sub __uri_encode ($$;$) {
237     my ($self, $s, $char) = @_;
238 wakaba 1.4 $char ||= qr([^0-9A-Za-z_.!~*'();/?:\@&=+\$,-]);
239 wakaba 1.2 require Encode;
240     $s = Encode::decode ('utf8', $s);
241     $s =~ s/($char)/sprintf '%%%02X', ord $1/ge;
242     $s;
243 wakaba 1.1 }
244    
245 wakaba 1.3 =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 wakaba 1.1 =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 wakaba 1.7 1; # $Date: 2004/02/18 07:20:28 $

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24  
Google Analytics is used in this page; Cookies are used. 忍者AdMax is used in this page; Cookies are used. Privacy policy.