#-------------------------------------------
# Full documentation should be available
# at the command line via perldoc.  Please
# report any errors or omissions to the
# author.  Thank you.  And have a nice day.
#-------------------------------------------
package  JF::ApacheRequest;
	@JF::ApacheRequest::ISA = qw( Apache::Request );

use strict;
use warnings;
use Apache::Request;
use Apache::Cookie;
use Apache::Util;
use Apache::Constants qw(REDIRECT);

#-------------------------------------------
# this new enforces a single request object
# no matter how many times it's called during a request
#-------------------------------------------
sub new {
    my $class = shift;
    # using instance() allows this to be called multiple times
    # during one request, and the POST data will still be there.
    return bless Apache::Request->instance( Apache->request, @_), $class;
}

#-------------------------------------------
# this param is not sensitive to scalar and list
# context - it always returns a scalar: the first
# off the list if there are multiple values.
# if you want multiple values (as an arrayref)
# then you should call multi_param() below
#-------------------------------------------
sub param {
    my $self = shift;
    if (@_ == 1) {
        return scalar($self->SUPER::param(shift));
    }
    return $self->SUPER::param(@_);
}

#-------------------------------------------
# if a value is _supposed_ to have multiple
# items, you can get them here, always as an
# arrayref (even if there is one or none).
#-------------------------------------------
sub multi_param {
    my $self = shift;
    return [$self->SUPER::param($_[0])];
}

#-------------------------------------------
# if you want the params in a hash, this is
# where you can get them.
#-------------------------------------------
sub param_hashref {
    my %in;
    my $self = shift;
    foreach my $k ($self->param) {
	$in{$k} = scalar($self->SUPER::param($k));
    }
    return \%in;
}

#-------------------------------------------
# this upload call mimics the behavior of
# the param call
#-------------------------------------------
sub upload {
    my $self = shift;
    if (@_) {
	my ($up, $fh);
	$up = $self->SUPER::upload(shift) || return undef;
	$fh = $up->fh || return undef;
	local $/;
	return scalar(<$fh>);
    } else {
	my @upload;
	foreach my $up ($self->SUPER::upload) {
	    push @upload, $up->name;
	}
	return @upload;
    }
}

#-------------------------------------------
# passthrough to retrieve the more flexible Apache::Upload object
#-------------------------------------------
sub upload_obj {
    my $class = shift;
    return $class->SUPER::upload(@_);
}

sub upload_hashref {
    my %in;
    my $self = shift;
    foreach my $k ($self->upload) {
	$in{$k} = $self->upload($k);
    }
    return \%in;
}

# a cookie function that acts like param
sub cookie {

    my ($self, $name, $value, $args) = @_;

    # I used to try to cache the cooke parse, but $self (as
    # inherited from Apache::Request) isn't a hash, and the
    # seemingly workable $r->pnotes() would complain about arguments
    if (not defined $name) {
	my $cookies = Apache::Cookie->fetch;
	return keys %{ $cookies };
    } elsif (not defined $value) {
	my $cookies = Apache::Cookie->fetch;
	return $cookies->{$name}
	    ?  $cookies->{$name}->value : undef;
    } else {

	my $domain = $args->{-domain};
        # unless a domain is provided, or it's a dotted decimal IP
        # we strip off the subdomain here so the cookie works more
        # consistently
	if (not $domain) {
	    if ($ENV{SERVER_NAME} =~ /^\d+\.\d+\.\d+\.\d+$/) {
		$domain = $ENV{SERVER_NAME};
	    } else {
		($domain) = $ENV{SERVER_NAME} =~ /(\.[^\.]+\.[^\.]+)$/;
	    }
	}

	my $c = Apache::Cookie->new(
	    $self,
	    -name    => $name,
	    -value   => $value,
	    $args->{-expires} ? (-expires => $args->{-expires}) : (),
	    -domain  => $domain,
	    -path    => ($args->{-path}||"/"),
	    $args->{-secure} ? (-secure => $args->{-secure}) : (),
	);

	$c->bake;
    }

}

sub cookie_hashref {
    my %in;
    my $self = shift;
    foreach my $k ($self->cookie) {
	$in{$k} = $self->cookie($k);
    }
    return \%in;
}

#-------------------------------------------
# do HTML escaping for a hashref, arrayref, or scalar
#-------------------------------------------
sub html_escape {

    my ($proto, $arg) = @_;

    if (ref $arg eq "HASH") {
	# make a copy so we don't clobber anything
	my $esc = {};
        foreach my $k (keys %$arg) {
	    if (defined $arg->{$k}) {
	        $esc->{$k} = Apache::Util::escape_html( $arg->{$k} );
	    } else {
		# we want "exists" to work the same before and after
	        $esc->{$k} = undef;
	    }
        }
	return $esc;
    } elsif (ref $arg eq "ARRAY") {
	# make a copy so we don't clobber anything
	my $esc = [];
        foreach my $v (@$arg) {
	    if (defined $v) {
	        push @$esc, Apache::Util::escape_html( $v );
	    } else {
		# we don't want to lose undefined elements
		push @$esc, undef;
	    }
        }
	return $esc;
    } else {
	if (not defined $arg) {
	    return undef;
	} else {
	    return Apache::Util::escape_html( $arg );
	}
    }

}

