Message/CGI/HTTP.pm


=head1 NAME

SuikaWiki::Input::HTTP - SuikaWiki: HTTP or HTTP CGI input support

=head1 DESCRIPTION

This module provides HTTP or HTTP CGI input support,
although current version of this module supports HTTP CGI only.

This module is part of SuikaWiki.

=cut

package SuikaWiki::Input::HTTP;
use strict;
our $VERSION = do{my @r=(q$Revision: 1.7 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

=head1 METHODS

=over 4

=item $http = SuikaWiki::Input::HTTP->new

Constructs new instance of HTTP input implementation

=cut

sub new ($;%) {
  my $self = bless {
                    decoder => {
                                '#default' => sub {$_[1]},
                               },
                   }, shift;
  my %opt = @_;
  $self->{wiki} = $opt{wiki};
  $self->{-in_handle} = $opt{input_handle} || *STDIN;
  $self;
}

=item $value = $http->meta_variable ($name)

Returns variable value.  $name should be a meta-variable name
defined by CGI specification, eg. CONTENT_TYPE, HTTP_USER_AGENT and so on.

=cut

sub meta_variable ($$) {
  $main::ENV{ $_[1] };
}

=item @list = $http->meta_variable_list

Returns list of meta variables.  Note that this list might contain
other environmental variables than CGI meta variables, since
they cannot distinglish unless we know what is CGI meta variable
and what is not.  Unfortunately, there is no complete list of CGI
meta variables, whilst list of standarized meta variables is available.

Future version of this module, which implements non-CGI HTTP request,
will not return non-CGI environmental variable names in non-CGI mode.

NOTE: Some application might use an environmental variable named
'HTTP_HOME', which might make some confusion with CGI meta variable
for HTTP 'Home:' header field.  Fortunately, such name of HTTP
header field is not intoroduced as far as I know.

=cut

sub meta_variable_list ($) {
  keys %main::ENV;
}

=item $value = $http->parameter ($name)

Returns parameter value if any.
Parameter value is set by query-string of Request-URI
and/or entity-body value.

When multiple values with same parameter name is specified,
the first one is returned in scalar context or
an array reference of all values is returned in array context.
(Note that query-string is "earlier" than entity-body.)

=item @keys = $http->parameter_names

Returnes a list of parameter names provided.

=cut

sub parameter ($$) {
  my ($self, $name) = @_;
  $self->__get_parameter unless $self->{param};
  wantarray ? ( @{$self->{param}->{$name}||[]} ) :
              ${$self->{param}->{$name}||[]}[0];
}

sub parameter_names ($) {
  my $self = shift;
  $self->__get_parameter unless $self->{param};
  return keys %{$self->{param}};
}

sub __get_parameter ($) {
  my $self = shift;
  my @src;
  
  ## Query-string of Request-URI
  my $qs = $self->meta_variable ('QUERY_STRING');
  push @src, $qs if (index ($qs, '=') > -1);
  
  ## Entity-body
  if ($self->meta_variable ('REQUEST_METHOD') eq 'POST') {
    my $mt = $self->meta_variable ('CONTENT_TYPE');
    if ($mt =~ m<^application/(?:x-www|sgml)-form-urlencoded\b>) {
      push @src, $self->body_text;
    }
    ## TODO: support non-standard "charset" parameter
  }
  
  my %temp_params;
  for my $src (@src) {
    for (split /[;&]/, $src) {
      my ($name, $val) = split '=', $_, 2;
      for ($name, $val) {
        tr/+/ /;
        s/%([0-9A-Fa-f][0-9A-Fa-f])/pack 'C', hex $1/ge;
      }
      $temp_params{$name} ||= [];
      push @{$temp_params{$name}}, $val;
    }
  }
  for (keys %temp_params) {
    my $name = &{$self->{decoder}->{'#name'}
               ||$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);
    for (@{$temp_params{$name}}) {
      push @{$self->{param}->{$name}}, 
           &{$self->{decoder}->{$name}
           ||$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);
    }
  }
}

=item $body = $http->body

Returns entity-body content if any.

It is expected that in future version of this module,
this method returns an object instantiated with body content
rather than body text itself.

=item $body = $http->body_text

Returnes entity-body context as a string.

=cut

sub body ($) {
  my $self = shift;
  $self->__get_entity_body unless defined $self->{body};
  $self->{body};
}

sub body_text ($) {
  $_[0]->body;
}
         
sub __get_entity_body ($) {
  my $self = shift;
  binmode $self->{-in_handle};
  read $self->{-in_handle}, $self->{body}, 
                            $self->meta_variable ('CONTENT_LENGTH');
}
## TODO: Entity too large

=item $uri = $http->request_uri

Returns Request-URI as a URI object.

Note that stringified value of returned value might not be same as the
URI specified as the Request-URI of HTTP request or (possibly pseudo-)
URI entered by the user, since no standarized way to get it is
defined by HTTP and CGI/1.1 specifications.

=cut

sub request_uri ($;%) {
  my ($self, %opt) = @_;
  require URI;
  my $uri = $opt{no_path_info} ? undef
          : $self->meta_variable ('REQUEST_URI'); # non-standard
  if ($uri) {
    $uri =~ s/\#[^#]*$//;  ## Fragment identifier not allowed here
    $uri =~ s/\?[^?]*$// if $opt{no_query};
    if ($uri =~ /^[0-9A-Za-z.%+-]+:/) {    ## REQUEST_URI is an absolute URI
      return URI->new ($uri);
    }
  } else {  ## REQUEST_URI is not provided
    my $pi = $opt{no_path_info} ? q<>
           : $self->meta_variable ('PATH_INFO');
    $uri = $self->__uri_encode ($self->meta_variable ('SCRIPT_NAME').$pi,
                                qr([^0-9A-Za-z_.!~*'();/:\@&=\$,-]));
    my $qs = $self->meta_variable ('QUERY_STRING');
    $uri .= '?' . $qs if not $opt{no_query} and defined $qs;
  }
  
  ## REQUEST_URI is a relative URI or
  ## REQUEST_URI is not provided
  my $scheme = 'http';
  my $port = ':' . $self->meta_variable ('SERVER_PORT');
  ## TODO: HTTPS=off
  if (   $self->meta_variable ('HTTPS')
      || $self->meta_variable ('CERT_SUBJECT')
      || $self->meta_variable ('SSL_VERSION')) {
    $scheme = 'https';
    $port = '' if $port eq ':443';
  } else {
    $port = '' if $port eq ':80';
  }
  
  my $host_and_port = $self->meta_variable ('HTTP_HOST');
  if ($host_and_port) {
    $uri = $scheme . '://'
         . $self->__uri_encode ($host_and_port, qr/[^0-9A-Za-z.:-]/)
         . $uri;  ## ISSUE: Should we allow "[" / "]" for IPv6 here?
  } else {
    $uri = $scheme . '://'
         . $self->__uri_encode ($self->meta_variable ('SERVER_NAME'),
                                qr/[^0-9A-Za-z.-]/)
         . $port . $uri;
  }
  return URI->new ($uri);
}


sub __uri_encode ($$;$) {
  my ($self, $s, $char) = @_;
  $char ||= qr([^0-9A-Za-z_.!~*'();/?:\@&=+\$,-]);
  require Encode;
  $s = Encode::decode ('utf8', $s);
  $s =~ s/($char)/sprintf '%%%02X', ord $1/ge;
  $s;
}

=item $http->exit

Declares that user no longer thinks the instance ($http) is interesting.
Usually, this method is automatically called.

=cut

sub exit ($) {
  my $self = shift;
  delete $self->{wiki};
  $self->{exited} = 1;
  1;
}

sub DESTORY ($) {
  my $self = shift;
  $self->exit unless $self->{exited};
}

=head1 TODO

=over 4

=item Use manakai

=item multipart/form-data support

=item HTTP (non-CGI) support

=cut

=head1 LICENSE

Copyright 2003 Wakaba <w@suika.fam.cx>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2004/07/25 06:54:29 $
1	wakaba	1.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.7 $=~/\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/07/25 06:54:29 $