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.1 $=~/\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;
}

=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;
    }
  }
  
  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 STDIN;
  read STDIN, $self->{body}, $main::ENV{CONTENT_LENGTH};
}

=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 = shift;
  require URI;
  my $uri = $self->meta_variable ('REQUEST_URI'); # non-standard
  if ($uri) {
    ## REQUEST_URI is an absolute URI
    if ($uri =~ /^[0-9A-Za-z.%+-]+:/) {
      return URI->new ($uri);
    }
  } else {  ## REQUEST_URI is not provided
    $uri = $self->__uri_encode ($self->meta_variable ('SCRIPT_NAME')
                               .$self->meta_variable ('PATH_INFO'),
                                qr([^0-9A-Za-z_.!~*'();/:\@&=\$,-]))
         . '?' . $self->meta_variable ('QUERY_STRING');
    substr ($uri, -1) = '' if substr ($uri, -1) eq '?';
  }
  
  ## REQUEST_URI is a relative URI or
  ## REQUEST_URI is not provided
  my $scheme = 'http';
  my $port = ':' . $self->meta_variable ('SERVER_PORT');
  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';
  }
  $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;
}

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