PUT results from the CPAN

Apache2-API

## All rights reserved
## 
## 
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package Apache2::API::Request;
BEGIN
{
    use strict;
    use warnings;
    warnings::register_categories( 'Apache2::API' );
    use parent qw( Module::Generic );
    use vars qw( $ERROR $VERSION $SERVER_VERSION );
    use utf8 ();
    use version;
    use Apache2::Access;
    use Apache2::Const -compile => qw( :common :methods :http );
    use Apache2::Connection ();
    use Apache2::Log ();
    use Apache2::Request;
    use Apache2::RequestRec ();
    use Apache2::RequestUtil ();
    use Apache2::ServerUtil ();
    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 ) );
        }

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


# Tells whether the connection has been aborted or not
sub aborted { return( shift->_try( 'connection', 'aborted' ) ); }

# e.g. text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
sub accept { return( shift->headers->{ 'Accept' } ); }

sub accept_charset { return( shift->_set_get_scalar( 'accept_charset', @_ ) ); }

# e.g. gzip, deflate, br
sub accept_encoding { return( shift->headers->{ 'Accept-Encoding' } ); }

# e.g.: en-GB,fr-FR;q=0.8,fr;q=0.6,ja;q=0.4,en;q=0.2
sub accept_language { return( shift->headers->{ 'Accept-Language' } ); }

sub accept_type { return( shift->_set_get_scalar( 'accept_type', @_ ) ); }

sub accept_version { return( shift->client_api_version( @_ ) ); }

sub acceptable
{
    my $self = shift( @_ );
    if( @_ )
    {
        my $ref = scalar( @_ ) == 1
            ? Scalar::Util::reftype( $_[0] ) eq 'ARRAY'
                ? shift( @_ )
                : [ @_ ]
            : [ @_ ];
        $self->{acceptable} = $self->new_array( $ref );
    }
    if( !$self->{acceptable} )
    {
        my $all = $self->acceptables;
        my $list = [];
        for( @$all )
        {
            push( @$list, $_->value->first );
        }
        $self->{acceptable} = $self->new_array( $list );
    }
    return( $self->{acceptable} );
}

sub acceptables
{
    my $self = shift( @_ );
    return( $self->{acceptables} ) if( $self->{acceptables} );
    my $accept_raw = $self->accept;
    if( $accept_raw )
    {
        $self->_load_class( 'Module::Generic::HeaderValue' ) || return( $self->pass_error );
        # Typical value from Ajax call: application/json, text/javascript, */*
        my $all = Module::Generic::HeaderValue->new_from_multi( $accept_raw ) ||
            return( $self->pass_error( Module::Generic::HeaderValue->error ) );
        $self->{acceptables} = $all;
    }
    return( $self->{acceptables} );
}

# The allowed methods, GET, POST, PUT, OPTIONS, HEAD, etc
sub allowed { return( shift->_try( 'request', 'allowed', @_ ) ); }

sub allow_methods { return( shift->_try( 'request', 'allow_methods', @_ ) ); }

sub allow_methods_list
{
    my $self = shift( @_ );
    my $r = $self->request;
    my $mask = $r->allowed;
    my $names =
    [
        map  { $methods_bit_to_name->{ $_ } }
        grep { $mask & (1 << $_) }
        keys( %$methods_bit_to_name )
    ];
    # Mirror Apache behavior: if GET is allowed, HEAD is implied.
    push( @$names, 'HEAD' ) if( $mask & ( 1 << Apache2::Const::M_GET ) );
    return( $names );
}

sub allow_options { return( shift->_try( 'request', 'allow_options', @_ ) ); }

sub allow_overrides { return( shift->_try( 'request', 'allow_overrides', @_ ) ); }

{
    # A nice alias
    # NOTE: sub apache
    no warnings 'once';
    *apache = \&request;
}

# APR::Request::Apache2->handle( $r );
sub apr { return( shift->_set_get_object( { field => 'apr', no_init => 1 }, 'APR::Request', @_ ) ); }

# sub args { return( shift->_try( 'request', 'args', @_ ) ); }
# Better yet, use APR::Body->args
sub args { return( shift->_try( 'apr', 'args', @_ ) ); }

sub args_status { return( shift->_try( 'args_status', 'args', @_ ) ); }

sub as_string { return( shift->_try( 'request', 'as_string' ) ); }

sub auth { return( shift->_set_get_scalar( 'auth', @_ ) ); }

