File Coverage

lib/HTTP/Promise/Message.pm
Criterion Covered Total %
statement 468 558 83.8
branch 225 362 62.1
condition 108 209 51.6
subroutine 54 57 94.7
pod 32 40 80.0
total 887 1226 72.3


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Asynchronous HTTP Request and Promise - ~/lib/HTTP/Promise/Message.pm
3             ## Version v0.2.0
4             ## Copyright(c) 2023 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2022/03/21
7             ## Modified 2023/09/08
8             ## All rights reserved.
9             ##
10             ##
11             ## This program is free software; you can redistribute it and/or modify it
12             ## under the same terms as Perl itself.
13             ##----------------------------------------------------------------------------
14             package HTTP::Promise::Message;
15             BEGIN
16             {
17 7     7   284207 use strict;
  7         25  
  7         217  
18 7     7   36 use warnings;
  7         15  
  7         171  
19 7     7   42 use warnings::register;
  7         10  
  7         838  
20 7     7   41 use parent qw( Module::Generic );
  7         18  
  7         72  
21 7     7   297489 use vars qw( $DEBUG $ERROR $AUTOLOAD $CRLF $HTTP_VERSION );
  7         15  
  7         622  
22 7     7   1429 use Data::UUID;
  7         1819  
  7         786  
23 7     7   4611 require HTTP::Promise::Headers;
24             # use Nice::Try;
25 7     7   1790 use URI;
  7         16055  
  7         733  
26 7         33 our $CRLF = "\015\012";
27             # HTTP/1.0, HTTP/1.1, HTTP/2
28 7         54 our $HTTP_VERSION = qr/(?<http_protocol>HTTP\/(?<http_version>(?<http_vers_major>[0-9])(?:\.(?<http_vers_minor>[0-9]))?))/;
29 7         216 our $VERSION = 'v0.2.0';
30             };
31              
32 7     7   51 use strict;
  7         13  
  7         174  
33 7     7   38 use warnings;
  7         16  
  7         12663  
