File Coverage

blib/lib/ASP4/Response.pm

Criterion	Covered	Total	%
statement	72	96	75.0
branch	6	18	33.3
condition	0	8	0.0
subroutine	22	25	88.0
pod	13	18	72.2
total	113	165	68.4

package ASP4::Response;

use strict;
use warnings 'all';
use HTTP::Date qw( time2str );
use ASP4::HTTPContext;
use ASP4::Mock::RequestRec;


sub new
{
  my $s = bless {
    _status           => 200,
    _expires          => 0,
    _content_type     => 'text/html',
    _expires_absolute => time2str( time() ),
  }, shift;
  $s->Status( $s->Status );
  $s->Expires( $s->Expires );
  $s->ContentType( $s->ContentType );

  return $s;
}# end new()

sub context { ASP4::HTTPContext->current }


sub ContentType
{
  my $s = shift;

  if( @_ )
  {
    my $type = shift;
    $s->{_content_type} = $type;
    $s->context->r->content_type( $type );
  }
  else
  {
    return $s->{_content_type};
  }# end if()
}# end ContentType()


sub Expires
{
  my $s = shift;
  if( @_ )
  {
    $s->{_expires} = shift;
    $s->{_expires_absolute} = time2str( time() + ( $s->{_expires} * 60 ) );
    $s->AddHeader( expires  => $s->ExpiresAbsolute );
  }# end if()

  return $s->{_expires};
}# end Expires()


sub ExpiresAbsolute { shift->{_expires_absolute} }


sub Status
{
  my $s = shift;

  @_ ? $s->context->r->status( $s->{_status} = +shift ) : $s->{_status};
}# end Status()


sub End
{
  my $s = shift;
  $s->Flush;

  # Would be nice to somehow stop all execution:
  $s->context->did_end( 1 );
}# end End()


sub Flush
{
  my $s = shift;
  $s->context->rflush;
}# end Flush()


sub Clear
{
  shift->context->rclear
}# end Clear()


sub IsClientConnected
{
  ! shift->context->r->connection->aborted();
}# end IsClientConnected()


sub Write
{
  my $s = shift;
  $s->context->rprint( shift(@_) )
}# end Write()


sub SetCookie
{
  my ($s, %args) = @_;

  $args{domain} ||= eval { $s->context->config->data_connections->session->cookie_domain } || $ENV{HTTP_HOST};
  $args{path}   ||= '/';
  my @parts = ( );
  push @parts, $s->context->server->URLEncode($args{name}) . '=' . $s->context->server->URLEncode($args{value});
  push @parts, 'domain=' . $s->context->server->URLEncode($args{domain});
  push @parts, 'path=' . $args{path};
  if( $args{expires} )
  {
    if( my ($num,$type) = $args{expires} =~ m/^(\-?\d+)([MHD])$/ )
    {
      my $expires;
      if( $type eq 'M' ) {
        # Minutes:
        $expires = time() + ( $num * 60 );
      }
      elsif( $type eq 'H' ) {
        # Hours:
        $expires = time() + ( $num * 60 * 60 );
      }
      elsif( $type eq 'D' ) {
        # Days:
        $expires = time() + ( $num * 60 * 60 * 24 );
      }# end if()
      push @parts, 'expires=' . time2str( $expires );
    }
    else
    {
      push @parts, 'expires=' . time2str( $args{expires} );
    }# end if()
  }# end if()
  $s->AddHeader( 'Set-Cookie' => join('; ', @parts) . ';' );
}# end SetCookie()


sub AddHeader
{
  my ($s, $name, $value) = @_;

  $s->context->headers_out->header( $name => $value );
}# end AddHeader()


sub Headers
{
  my $s = shift;

  my $out = $s->context->headers_out;
  map {{
    $_ => $out->{$_}
  }} keys %$out;
}# end Headers()


sub Redirect
{
  my ($s, $url) = @_;

  return if $s->context->did_send_headers;

  $s->Clear;
  $s->Status( 301 );
  $s->AddHeader( Location => $url );
  $s->End;
}# end Redirect()


sub Declined { -1 }


sub Include
{
  my ($s, $file, $args) = @_;

  $s->Write( $s->_subrequest( $file, $args ) );
}# end Include()


sub TrapInclude
{
  my ($s, $file, $args) = @_;

  return $s->_subrequest( $file, $args );
}# end TrapInclude()


sub _subrequest
{
  my ($s, $file, $args) = @_;

  $s->context->add_buffer();
  my $original_r = $s->context->r;
  my $root = $s->context->config->web->www_root;
  (my $uri = $file) =~ s/^\Q$root\E//;
  my $r = ASP4::Mock::RequestRec->new(
    uri   => $uri,
    args  => $original_r->args,
  );
  local $ENV{SCRIPT_NAME} = $uri;
  local $ENV{REQUEST_URI} = $uri;
  local $ENV{SCRIPT_FILENAME} = $file;
  $s->context->setup_request( $r, $s->context->cgi );
  $s->context->execute( $args, 1 );
  $s->Flush;
  my $buffer = $s->context->purge_buffer();
  $s->context->{r} = $original_r;
  return $r->buffer;
}# end _subrequest()