sub auth_headers { return( shift->_try( 'request', 'note_auth_failure', @_ ) ); }

sub auth_headers_basic { return( shift->_try( 'request', 'note_basic_auth_failure', @_ ) ); }

sub auth_headers_digest { return( shift->_try( 'request', 'note_digest_auth_failure', @_ ) ); }

sub auth_name { return( shift->_try( 'request', 'auth_name', @_ ) ); }

# with mod_perl2, we need to call ap_auth_type() rather than auth_type()
sub auth_type { return( shift->_try( 'request', 'ap_auth_type', @_ ) ); }

sub authorization { return( shift->headers( 'Authorization', @_ ) ); }

# Must manually update the counter
# $r->connection->keepalives($r->connection->keepalives + 1);
# See Apache2::RequestRec

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

        };
    }
    if( $@ )
    {
        return( $self->error( "An error occurred while trying to call Apache ", ucfirst( $pack ), " method \"$meth\": $@" ) );
    }
    return( wantarray() ? @rv : $rv );
}

# NOTE: sub FREEZE is inherited

sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }

sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }

# NOTE: sub THAW is inherited

1;
# NOTE: POD
__END__

=encoding utf8

=head1 NAME

Apache2::API::Request - Apache2 Incoming Request Access and Manipulation

=head1 SYNOPSIS

    use Apache2::API::Request;
    # $r is the Apache2::RequestRec object
    my $req = Apache2::API::Request->new( request => $r, debug => 1 );
    # or, to test it outside of a modperl environment:
    my $req = Apache2::API::Request->new( request => $r, debug => 1, checkonly => 1 );

    # Tells whether the connection has been aborted or not
    $req->aborted;

    # e.g.: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
    my $accept = $req->accept;

    # Returns an array object
    my $all = $req->acceptable;
    $req->acceptable( $array_ref );

    # Returns an array object
    my $all = $req->acceptables;

    my $charset = $req->accept_charset;

    # e.g.: gzip, deflate, br
    my $encoding = $req->accept_encoding;

    # en-GB,fr-FR;q=0.8,fr;q=0.6,ja;q=0.4,en;q=0.2
    my $lang = $req->accept_language;

    my $type = $req->accept_type;

    my $version = $req->accept_version;

    # GET, POST, PUT, OPTIONS, HEAD, etc
    my $methods = $req->allowed;

    # get an APR::Request::Apache2 object
    my $apr = $req->apr;

    # query string as an hash reference
    my $hash_ref = $req->args; # also an APR::Request::Param::Table object

    my $status = $req->args_status;

    # HTTP query
    my $string = $req->as_string;

    my $auth = $req->auth;
    my $auth = $req->authorization;
    my $auth_type = $req->auth_type;

    $req->auto_header(1);

    # returns an APR::Request::Param::Table object similar to APR::Table
    my $body = $req->body;

    my $status = $req->body_status;

    my $limit = $req->brigade_limit;

    my $charset = $req->charset;

    $req->child_terminate;

    my $api_version = $req->client_api_version;

    # close client connection
    $req->close;

    my $status_code = $req->code;

    # Apache2::Connection
    my $conn = $req->connection;
    my $id = $req->connection_id;

    # content of the request filename
    my $content = $req->content;

    my $encoding = $req->content_encoding;

    my $langs_array_ref = $req->content_languages;

    my $len = $req->content_length;

    # text/plain
    my $ct = $req->content_type;

    # Get a Cookie object
    my $cookie = $req->cookie( $name );
    # Cookie::Jar object
    my $jar = $req->cookies;

    # get data string sent by client
    my $data = $req->data;

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

Returns the HTTP C<Accept-Encoding> header value.

    Accept-Encoding: gzip, deflate;q=1.0, *;q=0.5
    Accept-Encoding: gzip, deflate, br

See also L</headers> and L<https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Accept-Encoding>

=head2 accept_language

Returns the HTTP C<Accept-Language> header value such as C<en-GB,fr-FR;q=0.8,fr;q=0.6,ja;q=0.4,en;q=0.2>

See also L</headers>

=head2 accept_type

Sets or gets the acceptable content type. This is computed upon object instantiation by looking at the C<Accept> header:

    Accept: application/json; version=1.0; charset=utf-8

Here, it would be C<application/json>

=head2 accept_version

Sets or gets the version of the api being queried. This is computed upon object instantiation by looking at the C<Accept> header:

    Accept: application/json; version=1.0; charset=utf-8