#-------------------------------------------
# do URL escaping for a hashref, arrayref, or scalar
#-------------------------------------------
sub url_encode {

    my ($proto, $arg) = @_;

    # Apache::Util::escape_uri would be much faster than the
    # perl regex, but it doesn't nail all the weird characters
    # like ?, &, =, /, etc. which is what we usually want

    if (ref $arg eq "HASH") {
	my $esc = {};
        foreach my $k (keys %$arg) {
	    $esc->{$k} = $arg->{$k};
            $esc->{$k} =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
        }
	return $esc;
    } elsif (ref $arg eq "ARRAY") {
	my $esc = [];
        foreach my $v (@$arg) {
            $v =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
	    push @$esc, $v;
        }
	return $esc;
    } else {
	$arg =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
	return $arg;
    }

}

sub url_decode {

    my ($proto, $arg) = @_;

    if (ref $arg eq "HASH") {
	my $esc = {};
        foreach my $k (keys %$arg) {
            $esc->{$k} = Apache::Util::unescape_uri_info($arg->{$k});
        }
	return $esc;
    } elsif (ref $arg eq "ARRAY") {
	my $esc = [];
        foreach my $v (@$arg) {
            push @$esc, Apache::Util::unescape_uri_info($v);
        }
	return $esc;
    } else {
        return Apache::Util::unescape_uri_info($arg);
    }

}

sub redirect {
    my ($self, $url) = @_;
    $self->status(REDIRECT); 
    $self->err_headers_out->add( Location => $url );
    $self->send_http_header;
    return REDIRECT;
}

sub this_url {
    my $r = shift;
    my $url = $r->uri;
    if ($r->query_string) {
	$url .= "?" . $r->query_string;
    }
    return $url;
}

1;

=head1 NAME

JF::ApacheRequest - a more complete Apache::Request object

=head1 SYNOPSIS

  use JF::ApacheRequest;

  my $r = JF::ApacheRequest->new;
  my $name   = $r->param("name");
  my $cookie = $r->cookie("auth");
  my $image  = $r->upload("image");

=head1 USAGE

For starters, this object inherits from Apache::Request (which
inherits from Apache), so it does everything that either request
object can do.

There are a few differences and extras.  First, the differences:

JF::ApacheRequest->new() can be called without any arguments - it will
get the Apache::Request itself.

A call to $r->param() is NOT context sensitive.  It never results in
multiple values or an empty list.  This is helpful in preventing unexpected
(and possibly insecure) behavior.  If there are multiple values, you get back
only the first.  If there were no values you get back undef.  To get an
arrayref of multiple values you must instead call $r->multi_param().  If
there were none you get back an empty arrayref.

Then we have several extra enhancements:

  # get uploads
  my @upload_names = $r->upload();
  my $upload = $r->upload("image");

These work just like their $r->param() counterparts, although you can't set
values for an upload.

  # get cookies
  my @cookie_names = $r->cookie();
  my $cookie = $r->cookie("stuff");

  # set cookies
  $r->cookie("stuff", "12345");
  $r->cookie("mostuff", "67890",
      { -expires => "+1Y", -path => "/cgi-bin/" }
  );

Works like $r->param().  You can set a cookie with just a name and
value. You can also pass in a hashref of the values you would pass to
Apache::Cookie->new(), minus the -name and -value (which are the first
and second arguments instead).  If you don't pass a hashref, the default
will be different from Apache::Cookie's default in two ways: the -path
will be set to "/" so the cookie will be returned to all URL's at your
site.  You can override this if you pass -path in the hashref.  The domain
will be stripped of it's subdomain (i.e. "www.foobar.com" and "dev.foobar.com"
both become "foobar.com")

  my $in = $r->param_hashref();
  my $up = $r->upload_hashref();
  my $ck = $r->cookie_hashref();

If you want the params, uploads, or cookies in a hashref, the above
functions is how you would get them.

  my $newstring   = JF::Request->html_escape( $string );
  my $newarrayref = JF::Request->html_escape( $arrayref );
  my $newhashref  = JF::Request->html_escape( $hashref );

  my $encoded = JF::Request->url_encode( $string );
  my $decoded = JF::Request->url_decode( $string );

These functions convert strings as expected.  They can also take arrayrefs
as an argument and will convert each element in the array, or if a hashref
is passed they will convert all the values (not the keys).

There's also $r->this_url which returns the server-relative url including
any query string arguments ... basically just a combination of $r->uri
and $r->query_string with enough smarts to leave off a trailing "?" if
there's no query string.

That's about it.

Oh yeah - one last conveniece.  A simple redirect method:

  return $r->redirect( $url );

=head1 NOTES

=head1 BUGS

=head1 DEPENDENCIES

  Apache::Request, Apache::Cookie, Apache::Util

=head1 AUTHOR

Jonathan Field - jon@binadopta.com