sub DESTROY
{
  my $s = shift;
  undef(%$s);
}# end DESTROY()

1;# return true:

=pod

=head1 NAME

ASP4::Response - Interface to the outgoing HTTP response

=head1 SYNOPSIS

  $Response->ContentType("text/html");

  $Response->Status( 200 );

  $Response->Clear();

  $Response->Flush();

  $Response->Write("Hello, World!");

  $Response->AddHeader( 'x-awesomeness' => '100%' );

  $Response->SetCookie(
    # Required parameters:
    name    => "customer-email",
    value   => $Form->{email},

    # The rest are optional:
    expires => '30D', # 30 days
    path    => '/',
    domain  => '.mysite.com',
  );

  $Response->Redirect( "/path/to/page.asp" );

  $Response->Include( $Server->MapPath("/my/include.asp") );
  $Response->Include( $Server->MapPath("/my/include.asp"), \%args );

  my $string = $Response->TrapInclude( $Server->MapPath("/my/widget.asp") );
  my $string = $Response->TrapInclude( $Server->MapPath("/my/widget.asp"), \%args );

  return $Response->Declined;

  $Response->End;

  while( 1 ) {
    last unless $Response->IsClientConnected();
    $Response->Write("Still Here!");
    sleep(1);
  }

  my HTTP::Headers $headers = $Response->Headers;

  # Read-only:
  my $expires_on = $Response->ExpiresAbsolute;

=head1 DESCRIPTION

The C<$Response> object offers a unified interface to send content back to the client.

=head1 PROPERTIES

=head2 ContentType( [$type] )

Sets or gets the C header for the response.  Examples are C, C, C, etc.

=head2 Status( [$status] )

Sets or gets the C header for the response.  See L for details.

B Only the numeric part is necessary - eg: 200, 301, 404, etc.

=head2 Headers()

Returns the L object that will be used for the outgoing response.

If necessary, you can manipulate this object in any way you see fit.

=head2 Declined

For use within a L subclass, like this:

  sub run {
    # Permit requests only every other second:
    if( time() % 2 ) {
      return $Response->Declined;
    }
    else {
      $Response->Write("Try again");
      return $Response->End;
    }
  }

=head2 IsClientConnected

In a ModPerl environment, this can be used to determine whether the client has
closed the connection (hit the "Stop" button or closed their browser).  Useful within
a long-running loop.

=head1 METHODS

=head2 Write( $str )

Adds C<$str> to the output buffer.

=head2 Flush( )

Causes the output buffer to be flushed to the client.

=head2 End( )

Aborts the current request.

Example:

  # Good:
  return $Response->End;

Simply calling...

  # Bad!
  $Response->End;

...will not work as intended.

=head2 AddHeader( $name => $value )

Adds a new header to the outgoing HTTP headers collection.

=head2 SetCookie( %args )

Adds a new cookie to the response.

C<%args> B contain the following:

=over 4

=item * name

A string - the name of the cookie.

=item * value

The value of the cookie.

=back

Other parameters are:

=over 4

=item * expires

Can be in one of the following formats:

=over 8

=item * 30B

Minutes - how many minutes from "now" calculated as C

Example:

  expires => '30M'
  expires => '-5M'  # 5 minutes ago

=item * 2B

Hours - how many hours from "now" calculated as C

Example:

  expires => '2H'   # 2 hours
  expires => '12H'  # 12 Hours

=item * 7B

Days - how many days from "now" calculated as C

Example:

  expires => '7D'   # A week
  expires => '30D'  # A month

=back

=item * path

Defaults to "C" - you can restrict the "path" that the cookie will apply to.

=item * domain

Defaults to whatever you set your config->data_connections->session->cookie_domain to
in your asp4-config.json.  Otherwise defaults to C<$ENV{HTTP_HOST}>.

You can override the defaults by passing in a domain, but the browser may not accept
other domains.  See L for details.

=back

=head2 Redirect( $url )

Causes the following HTTP header to be sent:

  Status: 301 Moved
  Location: $url

=head2 Include( $path [, \%args ] )

Executes the ASP script at C<$path> and includes its output.  Additional C<\%args>
may be passed along to the include.

The passed-in args are accessible to the include like this:

  <%
    my ($self, $context, $args) = @_;

    # Args is a hashref:
  %>

=head2 TrapInclude( $path [, \%args ] )

Executes the ASP script at C<$path> and returns its output.  Additional C<\%args>
may be passed along to the include.

The passed-in args are accessible to the include like this:

  <%
    my ($self, $context, $args) = @_;

    # Args is a hashref:
  %>

=cut