Message/CGI/HTTP.pm

=head1 NAME

Message::CGI::HTTP - An Object-Oriented HTTP CGI Interface

=head1 DESCRIPTION

The C<Message::CGI::HTTP> module provides an object-oriented
interface for inputs and outputs as defined by CGI specification.

This module is part of manakai.

=cut

package Message::CGI::HTTP;
use strict;
our $VERSION = do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
push our @ISA, 'Message::IF::CGIRequest', 'Message::IF::HTTPCGIRequest';

=head1 METHODS

=over 4

=item I<$cgi> = Message::CGI::HTTP->new;

Creates and returns a new instance of HTTP CGI interface object.

=cut

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

=item I<$value> = I<$cgi>->get_meta_variable (I<$name>)

Returns the value of the meta-variable I<$name>.  The name
specified by the I<$name> SHOULD be a meta-variable name
defined by a CGI specification, e.g. C<CONTENT_TYPE> or
C<HTTP_USER_AGENT>.  Otherwise, the result is implementation
dependent.  In an environment where meta-variables are supplied
as envirnoment variables, specifying an environment variable
that is not a meta-variable, such as C<PATH>, results in the
value of that environment variable.  However, CGI scripts
SHOULD NOT depend on such behavior.

This method might return C<undef> when the meta-variable
is not defined or is defined but its value is C<undef>.

=cut

sub get_meta_variable ($$) {
  return $main::ENV{ $_[1] };
} # get_meta_variable

=item I<$list> = I<$cgi>->meta_variable_names;

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.

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.

This method returns a C<Message::DOM::DOMStringList>.

=cut

sub meta_variable_names ($) {
  require Message::DOM::DOMStringList;
  bless [keys %main::ENV], 'Message::DOM::DOMStringList::StaticList';
} # meta_variable_names

=item I<$value> = C<$cgi>->get_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.)

=cut

sub get_parameter ($$) {
  my ($self, $name) = @_;
  $self->__get_parameter unless $self->{param};

  if (wantarray) {
    return @{$self->{param}->{$name}||[]};
  } else {
    return ${$self->{param}->{$name}||[]}[0];
  }
} # get_parameter

=item I<$keys> = I<$cgi>->parameter_names;

Returnes a list of parameter names provided.

This method returns a C<Message::DOM::DOMStringList>.

=cut

sub parameter_names ($) {
  my $self = shift;
  $self->__get_parameter unless $self->{param};
  
  require Message::DOM::DOMStringList;
  return bless [keys %{$self->{param}}],
      'Message::DOM::DOMStringList::StaticList';
} # parameter_names

sub __get_parameter ($) {
  my $self = shift;
  my @src;
  
  ## Query-string of Request-URI
  my $qs = $self->get_meta_variable ('QUERY_STRING');
  push @src, $qs if (index ($qs, '=') > -1);
  
  ## Entity-body
  if ($self->get_meta_variable ('REQUEST_METHOD') eq 'POST') {
    my $mt = $self->get_meta_variable ('CONTENT_TYPE');
    if ($mt =~ m<^application/(?:x-www|sgml)-form-urlencoded\b>) {
      push @src, $self->entity_body;
    }
    ## 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);
    }
  }
} # __get_parameter

=item I<$body> = I<$cgi>->entity_body;

Returns entity-body content if any.

=cut

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

  return $self->{body};
} # entity_body
         
sub __get_entity_body ($) {
  my $self = shift;
  binmode $self->{-in_handle};
  read $self->{-in_handle}, $self->{body}, 
                            $self->get_meta_variable ('CONTENT_LENGTH');
} # __get_entity_body
## TODO: Entity too large

=item I<$uri> = I<$cgi>->request_uri;

