view release on metacpan or  search on metacpan

lib/ASP4/HTTPContext.pm  view on Meta::CPAN

package ASP4::HTTPContext;

use strict;
use warnings 'all';
use HTTP::Date ();
use HTTP::Headers ();
use ASP4::ConfigLoader;
use ASP4::Request;
use ASP4::Response;
use ASP4::Server;
use ASP4::OutBuffer;
use ASP4::SessionStateManager::NonPersisted;
use Carp 'confess';

use vars '$_instance';

sub new
{
  my ($class, %args) = @_;
  
  my $s = bless {
    config => ASP4::ConfigLoader->load,
    buffer => [ ASP4::OutBuffer->new ],
    stash  => { },
    headers_out => HTTP::Headers->new(),
    is_subrequest => $args{is_subrequest},
  }, $class;
  $s->config->_init_inc();
  
  my $web = $s->config->web;
  $s->config->load_class( $web->handler_resolver );
  $s->config->load_class( $web->handler_runner );
  $s->config->load_class( $s->config->data_connections->session->manager );
  $s->config->load_class( $web->filter_resolver );
  
  return $s->is_subrequest ? $s : $_instance = $s;
}# end new()


sub setup_request
{
  my ($s, $r, $cgi) = @_;
  
  $ENV{DOCUMENT_ROOT} = $r->document_root;
  $s->{r} = $r;
  $s->{cgi} = $cgi;
  
  # Must instantiate $_instance before creating the other objects:
  $s->{request}   ||= ASP4::Request->new();
  $s->{response}  ||= ASP4::Response->new();
  $s->{server}    ||= ASP4::Server->new();
  
  if( $s->do_disable_session_state )
  {
    $s->{session} ||= ASP4::SessionStateManager::NonPersisted->new( $s->r );
  }
  else
  {
    $s->{session} ||= $s->config->data_connections->session->manager->new( $s->r );
  }# end if()
  
  return $_instance;
}# end setup_request()


# Intrinsics:
sub current   { $_instance || shift->new }
sub request   { shift->{request} }
sub response  { shift->{response} }
sub server    { shift->{server} }
sub session   { shift->{session} }
sub config    { shift->{config} }
sub stash     { shift->{stash} }

# More advanced:
sub is_subrequest { shift->{is_subrequest} }
sub cgi         { shift->{cgi} }
sub r           { shift->{r} }
sub handler     { shift->{handler} }
sub headers_out { shift->{headers_out} }
sub content_type  { my $s = shift; $s->r->content_type( @_ ) }
sub status        { my $s = shift; $s->r->status( @_ ) }
sub did_send_headers  { shift->{did_send_headers} }
sub did_end {
  my $s = shift;
  @_ ? $s->{did_end} = shift : $s->{did_end};
}

sub rprint {
  my ($s,$str) = @_;
  $s->buffer->add( $str );
}

sub rflush {
  my $s = shift;
  $s->send_headers;
  $s->r->print( $s->buffer->data );
  $s->r->rflush;
  $s->rclear;
}

sub rclear {
  my $s = shift;
  $s->buffer->clear;
}

sub send_headers
{
  my $s = shift;
  return if $s->{did_send_headers};
  
  my $headers = $s->headers_out;
  while( my ($k,$v) = each(%$headers) )
  {
    $s->r->err_headers_out->{$k} = $v;
  }# end while()

  $s->r->rflush;
  $s->{did_send_headers} = 1;
}# end send_headers()

# Here be dragons:
sub buffer        { shift->{buffer}->[-1] }