/[suikacvs]/messaging/manakai/lib/Message/CGI/HTTP.pm
Suika

Diff of /messaging/manakai/lib/Message/CGI/HTTP.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by wakaba, Sat Aug 11 13:37:09 2007 UTC revision 1.3 by wakaba, Sat Aug 11 13:51:36 2007 UTC
# Line 71  NOTE: Some application might use an envi Line 71  NOTE: Some application might use an envi
71  for HTTP 'Home:' header field.  Fortunately, such name of HTTP  for HTTP 'Home:' header field.  Fortunately, such name of HTTP
72  header field is not intoroduced as far as I know.  header field is not intoroduced as far as I know.
73    
74  This method returns a C<L<Message::DOM::DOMStringList>>.  This method returns a C<Message::DOM::DOMStringList>.
75    
76  =cut  =cut
77    
# Line 108  sub get_parameter ($$) { Line 108  sub get_parameter ($$) {
108    
109  Returnes a list of parameter names provided.  Returnes a list of parameter names provided.
110    
111  This method returns a C<L<Message::DOM::DOMStringList>>.  This method returns a C<Message::DOM::DOMStringList>.
112    
113  =cut  =cut
114    
# Line 126  sub __get_parameter ($) { Line 126  sub __get_parameter ($) {
126    my @src;    my @src;
127        
128    ## Query-string of Request-URI    ## Query-string of Request-URI
129    my $qs = $self->meta_variable ('QUERY_STRING');    my $qs = $self->get_meta_variable ('QUERY_STRING');
130    push @src, $qs if (index ($qs, '=') > -1);    push @src, $qs if (index ($qs, '=') > -1);
131        
132    ## Entity-body    ## Entity-body
133    if ($self->meta_variable ('REQUEST_METHOD') eq 'POST') {    if ($self->get_meta_variable ('REQUEST_METHOD') eq 'POST') {
134      my $mt = $self->meta_variable ('CONTENT_TYPE');      my $mt = $self->get_meta_variable ('CONTENT_TYPE');
135      if ($mt =~ m<^application/(?:x-www|sgml)-form-urlencoded\b>) {      if ($mt =~ m<^application/(?:x-www|sgml)-form-urlencoded\b>) {
136        push @src, $self->body_text;        push @src, $self->entity_body;
137      }      }
138      ## TODO: support non-standard "charset" parameter      ## TODO: support non-standard "charset" parameter
139    }    }
# Line 159  sub __get_parameter ($) { Line 159  sub __get_parameter ($) {
159             ||$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);             ||$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);
160      }      }
161    }    }
162  } # _get_parameter  } # __get_parameter
163    
164  =item I<$body> = I<$cgi>->entity_body;  =item I<$body> = I<$cgi>->entity_body;
165    
# Line 178  sub __get_entity_body ($) { Line 178  sub __get_entity_body ($) {
178    my $self = shift;    my $self = shift;
179    binmode $self->{-in_handle};    binmode $self->{-in_handle};
180    read $self->{-in_handle}, $self->{body},    read $self->{-in_handle}, $self->{body},
181                              $self->meta_variable ('CONTENT_LENGTH');                              $self->get_meta_variable ('CONTENT_LENGTH');
182  } # __get_entity_body  } # __get_entity_body
183  ## TODO: Entity too large  ## TODO: Entity too large
184    
185  =item I<$uri> = I<$cgi>->request_uri;  =item I<$uri> = I<$cgi>->request_uri;
186    
187  Returns Request-URI as a C<L<Message::URI::URIReference>> object.  Returns Request-URI as a C<Message::URI::URIReference> object.
188    
189  Note that stringified value of returned value might not be same as the  Note that stringified value of returned value might not be same as the
190  URI specified as the Request-URI of HTTP request or (possibly pseudo-)  URI specified as the Request-URI of HTTP request or (possibly pseudo-)
# Line 197  sub request_uri ($;%) { Line 197  sub request_uri ($;%) {
197    my ($self, %opt) = @_;    my ($self, %opt) = @_;
198    require Message::URI::URIReference;    require Message::URI::URIReference;
199    my $uri = $opt{no_path_info} ? undef    my $uri = $opt{no_path_info} ? undef
200            : $self->meta_variable ('REQUEST_URI'); # non-standard            : $self->get_meta_variable ('REQUEST_URI'); # non-standard
201    if ($uri) {    if ($uri) {
202      $uri =~ s/\#[^#]*$//;  ## Fragment identifier not allowed here      $uri =~ s/\#[^#]*$//;  ## Fragment identifier not allowed here
203      $uri =~ s/\?[^?]*$// if $opt{no_query};      $uri =~ s/\?[^?]*$// if $opt{no_query};
# Line 206  sub request_uri ($;%) { Line 206  sub request_uri ($;%) {
206      }      }
207    } else {  ## REQUEST_URI is not provided    } else {  ## REQUEST_URI is not provided
208      my $pi = $opt{no_path_info} ? q<>      my $pi = $opt{no_path_info} ? q<>
209             : $self->meta_variable ('PATH_INFO');             : $self->get_meta_variable ('PATH_INFO');
210      $uri = $self->__uri_encode ($self->meta_variable ('SCRIPT_NAME').$pi,      $uri = $self->__uri_encode ($self->get_meta_variable ('SCRIPT_NAME').$pi,
211                                  qr([^0-9A-Za-z_.!~*'();/:\@&=\$,-]));                                  qr([^0-9A-Za-z_.!~*'();/:\@&=\$,-]));
212      my $qs = $self->meta_variable ('QUERY_STRING');      my $qs = $self->get_meta_variable ('QUERY_STRING');
213      $uri .= '?' . $qs if not $opt{no_query} and defined $qs;      $uri .= '?' . $qs if not $opt{no_query} and defined $qs;
214    }    }
215        
216    ## REQUEST_URI is a relative URI or    ## REQUEST_URI is a relative URI or
217    ## REQUEST_URI is not provided    ## REQUEST_URI is not provided
218    my $scheme = 'http';    my $scheme = 'http';
219    my $port = ':' . $self->meta_variable ('SERVER_PORT');    my $port = ':' . $self->get_meta_variable ('SERVER_PORT');
220    ## TODO: HTTPS=off    ## TODO: HTTPS=off
221    if (   $self->meta_variable ('HTTPS')    if (   $self->get_meta_variable ('HTTPS')
222        || $self->meta_variable ('CERT_SUBJECT')        || $self->get_meta_variable ('CERT_SUBJECT')
223        || $self->meta_variable ('SSL_VERSION')) {        || $self->get_meta_variable ('SSL_VERSION')) {
224      $scheme = 'https';      $scheme = 'https';
225      $port = '' if $port eq ':443';      $port = '' if $port eq ':443';
226    } else {    } else {
227      $port = '' if $port eq ':80';      $port = '' if $port eq ':80';
228    }    }
229        
230    my $host_and_port = $self->meta_variable ('HTTP_HOST');    my $host_and_port = $self->get_meta_variable ('HTTP_HOST');
231    if ($host_and_port) {    if ($host_and_port) {
232      $uri = $scheme . '://'      $uri = $scheme . '://'
233           . $self->__uri_encode ($host_and_port, qr/[^0-9A-Za-z.:-]/)           . $self->__uri_encode ($host_and_port, qr/[^0-9A-Za-z.:-]/)
234           . $uri;  ## ISSUE: Should we allow "[" / "]" for IPv6 here?           . $uri;  ## ISSUE: Should we allow "[" / "]" for IPv6 here?
235    } else {    } else {
236      $uri = $scheme . '://'      $uri = $scheme . '://'
237           . $self->__uri_encode ($self->meta_variable ('SERVER_NAME'),           . $self->__uri_encode ($self->get_meta_variable ('SERVER_NAME'),
238                                  qr/[^0-9A-Za-z.-]/)                                  qr/[^0-9A-Za-z.-]/)
239           . $port . $uri;           . $port . $uri;
240    }    }
# Line 273  specification, however.) Line 273  specification, however.)
273    
274  Wakaba <w@suika.fam.cx>  Wakaba <w@suika.fam.cx>
275    
276    This module was originally developed as part of SuikaWiki.
277    
278  =head1 LICENSE  =head1 LICENSE
279    
280  Copyright 2003, 2007 Wakaba <w@suika.fam.cx>  Copyright 2003, 2007 Wakaba <w@suika.fam.cx>
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24