view release on metacpan or  search on metacpan

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

# -*- perl -*-
##----------------------------------------------------------------------------
## Apache2 API Framework - ~/lib/Apache2/API/Response.pm
## Version v0.2.0
## Copyright(c) 2025 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2023/05/30
## Modified 2025/11/02
## 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::Response;
BEGIN
{
    use strict;
    use warnings;
    warnings::register_categories( 'Apache2::API' );
    use parent qw( Module::Generic );
    use vars qw( $VERSION );
    use Apache2::Request;
    use Apache2::Const -compile => qw( :common :http );
    use Apache2::Log ();
    use Apache2::Response ();
    use Apache2::RequestIO ();
    use Apache2::RequestRec ();
    use Apache2::SubRequest ();
    use APR::Request ();
    # use APR::Request::Cookie;
    use Apache2::API::Status;
    use Cookie::Jar;
    use Scalar::Util;
    use URI::Escape ();
    our $VERSION = 'v0.2.0';
};

use strict;
use warnings;

sub init
{
    my $self = shift( @_ );
    my $r;
    $r = shift( @_ ) if( @_ % 2 );
    # Which is an Apache2::Request, but inherits everything from Apache2::RequestRec and APR::Request::Apache2
    $self->{request} = '';
    $self->{checkonly} = 0;
    $self->SUPER::init( @_ );
    $r ||= $self->{request};
    unless( $self->{checkonly} )
    {
        return( $self->error( "No Apache2::API::Request was provided." ) ) if( !$r );
        return( $self->error( "Apache2::API::Request provided ($r) is not an object!" ) ) if( !Scalar::Util::blessed( $r ) );
        return( $self->error( "I was expecting an Apache2::API::Request, but instead I got \"$r\"." ) ) if( !$r->isa( 'Apache2::API::Request' ) );
    }
    return( $self );
}

# Response header: <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Access-Control-Allow-Credentials>
sub allow_credentials { return( shift->_set_get_one( 'Access-Control-Allow-Credentials', @_ ) ); }

# Response header <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Access-Control-Allow-Headers>
sub allow_headers { return( shift->_set_get_one( 'Access-Control-Allow-Headers', @_ ) ); }

# <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Access-Control-Allow-Methods>
sub allow_methods { return( shift->_set_get_one( 'Access-Control-Allow-Methods', @_ ) ); }

# <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Access-Control-Allow-Origin>
sub allow_origin { return( shift->_set_get_one( 'Access-Control-Allow-Origin', @_ ) ); }

# <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Alt-Svc>
sub alt_svc { return( shift->_set_get_multi( 'Alt-Svc', @_ ) ); }

sub bytes_sent { return( shift->_try( '_request', 'bytes_sent' ) ); }

# <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Cache-Control>
sub cache_control { return( shift->_set_get_one( 'Cache-Control', @_ ) ); }

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

# <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Clear-Site-Data>
sub clear_site_data { return( shift->_set_get_multi( 'Clear-Site-Data', @_ ) ); }

# Apache2::Connection
sub connection { return( shift->_try( '_request', 'connection' ) ); }

# Set the http code to be returned, e.g,:
# return( $resp->code( Apache2::Const:HTTP_OK ) );
sub code { return( shift->_try( '_request', 'status', @_ ) ); }

# <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Content-Disposition>
# TODO: More work to be done here like create a disposition method to parse its content
sub content_disposition { return( shift->_set_get_one( 'Content-Disposition', @_ ) ); }

# sub content_encoding { return( shift->_request->content_encoding( @_ ) ); }
sub content_encoding
{
    my $self = shift( @_ );
    my( $pack, $file, $line ) = caller;
    my $sub = ( caller( 1 ) )[3];
    # try-catch
    local $@;
    my $rv = eval
    {
        return( $self->_request->content_encoding( @_ ) );
    };
    if( $@ )
    {

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

sub _headers
{
    my $self = shift( @_ );
    my $type = shift( @_ ) ||
        return( $self->error({
            message => "No header type was specified.",
            want => [qw( hash )],
        }) );
    my $req = $self->_request ||
        return( $self->error({
            message => "No Apache2::RequestRec found!",
            want => [qw( hash )],
        }) );
    my $code = $req->can( $type ) ||
        return( $self->error({
            message => "Header type '$type' is unsupported by Apache2::RequestRec",
            want => [qw( hash )],
        }) );
    my $apr = $code->( $req ) ||
        return( $self->error({
            message => "Could not get an APR::Table object from Apache2::RequestRec->${type}",
            want => [qw( hash )],
        }) );
    if( !$self->_is_a( $apr => 'APR::Table' ) )
    {
        return( $self->error({
            message => "Object retrieved from Apache2::RequestRec->${type} is not an APR::Table object.",
            want => [qw( hash )],
        }) );
    }
    if( scalar( @_ ) && !( @_ % 2 ) )
    {
        for( my $i = 0; $i < scalar( @_ ); $i += 2 )
        {
            if( !defined( $_[ $i + 1 ] ) )
            {
                $apr->unset( $_[ $i ] );
            }
            else
            {
                $apr->set( $_[ $i ] => $_[ $i + 1 ] );
            }
        }
    }
    elsif( scalar( @_ ) )
    {
        return( $apr->get( shift( @_ ) ) );
    }
    else
    {
        return( $apr );
    }
}

sub _request { return( shift->request->request ); }

sub _set_get_multi
{
    my $self = shift( @_ );
    my $f    = shift( @_ );
    return( $self->SUPER::error( "No field was provided to set its value." ) ) if( !defined( $f ) || !CORE::length( "$f" ) );
    my $headers = $self->headers;
    if( @_ )
    {
        my $v = shift( @_ );
        return( $headers->unset( $f ) ) if( !defined( $v ) );
        if( $self->_is_array( $v ) )
        {
            # Take a copy to be safe since this is a reference
            $headers->set( $f => [@$v] );
        }
        else
        {
            $headers->set( $f => [split( /\,[[:blank:]\h]*/, $v)] );
        }
        return( $self );
    }
    else
    {
        my $v = $headers->get( $f );
        unless( $self->_is_array( $v ) )
        {
            $v = [split( /\,[[:blank:]\h]*/, $v )];
        }
        return( $self->new_array( $v ) );
    }
}

sub _set_get_one
{
    my $self = shift( @_ );
    my $f    = shift( @_ );
    return( $self->SUPER::error( "No field was provided to set its value." ) ) if( !defined( $f ) || !CORE::length( "$f" ) );
    my $headers = $self->headers;
    if( @_ )
    {
        my $v = shift( @_ );
        return( $headers->unset( $f ) ) if( !defined( $v ) );
        $headers->set( $f => $v );
        return( $self );
    }
    else
    {
        my $v = $headers->get( $f );
        return( $self->new_scalar( $v ) ) if( !ref( $v ) );
        return( $self->new_array( $v ) ) if( $self->_is_array( $v ) );
        # By default
        return( $v );
    }
}

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;
    # $r->log_error( "Apache2::API::Response::_try to call method \"$meth\" in package \"$pack\"." );
    # 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;