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.3 $=~/\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};
}
## 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/06 05:32:43 $
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	wakaba	1.4	our $VERSION = do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18	wakaba	1.1
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	wakaba	1.2	=item @keys = $http->parameter_names
63
64			Returnes a list of parameter names provided.
65
66	wakaba	1.1	=cut
67
68			sub parameter ($$) {
69			my ($self, $name) = @_;
70	wakaba	1.2	$self->__get_parameter unless $self->{param};
71	wakaba	1.1	wantarray ? ( $self->{param}->{$name}\|\|[] ) :
72			${$self->{param}->{$name}\|\|[]}[0];
73			}
74
75	wakaba	1.2	sub parameter_names ($) {
76			my $self = shift;
77			$self->__get_parameter unless $self->{param};
78			return keys %{$self->{param}};
79			}
80
81	wakaba	1.1	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	wakaba	1.2	push @src, $qs if (index ($qs, '=') > -1);
88	wakaba	1.1
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	wakaba	1.2	my %temp_params;
98	wakaba	1.1	for my $src (@src) {
99			for (split /[;&]/, $src) {
100			my ($name, $val) = split '=', $_, 2;
101	wakaba	1.2	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	wakaba	1.1	push @{$self->{param}->{$name}},
114			&{$self->{decoder}->{$name}
115	wakaba	1.2	\|\|$self->{decoder}->{'#default'}} ($self, $_, \%temp_params);
116	wakaba	1.1	}
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	wakaba	1.4	## TODO: Entity too large
150	wakaba	1.1
151	wakaba	1.2	=item $uri = $http->request_uri
152
153			Returns Request-URI as a URI object.
154
155			Note that stringified value of returned value might not be same as the
156			URI specified as the Request-URI of HTTP request or (possibly pseudo-)
157			URI entered by the user, since no standarized way to get it is
158			defined by HTTP and CGI/1.1 specifications.
159
160			=cut
161
162	wakaba	1.4	sub request_uri ($;%) {
163			my ($self, %opt) = @_;
164	wakaba	1.2	require URI;
165	wakaba	1.4	my $uri = $opt{no_path_info} ? undef
166			: $self->meta_variable ('REQUEST_URI'); # non-standard
167	wakaba	1.2	if ($uri) {
168	wakaba	1.4	$uri =~ s/\#[^#]*$//; ## Fragment identifier not allowed here
169			$uri =~ s/\?[^?]*$// if $opt{no_query};
170			if ($uri =~ /^[0-9A-Za-z.%+-]+:/) { ## REQUEST_URI is an absolute URI
171	wakaba	1.2	return URI->new ($uri);
172			}
173			} else { ## REQUEST_URI is not provided
174	wakaba	1.4	my $pi = $opt{no_path_info} ? q<>
175			: $self->meta_variable ('PATH_INFO');
176			$uri = $self->__uri_encode ($self->meta_variable ('SCRIPT_NAME').$pi,
177			qr([^0-9A-Za-z_.!~*'();/:\@&=\$,-]));
178			my $qs = $self->meta_variable ('QUERY_STRING');
179			$uri .= '?' . $qs if not $opt{no_query} and defined $qs;
180	wakaba	1.2	}
181
182			## REQUEST_URI is a relative URI or
183			## REQUEST_URI is not provided
184			my $scheme = 'http';
185			my $port = ':' . $self->meta_variable ('SERVER_PORT');
186	wakaba	1.4	## TODO: HTTPS=off
187	wakaba	1.2	if ( $self->meta_variable ('HTTPS')
188			\|\| $self->meta_variable ('CERT_SUBJECT')
189			\|\| $self->meta_variable ('SSL_VERSION')) {
190			$scheme = 'https';
191			$port = '' if $port eq ':443';
192			} else {
193			$port = '' if $port eq ':80';
194			}
195	wakaba	1.4
196			my $host_and_port = $self->meta_variable ('HTTP_HOST');
197			if ($host_and_port) {
198			$uri = $scheme . '://'
199			. $self->__uri_encode ($host_and_port, qr/[^0-9A-Za-z.:-]/)
200			. $uri; ## ISSUE: Should we allow "[" / "]" for IPv6 here?
201			} else {
202			$uri = $scheme . '://'
203			. $self->__uri_encode ($self->meta_variable ('SERVER_NAME'),
204			qr/[^0-9A-Za-z.-]/)
205			. $port . $uri;
206			}
207	wakaba	1.2	return URI->new ($uri);
208			}
209
210
211			sub __uri_encode ($$;$) {
212			my ($self, $s, $char) = @_;
213	wakaba	1.4	$char \|\|= qr([^0-9A-Za-z_.!~*'();/?:\@&=+\$,-]);
214	wakaba	1.2	require Encode;
215			$s = Encode::decode ('utf8', $s);
216			$s =~ s/($char)/sprintf '%%%02X', ord $1/ge;
217			$s;
218	wakaba	1.1	}
219
220	wakaba	1.3	=item $http->exit
221
222			Declares that user no longer thinks the instance ($http) is interesting.
223			Usually, this method is automatically called.
224
225			=cut
226
227			sub exit ($) {
228			my $self = shift;
229			delete $self->{wiki};
230			$self->{exited} = 1;
231			1;
232			}
233
234			sub DESTORY ($) {
235			my $self = shift;
236			$self->exit unless $self->{exited};
237			}
238
239	wakaba	1.1	=head1 TODO
240
241			=over 4
242
243			=item Use manakai
244
245			=item multipart/form-data support
246
247			=item HTTP (non-CGI) support
248
249			=cut
250
251			=head1 LICENSE
252
253			Copyright 2003 Wakaba <w@suika.fam.cx>
254
255			This program is free software; you can redistribute it and/or
256			modify it under the same terms as Perl itself.
257
258			=cut
259
260	wakaba	1.4	1; # $Date: 2003/12/06 05:32:43 $