Here, it would be C<1.0>

=head2 acceptable

This method parse the request header C<Accept>, by calling L</acceptables>, which could be, for example:

    application/json, text/javascript, */*

And return an L<array object|Module::Generic::Array> of acceptable content types.

    my $all = $req->acceptable;
    my $first = $req->acceptable->first;

You can also sets its array reference by passing either a list of value or an array reference.

=head2 acceptables

This takes the value from the C<Accept> header, splits them using L<Module::Generic::HeaderValue/new_from_multi> and returns an L<array object|Module::Generic::Array> of L<Module::Generic::HeaderValue> objects with their L<value|Module::Generic::Head...

So, if the C<Accept> header value was C<application/json, text/javascript, */*>, the array object returned would contain 3 L<Module::Generic::HeaderValue> objects with each C<< $hdr->value->first >> method returning:

=over 4

=item 1. C<application/json>

=item 2. C<text/javascript>

=item 3. C<*/*>

=back

=head2 allowed

Gets or sets the allowed methods bitmask such as GET, POST, PUT, OPTIONS, HEAD, etc, by calling L<Apache2::RequestRec/allowed>

It returns a bitvector of the allowed methods.

For example, if the module can handle only C<GET> and C<POST> methods it could start with:

    use Apache2::API;
    unless( $r->method_number == Apache2::Const::M_GET || 
            $r->method_number == Apache2::Const::M_POST )
    {
        $r->allowed( $r->allowed | ( 1 << Apache2::Const::M_GET ) | ( 1 << Apache2::Const::M_POST ) );
        return( Apache2::Const::HTTP_METHOD_NOT_ALLOWED );
    }

See also L</allowed_methods>

=head2 allow_methods

    $req->allow_methods( $reset );
    $req->allow_methods( $reset, @methods );

Provided with a reset boolean and a list of HTTP methods, and this will set the allowed methods such as GET, POST, PUT, OPTIONS, HEAD, etc, by calling L<Apache2::Access/allow_methods>

If the reset boolean passed is a true value, then all the previously allowed methods are removed, otherwise they are left unchanged.

For example, to allow only C<GET> and C<POST>, notwithstanding what was set previously:

    $req->allow_methods( 1, qw( GET POST ) );

It does not return anything. This is used only to set the allowed method. To retrieve them, see L</allowed>

=head2 allow_methods_list

    my $names = $r->allow_methods_list;
    $r->print( "Allowed methods: " . join( ', ', @$methods ) . "\n" ); # GET, POST

Returns an array reference containing the list of HTTP method names currently allowed for the request, as reported by L<Apache2::RequestRec/allowed>

The list is made up of uppercase method names such as C<GET>, C<POST>, C<OPTIONS>. Only methods whose corresponding bit is set in the requestâ€™s L<allowed mask|Apache2::RequestRec/allowed> are included.

In addition, this method mirrors Apacheâ€™s internal behaviour: if C<GET> is allowed, then C<HEAD> is automatically added to the list, even if it was not explicitly marked as allowed.

This can be used, for instance, to build an C<Allow:> response header for an C<OPTIONS> request or to emit clearer diagnostics.

On success, returns an array reference of strings. On error, it sets an L<error|Module::Generic/error> and returns C<undef> in scalar context and an empty list in list context.

=head2 allow_options

    my $bitmask = $req->allow_options;

Retrieve the bitmask value of Apache configuration directive C<Options> for this request, by calling L<Apache2::Access/allow_options>

You would need to use Apache constants against the returned value.

For example if the configuration for the current request was:

    Options None
    Options Indexes FollowSymLinks

The following applies:

    use Apache2::API;
    $req->allow_options & Apache2::Const::OPT_INDEXES;   # true
    $req->allow_options & Apache2::Const::OPT_SYM_LINKS; # true
    $req->allow_options & Apache2::Const::OPT_EXECCGI;   # false

=head2 allow_overrides

    my $bitmask = $req->allow_overrides;

Retrieve the bitmask value of C<AllowOverride> for this request by calling L<Apache2::Access/allow_overrides>

You would need to use Apache constants against the returned value.

For example if the configuration for the current request was:

    AllowOverride AuthConfig

The following applies:

    use Apache2::API;
    $req->allow_overrides & Apache2::Const::OR_AUTHCFG; # true

( run in 0.963 second using v1.01-cache-2.11-cpan-56fb94df46f )