34              
35             sub init
36             {
37 96     96 1 97512 my $self = shift( @_ );
38 96         377 my( $headers, $content );
39 96 100 100     1598 if( @_ == 1 && ref( $_[0] ) eq 'HASH' )
    100 100        
    100 66        
      66        
40             {
41 34         117 my $opts = shift( @_ );
42 34         145 ( $headers, $content ) = CORE::delete( @$opts{qw( headers content )} );
43 34         168 @_ = %$opts;
44             }
45             elsif( @_ >= 1 &&
46             ( $self->_is_array( $_[0] ) ||
47             $self->_is_a( $_[0], 'HTTP::Promise::Headers' ) ||
48             $self->_is_a( $_[0], 'HTTP::Headers' ) ||
49             # HTTP::Promise::Message->new( undef, "some\ncontent" );
50             !defined( $_[0] )
51             ) )
52             {
53 46         2035 $headers = shift( @_ );
54             # Odd number of arguments and following argument is not an hash; or
55             # next argument is an hash
56             # this means the next parameter is the content
57             # $r->init( $headers, $content, name1 => value1, name2 => value2 );
58             # $r->init( $headers, $content, { name1 => value1, name2 => value2 } );
59             # First value must be either not a ref or a ref that stringifies
60 46 100 33     1371 if( ( !ref( $_[0] ) ||
      66        
      100        
61             ( ref( $_[0] ) && overload::Method( $_[0] => '""' ) ) ||
62             ( $self->_is_a( $_[0] => 'HTTP::Promise::Body' ) ) ||
63             ( $self->_is_a( $_[0] => 'HTTP::Promise::Body::Form' ) )
64             ) &&
65             (
66             @_ == 1 ||
67             # Odd number of parameters and the second one is not an hash ref:
68             # e.g.: $content, name1 => value1, name2 => value2
69             ( @_ > 2 && ( @_ % 2 ) && ref( $_[1] ) ne 'HASH' ) ||
70             # 2 params left and the second one is an hash reference:
71             # e.g.: $content, { name1 => value1, name2 => value2 }
72             ( @_ == 2 && ref( $_[1] ) eq 'HASH' )
73             )
74             )
75             {
76 29         128 $content = shift( @_ );
77             }
78             }
79             elsif( @_ && ref( $_[0] ) ne 'HASH' )
80             {
81 1         139 return( $self->error( "Bad header argument: ", $_[0] ) );
82             }
83            
84 95 100       1548 if( defined( $headers ) )
85             {
86 45 100 66     326 if( $self->_is_a( $headers, 'HTTP::Promise::Headers' ) || $self->_is_a( $headers, 'HTTP::Headers' ) )
    50          
87             {
88 16         740 $headers = $headers->clone;
89 16         82 $headers = bless( $headers => 'HTTP::Promise::Headers' );
90             }
91             elsif( $self->_is_array( $headers ) )
92             {
93 29         1665 $headers = HTTP::Promise::Headers->new( @$headers );
94             }
95             else
96             {
97 0         0 return( $self->error( "Unknown headers value passed. I was expecting an HTTP::Promise::Headers, or HTTP::Headers object or an array reference, but instead I got '$headers' (", overload::StrVal( $headers ), ")." ) );
98             }
99             }
100             else
101             {
102 50         480 $headers = HTTP::Promise::Headers->new;
103             }
104            
105 95 50 66     1073 if( !defined( $content ) && $headers->exists( 'Content' ) )
106             {
107 0         0 ( $content ) = $headers->remove_header( 'Content' );
108             # $content = $headers->header( 'Content' );
109             # $headers->remove_header( 'Content' );
110             }
111            
112 95 100       367 if( defined( $content ) )
113             {
114 29 100       227 $self->_utf8_downgrade( $content ) || return( $self->pass_error );
115             }
116            
117             # $self->{content} = $content;
118 94 50       821 $self->{entity} = undef unless( CORE::exists( $self->{entity} ) );
119 94         367 $self->{headers} = $headers;
120 94 50       591 $self->{protocol} = undef unless( exists( $self->{protocol} ) );
121 94 100       426 $self->{version} = '' unless( exists( $self->{version} ) );
122 94         226 $self->{_init_strict_use_sub} = 1;
123 94 50       487 $self->SUPER::init( @_ ) || return( $self->pass_error );
124 94         199478 my $ent = $self->entity;
125 94 50       2644 unless( $ent )
126             {
127 94 50       393 $self->_load_class( 'HTTP::Promise::Entity' ) || return( $self->pass_error );
128 94         4342 $ent = HTTP::Promise::Entity->new( headers => $headers, debug => $self->debug );
129 94         755 $self->entity( $ent );
130             }
131 94         3529 $ent->http_message( $self );
132 94         3469 $ent->debug( $self->debug );
133 94         3352 $headers->debug( $self->debug );
134            
135             # Even if it is zero bytes big, we still create the body
136             # If a $content was provided, we store it in a in-memory body
137             # If the user
138 94 100       344 if( defined( $content ) )
139             {
140 28 50       183 if( $self->_is_a( $content => [qw( HTTP::Promise::Body HTTP::Promise::Body::Form )] ) )
141             {
142 0 0       0 $ent->body( $content ) || return( $self->pass_error( $ent->error ) );
143             }
144             else
145             {
146 28         643 my $body = $ent->new_body( string => \$content );
147 28 50       98 return( $self->pass_error( $ent->error ) ) if( !defined( $body ) );
148 28         122 $ent->body( $body );
149             }
150             # If Content-Encoding is set, then set is_encoded to true
151 28 100       1353 if( $headers->content_encoding->length )
152             {
153 7         258387 $ent->is_encoded(1);
154             }
155             }
156             # There is no parts in this object. Everything is held in HTTP::Promise::Entity
157             # $self->{_parts} = [];
158 94         15164 return( $self );
159             }
160              
161             sub add_content
162             {
163 5     5 1 1747 my $self = shift( @_ );
164 5 50       38 if( defined( $_[0] ) )
165             {
166 5 100       33 $self->_utf8_downgrade( $self->_is_scalar( $_[0] ) ? ${$_[0]} : $_[0] ) ||
  1 100       16  
167             return( $self->pass_error );
168             }
169 4         21 my( $ent, $body );
170 4 50       29 unless( $ent = $self->entity )
171             {
172 0 0       0 $self->_load_class( 'HTTP::Promise::Entity' ) || return( $self->pass_error );
173 0         0 $ent = HTTP::Promise::Entity->new( debug => $self->debug );
174             }
175            
176 4         143 $body = $ent->body;
177 4 100       106 if( $body )
178             {
179 3 50       31 return( $self->error( "Unable to append to an entity body other than a HTTP::Promise::Body::Scalar" ) ) if( !$self->_is_a( $body => 'HTTP::Promise::Body::Scalar' ) );
180 3         194 $body->append( $_[0] );
181             }
182             else
183             {
184 1   50     20 $body = $ent->new_body( string => $_[0] ) ||
185             return( $self->pass_error( $ent->error ) );
186 1         11 $ent->body( $body );
187             }
188 4         103 return( $body );
189             }
190              
191             sub add_content_utf8
192             {
193 2     2 1 812 my( $self, $buff ) = @_;
194 2         18 utf8::upgrade( $buff );
195 2         7 utf8::encode( $buff );
196 2         19 return( $self->add_content( $buff ) );
197             }
198              
199             # Adding part will automatically makes it a multipart/form-data if not set already
200             # There is no such thing as multipart/mixed in HTTP
201             sub add_part
202             {
203 4     4 1 22 my $self = shift( @_ );
204 4         21 my $ent = $self->entity;
205 4         106 my $headers = $self->headers;
206 4 50       21 unless( $ent )
207             {
208 0 0       0 $self->_load_class( 'HTTP::Promise::Entity' ) || return( $self->pass_error );
209 0         0 $ent = HTTP::Promise::Entity->new( headers => $headers, debug => $self->debug );
210 0         0 $self->entity( $ent );
211             }
212 4 100 100     94 if( ( $self->content_type || '' ) !~ m,^multipart/, )
    50 33        
    50 66        
213             {
214 2 50       58 $ent->make_multipart( 'form-data' ) || return( $self->pass_error( $ent->error ) );
215             }
216             # elsif( $self->_parts->is_empty && ( $self->entity && $self->entity->body && !$self->entity->body->is_empty ) )
217             elsif( $ent->parts->is_empty && ( $ent->body && !$ent->body->is_empty ) )
218             {
219             # Should really use HTTP::Promise::Entity->make_multipart
220 0         0 $self->_make_parts;
221             }
222             elsif( $self->content_type->index( 'boundary' ) == -1 )
223             {
224 2         74460 my $ct = $headers->new_field( 'Content-Type' => $self->content_type );
225 2         11 $ct->boundary( $self->make_boundary );
226 2         1189 $self->content_type( $ct );
227             }
228            
229 4         911 my @new = ();
230 4         392 my $name;
231 4         26 for( my $i = 0; $i < scalar( @_ ); $i++ )
232             {
233 4         16 my $this = $_[$i];
234             # If this is a string or a scalar reference
235 4 50 33     76 if( defined( $this ) &&
      33        
236             ( !ref( $this ) || ( $self->_is_scalar( $this ) && overload::Method( $this => '""' ) ) ) )
237             {
238 0         0 $name = $this;
239 0         0 next;
240             }
241            
242             # Either a HTTP::Promise::Request, or a HTTP::Promise::Response, or even a HTTP::Promise::Message
243 4 50       79 unless( $self->_is_a( $this => 'HTTP::Promise::Entity' ) )
244             {
245 4 50       223 return( $self->error( "Part object provided (", overload::StrVal( $this ), ") is neither a HTTP::Promise::Entity or a HTTP::Promise::Message object." ) ) if( !$self->_is_a( $this => 'HTTP::Promise::Message' ) );
246 4         163 my $part_ent = $this->entity;
247 4 50       143 unless( $part_ent )
248             {
249 0   0     0 $part_ent = HTTP::Promise::Entity->new( headers => $this->headers, debug => $self->debug ) ||
250             return( $self->pass_error );
251 0         0 $this->entity( $part_ent );
252             }
253 4 50       25 $part_ent->name( $name ) if( defined( $name ) );
254 4         19 push( @new, $part_ent );
255 4         21 undef( $name );
256 4         15 next;
257             }
258 0 0       0 $this->name( $name ) if( defined( $name ) );
259 0         0 undef( $name );
260 0         0 push( @new, $this );
261             }
262            
263 4         24 $ent->parts->push( @new );
264 4         2223 return( $self );
265             }
266              
267             sub as_form_data
268             {
269 0     0 1 0 my( $self, $eol ) = @_;
270 0         0 my $type = $self->headers->type;
271 0   0     0 $type = lc( $type // '' );
272 0 0       0 $self->_load_class( 'HTTP::Promise::Body::Form' ) || return( $self->pass_error );
273 0         0 my $payload = $self->decoded_content_utf8->scalar;
274 0         0 my $uri;
275 0 0 0     0 if( $type eq 'multipart/form-data' )
    0 0        
    0 0        
      0        
276             {
277 0         0 return( $self->entity->as_form_data );
278             }
279             elsif( $type eq 'application/json' )
280             {
281 0 0       0 return( HTTP::Promise::Body::Form->new ) unless( length( $payload ) );
282 0         0 my $form;
283             # try-catch
284 0         0 local $@;
285             eval
286 0         0 {
287 0         0 my $hash = $self->new_json->decode( $payload );
288 0         0 $form = HTTP::Promise::Body::Form->new( $hash );
289             };
290 0 0       0 if( $@ )
291             {
292 0         0 return( $self->error( "Error trying to decode the JSON payload: $@" ) );
293             }
294 0         0 return( $form );
295             }
296             elsif( $self->can( 'uri' ) &&
297             ( $uri = $self->uri ) &&
298             $uri->query &&
299             ( !defined( $payload ) || !length( $payload ) ) )
300             {
301 0         0 my $hash = $uri->query_form_hash;
302 0         0 return( HTTP::Promise::Body::Form->new( $hash ) );
303             }
304             # elsif( $type eq 'application/x-www-form-urlencoded' )
305             else
306             {
307 0 0 0     0 return( length( $payload // '' ) ? HTTP::Promise::Body::Form->new( $payload ) : HTTP::Promise::Body::Form->new );
308             }
309             }
310              
311             sub as_string
312             {
313 24     24 1 14591 my( $self, $eol ) = @_;
314 24 100       151 $eol = $CRLF unless( defined( $eol ) );
315 24         101 my $ent = $self->entity;
316             # If there is no entity, we just print the headers and that's it.
317 24 50       811 return( $ent ? $ent->as_string( $eol ) : join( $eol, $self->start_line( $eol ), $self->headers->as_string( $eol ) ) . $eol );
318             }
319              
320 6     6 1 39218 sub boundary { return( shift->headers->boundary ); }
321              
322             sub can
323             {
324 115     115 1 227606 my( $self, $method ) = @_;
325              
326 115 100       798 if( my $own_method = $self->SUPER::can( $method ) )
327             {
328 89         322 return( $own_method );
329             }
330              
331 26 100       168 my $headers = ref( $self ) ? $self->headers : 'HTTP::Promise::Headers';
332 26         150 my $trace = '';
333 26   50     101 my $debug = $self->debug // 0;
334 26 100       887 if( $headers->can( $method ) )
335             {
336             # We create the function here so that it will not need to be
337             # autoloaded or recreated the next time.
338 7     7   59 no strict 'refs';
  7         20  
  7         11484  
339 12     46 0 1135 eval( <<EOT );
  19     22 1 74  
  5     19 0 3867  
        5 0    
          0    
340             sub $method { return( shift->headers->$method( \@_ ) ); }
341             EOT
342 12   50     127 my $ref = $self->UNIVERSAL::can( $method ) || die( "AUTOLOAD inconsistency error for dynamic sub \"$method\"." );
343 12         49 return( $ref );
344             }
345             else
346             {
347             }
348 14         51 return;
349             }
350              
351             sub clear
352             {
353 4     4 1 38382 my $self = shift( @_ );
354 42         12271 $self->headers->clear;
355 4 100 66     23 $self->entity->body->empty if( $self->entity && $self->entity->body );
356             # $self->_parts->reset;
357 5 50       137 $self->entity->parts->reset if( $self->entity );
358 8         2151 return;
359             }
360              
361             sub clone
362             {
363 10     48 1 3480 my $self = shift( @_ );
364 9         105 my $opts = $self->_get_args_as_hash( @_ );
365 9   100     569 $opts->{clone_entity} //= 1;
366             # my $new = $self->new( [], undef );
367 9         434 my $new = $self->SUPER::clone;
368 9         4685 my $new_headers;
369             my $ent;
370 9 100 66     75 if( ( $ent = $self->entity ) && $opts->{clone_entity} )
371             {
372 7         381 my $new_ent = $ent->clone( clone_message => 0 );
373 7         73 $new_headers = $new_ent->headers;
374 7         226 $new_ent->http_message( $new );
375 7         381 $new->entity( $new_ent );
376             }
377             else
378             {
379 2         70 $new_headers = $self->headers->clone;
380             }
381 9         823 $new->headers( $new_headers );
382 9         212 my $proto = $self->protocol;
383 9         7372 my $vers = $self->version;
384 9 100 66     7107 $new->protocol( "$proto" ) if( defined( $proto ) && length( $proto ) );
385 9 100 66     884 $new->version( "$vers" ) if( defined( $vers ) && length( $vers ) );
386 9         37677 $new->debug( $self->debug );
387 9         517 return( $new );
388             }
389              
390             sub content
391             {
392 46     47 1 39526 my $self = shift( @_ );
393 46 100       199 if( @_ )
394             {
395 17         46 my $has_ref = 0;
396 17         50 for( @_ )
397             {
398 17 100       54 next unless( defined( $_ ) );
399 16 100 100     101 return( $self->error( "I was expecting a string or a scalar reference, but instead got ", ref( $_ ) ) ) if( ref( $_ ) && !$self->_is_scalar( $_ ) );
400             # This affects how we set the content
401 15 100       91 $has_ref++ if( $self->_is_scalar( $_ ) );
402 15 100       194 $self->_utf8_downgrade( $self->_is_scalar( $_ ) ? $$_ : $_ ) ||
    100          
403             return( $self->pass_error );
404             }
405             # $self->_parts->reset;
406 15         50 my $ent = $self->entity;
407 15 50       384 unless( $ent )
408             {
409 0         0 my $headers = $self->headers;
410 0 0       0 $self->_load_class( 'HTTP::Promise::Entity' ) || return( $self->pass_error );
411 0         0 $ent = HTTP::Promise::Entity->new( headers => $headers, debug => $self->debug );
412 0         0 $self->entity( $ent );
413             }
414 15         74 my $body = $ent->body;
415 15 100       336 unless( $body )
416             {
417 7         51 $body = $ent->new_body( string => '' );
418 7 50       24 return( $self->pass_error( $ent->error ) ) if( !defined( $body ) );
419             # $ent->body( $body ) || return( $self->pass_error( $ent->error ) );
420 7         18 my $rv = $ent->body( $body );
421 7 50       319 if( !defined( $rv ) )
422             {
423             }
424 7 50       20 return( $self->pass_error( $ent->error ) ) if( !defined( $rv ) );
425             }
426            
427 15   50     158 my $io = $body->open( '+>', { binmode => 'raw', autoflush => 1 } ) ||
428             return( $self->pass_error( $body->error ) );
429 15 50       3561 if( $has_ref > 1 )
430             {
431 0         0 for( @_ )
432             {
433 0 0       0 $io->print( $self->_is_scalar( $_ ) ? $$_ : $_ ) || return( $self->pass_error( $io->error ) );
    0          
434             }
435             }
436             else
437             {
438 15 100 66     167 $io->print( ( @_ == 1 && $self->_is_scalar( $_[0] ) ) ? ${$_[0]} : @_ ) || return( $self->pass_error( $io->error ) );
  1 50       43  
439             }
440 15         1764 $io->close;
441 15         1356 $ent->parts->reset;
442 15         9048 return( $body );
443             }
444             else
445             {
446 29         112 my $ent = $self->entity;
447 29 50       919 return( '' ) if( !$ent );
448 29         142 my $body = $ent->body;
449 29 100       735 return( '' ) if( !$body );
450             # This is a real bad idea if the body is huge...
451             # NOTE: content() returns a scalar object (Module::Generic::Scalar)
452 28         201 return( $body->as_string );
453             }
454             }
455              
456             # NOTE: an outdated method since nowadays everyone use UTF-8
457             sub content_charset
458             {
459 5     7 1 487 my $self = shift( @_ );
460 5         13 my $ent = $self->entity;
461 5 50       125 return( '' ) unless( $ent );
462 5         31 return( $ent->content_charset );
463             }
464              
465             sub content_ref
466             {
467 4     9 1 1628 my $self = shift( @_ );
468 4 100       21 if( @_ )
469             {
470 1 50       7 return( $self->error( "Value provided is not a scalar reference." ) ) unless( $self->_is_scalar( $_[0] ) );
471 1         18 return( $self->content( @_ ) );
472             }
473             else
474             {
475 3         22 my $content = $self->content;
476 3         100 return( $content );
477             }
478             }
479              
480             sub decodable
481             {
482 2     3 1 21 my $self = shift( @_ );
483 2         12 local $@;
484 2 50       10 $self->_load_class( 'HTTP::Promise::Stream' ) || return( $self->pass_error );
485 2   50     79 my $all = HTTP::Promise::Stream->decodable( 'browser' ) ||
486             return( $self->error( HTTP::Promise::Stream->pass_error ) );
487 2         58 return( $all );
488             }
489              
490             sub decode
491             {
492 6     6 1 7507 my $self = shift( @_ );
493 6         43 my $headers = $self->headers;
494 6         66 my $ce = $headers->content_encoding;
495 6 100 66     150 return(1) if( !$ce || $ce->is_empty );
496 5   50     183 my $ent = $self->entity || return(1);
497 5         286 my $encodings = $ce->split( qr/[[:blank:]]*,[[:blank:]]*/ )->reverse->object;
498 5 50       1098 return(1) if( $encodings->is_empty );
499 5   100     263 my $body = $ent->decode_body( $encodings ) || return( $self->pass_error( $ent->error ) );
500             # Altering existing headers value is really really bad. This is done in HTTP::Message,
501             # but not in our class
502             # $self->remove_header( qw( Content-Encoding Content-Length Content-MD5 ) );
503 4         46 return(1);
504             }
505              
506             sub decode_content
507             {
508 20     20 1 64 my $self = shift( @_ );
509 20   50     72 my $ent = $self->entity || return(0);
510 20         587 my $opts = $self->_get_args_as_hash( @_ );
511 20   50     3256 my $body = $ent->body || return(0);
512 20 100       140 return( $body ) if( !$ent->is_encoded );
513 13         9210 my $ce = $self->headers->content_encoding;
514 13 100       369 if( $ce )
515             {
516             # object(9 is a noop to ensure an object is returned and not a list
517 12   100     241 $body = $ent->decode_body( $ce->split( qr/[[:blank:]\h]*\,[[:blank:]\h]*/ )->reverse->object, ( scalar( keys( %$opts ) ) ? $opts : () ) ) || return( $self->pass_error( $ent->error ) );
518             # $ent->is_decoded(1);
519             }
520 11         122 return( $body );
521             }
522              
523             sub decoded_content
524             {
525 20     20 1 20709 my $self = shift( @_ );
526 20         129 my $opts = $self->_get_args_as_hash( @_ );
527 20   100     2168 $opts->{charset_strict} //= 0;
528 20         170 my $old_fatal = $self->fatal;
529 20 100       16215 $self->fatal( $opts->{raise_error} ? 1 : 0 );
530 20 50       17431 my $body = $self->decode_content( ( scalar( keys( %$opts ) ) ? $opts : () ) );
531 19 100       14053 return( $self->pass_error ) if( !defined( $body ) );
532             # There is no entity or no body
533 18 50       96 if( !$body )
534             {
535 0         0 return( $self->new_scalar );
536             }
537 18         153 $self->fatal( $old_fatal );
538 18         16399 my $dummy = '';
539 18 0       225 return( $opts->{ref} ? \$dummy : $dummy ) if( $body->is_empty );
    50          
540 18 100       287 unless( $opts->{binmode} )
541             {
542             # Need to explicitly provide the body to get the encoding from, otherwise, io_encoding()
543             # would get the default one, which might not yet be replaced with its decoded version.
544 11         81 my $enc = $self->entity->io_encoding( body => $body, charset_strict => $opts->{charset_strict} );
545 11 100       5099 $opts->{binmode} = $enc if( $enc );
546             }
547            
548             # Because of an edge case where open with :binmode(utf-8) layer does not decode properly \x{FF}
549             # but Encode::decode( 'utf-8', $buff ) does, and since the body is loaded into a string
550             # anyway, we first read the data as raw and then decode it with Encode
551 18         60 my $binmode;
552 18 50 66     387 if( exists( $opts->{binmode} ) &&
      66        
553             length( $opts->{binmode} ) &&
554             lc( substr( $opts->{binmode}, 0, 3 ) ) eq 'utf' )
555             {
556 15         81 $binmode = delete( $opts->{binmode} );
557 15         115 $opts->{binmode} = 'raw';
558             }
559 18 50       221 my $content = $body->as_string( ( scalar( keys( %$opts ) ) ? $opts : () ) );
560 18 50       1926 if( !defined( $content ) )
561             {
562 0         0 return( $self->pass_error( $body->error ) );
563             }
564 18 100       62 if( defined( $binmode ) )
565             {
566 15 50       134 $self->_load_class( 'Encode' ) || return( $self->pass_error );
567             # try-catch
568 15         673 local $@;
569             eval
570 15         35 {
571 15         295 $$content = Encode::decode( $binmode, $$content, ( Encode::FB_DEFAULT | Encode::LEAVE_SRC ) );
572             };
573 15 50       1011 if( $@ )
574             {
575 0         0 return( $self->error( "Error decoding body content with character encoding '$binmode': $@" ) );
576             }
577             }
578            
579             # $content is a scalar object that stringifies
580 18 100       195 if( $self->headers->content_is_xml )
581             {
582             # Get rid of the XML encoding declaration if present (\x{FEFF})
583 7     7   1950 $$content =~ s/^\N{BOM}//;
  7         28741  
  7         110  
  2         42  
584 2 50       36 if( $$content =~ m/^(?<decl>[[:blank:]\h\v]*<\?xml(.*?)\?>)/is )
585             {
586 2     39   71 substr( $$content, 0, length( $+{decl} ) ) =~ s{
  39         41331  
  49         2081  
  25         10973  
587             [[:blank:]\h\v]+
588             encoding[[:blank:]\h\v]*=[[:blank:]\h\v]*
589             (?<quote>["'])
590             (?<encoding>(?>\\\g{quote}|(?!\g{quote}).)*+)
591             \g{quote}
592             }
593             {}xmis;
594             }
595 18         441 }
596             return( $content );
597             }
598              
599             sub decoded_content_utf8
600 0     0 1 0 {
601 0         0 my $self = shift( @_ );
602 0         0 my $opts = $self->_get_args_as_hash( @_ );
603 0         0 $opts->{binmode} = 'utf-8';
604 0 0       0 my $data = $self->decoded_content( $opts );
605             if( $self->headers->content_is_xml )
606             {
607 0         0 # Get rid of the XML encoding declaration if present
608             $$data =~ s/^\x{FEFF}//;
609 0 0       0
610             if( $$data =~ /^(\s*<\?xml[^\x00]*?\?>)/ )
611 0         0 {
612             substr( $$data, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//;
613             }
614 0         0 }
615             return( $data );
616             }
617              
618             sub dump
619 11     11 1 1611 {
620 11         63 my $self = shift( @_ );
621 11         1654 my $opts = $self->_get_args_as_hash( @_ );
622 11         50 my $content = '';
623 11         284 my $ent = $self->entity;
624 11 50       38 my $maxlen = $opts->{maxlength};
625 11         27 $maxlen = 512 unless( defined( $maxlen ) );
626 11 100       65 my $no_content = $opts->{no_content};
627 11 100 66     78 $no_content = "(no content)" unless( defined( $no_content ) );
628             if( $ent && $ent->body )
629 4   50     16 {
630             my $io = $ent->body->open( '<', { binmode => 'raw' } ) ||
631 4         264 return( $self->pass_error( $ent->error ) );
632 4 50       529 my $bytes = $io->read( $content, $maxlen );
633 4         21 return( $self->pass_error( $io->error ) ) if( !defined( $bytes ) );
634             $io->close;
635 11         949 }
636 11 100       40 my $chopped = 0;
637             if( length( $content ) )
638 4 50       20 {
639             if( $ent->body->length > $maxlen )
640 0         0 {
641 0         0 $content .= '...';
642             $chopped = $ent->body->length - $maxlen;
643 4         287777 }
644 4         619 $content =~ s/\\/\\\\/g;
645 4         14 $content =~ s/\t/\\t/g;
646             $content =~ s/\r/\\r/g;
647              
648 4         21 # no need for 3 digits in escape for these
  8         49  
649             $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
650 4         15  
  14         48  
651 4         13 $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
  0         0  
652             $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
653              
654 4         10 # remaining whitespace
  0         0  
655 4         7 $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
  0         0  
656 4         8 $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
657 4 100       19 $content =~ s/\n\z/\\n/;
658             if( $content eq $no_content )
659             {
660 1         6 # escape our $no_content marker
  1         9  
661             $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
662             }
663             }
664             else
665 7         12 {
666             $content = $no_content;
667             }
668 11         28
669 11 100       44 my @dump;
670 11         62 push( @dump, $opts->{preheader} ) if( $opts->{preheader} );
671 11 50       43 push( @dump, $self->headers->as_string, $content );
672             push( @dump, "(+ $chopped more bytes not shown)" ) if( $chopped );
673 11         45  
674 11 100       66 my $dump = join( "\n", @dump, '' );
675             $dump =~ s/^/$opts->{prefix}/gm if( $opts->{prefix} );
676 11 100       572  
677 11         125 print( $dump ) unless( defined( wantarray() ) );
678             return( $dump );
679             }
680              
681             sub encode
682 9     9 1 1197 {
683 9         90 my $self = shift( @_ );
684 9         1751 my $opts = $self->_get_args_as_hash( \@_, args_list => [qw( update_header )] );
685 9   100     101 my( @enc ) = @_;
686             $opts->{update_header} //= 1;
687 9 100       326  
688 8 100       736 return( $self->error( "Cannot encode multipart/* messages" ) ) if( $self->content_type =~ m,^multipart/, );
689 7         200 return( $self->error( "Cannot encode message/* messages" ) ) if( $self->content_type =~ m,^message/, );
690 7         73 my $headers = $self->headers;
691 7         2854 my $e = $headers->content_encoding->split( qr/[[:blank:]\h]*,[[:blank:]\h]*/ );
692 7         63 my $source = 'argv';
693 7 100       67 my $encodings;
694             if( @enc )
695 6         38 {
696             $encodings = $self->new_array( \@enc );
697             }
698             else
699 1         4 {
700 1         7 $source = 'header';
701             $encodings = $e;
702             }
703 7 100 66     310 # nothing to do
704 6   50     208 return(1) if( !$encodings || $encodings->is_empty );
705 6         243 my $ent = $self->entity || return(1);
706 6   100     210 $encodings->unique(1);
707 5         93 my $body = $ent->encode_body( $encodings ) || return( $self->pass_error( $ent->error ) );
708 5 50       4383 $ent->is_encoded(1);
709             if( $opts->{update_header} )
710 5 50       46 {
711             if( $source eq 'argv' )
712 5 100       42 {
713             if( $e )
714 2         51 {
715             $e->push( $encodings->list );
716             }
717             else
718 3         28 {
719             $e = $encodings;
720 5         145 }
721             $e->unique(1);
722 5         192 }
723 5         45 $headers->content_encoding( $e->join( ', ' )->scalar );
724             $headers->remove_header( qw( Content-Length Content-MD5 ) );
725 5         193 }
726             return(1);
727             }
728              
729             # sub entity { return( shift->_set_get_object_without_init( 'entity', 'HTTP::Promise::Entity', @_ ) ); }
730             sub entity
731 408     408 1 16410 {
732 408 100       1660 my $self = shift( @_ );
733             if( @_ )
734 117         538 {
735             return( $self->_set_get_object_without_init( 'entity', 'HTTP::Promise::Entity', @_ ) );
736 291 100 100     1398 }
737             if( $self->_is_a( $self->{entity} => 'HTTP::Promise::Entity' ) &&
738             !$self->{entity}->{http_message} )
739 3         147 {
740             $self->{entity}->{http_message} = $self;
741 291         10237 }
742             return( $self->_set_get_object_without_init( 'entity', 'HTTP::Promise::Entity' ) );
743             }
744 93     93 1 16308  
745             sub header { return( shift->headers->header( @_ ) ); }
746              
747             sub headers
748 376     376 1 6754 {
749 376 100       1910 my $self = shift( @_ );
    50          
750             if( @_ )
751 11         27 {
752 11 50       52 my $v = shift( @_ );
    0          
    0          
753             if( $self->_is_a( $v, 'HTTP::Promise::Headers' ) )
754 11         502 {
755             $self->{headers} = $v;
756             }
757             elsif( $self->_is_a( $v, 'HTTP::Headers' ) )
758 0         0 {
759 0         0 my $h = $v->clone;
760             $self->{headers} = bless( $h => 'HTTP::Promise::Headers' );
761             }
762             elsif( $self->_is_array( $v ) )
763 0         0 {
764             $self->{headers} = HTTP::Promise::Headers->new( @$v );
765             }
766             else
767 0         0 {
768             return( $self->error( "Bad value for headers. I was expecting either an array reference or a HTTP::Promise::Headers or a HTTP::Headers object and I got instead '", overload::StrVal( $v ), "'." ) );
769             }
770             }
771             elsif( !$self->{headers} )
772 0         0 {
773             $self->{headers} = HTTP::Promise::Headers->new;
774 376         2205 }
775             return( $self->{headers} );
776             }
777 1     1 1 5  
778             sub headers_as_string { return( shift->headers->as_string( @_ ) ); }
779              
780             sub is_encoding_supported
781 2     2 1 2152 {
782 2         21 my $self = shift( @_ );
783 2 50 33     176 my $enc = shift( @_ );
784 2 50       40 return( $self->error( "No encoding provided." ) ) if( !defined( $enc ) || !length( $enc ) );
785 2         193 $self->_load_class( 'HTTP::Promise::Stream' ) || return( $self->error );
786             return( HTTP::Promise::Stream->supported( lc( $enc ) ) );
787             }
788              
789             sub make_boundary
790 2     2 1 66 {
791 2         289 my $self = shift( @_ );
792 2         483 my $uuid = Data::UUID->new;
793 2         16817 my $boundary = $uuid->create_str;
794             return( "$boundary" );
795             }
796              
797             sub parse
798 12     12 1 52780 {
799 12         43 my $self = shift( @_ );
800 12 50       50 my $str = shift( @_ );
801 12         83 return( $self->error( "No http headers string was provided to parse." ) ) if( !defined( $str ) );
802 12 50 33     2015 my $opts = $self->_get_args_as_hash( @_ );
803             $opts->{debug} = $self->debug if( !CORE::exists( $opts->{debug} ) && ref( $self ) );
804 12 100       104 # Nothing to parse, we return a dummy object in line with legacy api of HTTP::Message
805             if( !length( "${str}" ) )
806 1         5 {
807             return( HTTP::Promise::Message->new( { debug => $opts->{debug} } ) );
808 11 50       100 }
809 11 50       121 $self = HTTP::Promise::Message->new( { debug => $opts->{debug} } ) if( !ref( $self ) );
810 11         824 $self->_load_class( 'HTTP::Promise::Parser' ) || return( $self->pass_error );
811 11         253 my $p = HTTP::Promise::Parser->new( debug => $opts->{debug} );
812 11         131 my $copy = $str;
813 11         104 $copy =~ s/\r/\\r/g;
814 11         190 $copy =~ s/\n/\\n/g;
815 11 100       45616 my $ent = $p->parse( \$str );
816             if( !defined( $ent ) )
817             {
818 8         37 # We do not support the legacy way of accepting an HTTP message that has no header
819             return( $self->pass_error( $p->error ) );
820 3         18 }
821 3 50       129 my $msg = $ent->http_message;
822             unless( $msg )
823 3         23 {
824 3         129 my $headers = $ent->headers;
825 3         28 $msg = HTTP::Promise::Message->new( $headers );
826             $msg->entity( $ent );
827 3         155 }
828             return( $msg );
829             }
830              
831             # NOTE: parts() will parse the current content and break it down into parts if applicable
832             # otherwise, it will simply return the array object $parts, which would be empty.
833             # It would be nice to come up with some efficient caching mechanism to avoid the if..elsif
834             # at the beginning of the subroutine.
835             sub parts
836 14     14 1 45868 {
837 14         47 my $self = shift( @_ );
838 14 100 66     508 my $ent = $self->entity;
    100 100        
      100        
      66        
      100        
      66        
839             if( $ent &&
840             $ent->parts->is_empty &&
841             $ent->body &&
842             !$ent->body->is_empty )
843 2 50       89 {
844             $self->_make_parts || return( $self->pass_error );
845             }
846             elsif( $ent &&
847             $ent->parts->is_empty &&
848             $ent->body &&
849             $ent->body->is_empty )
850 1         30 {
851             $ent->body( undef );
852             }
853 14 50       4508
854             unless( $ent )
855 0 0       0 {
856 0   0     0 $self->_load_class( 'HTTP::Promise::Entity' ) || return( $self->_pass_error );
857             $ent = HTTP::Promise::Entity->new( headers => $self->headers, debug => $self->debug ) ||
858 0         0 return( $self->pass_error( HTTP::Promise::Entity->error ) );
859             $self->entity( $ent );
860             }
861            
862 14 100       80 # Parts have been provided, add them if suitable
863             if( @_ )
864 5 100       19 {
  8         56  
865 5   100     205 my @parts = map{ $self->_is_array( $_ ) ? @$_ : $_ } @_;
866 5 100       90 my $ct = $self->content_type || '';
    100          
867             if( $ct =~ m,^message/, )
868 1 50       31 {
869             return( $self->error( "Only one part allowed for $ct content" ) ) if( @parts > 1 );
870             }
871             elsif( $ct !~ m,^multipart/, )
872 2         32 {
873 2         65 $self->remove_content_headers;
874             $self->content_type( 'multipart/mixed' );
875             }
876 4 50       68 # $self->_parts( \@parts );
877 4         233 $self->_load_class( 'HTTP::Promise::Entity' ) || return( $self->pass_error );
878 4         13 my @new = ();
879             for( @parts )
880             {
881 5 50       20 # Either a HTTP::Promise::Request, or a HTTP::Promise::Response, or even a HTTP::Promise::Message
882             unless( $self->_is_a( $_ => 'HTTP::Promise::Entity' ) )
883 5 50       192 {
884 5         155 return( $self->error( "Part object provided (", overload::StrVal( $_ ), ") is neither a HTTP::Promise::Entity or a HTTP::Promise::Message object." ) ) if( !$self->_is_a( $_ => 'HTTP::Promise::Message' ) );
885 5 50       125 my $ent = $_->entity;
886             unless( $ent )
887 0   0     0 {
888             $ent = HTTP::Promise::Entity->new( headers => $_->headers, debug => $self->debug ) ||
889 0         0 return( $self->pass_error );
890             $_->entity( $ent );
891 5         18 }
892 5         13 push( @new, $ent );
893             next;
894 0         0 }
895             push( @new, $_ );
896 4         38 }
897             $ent->parts( \@new );
898 13         3676 }
899 13         10362 my $parts = $ent->parts;
900             return( $parts );
901             }
902              
903             sub protocol
904 40     40 1 6912 {
905 40 100       155 my $self = shift( @_ );
906             if( @_ )
907 14         47 {
908 14         136 my $v = shift( @_ );
909 14 50       369 $v =~ s/^[[:blank:]\h]+|[[:blank:]\h]+$//g;
910             if( $v =~ m,^${HTTP_VERSION}$, )
911 14         121 {
912             $self->version( $+{http_version} );
913             }
914             else
915 0         0 {
916             return( $self->error( "Bad protocol value \"$v\". It should be something like HTTP/1.1" ) );
917 14         520036 }
918             return( $self->_set_get_scalar_as_object( protocol => $v ) );
919 26         153 }
920             return( $self->_set_get_scalar_as_object( 'protocol' ) );
921             }
922              
923 35     35 1 168 # NOTE: This method is superseded by the one in HTTP::Promise::Request or HTTP::Promise::Response
924             sub start_line { return( '' ) }
925 34     34 1 298  
926             sub version { return( shift->_set_get_number( 'version', @_ ) ); }
927              
928             # NOTE: _make_parts() is different from HTTP::Promise::Entity::make_multipart()
929             # This creates private parts attribute from current content (current entity body)
930             # whereas HTTP::Promise::Entity::make_multipart keeps and transforms the current content
931             # into multipart representation.
932             sub _make_parts
933 2     2   7 {
934 2         14 my $self = shift( @_ );
935             my $type = $self->headers->type;
936 2   50     8 # my $parts = $self->_parts;
937             my $ent = $self->entity ||
938 2         65 return( $self->error( "No entity object is set." ) );
939 2         42 my $body = $ent->body;
940 2 50 33     1577 my $parts = $ent->parts;
941 2         21 return( $parts ) unless( defined( $type ) && length( $type ) );
942             my $toptype = lc( [split( '/', $type, 2 )]->[0] );
943 2 50       11 # Nothing to do
944 2 50       15 return( $parts ) if( !$body );
    50          
    0          
945             if( $toptype eq 'multipart' )
946             {
947 0   0     0 # Now parse the raw data saved earlier
948             my $fh = $body->open( '+<', { binmode => 'raw' } ) ||
949 0 0       0 return( $self->pass_error( $ent->body->error ) );
950 0   0     0 $self->_load_class( 'HTTP::Promise::IO' ) || return( $self->pass_error );
951             my $reader = HTTP::Promise::IO->new( $fh, max_read_buffer => 4096, debug => $self->debug ) ||
952 0 0       0 return( $self->pass_error( HTTP::Promise::IO->error ) );
953 0         0 $self->_load_class( 'HTTP::Promise::Parser' ) || return( $self->pass_error );
954             my $parser = HTTP::Promise::Parser->new( debug => $self->debug );
955            
956             # Request body can be one of 3 types:
957             # application/x-www-form-urlencoded
958             # multipart/form-data
959             # text/plain or other mime types
960 0   0     0 # <https://developer.mozilla.org/en-US/docs/Web/HTTP/Methods/POST>
961             my $part_ent = $parser->parse_multi_part( entity => $ent, reader => $reader ) ||
962 0         0 return( $parser->pass_error );
963             $ent->body( undef );
964             }
965             # See rfc7230, section 8.3.1
966             # <https://tools.ietf.org/html/rfc7230#section-8.3.1>
967             elsif( $type eq 'message/http' )
968 2   50     16 {
969             my $fh = $body->open( '+<', { binmode => 'raw' } ) ||
970 2 50       124 return( $self->pass_error( $ent->body->error ) );
971 2   50     80 $self->_load_class( 'HTTP::Promise::IO' ) || return( $self->pass_error );
972             my $reader = HTTP::Promise::IO->new( $fh, max_read_buffer => 4096, debug => $self->debug ) ||
973             return( $self->pass_error( HTTP::Promise::IO->error ) );
974             # "It is RECOMMENDED that all HTTP senders and recipients support, at a minimum, request-line lengths of 8000 octets."
975             # Ref: <https://tools.ietf.org/html/rfc7230#section-3.1.1>
976 2         40 # getline() returns a scalar object
977 2 50       264 my $buff = $reader->getline( max_read_buffer => 8192 );
978 2 50       13 return( $self->pass_error( $reader->error ) ) if( !defined( $buff ) );
979 2         126 $self->_load_class( 'HTTP::Promise::Parser' ) || return( $self->pass_error );
980 2         78 my $parser = HTTP::Promise::Parser->new( debug => $self->debug );
981 2 50 33     24 my $def = $parser->looks_like_what( $buff );
982 2 50       34 warn( "Part found of type message/http, but its content does not match a HTTP request or response.\n" ) if( !$def && warnings::enabled() );
983             return( $self->pass_error( $parser->error ) ) if( !defined( $def ) );
984 2         51 # Give back what we just read to the reader for later use
985             $reader->unread( $buff );
986 2   50     69 # We parse it even if it may be a defective message/http part
987 2 50       362 my $sub_ent = $parser->parse( $fh, reader => $reader ) || return( $self->pass_error( $parser->error ) );
988             if( $def )
989 2         11 {
990 2         52 my $headers = $sub_ent->headers;
991 2 100       26 my $msg;
    50          
992             if( $def->{type} eq 'request' )
993 1 50       4 {
994 1   50     62 $self->_load_class( 'HTTP::Promise::Request' ) || return( $self->pass_error );
995             $msg = HTTP::Promise::Request->new( @$def{qw( method uri )}, $headers, { protocol => $def->{protocol}, version => $def->{http_version} } ) || return( $self->pass_error( HTTP::Promise::Request->error ) );
996             }
997             elsif( $def->{type} eq 'response' )
998 1 50       21 {
999 1   50     66 $self->_load_class( 'HTTP::Promise::Response' ) || return( $self->pass_error );
1000             $msg = HTTP::Promise::Response->new( @$def{qw( code status )}, $headers, { protocol => $def->{protocol}, version => $def->{http_version} } ) || return( $self->pass_error( HTTP::Promise::Response->error ) );
1001             }
1002             else
1003 0         0 {
1004             return( $self->error( "Something is wrong with the parser who returned HTTP message type '$def->{type}', which I do not recognise." ) );
1005             }
1006 2         24
1007 2         68 $msg->entity( $sub_ent );
1008             $sub_ent->http_message( $msg );
1009 2         438 }
1010 2         70 $parts->set( $sub_ent );
1011             $ent->body( undef );
1012             }
1013             elsif( $toptype eq 'message' )
1014 0   0     0 {
1015             my $fh = $body->open( '+<', { binmode => 'raw' } ) ||
1016 0         0 return( $self->pass_error( $ent->body->error ) );
1017 0   0     0 my $parser = HTTP::Promise::Parser->new( debug => $self->debug );
1018 0         0 my $ent = $parser->parse( $fh ) || return( $self->pass_error( $parser->error ) );
1019 0         0 $parts->set( $ent );
1020             $ent->body( undef );
1021             }
1022 2         8285 # Any other is not a multipart as per HTTP protocol
1023             return( $parts );
1024             }
1025              
1026             sub _set_content
1027 0     0   0 {
1028 0 0       0 my $self = shift( @_ );
1029 0         0 $self->_utf8_downgrade( $_[0] ) || return( $self->pass_error );
1030 0 0 0     0 $self->content( $_[0] );
1031             $self->entity->parts->reset unless( !$self->entity || $_[1] );
1032             }
1033              
1034             sub _utf8_downgrade
1035 49     49   326 {
1036 49         98 my $self = shift( @_ );
1037             my $rv;
1038 49         86 # try-catch
1039             local $@;
1040 49         83 eval
1041 49 50       181 {
1042             if( defined( &utf8::downgrade ) )
1043 49         188 {
1044             $rv = utf8::downgrade( $_[0], 1 );
1045             }
1046 49 50       147 };
1047             if( $@ )
1048 0         0 {
1049             return( $self->error( "Error downgrading utf8 data: $@" ) );
1050 49 100       260 }
1051             $rv || return( $self->error( 'HTTP::Promise::Message content must be bytes' ) );
1052             }
1053              
1054             sub AUTOLOAD
1055 13     13   39903 {
1056 13         74 my( $package, $method ) = $AUTOLOAD =~ m/\A(.+)::([^:]*)\z/;
1057 13 100       292 my $code = $_[0]->can( $method );
1058             goto( &$code ) if( $code );
1059 3         6 # Give a chance to our parent AUTOLOAD to kick in
1060 3         20 $Module::Generic::AUTOLOAD = $AUTOLOAD;
1061             goto( &Module::Generic::AUTOLOAD );
1062             }
1063              
1064             # sub CARP_TRACE { return( shift->_get_stack_trace ); }
1065              
1066       1     # avoid AUTOLOADing it
1067             sub DESTROY { }
1068              
1069             # NOTE: sub FREEZE is inherited
1070 3     3 0 179  
1071             sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }
1072 3     3 0 338  
1073             sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }
1074              
1075             # NOTE: sub THAW is inherited
1076             sub THAW
1077 3     3 0 18 {
1078 3 50 33     24 my( $self, $serialiser, @args ) = @_;
1079 3 50 33     56 my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
      0        
1080 3 50       14 my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
1081 3         6 my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
1082             my $new;
1083 3 50       11 # Storable pattern requires to modify the object it created rather than returning a new one
1084             if( CORE::ref( $self ) )
1085 3         23 {
1086             foreach( CORE::keys( %$hash ) )
1087 59         100 {
1088             $self->{ $_ } = CORE::delete( $hash->{ $_ } );
1089             }
1090            
1091 3 50 33     106 # Need to make sure the headers object, which is an XS one is properly post processed, because Storable does not handle well XS objects, as of version 3.26
      33        
      33        
1092             if( CORE::exists( $self->{headers} ) &&
1093             CORE::defined( $self->{headers} ) &&
1094             CORE::ref( $self->{headers} ) &&
1095             $self->{headers}->isa( 'HTTP::Promise::Headers' ) )
1096 3         23 {
1097             $self->{headers} = $self->{headers}->STORABLE_thaw_post_processing;
1098             }
1099 3 50 33     56 # The headers object in HTTP::Promise::Message must be the same shared on in HTTP::Promise::Entity
1100             if( CORE::exists( $self->{entity} ) &&
1101             CORE::exists( $self->{entity}->{headers} ) )
1102 3         12 {
1103             $self->{entity}->{headers} = $self->{headers};
1104 3         15 }
1105             $new = $self;
1106             }
1107             else
1108 0         0 {
1109             $new = bless( $hash => $class );
1110 3         40 }
1111             CORE::return( $new );
1112             }
1113              
1114 3     3 0 43 # NOTE: only here to avoid triggering HTTP::Promise::Headers::STORABLE_thaw_post_processing which we inherit when we did 'require HTTP::Promise::Headers'
1115             sub STORABLE_thaw_post_processing { CORE::return( $_[0] ); }
1116              
1117             1;
1118             # NOTE: POD
1119             __END__
1120              
1121             =encoding utf-8
1122              
1123             =head1 NAME
1124              
1125             HTTP::Promise::Message - HTTP Message Class
1126              
1127             =head1 SYNOPSIS
1128              
1129             use HTTP::Promise::Message;
1130             my $this = HTTP::Promise::Message->new(
1131             [ 'Content-Type' => 'text/plain' ],
1132             'Hello world'
1133             ) || die( HTTP::Promise::Message->error, "\n" );
1134              
1135             =head1 VERSION
1136              
1137             v0.2.0
1138              
1139             =head1 DESCRIPTION
1140              
1141             This class represents an HTTP message, and implements methods that are common to either a request or a response. This class is inherited by L<HTTP::Promise::Request> and L<HTTP::Promise::Response>. It difffers from L<HTTP::Promise::Entity> in that L<HTTP::Promise::Entity> represents en HTTP entity which is composed of headers and a body, and this can be embedded within another entity.
1142              
1143             Here is how it fits in overall relation with other classes.
1144            
1145             +-------------------------+ +--------------------------+
1146             | | | |
1147             | HTTP::Promise::Request | | HTTP::Promise::Response |
1148             | | | |
1149             +------------|------------+ +-------------|------------+
1150             | |
1151             | |
1152             | |
1153             | +------------------------+ |
1154             | | | |
1155             +--- HTTP::Promise::Message |---+
1156             | |
1157             +------------|-----------+
1158             |
1159             |
1160             +------------|-----------+
1161             | |
1162             | HTTP::Promise::Entity |
1163             | |
1164             +------------|-----------+
1165             |
1166             |
1167             +------------|-----------+
1168             | |
1169             | HTTP::Promise::Body |
1170             | |
1171             +------------------------+
1172              
1173             =head1 CONSTRUCTOR
1174              
1175             =head2 new
1176              
1177             This takes some parameters and instantiates a new L<HTTP::Promise::Message>.
1178              
1179             Accepted parameters can be one of the followings:
1180              
1181             =over 4
1182              
1183             =item 1. an L<headers object|HTTP::Promise::Headers> and some content as a string or scalar reference.
1184              
1185             my $msg = HTTP::Promise::Message->new( HTTP::Promise::Headers->new(
1186             Content_Type => 'text/plain',
1187             Content_Encoding => 'gzip',
1188             Host: 'www.example.org',
1189             ),
1190             "Some content",
1191             );
1192              
1193             my $str = "Some content";
1194             my $hdr = HTTP::Promise::Headers->new(
1195             Content_Type => 'text/plain',
1196             Content_Encoding => 'gzip',
1197             Host: 'www.example.org',
1198             );
1199             my $msg = HTTP::Promise::Message->new( $hdr, \$str );
1200              
1201             =item 2. an L<headers object|HTTP::Promise::Headers> and and L<HTTP::Promise::Body> or L<HTTP::Promise::Body::Form> object
1202              
1203             my $body = HTTP::Promise::Body::Scalar->new( "Some content" );
1204             my $hdr = HTTP::Promise::Headers->new(
1205             Content_Type => 'text/plain',
1206             Content_Encoding => 'gzip',
1207             Host: 'www.example.org',
1208             );
1209             my $msg = HTTP::Promise::Message->new( $hdr, $body );
1210              
1211             Using the x-www-form-urlencoded class:
1212              
1213             my $body = HTTP::Promise::Body::Form->new({ name => '嘉納 治五郎', age => 22, city => 'Tokyo' });
1214             my $hdr = HTTP::Promise::Headers->new(
1215             Content_Type => 'text/plain',
1216             Content_Encoding => 'gzip',
1217             Host: 'www.example.org',
1218             );
1219             my $msg = HTTP::Promise::Message->new( $hdr, $body );
1220              
1221             =item 3. an array reference of headers field-value pairs and some content as a string or scalar reference.
1222              
1223             my $msg = HTTP::Promise::Message->new([
1224             Content_Type => 'text/plain',
1225             Content_Encoding => 'gzip',
1226             Host: 'www.example.org',
1227             ],
1228             "Some content",
1229             );
1230              
1231             =item 4. an hash reference of parameters
1232              
1233             my $hdr = HTTP::Promise::Headers->new(
1234             Content_Type => 'text/plain',
1235             Content_Encoding => 'gzip',
1236             Host: 'www.example.org',
1237             );
1238             my $msg = HTTP::Promise::Message->new({
1239             headers => $hdr,
1240             content => \$str,
1241             # HTP::Promise::Entity
1242             entity => $entity_object,
1243             debug => 4,
1244             });
1245              
1246             =back
1247              
1248             In any case, you can provide additional object options by providing an hash reference as the last argument, such as:
1249              
1250             my $msg = HTTP::Promise::Message->new([
1251             Content_Type => 'text/plain',
1252             Content_Encoding => 'gzip',
1253             Host: 'www.example.org',
1254             ],
1255             "Some content",
1256             {
1257             debug => 4,
1258             entity => $entity_object
1259             },
1260             );
1261              
1262             If some content is provided, a new L<entity in-memory body object|HTTP::Promise::Body::Scalar> will be initiated
1263              
1264             It returns the new http message object, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1265              
1266             =head1 METHODS
1267              
1268             =head2 add_content
1269              
1270             This takes a string or a scalar reference and append it to the current body if the body object is an L<HTTP::Promise::Body::File> or L<HTTP::Promise::Body::Scalar> object. This does not work for L<HTTP::Promise::Body::Form>. You would have to call yourself the class methods to add your key-value pairs.
1271              
1272             The content thus provided is downgraded, which means it is flagged as being in perl's internal utf-8 representation. So you cannot use this method to add binary data. If you want to do so, you would need to use directly the body object methods. For example:
1273              
1274             my $io = $msg->entity->body->open( '>', { binmode => 'utf-8', autoflush => 1 }) ||
1275             die( $msg->entity->body->error );
1276             $io->print( $some_data ) || die( $io->error );
1277             $io->close;
1278              
1279             This code works for either L<HTTP::Promise::Body::File> or L<HTTP::Promise::Body::Scalar>
1280              
1281             If no entity, or body is set yet, it will create one automatically, and defaults to L<HTTP::Promise::Body::Scalar> for the body class.
1282              
1283             It returns the entity body object, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1284              
1285             =head2 add_content_utf8
1286              
1287             This is the same thing as L</add_content>, except it will encode in utf-8 the data provided, i.e. not perl's internal representation.
1288              
1289             =head2 add_part
1290              
1291             By default, this will check if the HTTP message C<Content-Type> is a multipart one, and if not, it will automatically set it to C<multipart/form-data> and transform the current HTTP message into the first part of a C<multipart/form-data>, and add after all the parts provided.
1292              
1293             If the C<Content-Type> is already a multipart one, but has no part yet and has a body content, it will parse that content to build one or more parts from it.
1294              
1295             When used for an HTTP request, C<multipart/form-data> is the only valid Content-Type for sending multiple data. L<rfc7578 in section 4.3|https://tools.ietf.org/html/rfc7578#section-4.3> states: "[RFC2388] suggested that multiple files for a single form field be transmitted using a nested "multipart/mixed" part. This usage is deprecated."
1296              
1297             See also this L<Stackoverflow discussion|https://stackoverflow.com/questions/36674161/http-multipart-form-data-multiple-files-in-one-input/41204533#41204533> and L<this one too|https://stackoverflow.com/questions/51575746/http-header-content-type-multipart-mixed-causes-400-bad-request>
1298              
1299             When used for an HTTP response, one can return either a C<multipart/form-data> or a C<multipart-mixed> HTTP message.
1300              
1301             If you want to make an HTTP request, then you need to provide pairs of form-name-and part object (either a L<HTTP::Promise::Entity> or a L<HTTP::Promise::Message> object with an L<HTTP::Promise::Entity> set with L</entity>) OR a list of parts whose L<name attribute|HTTP::Promise::Entity/name> is set.
1302              
1303             If you want to make an HTTP response, you can either return a C<multipart/form-data> by providing pairs of form-name-and part object as mentioned above, or a C<multipart/mixed> by providing a list of part object (either a L<HTTP::Promise::Entity> or a L<HTTP::Promise::Message> object with an L<HTTP::Promise::Entity> set with L</entity>).
1304              
1305             For example:
1306              
1307             $m->add_part(
1308             file1 => $ent1,
1309             file2 => $ent2,
1310             first_name => $ent3,
1311             last_name => $ent4,
1312             # etc...
1313             );
1314              
1315             or, using the L<name attribute|HTTP::Promise::Entity/name>:
1316              
1317             $ent1->name( 'file1' );
1318             $ent2->name( 'file2' );
1319             $ent3->name( 'first_name' );
1320             $ent4->name( 'last_name' );
1321             $m->add_part( $ent1, $ent2, $ent3, $ent4 );
1322              
1323             Note that you can always set an L<entity name|HTTP::Promise::Entity/name>, and it will only be used if the HTTP message Content-Type is of type C<multipart/form-data>, unless you set yourself the C<Content-Disposition> header value.
1324              
1325             It returns the current object, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1326              
1327             =head2 as_form_data
1328              
1329             This will read the body of the HTTP entity and return it as an object of key-value pairs with the module L<HTTP::Promise::Body::Form>
1330              
1331             This supports HTTP C<Content-Type> C<multipart/form-data>, C<application/json>, C<application/x-www-form-urlencoded>, or in the case of HTTP method C<GET>, C<HEAD>, or C<DELETE>, it will use any query string parameters, and return a new L<HTTP::Promise::Body::Form> object.
1332              
1333             It defaults to C<application/x-www-form-urlencoded>. Upon error, it will set an L<HTTP::Promise::Exception> and return C<undef> in scalar context, or an empty list in list context.
1334              
1335             The way this works is it checks first for C<multipart/form-data>, then C<application/json>, and for query strings only if there is no HTTP body content, and else it fallbacks to C<application/x-www-form-urlencoded>.
1336              
1337             This means you must be careful if you send or receive C<JSON> data to properly set the C<Content-Type> to C<application/json>
1338              
1339             =head2 as_string
1340              
1341             This takes an optional end-of-line terminator and returns a L<scalar object|Module::Generic::Scalar> representing the entire HTTP message.
1342              
1343             The end-of-line terminator defaults to C<$CRLF>, which is a global variable of L<HTTP::Promise::Message>
1344              
1345             =head2 boundary
1346              
1347             This is a shortcut.
1348              
1349             It returns the result returned by L<HTTP::Promise::Headers/boundary>
1350              
1351             =head2 can
1352              
1353             This behaves like L<UNIVERSAL/can>, with a twist.
1354              
1355             Provided with a method name and this check if this is supported by L<HTTP::Promise::Message>, or in last resort by L<HTTP::Promise::Headers> and if the latter is true, it will alias the headers method to this namespace.
1356              
1357             It returns the code reference of the requested method, or C<undef> if none could be found.
1358              
1359             =head2 clear
1360              
1361             Clears out the headers object by calling L<HTTP::Promise::Headers/clear>, empty the entity body, if any, and remove any part if any.
1362              
1363             It does not return anything. This should be called in void context.
1364              
1365             =head2 clone
1366              
1367             This clones the current HTTP message and returns a new object.
1368              
1369             =head2 content
1370              
1371             Get or set the HTTP message body.
1372              
1373             If one or more values are provided, they will be added to the newly created L<HTTP::Promise::Body> object.
1374              
1375             You can provide as values one or more instance of either a string or a scalar reference.
1376              
1377             For example:
1378              
1379             $m->content( \$string, 'Hello world', \$another_string );
1380              
1381             It returns the newly set L<HTTP::Promise::Body> object upon success or, upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1382              
1383             When no argument is provided, this returns the L<HTTP::Promise::Body> object as a L<scalar object|Module::Generic::Scalar>.
1384              
1385             Beware that the content returned might not be decoded if compression has been applied previously, or if compressed content was provided upon instantiation of the C<HTTP::Promise::Message> object, such as:
1386              
1387             my $m = HTTP::Promise::Message->new([
1388             'Content-Type' => 'text/plain',
1389             'Content-Encoding' => 'deflate, base64',
1390             ],
1391             '80jNyclXCM8vyklRBAA='
1392             );
1393             my $content = $m->content; # 80jNyclXCM8vyklRBAA=
1394              
1395             But even with utf-8 content, such as:
1396              
1397             my $m = HTTP::Promise::Message->new([
1398             'Content-Type' => 'text/plain; charset=utf-8',
1399             ],
1400             "\x{E3}\x{81}\x{8A}\x{E6}\x{97}\x{A9}\x{E3}\x{81}\x{86}\x{EF}\x{BC}\x{81}\x{A}",
1401             );
1402             my $content = $m->content;
1403              
1404             C<$content> would contain undecoded utf-8 bytes, i.e. not in perl's internal representation. Indeed, charset is never decoded. If you want the charset decoded content, use L</decoded_content>, which will guess the content charset to decode it into perl's internal representation. If you are sure this is utf-8, you can either call:
1405              
1406             my $decoded_content = $m->decoded_content( binmode => 'utf-8' );
1407              
1408             or
1409              
1410             my $decoded_content = $m->decoded_content_utf8;
1411              
1412             See L</decoded_content> for more information.
1413              
1414             =head2 content_charset
1415              
1416             This is a convenient method that calls L<HTTP::Promise::Entity/content_charset> and returns the result.
1417              
1418             This method attempts at guessing the content charset of the entity body.
1419              
1420             It returns a string representing the content charset, possibly empty if nothing was found, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1421              
1422             =head2 content_ref
1423              
1424             This sets or gets the content as a scalar reference.
1425              
1426             In assignment mode, this takes a scalar reference and pass it to L</content> and returns the L<body object|HTTP::Promise::Body>
1427              
1428             Otherwise, this returns the content as L<scalar object|Module::Generic::Scalar>.
1429              
1430             If an error occurs, this sets an L<error|Module::Generic/error> and returns C<undef>.
1431              
1432             =head2 decodable
1433              
1434             This gets an L<array object|Module::Generic::Array> of all supported and installed decodings on the system, by calling L<HTTP::Promise::Stream/decodable>
1435              
1436             =head2 decode
1437              
1438             This decodes the HTTP message body and return true.
1439              
1440             If there is no C<Content-Encoding> set, or the entity body is empty, or the entity body already has been decoded, this does nothing obviously. Otherwise, this calls L<HTTP::Promise::Entity/decode_body> passing it the encodings as an array reference.
1441              
1442             If an error occurs, this sets an L<error|Module::Generic/error> and returns C<undef>.
1443              
1444             =head2 decode_content
1445              
1446             This is similar to </decode>, except that it takes an hash or hash reference of options passed to L<HTTP::Promise::Entity/decode_body>, notably C<replace>, which if true will replace the body by its decoded version and if false will return a new body version representing the decoded body.
1447              
1448             This returns the entity body object upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1449              
1450             =head2 decoded_content
1451              
1452             This takes an hash or hash reference of options and returns the decoded representation of the body, including charset.
1453              
1454             This calls L</decode_content>, passing it the options provided, to decompress the entity body if necessary. Then, unless the C<binmode> option was provided, this calls L<HTTP::Promise::Entity/io_encoding> to guess the charset encoding, and set the C<binmode> option to it, if anything was found.
1455              
1456             If the entity body is an xml file, any C<BOM> (Byte Order Mark) will be removed.
1457              
1458             This returns the content as a L<scalar object|Module::Generic::Scalar>, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1459              
1460             Supported options are:
1461              
1462             =over 4
1463              
1464             =item * C<binmode>
1465              
1466             The L<PerlIO> encoding to apply to decode the data.
1467              
1468             If not provided, this will be guessed by calling L<HTTP::Promise::Entity/io_encoding>
1469              
1470             =item * C<charset_strict>
1471              
1472             If true, this will returns an error if there is some issues with the content charset. By default, this is false, making it lenient, especially with malformed utf-8.
1473              
1474             =item * C<raise_error>
1475              
1476             When set to true, this will cause this method to die upon error. Default is false.
1477              
1478             =back
1479              
1480             =head2 decoded_content_utf8
1481              
1482             This calls L</decoded_content>, but this sets the C<binmode> option to C<utf-8>.
1483              
1484             It returns whatever L</decode_content> returns.
1485              
1486             =head2 dump
1487              
1488             This takes an hash or hash reference of options and either print the resulting dump on the C<STDOUT> in void content, or returns a string representation of the HTTP message, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1489              
1490             Supported options are:
1491              
1492             =over 4
1493              
1494             =item * C<maxlength>
1495              
1496             The maximum amount of body data in bytes to display.
1497              
1498             =item * C<no_content>
1499              
1500             The string to use when there is no entity body data.
1501              
1502             =item * C<prefix>
1503              
1504             A string to be added at the beginning of each line of the data returned.
1505              
1506             =item * C<preheader>
1507              
1508             An arbitrary string to add before the HTTP headers, typically the HTTP C<start line>
1509              
1510             =back
1511              
1512             # Returns a string
1513             my $dump = $msg->dump;
1514             # Prints on the STDOUT the result
1515             $msg->dump;
1516              
1517             =head2 encode
1518              
1519             This takes an optional list of encoding and an optional hash or hash reference of options and encode the entity body and returns true, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1520              
1521             This will return an error if it is used on a multipart message or an C<message/*> such as C<message/http>.
1522              
1523             Obviously this is a no-op if no encoding was found, or if the body is empty, or if the body is already marked L<as encoded|HTTP::Promise::Entity/is_encoded>
1524              
1525             Supported options are:
1526              
1527             =over 4
1528              
1529             =item * C<update_header>
1530              
1531             When true, this will set the C<Content-Encoding> with the encoding used to encode the entity body and remove the headers C<Content-Length> and C<Content-MD5>. Defaults to true.
1532              
1533             =back
1534              
1535             =head2 entity
1536              
1537             Sets or gets the HTTP L<entity object|HTTP::Promise::Entity>
1538              
1539             =head2 header
1540              
1541             This is a shortcut by calling L<HTTP::Promise::Headers/header>
1542              
1543             =head2 headers
1544              
1545             Sets or gets the L<HTTP::Promise::Headers> object.
1546              
1547             =head2 headers_as_string
1548              
1549             This is a shortcut to call L<HTTP::Promise::Headers/as_string>
1550              
1551             =head2 is_encoding_supported
1552              
1553             Provided with an encoding and this returns true if the encoding is supported by L<HTTP::Promise::Stream>
1554              
1555             =head2 make_boundary
1556              
1557             Returns a newly generated boundary, which is basically a uuid generated by the XS module L<Data::UUID>
1558              
1559             =head2 parse
1560              
1561             Provided with a string and this will try to parse this HTTP message and returns the current message object if it was called with an HTTP message, or a new HTTP message if it was called as a class function, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1562              
1563             my $msg = HTTP::Promise::Message->parse( $some_http_message ) ||
1564             die( HTTP::Promise::Message->error );
1565            
1566             $msg->parse( $some_http_message ) ||
1567             die( HTTP::Promise::Message->error );
1568              
1569             =head2 parts
1570              
1571             This returns the HTTP message entity parts as an L<array object|Module::Generic::Array> and returns it, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1572              
1573             If the HTTP message has a body with content and there is no part and the mime-type top type is C<multipart> or C<message>, this will first parse the body into parts. Thus you could do:
1574              
1575             my $msg = HTTP::Promise::Message->new([
1576             Content_Type => 'multipart/form-data; boundary="abcd"',
1577             Content_Encoding => 'gzip',
1578             Host => 'example.org',
1579             ], <<EOT );
1580             --abcd
1581             Content-Disposition: form-data; name="name"
1582              
1583             Jigoro Kano
1584              
1585             --abcd
1586             Content-Disposition: form-data; name="birthdate"
1587              
1588             1860-12-10
1589             --abcd--
1590             EOT
1591              
1592             my $parts = $msg->parts;
1593              
1594             =head2 protocol
1595              
1596             Sets or gets the HTTP protocol. This is typically something like C<HTTP/1.0>, C<HTTP/1.1>, C<HTTP/2>
1597              
1598             Returns the HTTP protocol, if any was set, as a L<scalar object|Module::Generic::Scalar>, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
1599              
1600             Note that it may return C<undef> if no protocol was set. Errors are likely to occur when assigning an improper value.
1601              
1602             =head2 start_line
1603              
1604             This is a no-op since it is superseded by its inheriting classes L<HTTP::Promise::Request> and L<HTTP::Promise::Response>
1605              
1606             =head2 version
1607              
1608             Sets or gets the HTTP protocol version, something like C<1.0>, or C<1.1>, or maybe C<2>
1609              
1610             This returns a L<number object|Module::Generic::Number>
1611              
1612             =for Pod::Coverage STORABLE_thaw_post_processing
1613              
1614             =head1 AUTHOR
1615              
1616             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
1617              
1618             =head1 SEE ALSO
1619              
1620             L<HTTP::Promise>, L<HTTP::Promise::Request>, L<HTTP::Promise::Response>, L<HTTP::Promise::Message>, L<HTTP::Promise::Entity>, L<HTTP::Promise::Headers>, L<HTTP::Promise::Body>, L<HTTP::Promise::Body::Form>, L<HTTP::Promise::Body::Form::Data>, L<HTTP::Promise::Body::Form::Field>, L<HTTP::Promise::Status>, L<HTTP::Promise::MIME>, L<HTTP::Promise::Parser>, L<HTTP::Promise::IO>, L<HTTP::Promise::Stream>, L<HTTP::Promise::Exception>
1621              
1622             =head1 COPYRIGHT & LICENSE
1623              
1624             Copyright(c) 2022 DEGUEST Pte. Ltd.
1625              
1626             All rights reserved
1627             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
1628              
1629             =cut