File Coverage

blib/lib/MasonX/WebApp.pm

Criterion	Covered	Total	%
statement	22	33	66.6
branch	4	10	40.0
condition	3	8	37.5
subroutine	7	7	100.0
pod			n/a
total	36	58	62.0

package MasonX::WebApp;

use strict;

use 5.006;

use vars qw($VERSION);

$VERSION = 0.12;

use Exception::Class
    ( 'MasonX::WebApp::Exception' =>
      { alias => 'error',
        description => 'Generic super-class for MasonX::WebApp exceptions' },

      'MasonX::WebApp::Exception::Abort' =>
      { isa   => 'MasonX::WebApp::Exception',
        alias => 'abort_exception',
        description => 'The abort method was called' },

      'MasonX::WebApp::Exception::Declaration' =>
      { isa   => 'MasonX::WebApp::Exception',
        alias => 'declaration_error',
        description => 'Attempted to use a feature without declaring something needed for it' },

      'MasonX::WebApp::Exception::Params' =>
      { isa   => 'MasonX::WebApp::Exception',
        alias => 'param_error',
        description => 'Bad parameters given to a method/function' },
    );

MasonX::WebApp::Exception->Trace(1);

use base 'Class::Data::Inheritable';

my $ModPerlVersion;
my $ApReqClass;
BEGIN
{
    if ( $ENV{MOD_PERL} && $ENV{MOD_PERL} =~ /1\.99|2\.0/ )
    {
        require mod_perl2;
    }
    elsif ( $ENV{MOD_PERL} )
    {
        require mod_perl;
    }

    $ModPerlVersion = (mod_perl2->VERSION || mod_perl->VERSION || 0);

    if ( $ModPerlVersion >= 1.99 && $ModPerlVersion < 1.999022 )
    {
        die "mod_perl-1.99 is not supported; upgrade to 2.00";
    }

    if ( $ModPerlVersion < 1.99 )
    {
        eval "use Apache::Constants qw( OK REDIRECT )";
        require Apache::Request;
        $ApReqClass = 'Apache::Request';
    }
    else
    {
        eval "use Apache2::Const qw( OK REDIRECT )";
        require Apache2::RequestUtil;
        require Apache2::Request;
        $ApReqClass = 'Apache2::Request';
    }
    die $@ if $@;
}

use Class::Factory::Util;
use HTML::Mason::Interp;
use URI;

use Params::Validate
    qw( validate validate_pos validate_with UNDEF SCALAR BOOLEAN ARRAYREF HASHREF OBJECT );
Params::Validate::validation_options
    ( on_fail => sub { param_error( join '', @_ ) } );


BEGIN
{
    __PACKAGE__->mk_classdata( 'ActionURIPrefix' );
    __PACKAGE__->mk_classdata( 'ActionURIPrefixRegex' );

    __PACKAGE__->mk_classdata( 'ApacheHandlerParams' );

    __PACKAGE__->mk_classdata( 'MasonGlobalName' );

    __PACKAGE__->mk_classdata( 'RequireAbortAfterAction' );

    __PACKAGE__->mk_classdata( 'SessionWrapperParams' );
    __PACKAGE__->mk_classdata( 'UseSession' );

    __PACKAGE__->ActionURIPrefix('/submit/');
    __PACKAGE__->MasonGlobalName('$WebApp');
    __PACKAGE__->UseSession(0);
    __PACKAGE__->RequireAbortAfterAction(1);
}

{ no warnings 'redefine';

sub UseSession
{
    my $class = shift;

    if (@_)
    {
        my ($bool) = validate_pos( @_, { type => BOOLEAN } );

        $class->_UseSession_accessor($bool);

        if ( $class->_UseSession_accessor )
        {
            require Apache::Session::Wrapper;
        }
    }

    return $class->_UseSession_accessor;
}

sub SessionWrapperParams
{
    my $class = shift;

    if (@_)
    {
        my ($p) = validate_pos( @_, { type => HASHREF } );

        $class->_SessionWrapperParams_accessor($p);

        $class->UseSession(1);
    }

    return $class->_SessionWrapperParams_accessor;
}

sub ApacheHandlerParams
{
    my $class = shift;

    if (@_)
    {
        my ($p) = validate_pos( @_, { type => HASHREF } );

        $class->_ApacheHandlerParams_accessor($p);
    }

    return $class->_ApacheHandlerParams_accessor;
}

sub ActionURIPrefix
{
    my $class = shift;

    if (@_)
    {
        my ($prefix) = validate_pos( @_, { regex => qr{^(?:/|/.+/)$} } );

        $class->_ActionURIPrefix_accessor($prefix);

        $class->ActionURIPrefixRegex( qr/^\Q$prefix\E/ );
    }

    return $class->_ActionURIPrefix_accessor;
}

sub _LoadActions
{
    my $class = shift;

    foreach my $sub ( $class->subclasses )
    {
        eval "use ${class}::$sub";
        die $@ if $@;
    }
}

} # no warnings 'redefine'

