Apache::ParseFormData - Perl extension for dealing with client request data

Apache-ParseFormData documentation Contained in the Apache-ParseFormData distribution.

Index

Code Index:

NAME

Top

Apache::ParseFormData - Perl extension for dealing with client request data

SYNOPSIS

Top

  use Apache::RequestRec ();
  use Apache::RequestUtil ();
  use Apache::Const -compile => qw(DECLINED OK);
  use Apache::ParseFormData;

  sub handler {
    my $r = shift;
    my $apr = Apache::ParseFormData->new($r);

    my $scalar = 'abc';
    $apr->param('scalar_test' => $scalar);
    my $s_test = $apr->param('scalar_test');
    print $s_test;

    my @array = ('a', 'b', 'c');
    $apr->param('array_test' => \@array);
    my @a_test = $apr->param('array_test');
    print $a_test[0];

    my %hash = (
      a => 1,
      b => 2,
      c => 3,
    );
    $apr->param('hash_test' => \%hash);
    my %h_test = $apr->param('hash_test');
    print $h_test{'a'};

    $apr->notes->clear();

    return Apache::OK;
  }

ABSTRACT

Top

The Apache::ParseFormData module allows you to easily decode and parse form and query data, even multipart forms generated by "file upload". This module only work with mod_perl 2.

DESCRIPTION

Top

Apache::ParseFormData extension parses a GET and POST requests, with multipart form data input stream, and saves any files/parameters encountered for subsequent use.

Apache::ParseFormData METHODS

Top

new

Create a new Apache::ParseFormData object. The methods from Apache class are inherited. The optional arguments which can be passed to the method are the following:

temp_dir

Directory where the upload files are stored.

disable_uploads

Disable file uploads.

  my $apr = Apache::ParseFormData->new($r, disable_uploads => 1);

  my $status = $apr->parse_result;
  unless($status == Apache::OK) {
    my $error = $apr->notes->get("error-notes");
    ...
    return $status;
  }
post_max

Limit the size of POST data.

  my $apr = Apache::ParseFormData->new($r, post_max => 1024);

  my $status = $apr->parse_result;
  unless($status == Apache::OK) {
    my $error = $apr->notes->get("error-notes");
    ...
    return $status;
  }

parse_result

return the status code after the request is parsed.

param

Like CGI.pm you can add or modify the value of parameters within your script.

  my $scalar = 'abc';
  $apr->param('scalar_test' => $scalar);
  my $s_test = $apr->param('scalar_test');
  print $s_test;

  my @array = ('a', 'b', 'c');
  $apr->param('array_test' => \@array);
  my @a_test = $apr->param('array_test');
  print $a_test[0];

  my %hash = (
    a => 1,
    b => 2,
    c => 3,
  );
  $apr->param('hash_test' => \%hash);
  my %h_test = $apr->param('hash_test');
  print $h_test{'a'};

You can create a parameter with multiple values by passing additional arguments:

  $apr->param(
    'color'    => "red",
    'numbers'  => [0,1,2,3,4,5,6,7,8,9],
    'language' => "perl",
  );

Fetching the names of all the parameters passed to your script:

  foreach my $name (@names) {
    my $value = $apr->param($name);
    print "$name => $value\n";
  }

delete

To delete a parameter provide the name of the parameter:

  $apr->delete("color");

You can delete multiple values:

  $apr->delete("color", "nembers");

delete_all

This method clear all of the parameters

upload

You can access the name of an uploaded file with the param method, just like the value of any other form element.

  my %file_hash = $apr->param('file');
  my $filename = $file_hash{'filename'};
  my $content_type = $file_hash{'type'};
  my $size = $file_hash{'size'};

  my ($fh, $path) = $apr->upload('file_0');

  for my $form_name ($apr->upload()) {
    my ($fh, $path) = $apr->upload($form_name);

    while(<$fh>) {
      print $_;
    }

    my %file_hash = $apr->param($form_name);
    my $filename = $file_hash{'filename'};
    my $content_type = $file_hash{'type'};
    my $size = $file_hash{'size'};
    unlink($path);
  }

