Apache2-API
view release on metacpan or search on metacpan
lib/Apache2/API/Request.pm view on Meta::CPAN
# -*- perl -*-
##----------------------------------------------------------------------------
## Apache2 API Framework - ~/lib//mnt/src/perl/Apache2-API/lib/Apache2/API/Request.pm
## Version v0.4.2
## Copyright(c) 2026 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2023/05/30
## Modified 2026/06/17
## 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::Lite;
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.2';
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 );
lib/Apache2/API/Request.pm view on Meta::CPAN
sub client_api_version
{
my $self = shift( @_ );
if( @_ )
{
my $v = shift( @_ );
unless( ref( $v ) eq 'version' )
{
$v = version->parse( $v );
}
$self->{client_api_version} = $v;
}
return( $self->{client_api_version} );
}
# Close the client connection
# APR::Socket->close is not implemented; left undone
# So this is a successful work around
sub close
{
my $self = shift( @_ );
# Using APR::Socket to get the fileno
my $fd = $self->socket->fileno;
require IO::File;
my $sock = IO::File->new;
if( $sock->fdopen( $fd, 'w' ) )
{
return( $sock->close );
}
else
{
return(0);
}
}
sub code { return( shift->_try( 'request', 'status', @_ ) ); }
# Apache2::Connection
sub connection { return( shift->_try( 'request', 'connection' ) ); }
sub connection_id { return( shift->_try( 'connection', 'id' ) ); }
sub content { return( ${ shift->request->slurp_filename } ); }
sub content_encoding { return( shift->_try( 'request', 'content_encoding', @_ ) ); }
sub content_languages { return( shift->_try( 'request', 'content_languages', @_ ) ); }
sub content_length { return( shift->headers( 'Content-Length' ) ); }
sub content_type
{
my $self = shift( @_ );
my $ct = $self->headers( 'Content-Type' );
return( $ct ) if( !scalar( @_ ) );
$self->error( "Warning only: caller is trying to use ", ref( $self ), " to set the content-type. Use Apache2::API::Response for that instead." ) if( @_ );
return( $self->request->content_type( @_ ) );
}
# To get individual cookie sent. See APR::Request::Cookie
# APR::Request::Cookie
# sub cookie { return( shift->cookies->get( @_ ) ); }
sub cookie
{
my $self = shift( @_ );
my $name = shift( @_ );
# An erro has occurred if this is undef
my $jar = $self->cookies || return( $self->pass_error );
# Cookie::Jar might return undef if there was no match
my $v = $jar->get( $name );
return( $v ) unless( $v );
return( $v->value );
}
# To get all cookies; then we can fetch then with $jar->get( 'this_cookie' ) for example
# sub cookies { return( shift->request->jar ); }
# https://grokbase.com/t/modperl/modperl/06c91r49n4/apache2-cookie-apr-request-cookie
# sub cookies { return( APR::Request::Apache2->handle( shift->request->pool )->jar ); }
# my $req = APR::Request::Apache2->handle( $self->r );
# my %cookies;
# if ( $req->jar_status =~ /^(?:Missing input data|Success)$/ ) {
# my $jar = $req->jar;
# foreach my $key ( keys %$jar ) {
# $cookies{$key} = $jar->get($key);
# }
# }
#
# # Send warning with headers to explain bad cookie
# else {
# warn( "COOKIE ERROR: "
# . $req->jar_status . "\n"
# . Data::Dumper::Dumper( $self->r->headers_in() ) );
# }
sub cookies
{
my $self = shift( @_ );
return( $self->{_jar} ) if( $self->{_jar} );
my $jar = Cookie::Jar->new( request => $self->request, debug => $self->debug ) ||
return( $self->error( "An error occurred while trying to instantiate a new Cookie::Jar object: ", Cookie::Jar->error ) );
$jar->fetch;
$self->{_jar} = $jar;
return( $jar );
}
sub data
{
my $self = shift( @_ );
my $opts = $self->_get_args_as_hash( @_ );
my $r = $self->request;
# Mutator mode
if( $opts->{data} )
{
if( !defined( $opts->{data} ) ||
!CORE::length( $opts->{data} // '' ) )
{
warn( "Warning only: you are setting a zero-length payload data." ) if( $self->_is_warnings_enabled( 'Apache2::API' ) );
}
$self->pnotes( REQUEST_BODY => $opts->{data} );
# Optional: allow caller to mark as processed explicitly
if( $opts->{processed} )
{
$self->pnotes( REQUEST_BODY_PROCESSED => 1 );
}
return( $opts->{data} );
}
# Accessor mode
my $payload = $self->pnotes( 'REQUEST_BODY' );
return( $payload ) if( $self->pnotes( 'REQUEST_BODY_PROCESSED' ) );
my $ctype = $self->type;
my $max_size = 0;
# The request payload has been set or processed, so we re-use it.
if( defined( $payload ) )
{
# We do not set the 'REQUEST_BODY_PROCESSED' flag, because 1) we do not need to, and 2) it is an indicator if the request payload was processed at all. For example, one could force a different request payload by calling data() in mutator mode...
return( $payload );
}
if( $opts->{max_size} )
{
$max_size = $opts->{max_size};
}
elsif( my $val = $self->max_size )
{
$max_size = $val;
}
elsif( $r->dir_config( 'PAYLOAD_MAX_SIZE' ) )
{
$max_size = $r->dir_config( 'PAYLOAD_MAX_SIZE' );
}
$payload = '';
# Header Content-Length value
my $nbytes = $self->length;
# With Content-Length: read exactly $nbytes bytes
if( int( $nbytes // 0 ) > 0 )
{
if( $max_size && $nbytes > $max_size )
{
lib/Apache2/API/Request.pm view on Meta::CPAN
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;
my $formatter = $req->datetime;
my $decoded = $req->decode( $string );
my $do_not_track = $req->dnt;
my $encoded = $req->encode( $string );
$req->discard_request_body(1);
my $document_root = $req->document_root;
my $url = $req->document_uri;
# APR::Table object
my $hash_ref = $req->env;
my $headers = $req->err_headers_out;
# request filename
my $filename = $req->filename;
# APR::Finfo object
my $finfo = $req->finfo;
# e.g.: CGI/1.1
my $gateway = $req->gateway_interface;
my $code_ref = $req->get_handlers( $name );
# 404 Not Found
my $str = $req->get_status_line(404);
my $r = $req->global_request;
my $is_head = $req->header_only;
# same
my $is_head = $req->is_header_only;
my $content_type = $req->headers( 'Content-Type' );
# or (since it is case insensitive)
my $content_type = $req->headers( 'content-type' );
# or
my $content_type = $req->headers->{'Content-Type'};
$req->headers( 'Content-Type' => 'text/plain' );
# or
$req->headers->{'Content-Type'} = 'text/plain';
# APR::Table object
my $headers = $req->headers;
my $hash_ref = $req->headers_as_hashref;
my $json = $req->headers_as_json;
my $headers = $req->headers_in;
my $out = $req->headers_out;
my $hostname = $req->hostname;
my $uri_host = $req->http_host;
my $conn_id = $req->id;
my $if_mod = $req->if_modified_since;
my $if_no_match = $req->if_none_match;
my $filters = $req->input_filters;
lib/Apache2/API/Request.pm view on Meta::CPAN
=head2 connection
Returns a L<Apache2::Connection> object.
=head2 connection_id
Returns the connection id; unique at any point in time by calling L<Apache2::Connection/id>.
See L<Apache2::Connection> for more information.
=head2 content
Returns the content of the file specified with C<< $req->filename >>. It calls L<Apache2::RequestRec/slurp_filename>, but instead of returning a scalar reference, which L<Apache2::RequestRec/slurp_filename> does, it returns the data itself.
See L</slurp_filename> to get a scalar reference instead.
=head2 content_encoding
Returns the value of the C<Content-Encoding> HTTP response header.
See also L</headers>
=head2 content_languages
my $array_ref = $req->content_languages();
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;
lib/Apache2/API/Request.pm view on Meta::CPAN
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.
If a value is provided, it sets the document root to a new value only for the duration of the current request.
See L<Apache2::RequestUtil> for more information.
=head2 document_uri
Get the value for the environment variable C<DOCUMENT_URI>.
=head2 encode
Given a string, this returns its url-encoded version
This uses L<APR::Request> XS method.
=head2 env
my $val = $req->env( $name );
$req->env( $name, $value );
Using the Apache C<subprocess_env> table, this sets or gets environment variables. This is the equivalent of this:
$req->subprocess_env;
$env_table = $req->subprocess_env;
$req->subprocess_env( $key => $val );
$val = $req->subprocess_env( $key );
where C<$req> is this module object.
If one argument is provided, it will return the corresponding environment value.
If one or more sets of key-value pair are provided, they are set accordingly.
If nothing is provided, it returns a L<APR::Table> object.
=head2 err_headers_out
Get or sets HTTP response headers, which are printed out even on errors and persist across internal redirects.
According to the L<Apache2::RequestRec> documentation:
The difference between L</headers_out> (L<Apache2::RequestRec/headers_out>) and L</err_headers_out> (L<Apache2::RequestRec/err_headers_out>), is that the latter are printed even on error, and persist across internal redirects (so the headers printed ...
For example, if a handler wants to return a C<404> response, but nevertheless to set a cookie, it has to be:
$req->err_headers_out->add( 'Set-Cookie' => $cookie );
return( Apache2::Const::NOT_FOUND );
If the handler does:
$req->headers_out->add( 'Set-Cookie' => $cookie );
return( Apache2::Const::NOT_FOUND );
the C<Set-Cookie> header will not be sent.
See L<Apache2::RequestRec> for more information.
=head2 filename
Get or sets the filename (full file path) on disk corresponding to this request or response, by calling L<Apache2::RequestRec/filename>
See L<Apache2::RequestRec/filename> for more information.
=head2 finfo
Get and set the finfo request record member, by calling L<Apache2::RequestRec/finfo>
See L<Apache2::RequestRec/finfo> for more information.
=head2 gateway_interface
Sets or gets the environment variable C<GATEWAY_INTERFACE> using L</env>
Typical value returned from the environment variable C<GATEWAY_INTERFACE> is C<CGI/1.1>
=head2 get_handlers
Returns a reference to a list of handlers enabled for a given phase.
$handlers_list = $req->get_handlers( $hook_name );
Example, a list of handlers configured to run at the response phase:
my @handlers = @{ $req->get_handlers('PerlResponseHandler') || [] };
=head2 get_status_line
Return the C<Status-Line> for a given status code (excluding the HTTP-Version field), by calling L<Apache2::RequestRec/status_line>
For example:
print( $req->get_status_line( 400 ) );
will print:
400 Bad Request
See also L</status_line>
=head2 global_request
Returns the L<Apache2::RequestRec> object made global with the proper directive in the Apache VirtualHost configuration.
This calls L<Apache2::RequestUtil/request> to retrieve this value.
For example:
<Location /some/where/>
SetHandler perl-script
PerlOptions +GlobalRequest
# ...
</Location>
See also L<https://perl.apache.org/docs/2.0/user/config/config.html#C_GlobalRequest_>
lib/Apache2/API/Request.pm view on Meta::CPAN
my $accept = $req->headers->get( 'Accept' );
$req->headers->set( Accept => 'application/json' );
$req->headers->unset( 'Accept' );
$req->headers->add( Vary => 'Accept-Encoding' );
# Very useful for this header
$req->headers->merge( Vary => 'Accept-Encoding' );
# Empty the headers
$req->headers->clear;
use APR::Const qw( :table );
# to merge: multiple values for the same key are flattened into a comma-separated list.
$req->headers->compress( APR::Const::OVERLAP_TABLES_MERGE );
# to overwrite: each key will be set to the last value seen for that key.
$req->headers->compress( APR::Const::OVERLAP_TABLES_SET );
my $table = $req->headers->copy( $req2->pool );
my $headers = $req->headers;
$req->headers->do(sub
{
my( $key, $val ) = @_;
# Do something
# return(0) to abort
}, keys( %$headers ) );
# or without any filter keys
$req->headers->do(sub
{
my( $key, $val ) = @_;
# Do something
# return(0) to abort
});
# To prepare a table of 20 elements, but the table can still grow
my $table = APR::Table::make( $req->pool, 20 );
my $table2 = $req2->headers;
# overwrite any existing keys in our table $table
$table->overlap( $table2, APR::Const::OVERLAP_TABLES_SET );
# key, value pairs are added, regardless of whether there is another element with the same key in $table
$table->overlap( $table2, APR::Const::OVERLAP_TABLES_MERGE );
my $table3 = $table->overlay( $table2, $pool3 );
See L<APR::Table> for more information.
=head2 header_only
This is the same as L</is_header_only>
=head2 headers_as_hashref
Returns the list of headers as an hash reference, by calling L<Apache2::RequestRec/headers_in>
Since the call to L<Apache2::RequestRec> returns a L<APR::Table> object, we may get 2 or more same key name, and in that case, the hash with that key will have as a value an array reference.
=head2 headers_as_json
Returns the list of headers as a json data, by retrieving the hash from L</headers_as_hashref> and encode it with L<JSON>
=head2 headers_in
Returns the list of the headers as special hash, which is actually an L<APR::Table> object.
If a header name is provided, you can retrieve its value like so:
my $cookie = $req->headers_in->{Cookie} || '';
=head2 headers_out
This is identical to L</headers_in>, as it returns a L<APR::Table> object.
Returns or sets the key => value pairs of outgoing HTTP headers, only on 2xx responses.
See also L</err_headers_out>, which allows to set headers for non-2xx responses and persist across internal redirects.
More information at L<Apache2::RequestRec/headers_out>
=head2 hostname
Retrieve or set the HTTP server host name, such as C<www.example.com>, by calling L<Apache2::RequestRec/hostname>
This is not the machine hostname.
More information at L<Apache2::RequestRec>
=head2 http_host
Returns an C<URI> object of the HTTP host being accessed. This is created during object initiation phase.
This calls the method C<host> on the L<URI> object returned by L</uri>
=head2 id
Returns the connection id; unique at any point in time, by calling L<Apache2::Connection/id>.
See L<Apache2::Connection> for more information.
This is the same as L</connection_id>
=head2 if_modified_since
Returns the value of the HTTP header If-Modified-Since as a L<DateTime::Lite> object.
If no such header exists, it returns C<undef> or an empty list depending on the context.
=head2 if_none_match
Sets or gets the value of the HTTP header C<If-None-Match>
See also L</headers>
=head2 input_filters
Get or sets the first filter in a linked list of request level input filters. It returns a L<Apache2::Filter> object.
$input_filters = $req->input_filters();
$prev_input_filters = $req->input_filters( $new_input_filters );
According to the L<Apache2::RequestRec> documentation:
For example instead of using C<< $req->read() >> to read the C<POST> data, one could use an explicit walk through incoming bucket brigades to get that data. The following function C<read_post()> does just that (in fact that's what C<< $req->read() >>...
use APR::Brigade ();
use APR::Bucket ();
use Apache2::Filter ();
( run in 1.013 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )