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.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
push our @ISA, 'Message::IF::CGIRequest';

=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

package Message::IF::CGIRequest;

=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:37:09 $
1	=head1 NAME
2
3	Message::CGI::HTTP - An Object-Oriented HTTP CGI Interface
4
5	=head1 DESCRIPTION
6
7	The C<Message::CGI::HTTP> module provides an object-oriented
8	interface for inputs and outputs as defined by CGI specification.
9
10	This module is part of manakai.
11
12	=cut
13
14	package Message::CGI::HTTP;
15	use strict;
16	our $VERSION = do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17	push our @ISA, 'Message::IF::CGIRequest';
18
19	=head1 METHODS
20
21	=over 4
22
23	=item I<$cgi> = Message::CGI::HTTP->new;
24
25	Creates and returns a new instance of HTTP CGI interface object.
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->{-in_handle} = *main::STDIN;
37	$self;
38	} # new
39
40	=item I<$value> = I<$cgi>->get_meta_variable (I<$name>)
41
42	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
52	This method might return C<undef> when the meta-variable
53	is not defined or is defined but its value is C<undef>.
54
55	=cut
56
57	sub get_meta_variable ($$) {
58	return $main::ENV{ $_[1] };
59	} # get_meta_variable
60
61	=item I<$list> = I<$cgi>->meta_variable_names;
62
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	This method returns a C<Message::DOM::DOMStringList>.
75
76	=cut
77
78	sub meta_variable_names ($) {
79	require Message::DOM::DOMStringList;
80	bless [keys %main::ENV], 'Message::DOM::DOMStringList::StaticList';
81	} # meta_variable_names
82
83	=item I<$value> = C<$cgi>->get_parameter ($name);
84
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	=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
109	Returnes a list of parameter names provided.
110
111	This method returns a C<Message::DOM::DOMStringList>.
112
113	=cut
114
115	sub parameter_names ($) {
116	my $self = shift;
117	$self->__get_parameter unless $self->{param};
118
119	require Message::DOM::DOMStringList;
120	return bless [keys %{$self->{param}}],
121	'Message::DOM::DOMStringList::StaticList';
122	} # parameter_names
123
124	sub __get_parameter ($) {
125	my $self = shift;
126	my @src;
127
128	## Query-string of Request-URI
129	my $qs = $self->get_meta_variable ('QUERY_STRING');
130	push @src, $qs if (index ($qs, '=') > -1);
131
132	## Entity-body
133	if ($self->get_meta_variable ('REQUEST_METHOD') eq 'POST') {
134	my $mt = $self->get_meta_variable ('CONTENT_TYPE');
135	if ($mt =~ m<^application/(?:x-www\|sgml)-form-urlencoded\b>) {
136	push @src, $self->entity_body;
137	}
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	} # __get_parameter
163
164	=item I<$body> = I<$cgi>->entity_body;
165
166	Returns entity-body content if any.
167
168	=cut
169
170	sub entity_body ($) {
171	my $self = shift;
172	$self->__get_entity_body unless defined $self->{body};
173
174	return $self->{body};
175	} # entity_body
176
177	sub __get_entity_body ($) {
178	my $self = shift;
179	binmode $self->{-in_handle};
180	read $self->{-in_handle}, $self->{body},
181	$self->get_meta_variable ('CONTENT_LENGTH');
182	} # __get_entity_body
183	## TODO: Entity too large
184
185	=item I<$uri> = I<$cgi>->request_uri;
186
187	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
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	require Message::URI::URIReference;
199	my $uri = $opt{no_path_info} ? undef
200	: $self->get_meta_variable ('REQUEST_URI'); # non-standard
201	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	return Message::DOM::DOMImplementation->create_uri_reference ($uri);
206	}
207	} else { ## REQUEST_URI is not provided
208	my $pi = $opt{no_path_info} ? q<>
209	: $self->get_meta_variable ('PATH_INFO');
210	$uri = $self->__uri_encode ($self->get_meta_variable ('SCRIPT_NAME').$pi,
211	qr([^0-9A-Za-z_.!~*'();/:\@&=\$,-]));
212	my $qs = $self->get_meta_variable ('QUERY_STRING');
213	$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	my $port = ':' . $self->get_meta_variable ('SERVER_PORT');
220	## TODO: HTTPS=off
221	if ( $self->get_meta_variable ('HTTPS')
222	\|\| $self->get_meta_variable ('CERT_SUBJECT')
223	\|\| $self->get_meta_variable ('SSL_VERSION')) {
224	$scheme = 'https';
225	$port = '' if $port eq ':443';
226	} else {
227	$port = '' if $port eq ':80';
228	}
229
230	my $host_and_port = $self->get_meta_variable ('HTTP_HOST');
231	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	. $self->__uri_encode ($self->get_meta_variable ('SERVER_NAME'),
238	qr/[^0-9A-Za-z.-]/)
239	. $port . $uri;
240	}
241	return Message::DOM::DOMImplementation->create_uri_reference ($uri);
242	} # request_uri
243
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	return $s;
251	} # __uri_encode
252
253	package Message::IF::CGIRequest;
254
255	=back
256
257	=head1 TODO
258
259	=over 4
260
261	=item multipart/form-data support
262
263	=back
264
265	=head1 SEE ALSO
266
267	A draft specification for DOM CGI Module
268	<http://suika.fam.cx/gate/2005/sw/manakai/%E3%83%A1%E3%83%A2/2005-07-04>
269	(This module does not implement the interface defined in this
270	specification, however.)
271
272	=head1 AUTHOR
273
274	Wakaba <w@suika.fam.cx>
275
276	This module was originally developed as part of SuikaWiki.
277
278	=head1 LICENSE
279
280	Copyright 2003, 2007 Wakaba <w@suika.fam.cx>
281
282	This program is free software; you can redistribute it and/or
283	modify it under the same terms as Perl itself.
284
285	=cut
286
287	1;
288	# $Date: 2007/08/11 13:37:09 $