view release on metacpan or  search on metacpan

lib/HTTP/Promise/Entity.pm  view on Meta::CPAN

##----------------------------------------------------------------------------
## Asynchronous HTTP Request and Promise - ~/lib/HTTP/Promise/Entity.pm
## Version v0.2.2
## Copyright(c) 2023 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2022/04/19
## Modified 2025/08/30
## All rights reserved.
## 
## 
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package HTTP::Promise::Entity;
BEGIN
{
    use strict;
    use warnings;
    warnings::register_categories( 'HTTP::Promise' );
    use parent qw( Module::Generic );
    use vars qw( $VERSION $EXCEPTION_CLASS $BOUNDARY_DELIMITER $BOM2ENC $ENC2BOM $BOM_RE 
                 $BOM_MAX_LENGTH $DEFAULT_MIME_TYPE );
    use Data::UUID;
    use HTTP::Promise::Exception;
    use HTTP::Promise::Headers;
    use HTTP::Promise::Body;
    use Module::Generic::HeaderValue;
    # use Nice::Try;
    use Symbol;
    use URI::Escape::XS ();
    use constant CRLF => "\015\012";
    our $EXCEPTION_CLASS = 'HTTP::Promise::Exception';
    our $BOUNDARY_DELIMITER = "\015\012";
    our $DEFAULT_MIME_TYPE = 'application/octet-stream';
    our $VERSION = 'v0.2.2';
};

use strict;
use warnings;

sub init
{
    my $self = shift( @_ );
    $self->{body}           = undef;
    # Sie minimum from which compression is enabled, if mime type is suitable.
    # Defaults to 200Kb
    $self->{compression_min}= 204800;
    $self->{effective_type} = undef;
    $self->{epilogue}       = undef;
    $self->{ext_vary}       = undef;
    $self->{headers}        = undef;
    $self->{is_encoded}     = 0;
    $self->{output_dir}     = undef;
    $self->{preamble}       = undef;
    $self->{_init_strict_use_sub} = 1;
    $self->{_exception_class} = $EXCEPTION_CLASS;
    $self->SUPER::init( @_ ) || return( $self->pass_error );
    $self->{_parts} = [];
    return( $self );
}

sub add_part
{
    my $self = shift( @_ );
    my( $part, $index ) = @_;
    return( $self->error( "Part provided is not a HTTP::Promise::Entity object." ) ) if( !$self->_is_a( $part => 'HTTP::Promise::Entity' ) );
    my $parts = $self->_parts;
    $index = -1 if( !defined( $index ) );
    $index = $parts->size + 2 + $index if( $index < 0 );
    $parts->splice( $index, 0, $part );
    return( $part );
}