sub new
{
    my $class = shift;

    my %p =
        validate_with
            ( params => \@_,
              spec   =>
              { apache_req =>
                { can  => [ qw( method uri err_headers_out
                                headers_in status pnotes ) ],
                },
                args => { type => HASHREF },
              },
              allow_extra => 1,
            );

    my $self =  bless { __apache_req__ => delete $p{apache_req},
                        __args__       => delete $p{args},
                      }, $class;

    eval
    {
        $self->__set_wrapper if $self->UseSession;

        $self->_init(%p);

        $self->_handle_action;
    };

    if ($@)
    {
        if ( UNIVERSAL::isa( $@, 'MasonX::WebApp::Exception::Abort' ) )
        {
            # This shouldn't propogate out to the caller
            undef $@;
        }
        else
        {
            UNIVERSAL::can( $@, 'rethrow' ) ? $@->rethrow : die $@;
        }
    }

    return $self;
}

sub _init { }

sub apache_req { $_[0]->{__apache_req__} }
sub args       { $_[0]->{__args__} }

sub __set_wrapper
{
    my $self = shift;

    $self->{__wrapper__} = $self->_make_session_wrapper;
}

sub _make_session_wrapper
{
    return Apache::Session::Wrapper->new( %{ $_[0]->SessionWrapperParams || {} } );
}

sub session_wrapper
{
    error "Cannot call session_wrapper() method unless UseSession is true"
        unless $_[0]->UseSession;

    return $_[0]->{__wrapper__};
}

sub session { $_[0]->session_wrapper->session }

sub _handle_action
{
    my $self = shift;

    return if $self->aborted;

    my $prefix_re = $self->ActionURIPrefixRegex;

    return unless defined $prefix_re;

    my ($action) = $self->apache_req->uri =~ m{$prefix_re(\w+)};

    return unless defined $action && length $action;

    param_error "Invalid action: $action"
        unless $self->_is_valid_action($action);

    $self->$action();

    # This code is unlikely to be executed, as issuing an abort causes
    # an exception
    error "No abort was issued after the $action action."
        unless $self->aborted || ! $self->RequireAbortAfterAction;
}

sub _is_valid_action { $_[0]->can( $_[1] ) }

sub redirect
{
    my $self = shift;
    my %p = @_;

    my $uri = exists $p{uri} ? $p{uri} : $self->uri( %p, xhtml => 0 );

    if ( my $m = HTML::Mason::Request->instance )
    {
        $m->redirect($uri);
    }
    else
    {
        $self->{__redirected__} = 1;

        my $r = $self->apache_req;

        $r->method('GET');
        $r->headers_in->unset('Content-length');
        $r->err_headers_out->add( Location => $uri );
        $r->status( REDIRECT );

        $r->send_http_header
            if $ModPerlVersion < 1.99;

        $self->abort( REDIRECT );
    }
}

# kept for backwards compat - use aborted instead
sub redirected { $_[0]->{__redirected__} }

sub abort
{
    my $self = shift;
    my $status = shift;

    $self->{__aborted__} = 1;
    $self->{__abort_status__} = defined $status ? $status : OK;

    abort_exception;
}

sub aborted      { $_[0]->{__aborted__} }
sub abort_status { $_[0]->{__abort_status__} }