Returns Request-URI as a C<Message::URI::URIReference> 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 Message::URI::URIReference;
  my $uri = $opt{no_path_info} ? undef
          : $self->get_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 Message::DOM::DOMImplementation->create_uri_reference ($uri);
    }
  } else {  ## REQUEST_URI is not provided
    my $pi = $opt{no_path_info} ? q<>
           : $self->get_meta_variable ('PATH_INFO');
    $uri = $self->__uri_encode ($self->get_meta_variable ('SCRIPT_NAME').$pi,
                                qr([^0-9A-Za-z_.!~*'();/:\@&=\$,-]));
    my $qs = $self->get_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->get_meta_variable ('SERVER_PORT');
  ## TODO: HTTPS=off
  if (   $self->get_meta_variable ('HTTPS')
      || $self->get_meta_variable ('CERT_SUBJECT')
      || $self->get_meta_variable ('SSL_VERSION')) {
    $scheme = 'https';
    $port = '' if $port eq ':443';
  } else {
    $port = '' if $port eq ':80';
  }
  
  my $host_and_port = $self->get_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->get_meta_variable ('SERVER_NAME'),
                                qr/[^0-9A-Za-z.-]/)
         . $port . $uri;
  }
  return Message::DOM::DOMImplementation->create_uri_reference ($uri);
} # request_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;
  return $s;
} # __uri_encode

=item I<$value> = I<$cgi>->path_info ([I<$new_value>]);

This method reflects the meta-variable with the same name (in uppercase).

=cut

for (
  [path_info => 'PATH_INFO'],
  [query_string => 'QUERY_STRING'],
  [request_method => 'REQUEST_METHOD'],
  [script_name => 'SCRIPT_NAME'],
) {
  eval qq{
    sub $_->[0] (\$;\$) {
      if (\@_ > 1) {
        if (defined \$_[1]) {
          \$main::ENV{'$_->[1]'} = ''.\$_[1];
        } else {
          delete \$main::ENV{'$_->[1]'};
        }
      }
      return \$main::ENV{'$_->[1]'};
    }
  };
}

package Message::IF::CGIRequest;
package Message::IF::HTTPCGIRequest;

=back

=head1 TODO

=over 4

=item multipart/form-data support

=back

=head1 SEE ALSO

A draft specification for DOM CGI Module
<http://suika.fam.cx/gate/2005/sw/manakai/%E3%83%A1%E3%83%A2/2005-07-04>
(This module does not implement the interface defined in this
specification, however.)

=head1 AUTHOR

Wakaba <w@suika.fam.cx>

This module was originally developed as part of SuikaWiki.

=head1 LICENSE