sub as_form_data
{
    my $self = shift( @_ );
    my $type = $self->headers->type;
    return(0) unless( lc( $type ) eq 'multipart/form-data' );
    $self->_load_class( 'HTTP::Promise::Body::Form::Data' ) || return( $self->pass_error );
    my $form = HTTP::Promise::Body::Form::Data->new;
    $form->debug( $self->debug // 0 );
    my $parts = $self->parts;

lib/HTTP/Promise/Entity.pm  view on Meta::CPAN

    $new_body = $body->clone if( defined( $body ) );
    my $parts = $self->parts;
    if( !$parts->is_empty )
    {
        $new_parts = $self->new_array;
        # Each part is an HTTP::Promise::Entity
        for( @$parts )
        {
            my $paddr = $self->_refaddr( $_ );
            # This would be weird, but let's do it anyway
            if( $paddr eq $addr )
            {
                $new_parts->push( $new );
                next;
            }
            my $new_part = $_->clone;
            $new_parts->push( $new_part );
        }
        $new->parts( $new_parts );
    }
    $new->headers( $new_headers ) if( defined( $new_headers ) );
    $new->body( $new_body ) if( defined( $new_body ) );
    $new->name( $self->name ) if( $self->name );
    $new->is_encoded( $self->is_encoded );
    $new->debug( $self->debug );
    $new->preamble( $self->preamble->clone );
    $new->epilogue( $self->epilogue->clone );
    $new->compression_min( $self->compression_min );
    $new->effective_type( $self->effective_type );
    my $msg;
    if( ( $msg = $self->http_message ) && $opts->{clone_message} )
    {
        # To prevent endless recursion
        my $new_msg = $msg->clone( clone_entity => 0 );
        $new_msg->headers( $new_headers );
        $new_msg->entity( $new );
        $new->http_message( $new_msg );
    }
    return( $new );
}

sub compression_min { return( shift->_set_get_number( 'compression_min', @_ ) ); }

# NOTE: an outdated method since nowadays everyone use UTF-8
# This is not intended to be a generic method, but instead to be used specifically for this entity
# content parameter can be provided to avoid reading from the body if we already have data handy.
sub content_charset
{
    my $self = shift( @_ );
    my $opts = $self->_get_args_as_hash( @_ );
    my $headers = $self->headers;
    # If parameter content_type_charset is set to false, this means it was just tried and 
    # we should not try it again.
    if( ( my $charset = $headers->content_type_charset ) && 
        ( !exists( $opts->{content_type_charset} ) || $opts->{content_type_charset} ) )
    {
        return( $charset );
    }

    $self->_load_class( 'Encode' ) || return( $self->pass_error );
    unless( defined( $BOM2ENC ) && scalar( %$BOM2ENC ) )
    {
        # Credits: Matthew Lawrence (File::BOM)
        our $BOM2ENC = +{
            map{ Encode::encode( $_, "\x{feff}" ) => $_ } qw(
                UTF-8
                UTF-16BE
                UTF-16LE
                UTF-32BE
                UTF-32LE
            )
        };

        our $ENC2BOM = +{
            reverse( %$BOM2ENC ),
            map{ $_ => Encode::encode( $_, "\x{feff}" ) } qw(
                UCS-2
                iso-10646-1
                utf8
            )
        };
        my @boms = sort{ length( $b ) <=> length( $a ) } keys( %$BOM2ENC );
        our $BOM_MAX_LENGTH = length( $boms[0] );
        {
            local $" = '|';
            our $BOM_RE = qr/@boms/;
        }
    }
    
    # time to start guessing
    # If called from decoded_content, kind of pointless to call decoded_content again
    my $cref;
    if( exists( $opts->{content} ) && length( $opts->{content} ) )
    {
        return( $self->error( "Unsupported data type (", ref( $opts->{content} ), ")." ) ) if( ref( $opts->{content} ) && !$self->_is_scalar( $opts->{content} ) );
        $cref = $self->_is_scalar( $opts->{content} ) ? $opts->{content} : \$opts->{content};
    }
    else
    {
        my $body = $self->body || return( '' );
        my $io = $body->open( '<', { binmode => 'raw' } ) ||
            return( $self->pass_error( $body->error ) );
        my $buff;
        my $bytes = $io->read( $buff, 4096 );
        return( $self->pass_error( $io->error ) ) if( !defined( $bytes ) );
        return( '' ) if( !$bytes );
        $cref = \$buff;
    }
    
    # Is there a Byte Order Mark?
    if( $$cref =~ /^($BOM_RE)/ )
    {
        my $bom = $1;
        return( $BOM2ENC->{ $bom } );
    }

    # Unicode BOM
    return( 'UTF-8' )    if( $$cref =~ /^\xEF\xBB\xBF/ );
    return( 'UTF-32LE' ) if( $$cref =~ /^\xFF\xFE\x00\x00/ );
    return( 'UTF-32BE' ) if( $$cref =~ /^\x00\x00\xFE\xFF/ );
    return( 'UTF-16LE' ) if( $$cref =~ /^\xFF\xFE/ );
    return( 'UTF-16BE' ) if( $$cref =~ /^\xFE\xFF/ );

    if( $headers->content_is_xml )
    {
        # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
        # XML entity not accompanied by external encoding information and not
        # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
        # in which the first characters must be '<?xml'
        return( 'UTF-32BE' ) if( $$cref =~ /^\x00\x00\x00</ );
        return( 'UTF-32LE' ) if( $$cref =~ /^<\x00\x00\x00/ );
        return( 'UTF-16BE' ) if( $$cref =~ /^(?:\x00\s)*\x00</ );
        return( 'UTF-16LE' ) if( $$cref =~ /^(?:\s\x00)*<\x00/ );
        if( $$cref =~ /^[[:blank:]\h]*(<\?xml[^\x00]*?\?>)/ )
        {
            if( $1 =~ /[[:blank:]\h\v]encoding[[:blank:]\h\v]*=[[:blank:]\h\v]*(["'])(.*?)\1/ )
            {
                my $enc = $2;
                $enc =~ s/^[[:blank:]\h]+//;
                $enc =~ s/[[:blank:]\h]+\z//;
                return( $enc ) if( $enc );
            }
        }
        return( 'UTF-8' );
    }
    elsif( $headers->content_is_text )
    {
        my $encoding = $self->guess_character_encoding( content => $cref, object => 1 );
        return( ref( $encoding ) ? $encoding->mime_name : $encoding ) if( $encoding );
    }
    elsif( $headers->content_type eq 'application/json' )
    {
        # RFC 4627, ch 3
        return( 'UTF-32BE' ) if( $$cref =~ /^\x00\x00\x00./s );
        return( 'UTF-32LE' ) if( $$cref =~ /^.\x00\x00\x00/s );
        return( 'UTF-16BE' ) if( $$cref =~ /^\x00.\x00./s );
        return( 'UTF-16LE' ) if( $$cref =~ /^.\x00.\x00/s );
        return( 'UTF-8' );
    }
    # if( $headers->content_type =~ /^text\// && $self->_load_class( 'Encode' ) )
    if( $headers->content_type =~ /^text\// )
    {
        if( length( $$cref ) )
        {
            return( 'US-ASCII' ) unless( $$cref =~ /[\x80-\xFF]/ );
            my $encoding;
            # try-catch
            local $@;
            eval
            {
                Encode::decode_utf8( $$cref, ( Encode::FB_CROAK | Encode::LEAVE_SRC ) );
                $encoding = 'UTF-8';
            };
            if( $@ )
            {
                return( $self->error( "Failed to decode utf8 content: $@" ) );
            }