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