sub uri
{
    shift;
    my %p = validate( @_,
                      { scheme   => { type => SCALAR, default  => 'http' },
                        username => { type => SCALAR, optional => 1 },
                        password => { type => SCALAR, default  => '' },
                        host     => { type => SCALAR, optional => 1 },
                        port     => { type => SCALAR, optional => 1 },
                        path     => { type => SCALAR },
                        query    => { type => HASHREF, default => {} },
                        fragment => { type => SCALAR,  optional => 1 },
                        xhtml    => { type => BOOLEAN, default => 1 },
                      },
                    );

    my $uri = URI->new;

    if ( defined $p{host} )
    {
        $uri->scheme( $p{scheme} );

        if ( defined $p{username} )
        {
            $uri->authority( "$p{username}:$p{password}" );
        }

        $uri->host( $p{host} );
        $uri->port( $p{port} ) if $p{port};
    }

    $uri->path( $p{path} );

    # $uri->query_form doesn't handle hash ref values properly
    while ( my ( $k, $v ) = each %{ $p{query} } )
    {
        $p{query}{$k} = UNIVERSAL::isa( $v, 'HASH' ) ? [ %$v ] : $v;
    }

    $uri->query_form( %{ $p{query} } ) if keys %{ $p{query} };

    $uri->fragment( $p{fragment} ) if $p{fragment} ;

    my $canonical = $uri->canonical;

    # make URI XHTML-compliant
    $canonical =~ s/&(?!amp;)/&/g if $p{xhtml};

    # force stringification
    return $canonical . '';
}

sub _handle_error
{
    my $self = shift;

    my %p = validate_with( params => \@_,
                           spec   => { error     => { type => SCALAR | ARRAYREF | OBJECT },
                                       save_args => { type => HASHREF, default => {} },
                                     },
                           allow_extra => 1,
                    );

    if ( UNIVERSAL::can( $p{error}, 'messages' ) && $p{error}->messages )
    {
        $self->_add_error_message($_) for $p{error}->messages;
    }
    elsif ( UNIVERSAL::can( $p{error}, 'message' ) )
    {
        $self->_add_error_message( $p{error}->message );
    }
    elsif ( ref $p{error} eq 'ARRAY' )
    {
        $self->_add_error_message($_) for @{ $p{error} };
    }
    else
    {
        # force stringification
        $self->_add_error_message( "$p{error}" );
    }

    while ( my ( $k, $v ) = each %{ $p{save_args} } )
    {
        $self->_save_arg( $k => $v );
    }

    delete @p{ 'error', 'save_args' };

    $self->redirect(%p);
}

sub _save_arg  { $_[0]->session->{__saved_args__}{ $_[1] } = $_[2] }

sub saved_args { $_[0]->session->{__saved_args__} || {} }

sub _add_message       { push @{ $_[0]->session->{__messages__} }, $_[1] }

sub _add_error_message { push @{ $_[0]->session->{__errors__} }, $_[1] }

sub messages { my $s = $_[0]->session;
               $s->{__messages__} ? @{ delete $s->{__messages__} } : () }

sub errors   { my $s = $_[0]->session;
               $s->{__errors__} ? @{ delete $s->{__errors__} } : () }

sub clean_session { delete @{ $_[0]->session }{ qw( __messages__ __errors__ __saved_args__ ) } }

sub handler ($$) : method
{
    my $class = shift;
    my $r     = shift;
    my $apr   = $ApReqClass->new($r);

    my $ah = $class->_apache_handler_object;

    my $args = $ah->request_args($apr);

    my $app = $class->new( apache_req => $apr, args => $args );

    return $app->abort_status if $app->aborted;

    if ( $ah->interp->compiler->can('add_allowed_globals')
         && defined $class->MasonGlobalName )
    {
        $ah->interp->compiler->add_allowed_globals( $class->MasonGlobalName );
        $ah->interp->set_global( $class->MasonGlobalName => $app );
    }

    my $return = eval { $ah->handle_request($r) };

    my $err = $@;

    # We want to wipe out the variable before the request ends,
    # because if the $ah variable persists, then so does the interp,
    # which means the $app object won't be destroyed until the next
    # request in this process, which can hose up sessions big time.
    $ah->interp->set_global( $class->MasonGlobalName => undef );

    $app->clean_session if $class->UseSession;

    die $err if $err;

    return $return;
}

sub _apache_handler_object
{
    my $class = shift;

    return MasonX::WebApp::ApacheHandler->new( %{ $class->ApacheHandlerParams || {} } );
}


package MasonX::WebApp::ApacheHandler;

use base 'HTML::Mason::ApacheHandler';

sub request_args
{
    my $self = shift;
    my $r = shift;

    return $r->pnotes('__request_args__') if $r->pnotes('__request_args__');

    MasonX::WebApp::Exception->throw
        ( "request_args() requires an Apache::Request object or you must set "
          . "the ApacheHandler object's args_method parameter to 'CGI'" )
            if $self->args_method eq 'mod_perl' && ! $r->can('param');

    my $args = ($self->SUPER::request_args($r))[0] || {};

    $r->pnotes( __request_args__ => $args );

    return $args;
}


1;

__END__