view release on metacpan or  search on metacpan

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

        }
        else
        {
            $build_legacy_error->( $ref, $code, undef );
        }
    }
    # Success with no body details
    else
    {
        $ref->{success} = \1 unless( exists( $ref->{success} ) );
        $ref->{code}  //= $code;
        $ref->{code}    = int( $ref->{code} ) if( $ref->{code} =~ /^\d+$/ );
    }

    # Without an Access-Control-Allow-Origin field, this would trigger an error on the web browser
    # So we make sure it is there if not set already
    unless( $resp->headers->get( 'Access-Control-Allow-Origin' ) )
    {
        $resp->headers->set( 'Access-Control-Allow-Origin' => '*' );
    }
    # As an api, make sure there is no caching by default unless the field has already been set.
    unless( $resp->headers->get( 'Cache-Control' ) )
    {
        $resp->headers->set( 'Cache-Control' => 'private, no-cache, no-store, must-revalidate' );
    }

    # If we have a locale set, we use it
    my $locale;
    if( $is_error )
    {
        if( $use_rfc_error )
        {
            $locale = $ref->{locale} if( exists( $ref->{locale} ) );
        }
        else
        {
            $locale = $ref->{error}->{locale} if( exists( $ref->{error} ) && ref( $ref->{error} ) eq 'HASH' && exists( $ref->{error}->{locale} ) );
        }
    }
    # Success response
    else
    {
        $locale = $ref->{locale} if( exists( $ref->{locale} ) );
    }

    if( $locale )
    {
        # Set the content language for this payload unless the user has already set it.
        unless( $resp->headers->get( 'Content-Language' ) )
        {
            # en_GB -> en-GB
            ( my $hdr_locale = $locale ) =~ tr/_/-/;
            $resp->headers->set( 'Content-Language' => $hdr_locale );
        }
        $resp->headers->merge( 'Vary' => 'Accept-Language' );
    }

    # Choose Content-Type
    # If we use new modern error, then we set application/problem+json in line with rfc7807
    my $ctype = ( $is_error && $use_rfc_error )
        ? 'application/problem+json; charset=utf-8'
        : 'application/json; charset=utf-8';
    $resp->content_type( $ctype );

    # $r->status( $code );
    $resp->code( $code );
    if( defined( $msg ) && $ctype !~ m{^application/(?:json|problem\+json)}i )
    {
        $resp->custom_response( $code, $msg );
    }
    else
    {
        $resp->custom_response( $code, '' );
        #$r->status( $code );
    }

    if( exists( $ref->{cleanup} ) &&
        defined( $ref->{cleanup} ) &&
        ref( $ref->{cleanup} ) eq 'CODE' )
    {
        my $cleanup = delete( $ref->{cleanup} );
        # See <https://perl.apache.org/docs/2.0/user/handlers/http.html#PerlCleanupHandler>
        $r->pool->cleanup_register( $cleanup, $self );
    }

    # Our print() will possibly change the HTTP headers, so we do not flush now just yet.
    my $json = $self->json->utf8->relaxed(0)->allow_blessed->convert_blessed->encode( $ref );
    # Before we use this, we have to make sure all Apache module that deal with content encoding are de-activated because they would interfere
    if( !$self->print( $json ) )
    {
        return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
    }
    return( $code );
}

# Special reply for Server-Sent Event that need to close the connection if there was an error
sub reply_sse
{
    my $self = shift( @_ );
    my $code = $self->reply( @_ );
    $code //= 500;
    if( Apache2::API::Status->is_error( $code ) )
    {
        my $req = $self->request;
        $req->request->pool->cleanup_register(sub
        {
            $req->close;
        });
    }
    return( $code );
}

sub request { return( shift->_set_get_object( 'request', 'Apache2::API::Request', @_ ) ); }

sub response { return( shift->_set_get_object( 'response', 'Apache2::API::Response', @_ ) ); }

sub server
{
    my $self = shift( @_ );
    # try-catch
    local $@;
    my $rv = eval