Set the cookies before send any printable data to client.

  my $apr = Apache::ParseFormData->new($r);

  $apr->set_cookie(
    name    => "foo",
    value   => "bar",
    path    => "/cgi-bin/database",
    expires => time + 3600,
    secure  => 1,
    domain  => ".capricorn.com",
  );

Get the value of foo:

  $apr->param('foo');

Clean cookie:

  $apr->set_cookie(
    name    => "foo",
    value   => "",
    expires => time - 3600,
  );

SEE ALSO

Top

libapreq, Apache::Request

CREDITS

Top

This interface is based on the libapreq by Doug MacEachern.

AUTHOR

Top

Henrique Dias, <hdias@aesbuc.pt>

COPYRIGHT AND LICENSE

Top

Copyright 2003 by Henrique Dias

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

Apache-ParseFormData documentation Contained in the Apache-ParseFormData distribution. 
#############################################################################
#
# Apache::ParseFormData
# Last Modification: Thu Oct 23 11:44:58 WEST 2003
#
# Copyright (c) 2003 Henrique Dias <hdias@aesbuc.pt>. All rights reserved.
# This module is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
##############################################################################
package Apache::ParseFormData;

use strict;
use Apache::Log;
use Apache::Const -compile => qw(OK M_POST M_GET FORBIDDEN HTTP_REQUEST_ENTITY_TOO_LARGE);
use Apache::RequestIO ();
use APR::Table;
use IO::File;
use POSIX qw(tmpnam);
require Exporter;
our @ISA = qw(Exporter Apache::RequestRec);
our %EXPORT_TAGS = ( 'all' => [ qw() ] );
our @EXPORT = qw();
our $VERSION = '0.09';
require 5;

use constant NELTS => 10;
use constant BUFFLENGTH => 1024;

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $self  = shift;
	my %args = (
		temp_dir        => "/tmp",
		disable_uploads => 0,
		post_max        => 0,
		@_,
	);
	my $table = APR::Table::make($self->pool, NELTS);
	$self->pnotes('apr_req' => $table);
	bless ($self, $class);

	if(my $data = $self->headers_in->get('cookie')) {
		&_parse_query($self, $data, " *; *");
	}
	if($self->method_number == Apache::M_POST) {
		$self->pnotes('apr_req_result' => &parse_content($self, \%args));
	} elsif($self->method_number == Apache::M_GET) {
		my $data = $self->args();
		&_parse_query($self, $data) if($data);
		$self->pnotes('apr_req_result' => Apache::OK);
	}
	return($self);
}

sub DESTROY {  
	my $self = shift;
	for my $v (values(%{$self->pnotes('upload')})) {
		my $path = $v->[1];
		unlink($path) if(-e $path);
	}
}

sub parse_result { $_[0]->pnotes('apr_req_result') }

sub parms { $_[0]->pnotes('apr_req') }

sub _parse_query {
	my $r = shift;
	my $query_string = shift;
	my $re = shift || "&";

	my %hash = ();
	for(split(/$re/, $query_string)) {
		my ($n, $v) = split(/=/);
		defined($v) or $v = "";
		&decode_chars($n);
		&decode_chars($v);
		push(@{$hash{$n}}, $v);
	}
	$r->param(%hash);
	return();
}

sub decode_chars {
	$_[0] =~ tr/+/ /;
	$_[0] =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack("C", hex($1))/egi;
}

sub set_cookie {
	my $self = shift;
	my $args = {
		name    => "",
		value   => "",
		path    => "/",
		expires => "",
		secure  => 0,
		domain  => "",
		@_,
	};
	$args->{'name'} or return();
	my @a = (
		join("=", $args->{'name'}, $args->{'value'}),
		join("=", "path", $args->{'path'}),
	);
	push(@a, join("=", "expires", &cookie_expire($args->{'expires'}))) if($args->{'expires'});
	push(@a, join("=", "secure", $args->{'secure'})) if($args->{'secure'});
	push(@a, join("=", "domain", $args->{'domain'})) if($args->{'domain'});
	$self->headers_out->{'Set-Cookie'} = join(";", @a);
	$self->param($args->{'name'} => $args->{'value'});
	return();
}

