The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package EntityModel::Apache2::Apache;
BEGIN {
  $EntityModel::Apache2::Apache::VERSION = '0.001';
}
use EntityModel::Class { };

=head1 NAME

EntityModel::Web::Apache2::Apache - wrapper around Apache's request object

=head1 VERSION

version 0.001

=head1 SYNOPSIS

=head1 DESCRIPTION

=cut

use Apache2::RequestRec;
use Apache2::Request;
use Apache2::RequestUtil;
use APR::Table;
use HTTP::Date;

our @urlList;

BEGIN {
# Apache2::RequestRec wrappers
	foreach my $method (qw/uri unparsed_uri method headers_out no_cache hostname/) {
		no strict 'refs';
		*{__PACKAGE__ . '::' . $method} = sub {
			my ($self, @data) = @_;
			my $r = $self->{ r } || return;
			return $r->$method(@data);
		};
	}

# Apache2::Request wrappers
	foreach my $method (qw/param/) {
		no strict 'refs';
		*{__PACKAGE__ . '::' . $method} = sub {
			my ($self, @data) = @_;
			my $req = $self->req || return;
			return $req->$method(@data);
		};
	}
}

sub new {
	my $class = shift;
	my $r = shift || return;

	logStack("Bad type: %s", ref($r)) unless $r && ref($r) && $r->isa('Apache2::RequestRec');

	my $self = {
		r	=> $r
	};
	bless $self, $class;
	return $self;
}

sub r { shift->{ r } }

sub req {
	my $self = shift;
	unless ($self->{ req }) {
		# my $req = APR::Request::Apache2->handle($self->{r});
		# $req->read_limit(512*1024*1024);
		# $req->parse();
		$self->{ req } = new Apache2::Request($self->{r});
	}
	return $self->{ req };
}

sub setLifetime {
	my $self = shift;
	my $hours = shift;

	my $r = $self->{ r } || return;

# Apache2::RequestRec;
# APR::Table;
	if ($r->protocol =~ /(\d\.\d)/ && $1 >= 1.1) {
	    $r->headers_out->add('Cache-Control', "max-age=" . $hours * 60 * 60);
	} else {
	    $r->headers_out->add('Expires',
			   HTTP::Date::time2str(time + $hours * 24 * 60 * 60));
	}
	return $self;
}

sub content_type {
	my $self = shift;
	my $type = shift;
	my $r = $self->{ r } || return;
	logDebug("Already set content type to [%s], now [%s]?", $self->{ content_type }, $type) if $self->{content_type};
	$self->{ content_type } = $type;
	return $r->content_type($type);
}

sub print {
	my ($self, @data) = @_;
	my $r = $self->{ r } || return;
	$self->content_type('text/html') unless $self->{ content_type };
	return $r->print(@data);
}

1;

__END__

=head1 AUTHOR

Tom Molesworth <cpan@entitymodel.com>

=head1 LICENSE

Copyright Tom Molesworth 2009-2011. Licensed under the same terms as Perl itself.