Copyright 2003, 2007 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: 2007/08/11 13:51:36 $
1	wakaba	1.1	=head1 NAME
2
3	wakaba	1.2	Message::CGI::HTTP - An Object-Oriented HTTP CGI Interface
4	wakaba	1.1
5			=head1 DESCRIPTION
6
7	wakaba	1.2	The C<Message::CGI::HTTP> module provides an object-oriented
8			interface for inputs and outputs as defined by CGI specification.
9	wakaba	1.1
10	wakaba	1.2	This module is part of manakai.
11	wakaba	1.1
12			=cut
13
14	wakaba	1.2	package Message::CGI::HTTP;
15	wakaba	1.1	use strict;
16	wakaba	1.4	our $VERSION = do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17			push our @ISA, 'Message::IF::CGIRequest', 'Message::IF::HTTPCGIRequest';
18	wakaba	1.1
19			=head1 METHODS
20
21			=over 4
22
23	wakaba	1.2	=item I<$cgi> = Message::CGI::HTTP->new;
24	wakaba	1.1
25	wakaba	1.2	Creates and returns a new instance of HTTP CGI interface object.
26	wakaba	1.1
27			=cut
28
29			sub new ($;%) {
30			my $self = bless {
31			decoder => {
32			'#default' => sub {$_[1]},
33			},
34			}, shift;
35			my %opt = @_;
36	wakaba	1.2	$self->{-in_handle} = *main::STDIN;
37	wakaba	1.1	$self;
38	wakaba	1.2	} # new
39
40			=item I<$value> = I<$cgi>->get_meta_variable (I<$name>)
41	wakaba	1.1
42	wakaba	1.2	Returns the value of the meta-variable I<$name>. The name
43			specified by the I<$name> SHOULD be a meta-variable name
44			defined by a CGI specification, e.g. C<CONTENT_TYPE> or
45			C<HTTP_USER_AGENT>. Otherwise, the result is implementation
46			dependent. In an environment where meta-variables are supplied
47			as envirnoment variables, specifying an environment variable
48			that is not a meta-variable, such as C<PATH>, results in the
49			value of that environment variable. However, CGI scripts
50			SHOULD NOT depend on such behavior.
51	wakaba	1.1
52	wakaba	1.2	This method might return C<undef> when the meta-variable
53			is not defined or is defined but its value is C<undef>.
54	wakaba	1.1
55			=cut
56
57	wakaba	1.2	sub get_meta_variable ($$) {
58			return $main::ENV{ $_[1] };
59			} # get_meta_variable
60	wakaba	1.1
61	wakaba	1.2	=item I<$list> = I<$cgi>->meta_variable_names;
62	wakaba	1.1
63			Returns list of meta variables. Note that this list might contain
64			other environmental variables than CGI meta variables, since
65			they cannot distinglish unless we know what is CGI meta variable
66			and what is not. Unfortunately, there is no complete list of CGI
67			meta variables, whilst list of standarized meta variables is available.
68
69			NOTE: Some application might use an environmental variable named
70			'HTTP_HOME', which might make some confusion with CGI meta variable
71			for HTTP 'Home:' header field. Fortunately, such name of HTTP
72			header field is not intoroduced as far as I know.
73
74	wakaba	1.3	This method returns a C<Message::DOM::DOMStringList>.
75	wakaba	1.2
76	wakaba	1.1	=cut
77
78	wakaba	1.2	sub meta_variable_names ($) {
79			require Message::DOM::DOMStringList;
80			bless [keys %main::ENV], 'Message::DOM::DOMStringList::StaticList';
81			} # meta_variable_names
82	wakaba	1.1
83	wakaba	1.2	=item I<$value> = C<$cgi>->get_parameter ($name);
84	wakaba	1.1
85			Returns parameter value if any.
86			Parameter value is set by query-string of Request-URI
87			and/or entity-body value.
88
89			When multiple values with same parameter name is specified,
90			the first one is returned in scalar context or
91			an array reference of all values is returned in array context.
92			(Note that query-string is "earlier" than entity-body.)
93
94	wakaba	1.2	=cut
95
96			sub get_parameter ($$) {
97			my ($self, $name) = @_;
98			$self->__get_parameter unless $self->{param};
99
100			if (wantarray) {
101			return @{$self->{param}->{$name}\|\|[]};
102			} else {
103			return ${$self->{param}->{$name}\|\|[]}[0];
104			}
105			} # get_parameter
106
107			=item I<$keys> = I<$cgi>->parameter_names;
108	wakaba	1.1
109			Returnes a list of parameter names provided.
110
111	wakaba	1.3	This method returns a C<Message::DOM::DOMStringList>.
112	wakaba	1.2
113	wakaba	1.1	=cut
114
115			sub parameter_names ($) {
116			my $self = shift;
117			$self->__get_parameter unless $self->{param};
118	wakaba	1.2
119			require Message::DOM::DOMStringList;
120			return bless [keys %{$self->{param}}],
121			'Message::DOM::DOMStringList::StaticList';
122			} # parameter_names
123	wakaba	1.1
124			sub __get_parameter ($) {
125			my $self = shift;
126			my @src;
127
128			## Query-string of Request-URI
129	wakaba	1.3	my $qs = $self->get_meta_variable ('QUERY_STRING');
130	wakaba	1.1	push @src, $qs if (index ($qs, '=') > -1);
131
132			## Entity-body
133	wakaba	1.3	if ($self->get_meta_variable ('REQUEST_METHOD') eq 'POST') {
134			my $mt = $self->get_meta_variable ('CONTENT_TYPE');
135	wakaba	1.1	if ($mt =~ m<^application/(?:x-www\|sgml)-form-urlencoded\b>) {
136	wakaba	1.3	push @src, $self->entity_body;
137	wakaba	1.1	}
138			## TODO: support non-standard "charset" parameter
139			}
140
141			my %temp_params;
142			for my $src (@src) {
143			for (split /[;&]/, $src) {
144			my ($name, $val) = split '=', $_, 2;
145			for ($name, $val) {
146			tr/+/ /;
147			s/%([0-9A-Fa-f][0-9A-Fa-f])/pack 'C', hex $1/ge;
148			}
149			$temp_params{$name} \|\|= [];
150			push @{$temp_params{$name}}, $val;
151			}
152			}
153			for (keys %temp_params) {
154			my $name = &{$self->{decoder}->{'#name'}
155			\|\|$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);
156			for (@{$temp_params{$name}}) {
157			push @{$self->{param}->{$name}},
158			&{$self->{decoder}->{$name}
159			\|\|$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);
160			}
161			}
162	wakaba	1.3	} # __get_parameter
163	wakaba	1.1
164	wakaba	1.2	=item I<$body> = I<$cgi>->entity_body;
165	wakaba	1.1
166			Returns entity-body content if any.
167
168			=cut
169
170	wakaba	1.2	sub entity_body ($) {
171	wakaba	1.1	my $self = shift;
172			$self->__get_entity_body unless defined $self->{body};
173
174	wakaba	1.2	return $self->{body};
175			} # entity_body
176	wakaba	1.1
177			sub __get_entity_body ($) {
178			my $self = shift;
179			binmode $self->{-in_handle};
180			read $self->{-in_handle}, $self->{body},
181	wakaba	1.3	$self->get_meta_variable ('CONTENT_LENGTH');
182	wakaba	1.2	} # __get_entity_body
183	wakaba	1.1	## TODO: Entity too large
184
185	wakaba	1.2	=item I<$uri> = I<$cgi>->request_uri;
186	wakaba	1.1
187	wakaba	1.3	Returns Request-URI as a C<Message::URI::URIReference> object.
188	wakaba	1.1
189			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-)
191			URI entered by the user, since no standarized way to get it is
192			defined by HTTP and CGI/1.1 specifications.
193
194			=cut
195
196			sub request_uri ($;%) {
197			my ($self, %opt) = @_;
198	wakaba	1.2	require Message::URI::URIReference;
199	wakaba	1.1	my $uri = $opt{no_path_info} ? undef
200	wakaba	1.3	: $self->get_meta_variable ('REQUEST_URI'); # non-standard
201	wakaba	1.1	if ($uri) {
202			$uri =~ s/\#[^#]*$//; ## Fragment identifier not allowed here
203			$uri =~ s/\?[^?]*$// if $opt{no_query};
204			if ($uri =~ /^[0-9A-Za-z.%+-]+:/) { ## REQUEST_URI is an absolute URI
205	wakaba	1.2	return Message::DOM::DOMImplementation->create_uri_reference ($uri);
206	wakaba	1.1	}
207			} else { ## REQUEST_URI is not provided
208			my $pi = $opt{no_path_info} ? q<>
209	wakaba	1.3	: $self->get_meta_variable ('PATH_INFO');
210			$uri = $self->__uri_encode ($self->get_meta_variable ('SCRIPT_NAME').$pi,
211	wakaba	1.1	qr([^0-9A-Za-z_.!~*'();/:\@&=\$,-]));
212	wakaba	1.3	my $qs = $self->get_meta_variable ('QUERY_STRING');
213	wakaba	1.1	$uri .= '?' . $qs if not $opt{no_query} and defined $qs;
214			}
215
216			## REQUEST_URI is a relative URI or
217			## REQUEST_URI is not provided
218			my $scheme = 'http';
219	wakaba	1.3	my $port = ':' . $self->get_meta_variable ('SERVER_PORT');
220	wakaba	1.1	## TODO: HTTPS=off
221	wakaba	1.3	if ( $self->get_meta_variable ('HTTPS')
222			\|\| $self->get_meta_variable ('CERT_SUBJECT')
223			\|\| $self->get_meta_variable ('SSL_VERSION')) {
224	wakaba	1.1	$scheme = 'https';
225			$port = '' if $port eq ':443';
226			} else {
227			$port = '' if $port eq ':80';
228			}
229
230	wakaba	1.3	my $host_and_port = $self->get_meta_variable ('HTTP_HOST');
231	wakaba	1.1	if ($host_and_port) {
232			$uri = $scheme . '://'
233			. $self->__uri_encode ($host_and_port, qr/[^0-9A-Za-z.:-]/)
234			. $uri; ## ISSUE: Should we allow "[" / "]" for IPv6 here?
235			} else {
236			$uri = $scheme . '://'
237	wakaba	1.3	. $self->__uri_encode ($self->get_meta_variable ('SERVER_NAME'),
238	wakaba	1.1	qr/[^0-9A-Za-z.-]/)
239			. $port . $uri;
240			}
241	wakaba	1.2	return Message::DOM::DOMImplementation->create_uri_reference ($uri);
242			} # request_uri
243	wakaba	1.1
244			sub __uri_encode ($$;$) {
245			my ($self, $s, $char) = @_;
246			$char \|\|= qr([^0-9A-Za-z_.!~*'();/?:\@&=+\$,-]);
247			require Encode;
248			$s = Encode::decode ('utf8', $s);
249			$s =~ s/($char)/sprintf '%%%02X', ord $1/ge;
250	wakaba	1.2	return $s;
251			} # __uri_encode
252	wakaba	1.1
253	wakaba	1.4	=item I<$value> = I<$cgi>->path_info ([I<$new_value>]);
254
255			This method reflects the meta-variable with the same name (in uppercase).
256
257			=cut
258
259			for (
260			[path_info => 'PATH_INFO'],
261			[query_string => 'QUERY_STRING'],
262			[request_method => 'REQUEST_METHOD'],
263			[script_name => 'SCRIPT_NAME'],
264			) {
265			eval qq{
266			sub $_->[0] (\$;\$) {
267			if (\@_ > 1) {
268			if (defined \$_[1]) {
269			\$main::ENV{'$_->[1]'} = ''.\$_[1];
270			} else {
271			delete \$main::ENV{'$_->[1]'};
272			}
273			}
274			return \$main::ENV{'$_->[1]'};
275			}
276			};
277			}
278
279	wakaba	1.2	package Message::IF::CGIRequest;
280	wakaba	1.4	package Message::IF::HTTPCGIRequest;
281	wakaba	1.1
282	wakaba	1.2	=back
283	wakaba	1.1
284	wakaba	1.2	=head1 TODO
285	wakaba	1.1
286	wakaba	1.2	=over 4
287	wakaba	1.1
288	wakaba	1.2	=item multipart/form-data support
289	wakaba	1.1
290	wakaba	1.2	=back
291	wakaba	1.1
292	wakaba	1.2	=head1 SEE ALSO
293	wakaba	1.1
294	wakaba	1.2	A draft specification for DOM CGI Module
295			<http://suika.fam.cx/gate/2005/sw/manakai/%E3%83%A1%E3%83%A2/2005-07-04>
296			(This module does not implement the interface defined in this
297			specification, however.)
298	wakaba	1.1
299	wakaba	1.2	=head1 AUTHOR
300	wakaba	1.1
301	wakaba	1.2	Wakaba <w@suika.fam.cx>
302	wakaba	1.1
303	wakaba	1.3	This module was originally developed as part of SuikaWiki.
304
305	wakaba	1.1	=head1 LICENSE
306
307	wakaba	1.2	Copyright 2003, 2007 Wakaba <w@suika.fam.cx>
308	wakaba	1.1
309			This program is free software; you can redistribute it and/or
310			modify it under the same terms as Perl itself.
311
312			=cut
313
314	wakaba	1.2	1;
315	wakaba	1.4	# $Date: 2007/08/11 13:51:36 $