1#############################################################################
2#
3# Apache::ParseFormData
4# Last Modification: Thu Oct 23 11:44:58 WEST 2003
5#
6# Copyright (c) 2003 Henrique Dias <hdias@aesbuc.pt>. All rights reserved.
7# This module is free software; you can redistribute it and/or modify
8# it under the same terms as Perl itself.
9#
10##############################################################################
11package Apache::ParseFormData;
12
13use strict;
14use Apache2::Log;
15use Apache2::Const -compile => qw(OK M_POST M_GET FORBIDDEN HTTP_REQUEST_ENTITY_TOO_LARGE);
16use Apache2::RequestIO ();
17use APR::Table;
18use IO::File;
19use POSIX qw(tmpnam);
20require Exporter;
21our @ISA = qw(Exporter Apache::RequestRec);
22our %EXPORT_TAGS = ( 'all' => [ qw() ] );
23our @EXPORT = qw();
24our $VERSION = '0.09';
25require 5;
26
27use constant NELTS => 10;
28use constant BUFFLENGTH => 1024;
29
30sub new {
31	my $proto = shift;
32	my $class = ref($proto) || $proto;
33	my $self  = shift;
34	my %args = (
35		temp_dir        => "/tmp",
36		disable_uploads => 0,
37		post_max        => 0,
38		@_,
39	);
40	my $table = APR::Table::make($self->pool, NELTS);
41	$self->pnotes('apr_req' => $table);
42	bless ($self, $class);
43
44	if(my $data = $self->headers_in->get('cookie')) {
45		&_parse_query($self, $data, " *; *");
46	}
47	if($self->method_number == Apache2::Const::M_POST) {
48		$self->pnotes('apr_req_result' => &parse_content($self, \%args));
49	} elsif($self->method_number == Apache2::Const::M_GET) {
50		my $data = $self->args();
51		&_parse_query($self, $data) if($data);
52		$self->pnotes('apr_req_result' => Apache2::Const::OK);
53	}
54	return($self);
55}
56
57sub DESTROY {
58	my $self = shift;
59	for my $v (values(%{$self->pnotes('upload')})) {
60		my $path = $v->[1];
61		unlink($path) if(-e $path);
62	}
63}
64
65sub parse_result { $_[0]->pnotes('apr_req_result') }
66
67sub parms { $_[0]->pnotes('apr_req') }
68
69sub _parse_query {
70	my $r = shift;
71	my $query_string = shift;
72	my $re = shift || "&";
73
74	my %hash = ();
75	for(split(/$re/, $query_string)) {
76		my ($n, $v) = split(/=/);
77		defined($v) or $v = "";
78		&decode_chars($n);
79		&decode_chars($v);
80		push(@{$hash{$n}}, $v);
81	}
82	$r->param(%hash);
83	return();
84}
85
86sub decode_chars {
87	$_[0] =~ tr/+/ /;
88	$_[0] =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack("C", hex($1))/egi;
89}
90
91sub set_cookie {
92	my $self = shift;
93	my $args = {
94		name    => "",
95		value   => "",
96		path    => "/",
97		expires => "",
98		secure  => 0,
99		domain  => "",
100		@_,
101	};
102	$args->{'name'} or return();
103	my @a = (
104		join("=", $args->{'name'}, $args->{'value'}),
105		join("=", "path", $args->{'path'}),
106	);
107	push(@a, join("=", "expires", &cookie_expire($args->{'expires'}))) if($args->{'expires'});
108	push(@a, join("=", "secure", $args->{'secure'})) if($args->{'secure'});
109	push(@a, join("=", "domain", $args->{'domain'})) if($args->{'domain'});
110	$self->headers_out->{'Set-Cookie'} = join(";", @a);
111	$self->param($args->{'name'} => $args->{'value'});
112	return();
113}
114
115sub cookie_expire {
116	my $time = shift;
117	my ($sec,$min,$hour,$mday,$mon,$year,$wday) = localtime($time);
118	my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
119	my @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
120	return sprintf("%3s, %02d-%3s-%04d %02d:%02d:%02d GMT", $weekday[$wday], $mday, $months[$mon], $year+1900, $hour, $min, $sec);
121}
122
123sub upload {
124	my $self = shift;
125	my $name = shift || "";
126	return($name ? @{$self->pnotes('upload')->{$name}} : keys(%{$self->pnotes('upload')}));
127}
128
129sub parse_content {
130	my $r = shift;
131	my $args = shift;
132
133	my $buf = "";
134	$r->setup_client_block;
135	$r->should_client_block or return '';
136	my $ct = $r->headers_in->get('content-type');
137
138	if($args->{'disable_uploads'} && index($ct, "multipart/form-data") > -1) {
139		my $error_str = "[Apache::ParseFormData] file upload forbidden";
140		$r->notes->set("error-notes" => $error_str);
141		$r->log_error($error_str);
142		return(Apache2::Const::FORBIDDEN);
143	}
144	my $rm = $r->remaining;
145	if($args->{'post_max'} && ($rm > $args->{'post_max'})) {
146		my $pm = $args->{'post_max'};
147		my $error_str = "[Apache::ParseFormData] entity too large ($rm, max=$pm)";
148		$r->notes->set("error-notes" => $error_str);
149		$r->log_error($error_str);
150		return(Apache2::Const::HTTP_REQUEST_ENTITY_TOO_LARGE);
151	}
152	if($ct =~ /^multipart\/form-data; boundary=(.+)$/) {
153		my $boundary = $1;
154		my $lenbdr = length("--$boundary");
155		$r->get_client_block($buf, $lenbdr+2);
156		$buf = substr($buf, $lenbdr);
157		$buf =~ s/[\n\r]+//;
158		my $iter = -1;
159		my @data = ();
160		&multipart_data($r, $args, \@data, $boundary, BUFFLENGTH, 1, $buf, $iter);
161		my %uploads = ();
162		for(@data) {
163			if(exists($_->{'headers'}->{'content-disposition'})) {
164				my @a = split(/ *; */, $_->{'headers'}->{'content-disposition'});
165				if(shift(@a) eq "form-data") {
166					if(scalar(@a) == 1) {
167						my ($key) = ($a[0] =~ /name=\"([^\"]+)\"/);
168						$r->param($key => $_->{'values'} || "");
169					} else {
170						(ref($_->{'values'}) eq "ARRAY") or next;
171						my ($fh, $path) = @{$_->{'values'}};
172						seek($fh, 0, 0);
173						my %hash = (
174							filename => "",
175							type     => exists($_->{'headers'}->{'content-type'}) ? $_->{'headers'}->{'content-type'} : "",
176							size     => ($fh->stat())[7],
177						);
178						my $param = "";
179						for(@a) {
180							my ($name, $value) = (/([^=]+)=\"([^\"]+)\"/);
181							if($name eq "name") {
182								$uploads{$value} = [$fh, $path];
183								$param = $value;
184							} else {
185								$hash{$name} = $value;
186							}
187						}
188						$r->param($param => \%hash);
189					}
190				}
191			}
192		}
193		$r->pnotes('upload' => \%uploads);
194	} else {
195		my $len = $r->headers_in->get('content-length');
196		$r->get_client_block($buf, $len);
197		&_parse_query($r, $buf) if($buf);
198	}
199	return(Apache2::Const::OK);
200}
201
202sub extract_headers {
203	my $raw = shift;
204	my %hash = ();
205	for(split(/\r?\n/, $raw)) {
206		s/[\r\n]+$//;
207		$_ or next;
208		my ($h, $v) = split(/ *: */, $_, 2);
209		$hash{lc($h)} = $v;
210	}
211	$_[0] = \%hash;
212	return(exists($hash{'content-type'}));
213}
214
215sub output_data {
216	my $dest = shift;
217	my $data = shift;
218
219	if(ref($dest->{values}) eq "ARRAY") {
220		my $fh = $dest->{values}->[0];
221		print $fh $data;
222	} else { $dest->{values} .= $data; }
223}
224
225sub new_tmp_file {
226	my $temp_dir = shift;
227	my $data = shift;
228
229	my $path = "";
230	my $fh;
231	my $i = 0;
232	do {
233		$i < 3 or last;
234		my $name = tmpnam();
235		$name = (split("/", $name))[-1];
236		$path = join("/", $temp_dir, $name);
237		$i++;
238	} until($fh = IO::File->new($path, O_RDWR|O_CREAT|O_EXCL));
239	defined($fh) or return("Couldn't create temporary file: $path");
240	binmode($fh);
241	$fh->autoflush(1);
242	$data->{values} = [$fh, $path];
243	return();
244}
245
246sub multipart_data {
247	my $r = shift;
248	my $args = shift;
249	my $data = shift;
250	my $boundary = shift;
251	my $len = shift;
252	my $h = shift;
253	my $buff = shift;
254
255	my ($part, $content) = ($buff, "");
256	while($r->get_client_block($buff, $len)) {
257		$part .= $buff;
258		if($h) {
259			if($part =~ /\r?\n\r?\n/) {
260				my ($left, $right) = ($`, $');
261				$left =~ s/[\r\n]+$//;
262				$_[0]++;
263				push(@{$data}, {values => "", headers => {}});
264				if(&extract_headers($left, $data->[$_[0]]->{'headers'})) {
265					if(my $error = &new_tmp_file($args->{'temp_dir'}, $data->[$_[0]])) { $r->log->warn($error), next; }
266				}
267				$part = $content = $right;
268				$h = 0;
269			} else { next; }
270		}
271		if($part =~ /\r?\n--$boundary\r?\n/) {
272			my ($left, $right) = ($`, $');
273			&output_data($data->[$_[0]], $left) if($left);
274			&multipart_data($r, $args, $data, $boundary, $len, 1, $right, $_[0]);
275			$part = "";
276		}
277		if($part) {
278			$content = substr($part, 0, int($len/2));
279			&output_data($data->[$_[0]], $content) if($content);
280			$part = substr($part, int($len/2));
281		}
282	}
283	if($h && $part =~ /\r?\n\r?\n/) {
284		my ($left, $right) = ($`, $');
285		$left =~ s/[\r\n]+$//;
286		$_[0]++;
287		push(@{$data}, {values => "", headers => {}});
288		if(&extract_headers($left, $data->[$_[0]]->{'headers'})) {
289			if(my $error = &new_tmp_file($args->{'temp_dir'}, $data->[$_[0]])) { $r->log->warn($error), next; }
290		}
291		$part = $right;
292		$h = 0;
293	}
294	if($part =~ /\r?\n--$boundary\r?\n/) {
295		my ($left, $right) = ($`, $');
296		&output_data($data->[$_[0]], $left) if($left);
297		&multipart_data($r, $args, $data, $boundary, $len, 1, $right, $_[0]);
298		$part = "";
299	}
300	if($part =~ /\r?\n--$boundary--[\r\n]*/) {
301		my $left = $`;
302		&output_data($data->[$_[0]], $left) if($left);
303	}
304	return();
305}
306
307sub delete {
308	my $self = shift;
309	map { $self->parms->unset($_); } @_;
310	return();
311}
312
313sub delete_all {
314	my $self = shift;
315	$self->parms->clear();
316	return();
317}
318
319sub param {
320	my $self = shift;
321
322	if(scalar(@_) > 1) {
323		my %hash = @_;
324		while(my ($k, $v) = each(%hash)) {
325			my @transfer = (ref($v) eq "HASH") ? %{$v} : (ref($v) eq "ARRAY") ? @{$v} : ($v);
326			my $first = shift(@transfer) || "";
327			$self->parms->set($k => $first);
328			map { $self->parms->add($k, $_); } @transfer;
329		}
330		return();
331	}
332	if(scalar(@_) == 1) {
333		my $k = shift;
334		return($self->parms->get($k));
335	}
336	return(keys(%{$self->parms}));
337}
338
3391;
340__END__
341
342=head1 NAME
343
344Apache::ParseFormData - Perl extension for dealing with client request data
345
346=head1 SYNOPSIS
347
348  use Apache::RequestRec ();
349  use Apache::RequestUtil ();
350  use Apache::Const -compile => qw(DECLINED OK);
351  use Apache::ParseFormData;
352
353  sub handler {
354    my $r = shift;
355    my $apr = Apache::ParseFormData->new($r);
356
357    my $scalar = 'abc';
358    $apr->param('scalar_test' => $scalar);
359    my $s_test = $apr->param('scalar_test');
360    print $s_test;
361
362    my @array = ('a', 'b', 'c');
363    $apr->param('array_test' => \@array);
364    my @a_test = $apr->param('array_test');
365    print $a_test[0];
366
367    my %hash = (
368      a => 1,
369      b => 2,
370      c => 3,
371    );
372    $apr->param('hash_test' => \%hash);
373    my %h_test = $apr->param('hash_test');
374    print $h_test{'a'};
375
376    $apr->notes->clear();
377
378    return Apache::OK;
379  }
380
381=head1 ABSTRACT
382
383The Apache::ParseFormData module allows you to easily decode and parse
384form and query data, even multipart forms generated by "file upload".
385This module only work with mod_perl 2.
386
387=head1 DESCRIPTION
388
389C<Apache::ParseFormData> extension parses a GET and POST requests, with
390multipart form data input stream, and saves any files/parameters
391encountered for subsequent use.
392
393=head1 Apache::ParseFormData METHODS
394
395
396=head2 new
397
398Create a new I<Apache::ParseFormData> object. The methods from I<Apache>
399class are inherited. The optional arguments which can be passed to the
400method are the following:
401
402=over 3
403
404=item temp_dir
405
406Directory where the upload files are stored.
407
408=item disable_uploads
409
410Disable file uploads.
411
412  my $apr = Apache::ParseFormData->new($r, disable_uploads => 1);
413
414  my $status = $apr->parse_result;
415  unless($status == Apache::OK) {
416    my $error = $apr->notes->get("error-notes");
417    ...
418    return $status;
419  }
420
421=item post_max
422
423Limit the size of POST data.
424
425  my $apr = Apache::ParseFormData->new($r, post_max => 1024);
426
427  my $status = $apr->parse_result;
428  unless($status == Apache::OK) {
429    my $error = $apr->notes->get("error-notes");
430    ...
431    return $status;
432  }
433
434=back
435
436=head2 parse_result
437
438return the status code after the request is parsed.
439
440=head2 param
441
442Like I<CGI.pm> you can add or modify the value of parameters within your
443script.
444
445  my $scalar = 'abc';
446  $apr->param('scalar_test' => $scalar);
447  my $s_test = $apr->param('scalar_test');
448  print $s_test;
449
450  my @array = ('a', 'b', 'c');
451  $apr->param('array_test' => \@array);
452  my @a_test = $apr->param('array_test');
453  print $a_test[0];
454
455  my %hash = (
456    a => 1,
457    b => 2,
458    c => 3,
459  );
460  $apr->param('hash_test' => \%hash);
461  my %h_test = $apr->param('hash_test');
462  print $h_test{'a'};
463
464You can create a parameter with multiple values by passing additional
465arguments:
466
467  $apr->param(
468    'color'    => "red",
469    'numbers'  => [0,1,2,3,4,5,6,7,8,9],
470    'language' => "perl",
471  );
472
473Fetching the names of all the parameters passed to your script:
474
475  foreach my $name (@names) {
476    my $value = $apr->param($name);
477    print "$name => $value\n";
478  }
479
480=head2 delete
481
482To delete a parameter provide the name of the parameter:
483
484  $apr->delete("color");
485
486You can delete multiple values:
487
488  $apr->delete("color", "nembers");
489
490=head2 delete_all
491
492This method clear all of the parameters
493
494=head2 upload
495
496You can access the name of an uploaded file with the param method, just
497like the value of any other form element.
498
499  my %file_hash = $apr->param('file');
500  my $filename = $file_hash{'filename'};
501  my $content_type = $file_hash{'type'};
502  my $size = $file_hash{'size'};
503
504  my ($fh, $path) = $apr->upload('file_0');
505
506  for my $form_name ($apr->upload()) {
507    my ($fh, $path) = $apr->upload($form_name);
508
509    while(<$fh>) {
510      print $_;
511    }
512
513    my %file_hash = $apr->param($form_name);
514    my $filename = $file_hash{'filename'};
515    my $content_type = $file_hash{'type'};
516    my $size = $file_hash{'size'};
517    unlink($path);
518  }
519
520=head2 set_cookie
521
522Set the cookies before send any printable data to client.
523
524  my $apr = Apache::ParseFormData->new($r);
525
526  $apr->set_cookie(
527    name    => "foo",
528    value   => "bar",
529    path    => "/cgi-bin/database",
530    expires => time + 3600,
531    secure  => 1,
532    domain  => ".capricorn.com",
533  );
534
535Get the value of foo:
536
537  $apr->param('foo');
538
539Clean cookie:
540
541  $apr->set_cookie(
542    name    => "foo",
543    value   => "",
544    expires => time - 3600,
545  );
546
547=head1 SEE ALSO
548
549libapreq, Apache::Request
550
551=head1 CREDITS
552
553This interface is based on the libapreq by Doug MacEachern.
554
555=head1 AUTHOR
556
557Henrique Dias, E<lt>hdias@aesbuc.ptE<gt>
558
559=head1 COPYRIGHT AND LICENSE
560
561Copyright 2003 by Henrique Dias
562
563This library is free software; you can redistribute it and/or modify
564it under the same terms as Perl itself.
565
566=cut
567