sub cookie_expire {
	my $time = shift;
	my ($sec,$min,$hour,$mday,$mon,$year,$wday) = localtime($time);
	my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
	my @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
	return sprintf("%3s, %02d-%3s-%04d %02d:%02d:%02d GMT", $weekday[$wday], $mday, $months[$mon], $year+1900, $hour, $min, $sec);
}

sub upload {
	my $self = shift;
	my $name = shift || "";
	return($name ? @{$self->pnotes('upload')->{$name}} : keys(%{$self->pnotes('upload')}));
}

sub parse_content {
	my $r = shift;
	my $args = shift;

	my $buf = "";
	$r->setup_client_block;
	$r->should_client_block or return '';
	my $ct = $r->headers_in->get('content-type');

	if($args->{'disable_uploads'} && index($ct, "multipart/form-data") > -1) {
		my $error_str = "[Apache::ParseFormData] file upload forbidden";
		$r->notes->set("error-notes" => $error_str);
		$r->log_error($error_str);
		return(Apache::FORBIDDEN);
	}
	my $rm = $r->remaining;
	if($args->{'post_max'} && ($rm > $args->{'post_max'})) {
		my $pm = $args->{'post_max'};
		my $error_str = "[Apache::ParseFormData] entity too large ($rm, max=$pm)";
		$r->notes->set("error-notes" => $error_str);
		$r->log_error($error_str);
		return(Apache::HTTP_REQUEST_ENTITY_TOO_LARGE);
	}
	if($ct =~ /^multipart\/form-data; boundary=(.+)$/) {
		my $boundary = $1;
		my $lenbdr = length("--$boundary");
		$r->get_client_block($buf, $lenbdr+2);
		$buf = substr($buf, $lenbdr);
		$buf =~ s/[\n\r]+//;
		my $iter = -1;
		my @data = ();
		&multipart_data($r, $args, \@data, $boundary, BUFFLENGTH, 1, $buf, $iter);
		my %uploads = ();
		for(@data) {
			if(exists($_->{'headers'}->{'content-disposition'})) {
				my @a = split(/ *; */, $_->{'headers'}->{'content-disposition'});
				if(shift(@a) eq "form-data") {
					if(scalar(@a) == 1) {
						my ($key) = ($a[0] =~ /name=\"([^\"]+)\"/);
						$r->param($key => $_->{'values'} || "");
					} else {
						(ref($_->{'values'}) eq "ARRAY") or next;
						my ($fh, $path) = @{$_->{'values'}};
						seek($fh, 0, 0);
						my %hash = (
							filename => "",
							type     => exists($_->{'headers'}->{'content-type'}) ? $_->{'headers'}->{'content-type'} : "",
							size     => ($fh->stat())[7],
						);
						my $param = "";
						for(@a) {
							my ($name, $value) = (/([^=]+)=\"([^\"]+)\"/);
							if($name eq "name") {
								$uploads{$value} = [$fh, $path];
								$param = $value;
							} else {
								$hash{$name} = $value;
							}
						}
						$r->param($param => \%hash);
					}
				}
			}
		}
		$r->pnotes('upload' => \%uploads);
	} else {
		my $len = $r->headers_in->get('content-length');
		$r->get_client_block($buf, $len);
		&_parse_query($r, $buf) if($buf);
	}
	return(Apache::OK);
}

sub extract_headers {
	my $raw = shift;
	my %hash = ();
	for(split(/\r?\n/, $raw)) {
		s/[\r\n]+$//;
		$_ or next;
		my ($h, $v) = split(/ *: */, $_, 2);
		$hash{lc($h)} = $v;
	}
	$_[0] = \%hash;
	return(exists($hash{'content-type'}));
}

sub output_data {
	my $dest = shift;
	my $data = shift;

	if(ref($dest->{values}) eq "ARRAY") {
		my $fh = $dest->{values}->[0];
		print $fh $data;
	} else { $dest->{values} .= $data; }
}

sub new_tmp_file {
	my $temp_dir = shift;
	my $data = shift;

	my $path = "";
	my $fh;
	my $i = 0;
	do {
		$i < 3 or last;
		my $name = tmpnam(); 
		$name = (split("/", $name))[-1];
		$path = join("/", $temp_dir, $name);
		$i++;
	} until($fh = IO::File->new($path, O_RDWR|O_CREAT|O_EXCL));
	defined($fh) or return("Couldn't create temporary file: $path");
	binmode($fh);
	$fh->autoflush(1);
	$data->{values} = [$fh, $path];
	return();
}

sub multipart_data {
	my $r = shift;
	my $args = shift;
	my $data = shift;
	my $boundary = shift;
	my $len = shift;
	my $h = shift;
	my $buff = shift;

	my ($part, $content) = ($buff, "");
	while($r->get_client_block($buff, $len)) {
		$part .= $buff;
		if($h) {
			if($part =~ /\r?\n\r?\n/) {
				my ($left, $right) = ($`, $');
				$left =~ s/[\r\n]+$//;
				$_[0]++;
				push(@{$data}, {values => "", headers => {}});
				if(&extract_headers($left, $data->[$_[0]]->{'headers'})) {
					if(my $error = &new_tmp_file($args->{'temp_dir'}, $data->[$_[0]])) { $r->log->warn($error), next; }
				}
				$part = $content = $right;
				$h = 0;
			} else { next; }
		}
		if($part =~ /\r?\n--$boundary\r?\n/) {
			my ($left, $right) = ($`, $');
			&output_data($data->[$_[0]], $left) if($left);
			&multipart_data($r, $args, $data, $boundary, $len, 1, $right, $_[0]);
			$part = "";
		}
		if($part) {
			$content = substr($part, 0, int($len/2));
			&output_data($data->[$_[0]], $content) if($content);
			$part = substr($part, int($len/2));
		}
	}
	if($h && $part =~ /\r?\n\r?\n/) {
		my ($left, $right) = ($`, $');
		$left =~ s/[\r\n]+$//;
		$_[0]++;
		push(@{$data}, {values => "", headers => {}});
		if(&extract_headers($left, $data->[$_[0]]->{'headers'})) {
			if(my $error = &new_tmp_file($args->{'temp_dir'}, $data->[$_[0]])) { $r->log->warn($error), next; }
		}
		$part = $right;
		$h = 0;
	}
	if($part =~ /\r?\n--$boundary\r?\n/) {
		my ($left, $right) = ($`, $');
		&output_data($data->[$_[0]], $left) if($left);
		&multipart_data($r, $args, $data, $boundary, $len, 1, $right, $_[0]);
		$part = "";
	}
	if($part =~ /\r?\n--$boundary--[\r\n]*/) {
		my $left = $`;
		&output_data($data->[$_[0]], $left) if($left);
	}
	return();
}

sub delete {
	my $self = shift;
	map { $self->parms->unset($_); } @_;
	return();
}

sub delete_all {
	my $self = shift;
	$self->parms->clear();
	return();
}

sub param {
	my $self = shift;

	if(scalar(@_) > 1) {
		my %hash = @_;
		while(my ($k, $v) = each(%hash)) {
			my @transfer = (ref($v) eq "HASH") ? %{$v} : (ref($v) eq "ARRAY") ? @{$v} : ($v);
			my $first = shift(@transfer) || "";
			$self->parms->set($k => $first);
			map { $self->parms->add($k, $_); } @transfer;
		}
		return();
	}
	if(scalar(@_) == 1) {
		my $k = shift;
		return($self->parms->get($k));
	}
	return(keys(%{$self->parms}));
}

1;
__END__