view release on metacpan or  search on metacpan

lib/Apache2/API/Request.pm  view on Meta::CPAN

    use Apache2::RequestIO ();
    use Apache2::Log;
    use APR::Pool ();
    use APR::Request ();
    use APR::Socket ();
    use APR::SockAddr ();
    use APR::Request::Cookie;
    use APR::Request::Apache2;
    # For subnet_of() method
    use APR::IpSubnet ();
    use Apache2::API::Request::Params;
    use Apache2::API::Request::Upload;
    use Apache2::API::DateTime;
    use Apache2::API::Query;
    use Apache2::API::Status;
    use Cookie::Jar;
    use DateTime;
    use Encode ();
    use File::Which ();
    use HTTP::AcceptLanguage;
    use JSON ();
    use Module::Generic::HeaderValue;
    use Scalar::Util;
    use URI;
    use URI::Escape;
    our $VERSION = 'v0.4.1';
    our( $SERVER_VERSION, $ERROR );
};

use strict;
use warnings;

my $methods_bit_to_name =
{
    Apache2::Const::M_GET()        => 'GET',
    Apache2::Const::M_POST()       => 'POST',
    Apache2::Const::M_PUT()        => 'PUT',
    Apache2::Const::M_DELETE()     => 'DELETE',
    Apache2::Const::M_OPTIONS()    => 'OPTIONS',
    Apache2::Const::M_TRACE()      => 'TRACE',
    Apache2::Const::M_CONNECT()    => 'CONNECT',
    (Apache2::Const->can('M_PATCH')       ? (Apache2::Const::M_PATCH()       => 'PATCH')       : ()),
    (Apache2::Const->can('M_PROPFIND')    ? (Apache2::Const::M_PROPFIND()    => 'PROPFIND')    : ()),
    (Apache2::Const->can('M_PROPPATCH')   ? (Apache2::Const::M_PROPPATCH()   => 'PROPPATCH')   : ()),
    (Apache2::Const->can('M_MKCOL')       ? (Apache2::Const::M_MKCOL()       => 'MKCOL')       : ()),
    (Apache2::Const->can('M_COPY')        ? (Apache2::Const::M_COPY()        => 'COPY')        : ()),
    (Apache2::Const->can('M_MOVE')        ? (Apache2::Const::M_MOVE()        => 'MOVE')        : ()),
    (Apache2::Const->can('M_LOCK')        ? (Apache2::Const::M_LOCK()        => 'LOCK')        : ()),
    (Apache2::Const->can('M_UNLOCK')      ? (Apache2::Const::M_UNLOCK()      => 'UNLOCK')      : ()),
};

my $json_ctypes_re = qr{\Aapplication/(?:[a-zA-Z][\w\-]+\+)?json\z}i;

sub init
{
    my $self = shift( @_ );
    my $r;
    $r = shift( @_ ) if( @_ % 2 );
    $self->{request} = $r;
    $self->{checkonly} = 0;
    $self->SUPER::init( @_ ) || return( $self->pass_error );
    $r ||= $self->{request};
    $self->{accept_charset}     = undef;
    $self->{auth}               = undef;
    $self->{charset}            = undef;
    $self->{client_api_version} = undef;
    $self->{_server_version}    = undef;
    # Which is an Apache2::Request, but inherits everything from Apache2::RequestRec and APR::Request::Apache2
    unless( $self->{checkonly} )
    {
        return( $self->error( "No Apache2::RequestRec was provided." ) ) if( !$r );
        return( $self->error( "Apache2::RequestRec provided ($r) is not an object!" ) ) if( !Scalar::Util::blessed( $r ) );
        return( $self->error( "I was expecting an Apache2::RequestRec, but instead I got \"$r\"." ) ) if( !$r->isa( 'Apache2::RequestRec' ) );
        $self->{request} = $r;
        # Important as few other methods rely on this
        $self->{apr} = APR::Request::Apache2->handle( $r );
        my $headers = $self->headers;
        # rfc 6750 <https://tools.ietf.org/html/rfc6750>
        my $auth = $headers->{Authorization};
        $self->auth( $auth ) if( length( $auth ) );
        # Content-Type: application/json; charset=utf-8
        my $ctype_raw = $self->content_type;
        # Accept: application/json; version=1.0; charset=utf-8
        my $accept_raw = $self->accept;
        # Returns an array of Module::Generic::HeaderValue objects
        my $accept_all = $self->acceptables;
        my( $ctype_def, $ctype );

        if( defined( $ctype_raw ) && CORE::length( $ctype_raw // '' ) )
        {
            $ctype_def = Module::Generic::HeaderValue->new_from_header( $ctype_raw );
            $ctype = lc( $ctype_def->value->first // '' );
            $self->type( $ctype );
            my $enc = $ctype_def->param( 'charset' );
            $self->charset( $enc ) if( defined( $enc ) && length( $enc ) );
        }

        if( defined( $accept_all ) && !$accept_all->is_empty )
        {
            my $accept_def = $accept_all->first;
            $self->accept_type( $accept_def->value->first );
            $self->client_api_version( $accept_def->param( 'version' ) );
            $self->accept_charset( $accept_def->param( 'charset' ) );
        }

        my $json    = $self->json->utf8;
        my $payload = $self->data;
        # An error occurred while reading the payload, because even empty, data would return an empty string.
        return( $self->pass_error ) if( !defined( $payload ) );
        if( defined( $ctype ) && 
            $ctype =~ $json_ctypes_re && 
            CORE::length( $payload ) )
        {
            my $json_data = '';
            # try-catch
            local $@;
            eval
            {
                $json_data = $json->decode( $payload );
            };
            if( $@ )