SuikaWiki/Input/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.4 $=~/\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 $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: 2003/12/26 06:45:50 $
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.4 $=~/\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 $value = $http->parameter ($name)
53
54	Returns parameter value if any.
55	Parameter value is set by query-string of Request-URI
56	and/or entity-body value.
57
58	When multiple values with same parameter name is specified,
59	the first one is returned in scalar context or
60	an array reference of all values is returned in array context.
61	(Note that query-string is "earlier" than entity-body.)
62
63	=item @keys = $http->parameter_names
64
65	Returnes a list of parameter names provided.
66
67	=cut
68
69	sub parameter ($$) {
70	my ($self, $name) = @_;
71	$self->__get_parameter unless $self->{param};
72	wantarray ? ( $self->{param}->{$name}\|\|[] ) :
73	${$self->{param}->{$name}\|\|[]}[0];
74	}
75
76	sub parameter_names ($) {
77	my $self = shift;
78	$self->__get_parameter unless $self->{param};
79	return keys %{$self->{param}};
80	}
81
82	sub __get_parameter ($) {
83	my $self = shift;
84	my @src;
85
86	## Query-string of Request-URI
87	my $qs = $self->meta_variable ('QUERY_STRING');
88	push @src, $qs if (index ($qs, '=') > -1);
89
90	## Entity-body
91	if ($self->meta_variable ('REQUEST_METHOD') eq 'POST') {
92	my $mt = $self->meta_variable ('CONTENT_TYPE');
93	if ($mt =~ m<^application/(?:x-www\|sgml)-form-urlencoded\b>) {
94	push @src, $self->body_text;
95	}
96	## TODO: support non-standard "charset" parameter
97	}
98
99	my %temp_params;
100	for my $src (@src) {
101	for (split /[;&]/, $src) {
102	my ($name, $val) = split '=', $_, 2;
103	for ($name, $val) {
104	tr/+/ /;
105	s/%([0-9A-Fa-f][0-9A-Fa-f])/pack 'C', hex $1/ge;
106	}
107	$temp_params{$name} \|\|= [];
108	push @{$temp_params{$name}}, $val;
109	}
110	}
111	for (keys %temp_params) {
112	my $name = &{$self->{decoder}->{'#name'}
113	\|\|$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);
114	for (@{$temp_params{$name}}) {
115	push @{$self->{param}->{$name}},
116	&{$self->{decoder}->{$name}
117	\|\|$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);
118	}
119	}
120	}
121
122	=item $body = $http->body
123
124	Returns entity-body content if any.
125
126	It is expected that in future version of this module,
127	this method returns an object instantiated with body content
128	rather than body text itself.
129
130	=item $body = $http->body_text
131
132	Returnes entity-body context as a string.
133
134	=cut
135
136	sub body ($) {
137	my $self = shift;
138	$self->__get_entity_body unless defined $self->{body};
139	$self->{body};
140	}
141
142	sub body_text ($) {
143	$_[0]->body;
144	}
145
146	sub __get_entity_body ($) {
147	my $self = shift;
148	binmode $self->{-in_handle};
149	read $self->{-in_handle}, $self->{body},
150	$self->meta_variable ('CONTENT_LENGTH');
151	}
152	## TODO: Entity too large
153
154	=item $uri = $http->request_uri
155
156	Returns Request-URI as a URI object.
157
158	Note that stringified value of returned value might not be same as the
159	URI specified as the Request-URI of HTTP request or (possibly pseudo-)
160	URI entered by the user, since no standarized way to get it is
161	defined by HTTP and CGI/1.1 specifications.
162
163	=cut
164
165	sub request_uri ($;%) {
166	my ($self, %opt) = @_;
167	require URI;
168	my $uri = $opt{no_path_info} ? undef
169	: $self->meta_variable ('REQUEST_URI'); # non-standard
170	if ($uri) {
171	$uri =~ s/\#[^#]*$//; ## Fragment identifier not allowed here
172	$uri =~ s/\?[^?]*$// if $opt{no_query};
173	if ($uri =~ /^[0-9A-Za-z.%+-]+:/) { ## REQUEST_URI is an absolute URI
174	return URI->new ($uri);
175	}
176	} else { ## REQUEST_URI is not provided
177	my $pi = $opt{no_path_info} ? q<>
178	: $self->meta_variable ('PATH_INFO');
179	$uri = $self->__uri_encode ($self->meta_variable ('SCRIPT_NAME').$pi,
180	qr([^0-9A-Za-z_.!~*'();/:\@&=\$,-]));
181	my $qs = $self->meta_variable ('QUERY_STRING');
182	$uri .= '?' . $qs if not $opt{no_query} and defined $qs;
183	}
184
185	## REQUEST_URI is a relative URI or
186	## REQUEST_URI is not provided
187	my $scheme = 'http';
188	my $port = ':' . $self->meta_variable ('SERVER_PORT');
189	## TODO: HTTPS=off
190	if ( $self->meta_variable ('HTTPS')
191	\|\| $self->meta_variable ('CERT_SUBJECT')
192	\|\| $self->meta_variable ('SSL_VERSION')) {
193	$scheme = 'https';
194	$port = '' if $port eq ':443';
195	} else {
196	$port = '' if $port eq ':80';
197	}
198
199	my $host_and_port = $self->meta_variable ('HTTP_HOST');
200	if ($host_and_port) {
201	$uri = $scheme . '://'
202	. $self->__uri_encode ($host_and_port, qr/[^0-9A-Za-z.:-]/)
203	. $uri; ## ISSUE: Should we allow "[" / "]" for IPv6 here?
204	} else {
205	$uri = $scheme . '://'
206	. $self->__uri_encode ($self->meta_variable ('SERVER_NAME'),
207	qr/[^0-9A-Za-z.-]/)
208	. $port . $uri;
209	}
210	return URI->new ($uri);
211	}
212
213
214	sub __uri_encode ($$;$) {
215	my ($self, $s, $char) = @_;
216	$char \|\|= qr([^0-9A-Za-z_.!~*'();/?:\@&=+\$,-]);
217	require Encode;
218	$s = Encode::decode ('utf8', $s);
219	$s =~ s/($char)/sprintf '%%%02X', ord $1/ge;
220	$s;
221	}
222
223	=item $http->exit
224
225	Declares that user no longer thinks the instance ($http) is interesting.
226	Usually, this method is automatically called.
227
228	=cut
229
230	sub exit ($) {
231	my $self = shift;
232	delete $self->{wiki};
233	$self->{exited} = 1;
234	1;
235	}
236
237	sub DESTORY ($) {
238	my $self = shift;
239	$self->exit unless $self->{exited};
240	}
241
242	=head1 TODO
243
244	=over 4
245
246	=item Use manakai
247
248	=item multipart/form-data support
249
250	=item HTTP (non-CGI) support
251
252	=cut
253
254	=head1 LICENSE
255
256	Copyright 2003 Wakaba <w@suika.fam.cx>
257
258	This program is free software; you can redistribute it and/or
259	modify it under the same terms as Perl itself.
260
261	=cut
262
263	1; # $Date: 2003/12/26 06:45:50 $