Apache2-API
view release on metacpan or search on metacpan
lib/Apache2/API/Request.pm view on Meta::CPAN
# -*- perl -*-
##----------------------------------------------------------------------------
## Apache2 API Framework - ~/lib/Apache2/API/Request.pm
## Version v0.4.1
## Copyright(c) 2025 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2023/05/30
## Modified 2026/03/19
## 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 ) );
}
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( $@ )
{
$r->log_error( ref( $self ), "::init() JSON data provided is malformed: $@" );
return( $self->error({ code => Apache2::Const::HTTP_BAD_REQUEST, message => "JSON data provided is malformed." }) );
}
$self->payload( $json_data );
}
}
return( $self );
}
# 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 )
lib/Apache2/API/Request.pm view on Meta::CPAN
my $chunk = '';
my $want = $to_read - $read;
# Cap chunk size
$want = 65536 if( $want > 65536 );
my $n = eval{ $r->read( $chunk, $want ); };
# APR::Error
if( $@ )
{
return( $self->error( "Error trying to read $want bytes from the APR::Bucket: $@" ) );
}
# EOF/abort
last unless( $n );
$payload .= $chunk;
$read += $n;
}
}
# No Content-Length: stream until read() returns 0
elsif( defined( $ctype ) &&
lc( $ctype ) eq 'application/json' )
{
my $total = 0;
while(1)
{
# try-catch
local $@;
my $chunk = '';
my $n = eval{ $r->read( $chunk, 8192 ); };
# APR::Error
if( $@ )
{
return( $self->error( "Error trying to read 8192 bytes from the APR::Bucket: $@" ) );
}
last unless( $n );
$payload .= $chunk;
$total += $n;
if( $max_size && $total > $max_size )
{
return( $self->error({
code => Apache2::Const::HTTP_REQUEST_ENTITY_TOO_LARGE,
message => "Total payload submitted ($total bytes) exceeds configured limit ($max_size)."
}) );
}
}
}
# try-catch
local $@;
eval
{
# This is set during the init() phase
my $charset = $self->charset;
if( defined( $charset ) && $charset )
{
$payload = Encode::decode( $charset, $payload, Encode::FB_CROAK );
}
# We only UTF-8 decode it if it is a pure text file.
# If no $ctype is defined, the default should be application/octet-stream
elsif( defined( $ctype ) && $ctype =~ m,^text/,i )
{
$payload = Encode::decode_utf8( $payload, Encode::FB_CROAK );
}
};
if( $@ )
{
return( $self->error({
code => Apache2::Const::HTTP_BAD_REQUEST,
message => "Error while decoding payload received from http client: $@"
}) );
}
# Cache the request body so other handlers can access it too.
$self->pnotes( REQUEST_BODY => $payload );
$self->pnotes( REQUEST_BODY_PROCESSED => 1 );
return( $payload );
}
sub datetime { return( Apache2::API::DateTime->new( debug => shift->debug ) ); }
sub decode
{
my $self = shift( @_ );
return( APR::Request::decode( shift( @_ ) ) );
}
sub discard_request_body { return( shift->_try( 'request', 'discard_request_body' ) ); }
# Do not track: 1 or 0
sub dnt { return( shift->env( 'HTTP_DNT', @_ ) ); }
sub document_root { return( shift->_try( 'request', 'document_root', @_ ) ); }
sub document_uri { return( shift->env( 'document_uri', @_ ) ); }
sub encode
{
my $self = shift( @_ );
return( APR::Request::encode( shift( @_ ) ) );
}
sub env
{
my $self = shift( @_ );
my $r = $self->request;
if( @_ )
{
if( scalar( @_ ) == 1 )
{
my $v = shift( @_ );
if( ref( $v ) eq 'HASH' )
{
foreach my $k ( sort( keys( %$v ) ) )
{
$r->subprocess_env( $k => $v->{ $k } );
}
}
else
{
return( $r->subprocess_env( $v ) );
}
}
else
lib/Apache2/API/Request.pm view on Meta::CPAN
sub header
{
my $self = shift( @_ );
return( $self->error( "No header field name was provided to set or retrieve its value." ) ) if( !scalar( @_ ) );
my $field = shift( @_ );
my $hdrs = $self->headers || return( $self->pass_error );
if( scalar( @_ ) > 1 )
{
return( $hdrs->set( "$field" => @_ ) );
}
else
{
return( $hdrs->get( "$field" ) );
}
}
sub header_only { return( shift->request->header_only ); }
# sub headers { return( shift->request->headers_in ); }
sub headers { return( shift->_headers( 'headers_in', @_ ) ); }
sub headers_as_hashref
{
my $self = shift( @_ );
my $ref = {};
my $h = $self->headers;
while( my( $k, $v ) = each( %$h ) )
{
if( CORE::exists( $ref->{ $k } ) )
{
# if( ref( $ref->{ $k } ) eq 'ARRAY' )
if( $self->_is_array( $ref->{ $k } ) )
{
CORE::push( @{$ref->{ $k }}, $v );
}
else
{
my $old = $ref->{ $k };
$ref->{ $k } = [];
CORE::push( @{$ref->{ $k }}, $old, $v );
}
}
else
{
$ref->{ $k } = $v;
}
}
return( $ref );
}
sub headers_as_json
{
my $self = shift( @_ );
my $ref = $self->headers_as_hashref;
my $json;
# try-catch
local $@;
eval
{
# Non-utf8 encoded, because this resulting data may be sent over http or stored in a database which would typically encode data on the fly, and double encoding will damage data
$json = $self->json->encode( $ref );
};
if( $@ )
{
return( $self->error( "An error occured while encoding the headers hash reference into json: $@" ) );
}
return( $json );
}
sub headers_in { return( shift->request->headers_in ); }
sub headers_out { return( shift->request->headers_out ); }
sub hostname { return( shift->_try( 'request', 'hostname' ) ); }
sub http_host { return( shift->uri->host ); }
sub id { return( shift->_try( 'connection', 'id' ) ); }
sub if_modified_since
{
my $self = shift( @_ );
my $v = $self->headers( 'If-Modified-Since' ) || return;
return( $self->datetime->str2datetime( $v ) );
}
sub if_none_match { return( shift->headers( 'If-None-Match', @_ ) ); }
sub input_filters { return( shift->_try( 'request', 'input_filters' ) ); }
# <https://perl.apache.org/docs/1.0/guide/debug.html#toc_Detecting_Aborted_Connections>
sub is_aborted
{
my $self = shift( @_ );
my $r = $self->request ||
return( $self->error( "No Apache2::RequestRec object set anymore!" ) );
# try-catch
local $@;
eval
{
$r->print( "\0" );
$r->rflush;
};
return(1) if( $@ && $@ =~ /Broken pipe/i );
return( $r->connection->aborted );
}
sub is_auth_required { return( shift->_try( 'request', 'some_auth_required' ) ); }
# A HEAD request maybe ?
sub is_header_only { return( shift->request->header_only ); }
# To find out if a PerlOptions is activated like +GlobalRequest or -GlobalRequest
sub is_perl_option_enabled { return( shift->_try( 'request', 'is_perl_option_enabled', @_ ) ); }
sub is_initial_req { return( shift->_try( 'request', 'is_initial_req', @_ ) ); }
sub is_secure { return( ( shift->env( 'HTTPS' ) // '' ) eq 'on' ? 1 : 0 ); }
sub json
lib/Apache2/API/Request.pm view on Meta::CPAN
sub mtime { return( shift->_try( 'request', 'mtime' ) ); }
sub next { return( shift->_try( 'request', 'next' ) ); }
# Tells the client not to cache the response
sub no_cache { return( shift->_try( 'request', 'no_cache', @_ ) ); }
# Takes an APR::Table object
# There is also one available via the connection object
# It returns an APR::Table object which can be used like a hash ie foreach my $k ( sort( keys( %{$table} ) ) )
sub notes
{
my $self = shift( @_ );
if( @_ )
{
my $hash = shift( @_ );
return( $self->error( "Value provided is not a hash reference." ) ) if( ref( $hash ) ne 'HASH' );
#my $pool = $self->pool->new;
#my $table = APR::Table::make( $pool, 1 );
#foreach my $k ( sort( keys( %$hash ) ) )
#{
# $table->set( $k => $hash->{ $k } );
#}
my $r = $self->request;
#$r->notes( $table );
$r->pnotes( $hash );
}
return( $self->request->notes );
}
sub output_filters { return( shift->_try( 'request', 'output_filters', @_ ) ); }
sub param
{
my $self = shift( @_ );
my $name = shift( @_ ) || return;
my $r = Apache2::API::Request::Params->new( $self->request );
if( @_ )
{
return( $r->param( $name, @_ ) );
}
else
{
my $val = $r->param( $name );
my $up = $r->upload( $name );
# Return the Net:::API::REST::Request::Upload object if it is one
return( $up ) if( Scalar::Util::blessed( $up ) );
return( $val );
}
}
sub params
{
my $self = shift( @_ );
return( $self->query ) if( $self->method eq 'GET' );
# my $r = Apache2::Request->new( $self->request );
my $r = Apache2::API::Request::Params->new( request => $self->request );
# https://perl.apache.org/docs/1.0/guide/snippets.html#Reusing_Data_from_POST_request
# my %params = $r->method eq 'POST' ? $r->content : $r->args;
# Data are in pure utf8; not perl's internal, so it is up to us to decode them
my( @params ) = $r->param;
my( @uploads ) = $r->upload;
my $upload_fields = {};
# To make it easy to check if it exists
if( scalar( @uploads ) )
{
@$upload_fields{ @uploads } = ( 1 ) x scalar( @uploads );
}
my $form = {};
#my $io = IO::File->new( ">/tmp/form_data.txt" );
#my $io2 = IO::File->new( ">/tmp/form_data_after_our_decoding.txt" );
#my $raw = IO::File->new( ">/tmp/raw_form_data.txt" );
#$io->binmode( ':utf8' );
#$io2->binmode( ':utf8' );
foreach my $k ( @params )
{
my( @values ) = $r->param( $k );
#$raw->print( "$k => " );
#$io->print( "$k => " );
my $name = utf8::is_utf8( $k ) ? $k : Encode::decode_utf8( $k );
#$io2->print( "$name => " );
$form->{ $name } = scalar( @values ) > 1 ? \@values : $values[0];
if( CORE::exists( $upload_fields->{ $name } ) )
{
my $up = $r->upload( $name );
if( !$up )
{
CORE::warn( "Error: could not get the Apache2::API::Params::Upload object for this upload field \"$name\".\n" );
next;
}
else
{
$form->{ $name } = $up;
}
}
elsif( ref( $form->{ $name } ) )
{
#$raw->print( "[\n" );
#$io->print( "[\n" );
#$io2->print( "[\n" );
for( my $i = 0; $i < scalar( @{$form->{ $name }} ); $i++ )
{
#$raw->print( "\t[$i]: ", $form->{ $name }->[ $i ], "\n" );
#$io->print( "\t[$i]: ", $form->{ $name }->[ $i ], "\n" );
$form->{ $name }->[ $i ] = utf8::is_utf8( $form->{ $name }->[ $i ] ) ? $form->{ $name }->[ $i ] : Encode::decode_utf8( $form->{ $name }->[ $i ] );
#$io2->print( "\t[$i]: ", $form->{ $name }->[ $i ], "\n" );
}
#$raw->print( "];\n" );
#$io->print( "];\n" );
#$io2->print( "];\n" );
}
else
{
#$raw->print( $form->{ $name }, "\n" );
#$io->print( $form->{ $name }, "\n" );
$form->{ $name } = utf8::is_utf8( $form->{ $name } ) ? $form->{ $name } : Encode::decode_utf8( $form->{ $name } );
#$io2->print( $form->{ $name }, "\n" );
}
}
#$raw->close;
#$io->close;
#$io2->close;
return( $form );
}
# NOTE: parse_date for compatibility
sub parse_date { return( shift->datetime->parse_date( @_ ) ); }
# example: /bin:/usr/bin:/usr/local/bin
sub path { return( shift->env( 'PATH', @_ ) ); }
sub path_info { return( shift->_try( 'request', 'path_info', @_ ) ); }
sub payload { return( shift->_set_get_hash( 'payload', @_ ) ); }
sub per_dir_config { return( shift->_try( 'rquest', 'per_dir_config' ) ); }
sub pnotes { return( shift->_try( 'request', 'pnotes', @_ ) ); }
sub pool { return( shift->_try( 'connection', 'pool' ) ); }
sub preferred_language
{
my $self = shift( @_ );
my $ok_langs = [];
if( @_ )
{
return( $self->error( "I was expecting a list of supported languages as array reference, but instead I received this '", join( "', '", @_ ), "'." ) ) if( !$self->_is_array( $_[0] ) );
# Make a copy
$ok_langs = [ @{$_[0]} ];
# Make sure the languages provided are in web format (e.g. en-GB), not unix format (e.g. en_GB)
for( my $i = 0; $i < scalar( @$ok_langs ); $i++ )
{
$ok_langs->[ $i ] =~ tr/_/-/;
}
}
else
{
return( $self->error( "No supported languages list was provided as array reference." ) );
}
# No supported languages was provided
return( '' ) if( !scalar( @$ok_langs ) );
# The user has not set his/her preferred languages
my $accept_langs = $self->accept_language || return( '' );
my $al = HTTP::AcceptLanguage->new( $accept_langs );
# Get the most suitable one
my $ok = $al->match( @$ok_langs );
return( $ok ) if( CORE::length( $ok // '' ) );
# No match, we return empty. undef is for error only
return( '' );
}
sub prev { return( shift->_try( 'request', 'prev' ) ); }
sub protocol { return( shift->_try( 'request', 'protocol' ) ); }
lib/Apache2/API/Request.pm view on Meta::CPAN
{
$apr->set( $_[ $i ] => $_[ $i + 1 ] );
}
}
}
elsif( scalar( @_ ) )
{
return( $apr->get( shift( @_ ) ) );
}
else
{
return( $apr );
}
}
sub _try
{
my $self = shift( @_ );
my $pack = shift( @_ ) || return( $self->error( "No Apache package name was provided to call method" ) );
my $meth = shift( @_ ) || return( $self->error( "No method name was provided to try!" ) );
# my $r = Apache2::RequestUtil->request;
my $r = $self->request;
# try-catch
local $@;
my( @rv, $rv );
if( wantarray() )
{
@rv = eval
{
return( $self->$pack->$meth() ) if( !scalar( @_ ) );
return( $self->$pack->$meth( @_ ) );
};
}
else
{
$rv = eval
{
return( $self->$pack->$meth() ) if( !scalar( @_ ) );
return( $self->$pack->$meth( @_ ) );
};
}
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;
lib/Apache2/API/Request.pm view on Meta::CPAN
my $array_ref = $req->content_languages( $array_reference );
Sets or gets the value of the C<Content-Language> HTTP header, by calling L<Apache2::RequestRec/content_languages>
Content languages are string like C<en> or C<fr>.
If a new value is provided, it must be an array reference of language codes.
It returns the language codes as an array reference.
=head2 content_length
Returns the length in byte of the request body, by getting the header C<Content-Length> value.
See also L</headers>
=head2 content_type
Retrieves the value of the C<Content-type> header value. See L<Apache2::RequestRec> for more information.
For example:
application/json; charset=utf-8
See also L</type> to retrieve only the content type, i.e without other information such as charset.
See also L</client_api_version> which would contain the requested api version, if any.
See also L<charset> for the charset provided, if any. For example C<utf-8>
=head2 cookie
Returns the current value for the given cookie name, which may be C<undef> if nothing is found.
This works by calling the L</cookies> method, which returns a L<cookie jar object|Cookie::Jar>.
=head2 cookies
Returns a L<Cookie::Jar> object acting as a jar with various methods to access, manipulate and create cookies.
=head2 data
This method reads the data sent by the client. It can be used as an accessor, and it will return a cached data, if any, or read the data from L<APR::Bucket>, or it can be used as a mutator to artificially set a payload.
Internally it uses L<Apache2::RequestUtil/pnotes> to cache the processed request body and stores it in C<REQUEST_BODY>, and set the shared property C<REQUEST_BODY_PROCESSED> to C<1>. Thus, the processed raw request body is always for other handlers w...
It takes an optional hash or hash reference of the following options:
=over 4
=item * C<data>
When provided, this will set the request body to the value provided.
=item * C<max_size>
The maximum size of the data that can be transmitted to us over HTTP. By default, there is no limit.
=back
Finally, if a charset is specified, this will also decode it from its encoded charset into perl internal utf8.
This is specifically designed for C<JSON> payload.
It returns a string of data upon success, or sets an L<error|Module::Generic/error> and return C<undef> or an empty list depending on the context.
You can also set a maximum size to read by setting the attribute C<PAYLOAD_MAX_SIZE> in Apache configuration file.
For example:
<Directory /home/john/www>
PerlOptions +GlobalRequest
SetHandler modperl
# package inheriting from Apache2::API
PerlResponseHandler My::API
# 2Mb upload limit
PerlSetVar PAYLOAD_MAX_SIZE 2097152
</Directory>
This is just an example and not a recommandation. Your mileage may vary.
=head2 datetime
Returns a new L<Apache2::API::DateTime> object, which is used to parse and format dates for HTTP.
See L<Apache2::API/parse_datetime> and L<Apache2::API/format_datetime>
=head2 decode
Given a url-encoded string, this returns the decoded string, by calling L<APR::Request/decode>
This uses L<APR::Request> XS method.
See also L<rfc3986|https://datatracker.ietf.org/doc/html/rfc3986>
=head2 discard_request_body
my $rc = $req->discard_request_body;
In C<HTTP/1.1>, any method can have a body. However, most C<GET> handlers would not know what to do with a request body if they received one. This helper routine tests for and reads any message body in the request, simply discarding whatever it recei...
Returns C<Apache2::Const::OK> upon success.
use Apache2::API;
my $rc = $req->discard_request_body;
return( $rc ) if( $rc != Apache2::Const::OK );
This method calls L<Apache2::RequestIO/discard_request_body>
=head2 dnt
Sets or gets the environment variable C<HTTP_DNT> using L<Apache2::RequestRec/subprocess_env>. See L</env> below for more on that.
This is an abbreviation for C<Do not track>
If available, typical value is a boolean such as C<0> or C<1>
=head2 document_root
Sets or retrieve the document root for this server.
lib/Apache2/API/Request.pm view on Meta::CPAN
use APR::Brigade ();
use APR::Bucket ();
use Apache2::Filter ();
sub send_response_body
{
my( $req, $data ) = @_;
my $bb = APR::Brigade->new( $req->pool,
$req->connection->bucket_alloc );
my $b = APR::Bucket->new( $bb->bucket_alloc, $data );
$bb->insert_tail( $b );
$req->output_filters->fflush( $bb );
$bb->destroy;
}
In fact that's what C<< $req->read() >> does behind the scenes. But it also knows to parse HTTP headers passed together with the data and it also implements buffering, which the above function does not.
=head2 param
Provided a name, this returns its equivalent value, using L<Apache2::API::Request::Params/param>.
If C<$name> is an upload field, ie part of a multipart post data, it returns an L<Apache2::API::Request::Upload> object instead.
If a value is provided, this calls L<Apache2::API::Request::Param/param> providing it with the name ane value. This uses L<APR::Request::Param>.
=head2 params
Get the request parameters (using case-insensitive keys) by mimicing the OO interface of L<CGI::param>.
It can take as argument, only a key and it will then retrieve the corresponding value, or it can take a key and value pair to set them using L<Apache2::API::Request::Params/param>
If the value is an array, this will set multiple entry of the key for each value provided.
This uses Apache L<APR::Table> and works for both C<POST> and C<GET> methods.
If the methods received was a C<GET> method, this method returns the value of the L</query> method instead.
=head2 parse_date
Alias to L<Apache2::API::DateTime/parse_date>
=head2 path
Get the value for the environment variable C<PATH>
See also L</env>
=head2 path_info
my $path_info = $req->path_info();
my $prev_path_info = $req->path_info( $path_info );
Get or set the C<PATH_INFO>, what is left in the path after the C<< URI --> filename >> translation, by calling L<Apache2::RequestRec/path_info>
Return a string as the current value.
=head2 payload
Returns the JSON data decoded into a perl structure. This is set at object initiation phase and calls the L</data> method to read the incoming data and decoded it into perl internal utf8.
=head2 per_dir_config
Get the dir config vector, by calling L<Apache2::RequestRec/per_dir_config>. Returns a L<Apache2::ConfVector> object.
For an in-depth discussion, refer to the Apache Server Configuration Customization in Perl chapter.
=head2 pnotes
Share Perl variables between Perl HTTP handlers, using L<Apache2::RequestUtil/pnotes>.
# to share variables by value and not reference, $val should be a lexical.
$old_val = $req->pnotes( $key => $val );
$val = $req->pnotes( $key );
$hash_ref = $req->pnotes();
Note: sharing variables really means it. The variable is not copied. Only its reference count is incremented. If it is changed after being put in pnotes that change also affects the stored value. The following example illustrates the effect:
my $v = 1; my $v = 1;
$req->pnotes( 'v'=> $v ); $req->pnotes->{v} = $v;
$v++; $v++;
my $x = $req->pnotes('v'); my $x = $req->pnotes->{v};
=head2 pool
Returns the pool associated with the request as a L<APR::Pool> object of the L<Apache2 connection|Apache2::Connection>. If you rather want access to the pool object of the Apache2 request itself, use L</request>, such as:
# $rest being a Apache2::API object
my $request_pool = $req->pool;
$request_pool->cleanup_register( \&cleanup );
=head2 preferred_language
Given an array reference of supported languages, this method will get the client accepted languages by calling L</accept_language> and derive the best match, ie the client preferred language, using L<HTTP::AcceptLanguage>,.
It returns a string representing a language code.
Note that it does not matter if the array reference of supported language use underscore or dash, so both of the followings are equivalent:
my $best_lang = $req->preferred_language( [qw( en_GB fr_FR ja_JP ko_KR )] );
and
my $best_lang = $req->preferred_language( [qw( en-GB fr-FR ja-JP ko-KR )] );
If somehow, no suitable language could be found, it will return an empty string, and it will return C<undef> in scalar context, or an empty list in list context upon error, so check if the return value is defined or not.
See also: L</languages> and L</accept_language>
=head2 prev
my $prev_r = $req->prev();
Pointer to the previous request if this is an internal redirect, by calling L<Apache2::RequestRec/prev>.
Returns a L<Apache2::RequestRec> blessed reference to the previous (internal) request structure or C<undef> if there is no previous request.
=head2 protocol
my $protocol = $req->protocol();
( run in 1.047 second using v1.01-cache-2.11-cpan-39bf76dae61 )