File Coverage

lib/HTTP/Promise/Entity.pm
Criterion Covered Total %
statement 631 968 65.1
branch 281 698 40.2
condition 164 395 41.5
subroutine 62 76 81.5
pod 54 57 94.7
total 1192 2194 54.3


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Asynchronous HTTP Request and Promise - ~/lib/HTTP/Promise/Entity.pm
3             ## Version v0.2.1
4             ## Copyright(c) 2023 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2022/04/19
7             ## Modified 2023/09/22
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::Entity;
15             BEGIN
16             {
17 12     12   428499 use strict;
  12         44  
  12         382  
18 12     12   107 use warnings;
  12         38  
  12         327  
19 12     12   66 use warnings::register;
  12         30  
  12         1388  
20 12     12   86 use parent qw( Module::Generic );
  12         47  
  12         102  
21 12         1165 use vars qw( $VERSION $EXCEPTION_CLASS $BOUNDARY_DELIMITER $BOM2ENC $ENC2BOM $BOM_RE
22 12     12   943 $BOM_MAX_LENGTH $DEFAULT_MIME_TYPE );
  12         29  
23 12     12   965 use Data::UUID;
  12         1169  
  12         966  
24 12     12   2287 use HTTP::Promise::Exception;
  12         36  
  12         117  
25 12     12   8813 use HTTP::Promise::Headers;
  12         33  
  12         525  
26 12     12   5757 use HTTP::Promise::Body;
  12         35  
  12         137  
27 12     12   8713 use Module::Generic::HeaderValue;
  12         32132  
  12         145  
28             # use Nice::Try;
29 12     12   3164 use Symbol;
  12         29  
  12         881  
30 12     12   89 use URI::Escape::XS ();
  12         51  
  12         433  
31 12     12   75 use constant CRLF => "\015\012";
  12         24  
  12         1340  
32 12     12   50 our $EXCEPTION_CLASS = 'HTTP::Promise::Exception';
33 12         24 our $BOUNDARY_DELIMITER = "\015\012";
34 12         30 our $DEFAULT_MIME_TYPE = 'application/octet-stream';
35 12         221 our $VERSION = 'v0.2.1';
36             };
37              
38 12     12   69 use strict;
  12         24  
  12         254  
39 12     12   63 use warnings;
  12         25  
  12         75573  
40              
41             sub init
42             {
43 155     155 1 145377 my $self = shift( @_ );
44 155         1394 $self->{body} = undef;
45             # Sie minimum from which compression is enabled, if mime type is suitable.
46             # Defaults to 200Kb
47 155         582 $self->{compression_min}= 204800;
48 155         484 $self->{effective_type} = undef;
49 155         409 $self->{epilogue} = undef;
50 155         477 $self->{ext_vary} = undef;
51 155         490 $self->{headers} = undef;
52 155         613 $self->{is_encoded} = 0;
53 155         626 $self->{output_dir} = undef;
54 155         505 $self->{preamble} = undef;
55 155         366 $self->{_init_strict_use_sub} = 1;
56 155         560 $self->{_exception_class} = $EXCEPTION_CLASS;
57 155 50       895 $self->SUPER::init( @_ ) || return( $self->pass_error );
58 155         10548 $self->{_parts} = [];
59 155         566 return( $self );
60             }
61              
62             sub add_part
63             {
64 5     5 1 36267 my $self = shift( @_ );
65 5         32 my( $part, $index ) = @_;
66 5 50       48 return( $self->error( "Part provided is not a HTTP::Promise::Entity object." ) ) if( !$self->_is_a( $part => 'HTTP::Promise::Entity' ) );
67 5         348 my $parts = $self->_parts;
68 5 50       4073 $index = -1 if( !defined( $index ) );
69 5 50       60 $index = $parts->size + 2 + $index if( $index < 0 );
70 5         182976 $parts->splice( $index, 0, $part );
71 5         1473 return( $part );
72             }
73              
74             sub as_form_data
75             {
76 1     1 1 36856 my $self = shift( @_ );
77 1         10 my $type = $self->headers->type;
78 1 50       10 return(0) unless( lc( $type ) eq 'multipart/form-data' );
79 1 50       39 $self->_load_class( 'HTTP::Promise::Body::Form::Data' ) || return( $self->pass_error );
80 1         483 my $form = HTTP::Promise::Body::Form::Data->new;
81 1   50     665 $form->debug( $self->debug // 0 );
82 1         36932 my $parts = $self->parts;
83             # nothing to do
84 1 50       802 return( $form ) if( $parts->is_empty );
85 1         29 foreach my $part ( @$parts )
86             {
87 4         204 my $headers = $part->headers;
88 4         97 my $body = $part->body;
89 4         76 my $name;
90 4         11 my $dispo = $headers->content_disposition;
91 4 50       82 next unless( $dispo );
92 4         46 my $cd = $headers->new_field( 'Content-Disposition' => "$dispo" );
93 4 50       11 return( $self->pass_error( $headers->error ) ) if( !defined( $cd ) );
94 4         20 $name = $cd->name;
95 4 50 33     2155 next if( !defined( $name ) || !length( "$name" ) );
96 4         20 my $encodings = $headers->content_encoding;
97 4 50 33     44 if( $part->is_encoded && $encodings )
98             {
99 0   0     0 $body = $part->decode_body( encoding => $encodings ) ||
100             return( $self->pass_error( $part->error ) );
101             }
102            
103 4         2759 my $field = $form->new_field(
104             name => $name,
105             body => $body,
106             headers => $headers,
107             );
108 4 50       11 return( $self->pass_error( $form->error ) ) if( !defined( $field ) );
109            
110 4 50       78 if( exists( $form->{ $name } ) )
111             {
112 0         0 $form->{ $name } = [$form->{ $name }];
113 0         0 push( @{$form->{ $name }}, $field );
  0         0  
114             }
115             else
116             {
117 4         132 $form->{ $name } = $field;
118             }
119             }
120 1         70 return( $form );
121             }
122              
123             sub as_string
124             {
125 30     30 1 2254 my $self = shift( @_ );
126 30         70 my $eol = shift( @_ );
127 30         149 my $opts = $self->_get_args_as_hash( @_ );
128 30 100       336 $opts->{eol} = $eol if( defined( $eol ) );
129 30         220 my $output = $self->new_scalar;
130             # Because of an edge case where open with :binmode(utf-8) layer does not decode properly \x{FF}
131             # but Encode::decode( 'utf-8', $buff ) does, and since the body is loaded into a string
132             # anyway, we first read the data as raw and then decode it with Encode
133 30         1068 my $binmode;
134 30 0 33     189 if( exists( $opts->{binmode} ) &&
      33        
135             length( $opts->{binmode} ) &&
136             lc( substr( $opts->{binmode}, 0, 3 ) ) eq 'utf' )
137             {
138 0         0 $binmode = delete( $opts->{binmode} );
139 0         0 $opts->{binmode} = 'raw';
140             }
141 30   50     201 my $fh = $output->open( '>' ) || return( $self->pass_error( $output->error ) );
142             # $self->print( $fh, ( scalar( keys( %$opts ) ) ? $opts : () ) ) || return( $self->pass_error );
143 30 100       21068 $self->print( $fh, ( scalar( keys( %$opts ) ) ? $opts : () ) ) || return( $self->pass_error );
    50          
144 30         144 $fh->close;
145 30 50       3063 if( defined( $binmode ) )
146             {
147 0 0       0 $self->_load_class( 'Encode' ) || return( $self->pass_error );
148             # try-catch
149 0         0 local $@;
150             eval
151 0         0 {
152 0         0 $$output = Encode::decode( $binmode, $$output, ( Encode::FB_DEFAULT | Encode::LEAVE_SRC ) );
153             };
154 0 0       0 if( $@ )
155             {
156 0         0 return( $self->error( "Error decoding body content with character encoding '$binmode': $@" ) );
157             }
158             }
159 30         128 return( $output );
160             }
161              
162             sub attach
163             {
164 3     3 1 1178 my $self = shift( @_ );
165 3   33     21 my $class = ref( $self ) || $self;
166 3 50       44 $self->make_multipart || return( $self->pass_error );
167 3   50     29 my $part = $class->build( @_, top => 0 ) ||
168             return( $self->pass_error( $class->error ) );
169 3         1558 return( $self->add_part( $part ) );
170             }
171              
172 371     371 1 9237 sub body { return( shift->_set_get_object_without_init( 'body', [qw( HTTP::Promise::Body HTTP::Promise::Body::Form )], @_ ) ); }
173              
174             sub body_as_array
175             {
176 0     0 1 0 my $self = shift( @_ );
177 0 0       0 my $eol = @_ ? shift( @_ ) : CRLF;
178 0 0       0 return( $self->error( "You cannot use the method body() to set the encoded contents." ) ) if( scalar( @_ ) );
179 0         0 my $output = $self->new_scalar;
180 0   0     0 my $fh = $output->open( '>' ) ||
181             return( $self->pass_error( $output->error ) );
182 0 0       0 $self->print_body( $fh ) || return( $self->pass_error );
183 0         0 $fh->close;
184 0         0 my $ary = $output->split( qr/\015?\012/ );
185 0         0 for( @$ary )
186             {
187 0         0 $_ .= $eol;
188             }
189 0         0 return( $ary );
190             }
191              
192             sub body_as_string
193             {
194 1     1 1 484 my $self = shift( @_ );
195 1         25 my $opts = $self->_get_args_as_hash( @_ );
196 1         25 my $output = $self->new_scalar;
197             # Because of an edge case where open with :binmode(utf-8) layer does not decode properly \x{FF}
198             # but Encode::decode( 'utf-8', $buff ) does, and since the body is loaded into a string
199             # anyway, we first read the data as raw and then decode it with Encode
200 1         41 my $binmode;
201 1 0 33     36 if( exists( $opts->{binmode} ) &&
      33        
202             length( $opts->{binmode} ) &&
203             lc( substr( $opts->{binmode}, 0, 3 ) ) eq 'utf' )
204             {
205 0         0 $binmode = delete( $opts->{binmode} );
206 0         0 $opts->{binmode} = 'raw';
207             }
208 1   50     21 my $fh = $output->open( '>' ) ||
209             return( $self->pass_error( $output->error ) );
210 1 50       430 $self->print_body( $fh, ( scalar( keys( %$opts ) ) ? $opts : () ) ) || return( $self->pass_error );
    50          
211 1         17 $fh->close;
212 1 50       112 if( defined( $binmode ) )
213             {
214 0 0       0 $self->_load_class( 'Encode' ) || return( $self->pass_error );
215             # try-catch
216 0         0 local $@;
217             eval
218 0         0 {
219 0         0 $$output = Encode::decode( $binmode, $$output, ( Encode::FB_DEFAULT | Encode::LEAVE_SRC ) );
220             };
221 0 0       0 if( $@ )
222             {
223 0         0 return( $self->error( "Error decoding body content with character encoding '$binmode': $@" ) );
224             }
225             }
226 1         14 return( $output );
227             }
228              
229             sub build
230             {
231 17     17 1 104624 my $self = shift( @_ );
232 17         140 my( $opts, $order ) = $self->_get_args_as_hash( @_ );
233 17         3484 my( $field, $filename, $boundary );
234 17   100     236 my $type = delete( $opts->{type} ) || 'text/plain';
235 17         108 my $charset = delete( $opts->{charset} );
236 17 100       133 my $is_multipart = ( $type =~ m{^multipart/}i ? 1 : 0 );
237 17   100     148 my $encoding = delete( $opts->{encoding} ) || '';
238 17         66 my $desc = delete( $opts->{description} );
239 17 100       79 my $top = exists( $opts->{top} ) ? delete( $opts->{top} ) : 1;
240             # my $disposition = $opts->{disposition} || 'inline';
241             # inline, attachment or multipart/form-data
242             # Ref: <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Content-Disposition>
243             # We could, technically, default to 'inline' and end up with something like:
244             # Content-Disposition: inline; filename=foo.txt
245             # But, even though it would be ok for mail, for HTTP, it would be weird, so, no default
246             # and instead if a path is provided, but no Content-Disposition, we fall back to 'attachment'
247 17         54 my $disposition = delete( $opts->{disposition} );
248 17         45 my $id = delete( $opts->{id} );
249 17   100     145 my $debug = delete( $opts->{debug} ) // 0;
250             # Ensure this is an object
251 17   50     129 my $new = $self->new( debug => $debug ) || return( $self->pass_error );
252 17   50     149 my $headers = HTTP::Promise::Headers->new( { debug => $self->debug } ) ||
253             return( $self->pass_error( HTTP::Promise::Headers->error ) );
254 17         90 $new->headers( $headers );
255            
256             # Either data or path
257 17         837 my $data = delete( $opts->{data} );
258 17         63 my $path = delete( $opts->{path} );
259 17   100     265 my( $path_fname ) = ( ( $path || '' ) =~ m{([^/]+)\Z} );
260 17 100       96 $filename = ( exists( $opts->{filename} ) ? delete( $opts->{filename} ) : $path_fname );
261 17 50 66     147 $filename = undef() if( defined( $filename ) and $filename eq '' );
262 17         40 my $filename_utf8;
263 17 100 66     193 if( defined( $filename ) && length( $filename ) && $filename =~ /[^\w\.]+/ )
      100        
264             {
265 3         31 $filename_utf8 = $new->headers->encode_filename( $filename );
266             }
267 17 100 66     844 if( defined( $encoding ) &&
268             $type =~ m{^(multipart/|message/(rfc822|partial|external-body|delivery-status|disposition-notification|feedback-report|http)$)}i )
269             {
270 3         19 undef( $encoding );
271             }
272            
273             # Multipart or not? Do sanity check and fixup:
274 17 100       64 if( $is_multipart )
275             {
276             # Get any supplied boundary, and check it:
277 2 50       24 if( defined( $boundary = delete( $opts->{boundary} ) ) )
278             {
279 0 0       0 if( !length( $boundary ) )
    0          
280             {
281 0 0       0 warn( "Empty string not a legal boundary: I am ignoring it\n" ) if( $self->_warnings_is_enabled );
282 0         0 $boundary = undef();
283             }
284             elsif( $boundary =~ m{[^0-9a-zA-Z_\'\(\)\+\,\.\/\:\=\?\- ]} )
285             {
286 0 0       0 warn( "Boundary ignored: illegal characters ($boundary)\n" ) if( $self->_warnings_is_enabled );
287 0         0 $boundary = undef();
288             }
289             }
290             # If we have to roll our own boundary, do so:
291 2 50       30 $boundary = $new->make_boundary if( !defined( $boundary ) );
292             }
293             # Or this is a single part
294             else
295             {
296             # Create body:
297 15 100 66     149 if( defined( $path ) && length( $path ) )
    50 33        
298             {
299 12   50     180 my $f = HTTP::Promise::Body::File->new( $path ) ||
300             return( $self->pass_error( HTTP::Promise::Body::File->error ) );
301 12 50       583 $new->body( $f ) || return( $self->pass_error );
302             # Set the Content-Disposition to 'attachment' by default if not set
303             # $disposition = 'attachment' if( !defined( $disposition ) || !length( $disposition ) );
304             }
305             elsif( defined( $data ) && length( $data ) )
306             {
307 3   50     54 my $s = HTTP::Promise::Body::InCore->new( $data ) ||
308             return( $self->pass_error( HTTP::Promise::Body::InCore->error ) );
309 3 50       28 $new->body( $s ) || return( $self->pass_error );
310             }
311             else
312             {
313 0         0 return( $self->error( "Unable to build HTTP entity: no body, and not multipart" ) );
314             }
315             # $self->body->binmode(1) unless( $self->textual_type( $type ) );
316             }
317            
318 17         1395 my $ct = Module::Generic::HeaderValue->new_from_header( $type );
319 17 50       91566 return( $self->pass_error( Module::Generic::HeaderValue->error ) ) if( !defined( $ct ) );
320 17 100       99 $ct->param( charset => $charset ) if( $charset );
321 17 100       1209 if( defined( $filename_utf8 ) )
    100          
322             {
323 3         69 $ct->param( 'name*' => sprintf( "UTF-8''%s", $filename_utf8 ) );
324             }
325             elsif( defined( $filename ) )
326             {
327 8         102 $ct->param( name => $filename );
328             }
329 17 100       11879 $ct->param( boundary => $boundary ) if( defined( $boundary ) );
330 17         2290 $headers->replace( 'Content-Type' => "$ct" );
331            
332 17 100 100     269 if( defined( $encoding ) && lc( $encoding ) eq 'suggest' )
333             {
334 3         81 $encoding = $new->suggest_encoding;
335             }
336            
337             # unless( $is_multipart )
338 17 100 100     545 if( !$is_multipart && ( defined( $disposition ) || defined( $filename ) ) )
      100        
339             {
340 11 100       117 $disposition = 'attachment' if( !defined( $disposition ) );
341 11 50       122 $field = Module::Generic::HeaderValue->new_from_header( ( defined( $disposition ) ? $disposition : () ) );
342 11 50       57831 return( $self->pass_error( Module::Generic::HeaderValue->error ) ) if( !defined( $field ) );
343 11 100       90 if( defined( $filename_utf8 ) )
    50          
344             {
345 3         48 $field->param( 'filename*' => sprintf( "UTF-8''%s", $filename_utf8 ) );
346             }
347             elsif( defined( $filename ) )
348             {
349 8         53 $field->param( filename => $filename );
350             }
351 11         12124 $headers->replace( 'Content-disposition', "$field" );
352             }
353 17 100 100     191 $headers->replace( 'Content-encoding', $encoding ) if( defined( $encoding ) && length( $encoding ) );
354 17 50 33     100 if( defined( $desc ) && length( $desc ) )
355             {
356 0 0       0 warn( "There is no Content-Description in HTTP protocole\n" ) if( $self->_warnings_is_enabled );
357             }
358              
359 17 50       71 if( defined( $id ) )
360             {
361 0 0       0 warn( "There is no Content-ID for HTTP multipart data\n" ) if( $self->_warnings_is_enabled );
362             }
363            
364 17         98 foreach( @$order )
365             {
366             # Maybe it has been removed since then? So that only headers remain
367 40 50       160 next if( !exists( $opts->{ $_ } ) );
368             # Value is undef -> remove the header, if any.
369 0 0       0 if( !defined( $opts->{ $_ } ) )
    0          
370             {
371 0         0 $headers->remove_header( $_ );
372             }
373             elsif( length( $opts->{ $_ } ) )
374             {
375 0         0 $headers->delete( $_ );
376 0 0       0 foreach my $val ( $self->_is_array( $opts->{ $_ } ) ? @{$opts->{ $_ }} : ( $opts->{ $_ } ) )
  0         0  
377             {
378 0         0 $headers->add( $_ => $val );
379             }
380             }
381             }
382 17         143 return( $new );
383             }
384              
385             sub clone
386             {
387 10     10 1 73 my $self = shift( @_ );
388 10         78 my $opts = $self->_get_args_as_hash( @_ );
389 10   100     1260 $opts->{clone_message} //= 1;
390 10         165 my $addr = $self->_refaddr( $self );
391 10         85 my $new = $self->new;
392 10         107 my( $new_headers, $new_body, $new_parts );
393 10         83 my $headers = $self->headers;
394 10         316 my $body = $self->body;
395 10 50       391 $new_headers = $headers->clone if( defined( $headers ) );
396 10 100       274 $new_body = $body->clone if( defined( $body ) );
397 10         448 my $parts = $self->parts;
398 10 100       8256 if( !$parts->is_empty )
399             {
400 1         31 $new_parts = $self->new_array;
401             # Each part is an HTTP::Promise::Entity
402 1         31 for( @$parts )
403             {
404 1         3 my $paddr = $self->_refaddr( $_ );
405             # This would be weird, but let's do it anyway
406 1 50       6 if( $paddr eq $addr )
407             {
408 0         0 $new_parts->push( $new );
409 0         0 next;
410             }
411 1         7 my $new_part = $_->clone;
412 1         6 $new_parts->push( $new_part );
413             }
414 1         15 $new->parts( $new_parts );
415             }
416 10 50       1238 $new->headers( $new_headers ) if( defined( $new_headers ) );
417 10 100       482 $new->body( $new_body ) if( defined( $new_body ) );
418 10 50       336 $new->name( $self->name ) if( $self->name );
419 10         7111 $new->is_encoded( $self->is_encoded );
420 10         8425 $new->debug( $self->debug );
421 10         549 $new->preamble( $self->preamble->clone );
422 10         8438 $new->epilogue( $self->epilogue->clone );
423 10         8721 $new->compression_min( $self->compression_min );
424 10         366286 $new->effective_type( $self->effective_type );
425 10         5200 my $msg;
426 10 100 66     76 if( ( $msg = $self->http_message ) && $opts->{clone_message} )
427             {
428             # To prevent endless recursion
429 3         120 my $new_msg = $msg->clone( clone_entity => 0 );
430 3         18 $new_msg->headers( $new_headers );
431 3         15 $new_msg->entity( $new );
432 3         675 $new->http_message( $new_msg );
433             }
434 10         480 return( $new );
435             }
436              
437 23     23 1 289871 sub compression_min { return( shift->_set_get_number( 'compression_min', @_ ) ); }
438              
439             # NOTE: an outdated method since nowadays everyone use UTF-8
440             # This is not intended to be a generic method, but instead to be used specifically for this entity
441             # content parameter can be provided to avoid reading from the body if we already have data handy.
442             sub content_charset
443             {
444 11     11 1 746 my $self = shift( @_ );
445 11         57 my $opts = $self->_get_args_as_hash( @_ );
446 11         932 my $headers = $self->headers;
447             # If parameter content_type_charset is set to false, this means it was just tried and
448             # we should not try it again.
449 11 0 0     831 if( ( my $charset = $headers->content_type_charset ) &&
      33        
450             ( !exists( $opts->{content_type_charset} ) || $opts->{content_type_charset} ) )
451             {
452 0         0 return( $charset );
453             }
454              
455 11 50       721 $self->_load_class( 'Encode' ) || return( $self->pass_error );
456 11 100 100     471 unless( defined( $BOM2ENC ) && scalar( %$BOM2ENC ) )
457             {
458             # Credits: Matthew Lawrence (File::BOM)
459             our $BOM2ENC = +{
460 2         21 map{ Encode::encode( $_, "\x{feff}" ) => $_ } qw(
  10         8408  
461             UTF-8
462             UTF-16BE
463             UTF-16LE
464             UTF-32BE
465             UTF-32LE
466             )
467             };
468              
469             our $ENC2BOM = +{
470             reverse( %$BOM2ENC ),
471 2         100 map{ $_ => Encode::encode( $_, "\x{feff}" ) } qw(
  6         2708  
472             UCS-2
473             iso-10646-1
474             utf8
475             )
476             };
477 2         121 my @boms = sort{ length( $b ) <=> length( $a ) } keys( %$BOM2ENC );
  13         51  
478 2         15 our $BOM_MAX_LENGTH = length( $boms[0] );
479             {
480 2         8 local $" = '|';
  2         10  
481 2         101 our $BOM_RE = qr/@boms/;
482             }
483             }
484            
485             # time to start guessing
486             # If called from decoded_content, kind of pointless to call decoded_content again
487 11         33 my $cref;
488 11 100 66     108 if( exists( $opts->{content} ) && length( $opts->{content} ) )
489             {
490 6 50 33     80 return( $self->error( "Unsupported data type (", ref( $opts->{content} ), ")." ) ) if( ref( $opts->{content} ) && !$self->_is_scalar( $opts->{content} ) );
491 6 50       95 $cref = $self->_is_scalar( $opts->{content} ) ? $opts->{content} : \$opts->{content};
492             }
493             else
494             {
495 5   50     26 my $body = $self->body || return( '' );
496 5   50     33 my $io = $body->open( '<', { binmode => 'raw' } ) ||
497             return( $self->pass_error( $body->error ) );
498 5         228 my $buff;
499 5         16 my $bytes = $io->read( $buff, 4096 );
500 5 50       534 return( $self->pass_error( $io->error ) ) if( !defined( $bytes ) );
501 5 50       20 return( '' ) if( !$bytes );
502 5         21 $cref = \$buff;
503             }
504            
505             # Is there a Byte Order Mark?
506 11 100       680 if( $$cref =~ /^($BOM_RE)/ )
507             {
508 6         15 my $bom = $1;
509 6         121 return( $BOM2ENC->{ $bom } );
510             }
511              
512             # Unicode BOM
513 5 50       65 return( 'UTF-8' ) if( $$cref =~ /^\xEF\xBB\xBF/ );
514 5 50       36 return( 'UTF-32LE' ) if( $$cref =~ /^\xFF\xFE\x00\x00/ );
515 5 50       39 return( 'UTF-32BE' ) if( $$cref =~ /^\x00\x00\xFE\xFF/ );
516 5 50       41 return( 'UTF-16LE' ) if( $$cref =~ /^\xFF\xFE/ );
517 5 50       39 return( 'UTF-16BE' ) if( $$cref =~ /^\xFE\xFF/ );
518              
519 5 50       51 if( $headers->content_is_xml )
    50          
    0          
520             {
521             # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
522             # XML entity not accompanied by external encoding information and not
523             # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
524             # in which the first characters must be '<?xml'
525 0 0       0 return( 'UTF-32BE' ) if( $$cref =~ /^\x00\x00\x00</ );
526 0 0       0 return( 'UTF-32LE' ) if( $$cref =~ /^<\x00\x00\x00/ );
527 0 0       0 return( 'UTF-16BE' ) if( $$cref =~ /^(?:\x00\s)*\x00</ );
528 0 0       0 return( 'UTF-16LE' ) if( $$cref =~ /^(?:\s\x00)*<\x00/ );
529 0 0       0 if( $$cref =~ /^[[:blank:]\h]*(<\?xml[^\x00]*?\?>)/ )
530             {
531 0 0       0 if( $1 =~ /[[:blank:]\h\v]encoding[[:blank:]\h\v]*=[[:blank:]\h\v]*(["'])(.*?)\1/ )
532             {
533 0         0 my $enc = $2;
534 0         0 $enc =~ s/^[[:blank:]\h]+//;
535 0         0 $enc =~ s/[[:blank:]\h]+\z//;
536 0 0       0 return( $enc ) if( $enc );
537             }
538             }
539 0         0 return( 'UTF-8' );
540             }
541             elsif( $headers->content_is_text )
542             {
543 5         180 my $encoding = $self->guess_character_encoding( content => $cref, object => 1 );
544 5 0       33 return( ref( $encoding ) ? $encoding->mime_name : $encoding ) if( $encoding );
    50          
545             }
546             elsif( $headers->content_type eq 'application/json' )
547             {
548             # RFC 4627, ch 3
549 0 0       0 return( 'UTF-32BE' ) if( $$cref =~ /^\x00\x00\x00./s );
550 0 0       0 return( 'UTF-32LE' ) if( $$cref =~ /^.\x00\x00\x00/s );
551 0 0       0 return( 'UTF-16BE' ) if( $$cref =~ /^\x00.\x00./s );
552 0 0       0 return( 'UTF-16LE' ) if( $$cref =~ /^.\x00.\x00/s );
553 0         0 return( 'UTF-8' );
554             }
555             # if( $headers->content_type =~ /^text\// && $self->_load_class( 'Encode' ) )
556 5 50       27 if( $headers->content_type =~ /^text\// )
557             {
558 5 50       194 if( length( $$cref ) )
559             {
560 0 0       0 return( 'US-ASCII' ) unless( $$cref =~ /[\x80-\xFF]/ );
561 0         0 my $encoding;
562             # try-catch
563 0         0 local $@;
564             eval
565 0         0 {
566 0         0 Encode::decode_utf8( $$cref, ( Encode::FB_CROAK | Encode::LEAVE_SRC ) );
567 0         0 $encoding = 'UTF-8';
568             };
569 0 0       0 if( $@ )
570             {
571 0         0 return( $self->error( "Failed to decode utf8 content: $@" ) );
572             }
573             # return( 'ISO-8859-1' );
574 0         0 return( $encoding );
575             }
576             }
577 5         21 return( '' );
578             }
579              
580             sub decode_body
581             {
582 21     21 1 2901 my $self = shift( @_ );
583 21         58 my $this = shift( @_ );
584 21         93 my $opts = $self->_get_args_as_hash( @_ );
585 21 50       1567 return( $self->error( "No decoding string or array has been provided." ) ) if( !defined( $this ) );
586 21 50 33     97 return( $self->error( "Bad argument provided. decode_body() accepts only either an array of encodings or a string or something that stringifies." ) ) if( !$self->_is_array( $this ) && ( ref( $this ) && !overload::Method( $this => '""' ) ) );
      66        
587 21 100       1127 my $encodings = $self->_is_array( $this ) ? $this : [split( /[[:blank:]\h]*,[[:blank:]\h]*/, "${this}" )];
588 21   100     691 $opts->{replace} //= 1;
589 21   100     311 $opts->{raise_error} //= 0;
590 21 50       146 $self->_load_class( 'HTTP::Promise::Stream' ) || return( $self->error );
591 21         1384 my $body = $self->body;
592 21 50 33     747 warn( "No encoding were provided to decode the HTTP body.\n" ) if( !scalar( @$encodings ) && warnings::enabled( ref( $self ) ) );
593             # Nothing to do
594 21 50 33     427 return( $self ) if( !$body || !scalar( @$encodings ) );
595             # Parameters to be passed. Transparent set to 0 allow for failure
596 21         660 my $enc2params =
597             {
598             bzip2 => { Transparent => 0 },
599             deflate => { Transparent => 0 },
600             inflate => { Transparent => 0 },
601             gzip => { Transparent => 0 },
602             lzf => { Transparent => 0 },
603             lzip => { Transparent => 0 },
604             lzma => { Transparent => 0 },
605             lzop => { Transparent => 0 },
606             rawdeflate => { Transparent => 0 },
607             rawinflate => { Transparent => 0 },
608             xz => { Transparent => 0 },
609             zstd => { Transparent => 0 },
610             };
611            
612 21 50       466 if( $body->isa( 'HTTP::Promise::Body::File' ) )
    50          
613             {
614 0         0 my $f = $body;
615 0 0       0 if( $f->is_empty )
616             {
617 0 0       0 warn( "HTTP Body file '$f' is empty, so there is nothing to decode\n" ) if( warnings::enabled( ref( $self ) ) );
618 0         0 return( $self );
619             }
620 0         0 my $ext = $f->extension;
621 0         0 my $ext_vary = $self->ext_vary;
622 0         0 my $ext_parts;
623 0 0       0 if( $ext_vary )
624             {
625 0         0 $ext_parts = $f->extensions;
626             }
627            
628 0         0 foreach my $enc ( @$encodings )
629             {
630 0 0 0     0 next if( $enc eq 'identity' || $enc eq 'none' );
631 0         0 my $params = {};
632 0 0       0 $params = $enc2params->{ $enc } if( exists( $enc2params->{ $enc } ) );
633             my $s = HTTP::Promise::Stream->new( $f,
634             decoding => $enc,
635             fatal => $opts->{raise_error}
636 0   0     0 ) || return( $self->pass_error( HTTP::Promise::Stream->error ) );
637 0         0 my $ext_deb = $s->encoding2suffix( $enc )->first;
638 0         0 my $ext_enc;
639 0 0 0     0 if( $ext_vary &&
      0        
640             ( $ext_enc = $s->encoding2suffix( $enc )->first ) &&
641             $ext_parts->[-1] eq $ext_enc )
642             {
643 0         0 pop( @$ext_parts );
644 0         0 $ext = join( '.', @$ext_parts );
645             }
646 0         0 my $tempfile = $self->new_tempfile( extension => $ext );
647             # my $len = $s->read( $tempfile, ( exists( $params->{ $enc } ) ? %{$params->{ $enc }} : () ) );
648 0         0 my $len = $s->read( $tempfile, $params );
649 0 0       0 if( !defined( $len ) )
650             {
651 0 0 0     0 if( $enc eq 'deflate' || $enc eq 'inflate' )
652             {
653             # Try again, but using rawinflate this time
654 0 0       0 if( $s->error->message =~ /Header Error: CRC mismatch/ )
655             {
656 0         0 $enc = "raw${enc}";
657 0         0 $params = {};
658 0 0       0 $params = $enc2params->{ $enc } if( exists( $enc2params->{ $enc } ) );
659             my $s = HTTP::Promise::Stream->new( $f,
660             decoding => $enc,
661             fatal => $opts->{raise_error}
662 0   0     0 ) || return( $self->pass_error( HTTP::Promise::Stream->error ) );
663             # $len = $s->read( $tempfile, ( exists( $params->{ $enc } ) ? ( $params->{ $enc } ) : () ) );
664 0         0 $len = $s->read( $tempfile, $params );
665 0 0       0 return( $self->pass_error( $s->error ) ) if( !defined( $len ) );
666             }
667             else
668             {
669 0         0 return( $self->pass_error( $s->error ) )
670             }
671             }
672             else
673             {
674 0         0 return( $self->pass_error( $s->error ) );
675             }
676             }
677 0 0       0 return( $self->error( "The decoding pass on the HTTP body file source '$f' to target '$tempfile' with encoding '$enc' resulted in 0 byte decoded!" ) ) if( !$len );
678 0         0 $f = $tempfile;
679             }
680 0   0     0 $body = HTTP::Promise::Body::File->new( $f ) ||
681             return( $self->pass_error( HTTP::Promise::Body::File->error ) );
682 0 0       0 if( $opts->{replace} )
683             {
684 0         0 $self->body( $body );
685 0         0 $self->is_decoded(1);
686             }
687             }
688             elsif( $body->isa( 'HTTP::Promise::Body::Scalar' ) )
689             {
690 21         71 my $temp = $body;
691 21 50       149 if( $body->is_empty )
692             {
693 0 0       0 warn( "HTTP Body in memory is empty, so there is nothing to decode\n" ) if( warnings::enabled( ref( $self ) ) );
694 0         0 return( $self );
695             }
696            
697 21         264 foreach my $enc ( @$encodings )
698             {
699 32 100 100     17297 next if( $enc eq 'identity' || $enc eq 'none' );
700 30         103 my $params = {};
701 30 100       184 $params = $enc2params->{ $enc } if( exists( $enc2params->{ $enc } ) );
702             my $s = HTTP::Promise::Stream->new( $temp,
703             decoding => $enc,
704             fatal => $opts->{raise_error},
705 30   100     233 debug => $self->debug
706             ) || return( $self->pass_error( HTTP::Promise::Stream->error ) );
707 27         367 my $decoded = $self->new_scalar;
708             # my $len = $s->read( $decoded, ( exists( $params->{ $enc } ) ? ( $params->{ $enc } ) : () ) );
709 27         982 my $len = $s->read( $decoded, $params );
710             # my $len = $s->read( $decoded );
711             # return( $self->pass_error( $s->error ) ) if( !defined( $len ) );
712 27 100       7907 if( !defined( $len ) )
713             {
714 1 50 33     45 if( $enc eq 'deflate' || $enc eq 'inflate' )
715             {
716             # Try again, but using rawinflate this time
717 1 50       21 if( $s->error->message =~ /Header Error: CRC mismatch/ )
718             {
719 1         906 $enc = "raw${enc}";
720 1         8 $params = {};
721 1 50       27 $params = $enc2params->{ $enc } if( exists( $enc2params->{ $enc } ) );
722             my $s = HTTP::Promise::Stream->new( $temp,
723             decoding => $enc,
724             fatal => $opts->{raise_error},
725 1   50     31 debug => $self->debug
726             ) || return( $self->pass_error( HTTP::Promise::Stream->error ) );
727             # $len = $s->read( $decoded, ( exists( $params->{ $enc } ) ? $params->{ $enc } : () ) );
728 1         36 $len = $s->read( $decoded, $params );
729 1 50       73 return( $self->pass_error( $s->error ) ) if( !defined( $len ) );
730             }
731             else
732             {
733 0         0 return( $self->pass_error( $s->error ) )
734             }
735             }
736             else
737             {
738 0         0 return( $self->pass_error( $s->error ) );
739             }
740             }
741 27 50       1999 return( $self->error( "The decoding pass on the HTTP body in memory with encoding '$enc' resulted in 0 byte decoded!" ) ) if( !$len );
742 27         1140 $temp = $decoded;
743             }
744             # Replace content (default)
745 18 100       34954 if( $opts->{replace} )
746             {
747 14         339 $body->set( $temp );
748 14         742 $self->body( $body );
749 14         1360 $self->is_decoded(1);
750             }
751             # Make a copy to return it
752             else
753             {
754 4         99 $body = $body->new( $temp );
755             }
756             }
757             else
758             {
759 0         0 return( $self->error( "I do not know how to handle HTTP body object of class ", ref( $body ) ) );
760             }
761 18         12037 return( $body );
762             }
763              
764             sub dump
765             {
766 2     2 1 2133 my $self = shift( @_ );
767 2         21 my $opts = $self->_get_args_as_hash( @_ );
768 2         383 my $content = '';
769 2         7 my $maxlen = $opts->{maxlength};
770 2 50       8 $maxlen = 512 unless( defined( $maxlen ) );
771 2         8 my $no_content = $opts->{no_content};
772 2 50       13 $no_content = "(no content)" unless( defined( $no_content ) );
773 2         12 my $body = $self->body;
774 2         59 my $chopped = 0;
775 2         12 my $mime_type = $self->mime_type;
776 2         5 my $toptype;
777 2 50       25 $toptype = [split( '/', lc( $mime_type ), 2 )]->[0] if( defined( $mime_type ) );
778 2   50     12 my $crlf = $HTTP::Promise::Entity::BOUNDARY_DELIMITER || CRLF;
779              
780 2 50       8 if( defined( $body ) )
    0          
781             {
782 2   50     27 my $io = $body->open( '<', { binmode => 'raw' } ) ||
783             return( $self->pass_error( $body->error ) );
784 2   66     130 my $bytes = $io->read( $content, ( $maxlen || $body->length ) );
785 2 50       36876 return( $self->pass_error( $io->error ) ) if( !defined( $bytes ) );
786 2         141 $io->close;
787 2         188 my $encoding = $self->headers->mime_encoding;
788 2         7 my $encodings = [];
789 2 50 33     16 $encodings = [split( /[[:blank:]\h]*,[[:blank:]\h]*/, $encoding )] if( defined( $encoding ) && length( $encoding ) );
790 2 50       25 $self->_load_class( 'HTTP::Promise::Stream' ) || return( $self->error );
791             # Process encoding
792 2 50 33     113 if( scalar( @$encodings ) && !$self->is_encoded )
793             {
794 0         0 my $temp = $content;
795 0         0 my $has_error = 0;
796 0         0 foreach my $enc ( @$encodings )
797             {
798 0   0     0 my $s = HTTP::Promise::Stream->new( $temp, encoding => $enc ) ||
799             return( $self->pass_error( HTTP::Promise::Stream->error ) );
800 0         0 my $encoded = $self->new_scalar;
801 0         0 my $len = $s->read( $encoded );
802 0 0       0 return( $self->pass_error( $s->error ) ) if( !defined( $len ) );
803 0 0       0 if( !$len )
804             {
805 0         0 warn( "The encoding pass on the HTTP body in memory with encoding '$enc' resulted in 0 byte encoded!\n" );
806 0         0 $has_error++;
807 0         0 last;
808             }
809 0         0 $temp = $encoded;
810             }
811 0 0       0 $content = $temp unless( $has_error );
812             }
813            
814 2 50       8 if( length( $content ) )
815             {
816 2 50       11 if( $self->is_binary( \$content ) )
817             {
818 0         0 $content = '(content is ' . length( $content ) . ' bytes of binary data)';
819             }
820             else
821             {
822 2 100 66     26 if( $maxlen && $body->length > $maxlen )
823             {
824 1         35537 $content .= '...';
825 1         7 $chopped = $body->length - $maxlen;
826             }
827 2         35820 $content =~ s/\\/\\\\/g;
828 2         255 $content =~ s/\t/\\t/g;
829 2         6 $content =~ s/\r/\\r/g;
830              
831             # no need for 3 digits in escape for these
832 2         6 $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
  0         0  
833              
834 2         5 $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
  0         0  
835 2         5 $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
  0         0  
836              
837             # remaining whitespace
838 2         5 $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
  0         0  
839 2         9 $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
  0         0  
840 2         6 $content =~ s/\n\z/\\n/;
841 2 50       8 if( $content eq $no_content )
842             {
843             # escape our $no_content marker
844 0         0 $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
  0         0  
845             }
846             }
847             }
848             else
849             {
850 0         0 $content = $no_content;
851             }
852 2 100       14 $content .= "\n(+ $chopped more bytes not shown)" if( $chopped );
853             }
854             elsif( !$self->part->is_empty )
855             {
856 0         0 my $boundary = $self->_prepare_multipart_headers;
857             # Multipart... form-data or mixed
858 0 0 0     0 if( defined( $toptype ) && $toptype eq 'multipart' )
859             {
860 0         0 my $boundary = $self->_prepare_multipart_headers();
861              
862             # Preamble. I do not think there should be any anyway for HTTP multipart
863 0         0 my $plines = $self->preamble;
864 0 0       0 if( defined( $plines ) )
865             {
866             # Defined, so output the preamble if it exists (avoiding additional
867             # newline as per ticket 60931)
868 0 0       0 $content .= join( '', @$plines ) . $crlf if( @$plines > 0 );
869             }
870             # Otherwise, no preamble.
871              
872             # Parts
873 0         0 foreach my $part ( $self->parts->list )
874             {
875 0         0 $content .= "--${boundary}${crlf}";
876 0         0 $content .= $part->dump( $opts );
877             # Trailing CRLF
878 0         0 $content .= $crlf;
879             }
880 0         0 $content .= "--${boundary}--${crlf}";
881              
882             # Epilogue
883 0         0 my $epilogue = $self->epilogue;
884 0 0 0     0 if( defined( $epilogue ) && !$epilogue->is_empty )
885             {
886 0         0 $content .= $epilogue->join( '' )->scalar;
887 0 0       0 if( $epilogue !~ /(?:\015?\012)\Z/ )
888             {
889 0         0 $content .= $crlf;
890             }
891             }
892             }
893             # Singlepart type with parts...
894             # This makes $ent->print handle message/rfc822 bodies
895             # when parse_nested_messages('NEST') is on [idea by Marc Rouleau].
896             else
897             {
898 0         0 my $need_sep = 0;
899 0         0 my $part;
900 0         0 foreach $part ( $self->parts->list )
901             {
902 0 0       0 if( $need_sep++ )
903             {
904 0         0 $content .= "${crlf}${crlf}";
905             }
906 0         0 $content .= $part->dump( $opts );
907             }
908             }
909             }
910              
911 2         279 my @dump;
912 2 50       8 push( @dump, $opts->{preheader} ) if( $opts->{preheader} );
913 2         5 my $start_line;
914 2 50 33     10 if( $self->http_message && ( $start_line = $self->http_message->start_line ) )
915             {
916 0         0 push( @dump, $start_line );
917             }
918 2         8 push( @dump, $self->headers->as_string, $content );
919              
920 2         10 my $dump = join( "\n", @dump, '' );
921 2 50       9 $dump =~ s/^/$opts->{prefix}/gm if( $opts->{prefix} );
922 2         30 return( $dump );
923             }
924              
925             sub dump_skeleton
926             {
927 0     0 1 0 my $self = shift( @_ );
928 0         0 my( $fh, $indent ) = @_;
929 0 0       0 $fh = select if( !$fh );
930 0 0       0 $indent = 0 if( !defined( $indent ) );
931 0         0 my $ind = ' ' x $indent;
932 0         0 my $part;
933 12     12   129 no strict 'refs';
  12         45  
  12         33817  
934 0         0 my $crlf = CRLF;
935 0         0 my @first_line = ();
936 0 0       0 if( my $msg = $self->http_message )
937             {
938 0 0       0 if( $msg->isa( 'HTTP::Promise::Request' ) )
939             {
940 0         0 push( @first_line, $msg->method, $msg->uri, $msg->protocol );
941             }
942             else
943             {
944 0         0 push( @first_line, $msg->protocol, $msg->code, $msg->status );
945             }
946 0 0       0 print( $fh join( ' ', @first_line ), $crlf ) if( @first_line );
947             }
948 0         0 my $headers = $self->headers;
949 0 0       0 print( $fh $headers->as_string, $crlf ) || return( $self->error( $! ) );
950 0         0 my $body = $self->body;
951 0 0       0 if( $body )
952             {
953 0 0       0 if( $body->isa( 'HTTP::Promise::Body::File' ) )
    0          
954             {
955 0 0       0 print( $fh "${ind}Body is stored in a temporary file at '", $body->filename, "' and is ", $body->length, " bytes big.${crlf}" ) ||
956             return( $self->error( $! ) );
957             }
958             elsif( $body->isa( 'HTTP::Promise::Body::Form' ) )
959             {
960 0 0       0 print( $fh "${ind}Body is a x-www-form-urlencoded data with ", $body->length, " elements:\n", $body->dump ) ||
961             return( $self->error( $! ) );
962             }
963             else
964             {
965 0 0       0 print( $fh "${ind}Body is stored in memory and is ", $body->length, " bytes big.${crlf}" ) ||
966             return( $self->error( $! ) );
967             }
968             }
969 0 0       0 if( my $cd = $headers->content_disposition )
970             {
971 0 0       0 print( $fh "${ind}Body is encoded using $cd\n" ) || return( $self->error( $! ) );
972             }
973 0         0 my $filename = $self->headers->recommended_filename;
974 0 0       0 print( $fh $ind, "${ind}Recommended filename is: '${filename}'$crlf" ) if( $filename );
975              
976             # The parts
977 0         0 my $parts = $self->parts;
978 0         0 printf( $fh "${ind}This HTTP message has %d parts.${crlf}", $parts->length );
979 0         0 print( $fh $ind, "--\n" );
980 0         0 foreach $part ( @$parts )
981             {
982 0         0 $part->dump_skeleton( $fh, $indent + 1 );
983             }
984 0         0 return( $self );
985             }
986              
987             sub effective_type
988             {
989 23     23 1 185 my $self = shift( @_ );
990 23 100       115 if( @_ )
991             {
992 10         55 $self->_set_get_scalar_as_object( 'effective_type', @_ );
993             }
994 23   66     8211 return( $self->_set_get_scalar_as_object( 'effective_type' ) || $self->mime_type );
995             }
996              
997             sub encode_body
998             {
999 12     12 1 63 my $self = shift( @_ );
1000 12         74 my $this = shift( @_ );
1001 12 50 33     189 return( $self->error( "Bad argument provided. encode_body() accepts only either an array of encodings or a string or something that stringifies." ) ) if( !defined( $this ) || ( !$self->_is_array( $this ) && ( ref( $this ) && !overload::Method( $this => '""' ) ) ) );
      66        
      33        
1002 12 100       1376 my $encodings = $self->new_array( $self->_is_array( $this ) ? $this : [split( /[[:blank:]\h]*,[[:blank:]\h]*/, "${this}" )] );
1003 12 50       946 $self->_load_class( 'HTTP::Promise::Stream' ) || return( $self->error );
1004 12         944 my $body = $self->body;
1005 12 50 33     487 warn( "No encodings were provided to encode the HTTP body.\n" ) if( !scalar( @$encodings ) && warnings::enabled( ref( $self ) ) );
1006             # Nothing to do
1007 12 50       548 return( $self ) if( !$body );
1008 12         68 my $seen = {};
1009 12 100       268 if( $body->isa( 'HTTP::Promise::Body::File' ) )
    50          
1010             {
1011 1         2 my $f = $body;
1012 1 50       31 if( $f->is_empty )
1013             {
1014 0 0       0 warn( "HTTP Body file '$f' is empty, so there is nothing to encode\n" ) if( warnings::enabled( ref( $self ) ) );
1015 0         0 return( $self );
1016             }
1017 1         37903 my $ext = $f->extension;
1018 1         167 foreach my $enc ( @$encodings )
1019             {
1020 2 50 33     2001 next if( $enc eq 'identity' || $enc eq 'none' );
1021 2 50       18 next if( ++$seen->{ $enc } > 1 );
1022 2   50     30 my $s = HTTP::Promise::Stream->new( $f, encoding => $enc ) ||
1023             return( $self->pass_error( HTTP::Promise::Stream->error ) );
1024 2 50       44 if( $self->ext_vary )
1025             {
1026 0   0     0 my $enc_ext = HTTP::Promise::Stream->encoding2suffix( $enc ) ||
1027             return( $self->pass_error( HTTP::Promise::Stream->error ) );
1028 0 0       0 if( !$enc_ext->is_empty )
1029             {
1030 0         0 $ext .= '.' . $enc_ext->join( '.' )->scalar;
1031             }
1032             }
1033 2         1391 my $tempfile = $self->new_tempfile( extension => $ext );
1034 2         103602 my $len = $s->read( $tempfile );
1035 2 50       109 return( $self->pass_error( $s->error ) ) if( !defined( $len ) );
1036 2 50       19 return( $self->error( "The encoding pass on the HTTP body file source '$f' to target '$tempfile' with encoding '$enc' resulted in 0 byte encoded!" ) ) if( !$len );
1037 2         40 $f = $tempfile;
1038             }
1039 1   50     3649 $body = HTTP::Promise::Body::File->new( $f ) ||
1040             return( $self->pass_error( HTTP::Promise::Body::File->error ) );
1041 1         119 $self->body( $body );
1042             }
1043             elsif( $body->isa( 'HTTP::Promise::Body::Scalar' ) )
1044             {
1045 11         49 my $temp = $body;
1046 11 50       132 if( $body->is_empty )
1047             {
1048 0 0       0 warn( "HTTP Body in memory is empty, so there is nothing to encode\n" ) if( warnings::enabled( ref( $self ) ) );
1049 0         0 return( $self );
1050             }
1051            
1052 11         186 foreach my $enc ( @$encodings )
1053             {
1054 13 100 100     3893 next if( $enc eq 'identity' || $enc eq 'none' );
1055 11 50       100 next if( ++$seen->{ $enc } > 1 );
1056 11   100     173 my $s = HTTP::Promise::Stream->new( $temp, encoding => $enc ) ||
1057             return( $self->pass_error( HTTP::Promise::Stream->error ) );
1058 10         165 my $encoded = $self->new_scalar;
1059 10         385 my $len = $s->read( $encoded );
1060 10 50       375 return( $self->pass_error( $s->error ) ) if( !defined( $len ) );
1061 10 50       67 return( $self->error( "The encoding pass on the HTTP body in memory with encoding '$enc' resulted in 0 byte encoded!" ) ) if( !$len );
1062 10         328 $temp = $encoded;
1063             }
1064 10         15381 $body->set( $temp );
1065 10         412 $self->body( $body );
1066             }
1067             else
1068             {
1069 0         0 return( $self->error( "I do not know how to handle HTTP body object of class ", ref( $body ) ) );
1070             }
1071 11         3498 return( $body );
1072             }
1073              
1074 32     32 1 7236 sub epilogue { return( shift->_set_get_array_as_object( 'epilogue', @_ ) ); }
1075              
1076 2     2 1 31 sub ext_vary { return( shift->_set_get_boolean( 'ext_vary', @_ ) ); }
1077              
1078             # Credits: Christopher J. Madsen (IO::HTML)
1079             # Extract here, because I do not want to load all the modules
1080             sub guess_character_encoding
1081             {
1082 5     5 1 28 my $self = shift( @_ );
1083 5         31 my $opts = $self->_get_args_as_hash( @_ );
1084 5         777 my $data;
1085 5 50 33     100 if( exists( $opts->{content} ) && length( $opts->{content} ) )
1086             {
1087 5 50 33     83 return( $self->error( "Unsupported data type (", ref( $opts->{content} ), ")." ) ) if( ref( $opts->{content} ) && !$self->_is_scalar( $opts->{content} ) );
1088 5 50       85 $data = $self->_is_scalar( $opts->{content} ) ? $opts->{content} : \$opts->{content};
1089             }
1090             else
1091             {
1092 0         0 my $body = $self->body;
1093 0 0 0     0 return( '' ) if( !$body || $body->is_empty );
1094 0         0 my $buff;
1095 0   0     0 my $io = $body->open( '<', { binmode => 'raw' } ) ||
1096             return( $self->pass_error( $body->error ) );
1097 0         0 my $bytes = $io->read( $buff, 4096 );
1098 0         0 $io->close;
1099 0 0       0 return( $self->pass_error( $io->error ) ) if( !defined( $bytes ) );
1100 0         0 $data = \$buff;
1101             }
1102 5 50       87 return( '' ) if( $self->is_binary( $data ) );
1103              
1104 5         16 my $encoding;
1105 5 50       85 if( $$data =~ /^\xFe\xFF/ )
    50          
    50          
1106             {
1107 0         0 $encoding = 'UTF-16BE';
1108             }
1109             elsif( $$data =~ /^\xFF\xFe/ )
1110             {
1111 0         0 $encoding = 'UTF-16LE';
1112             }
1113             elsif( $$data =~ /^\xEF\xBB\xBF/ )
1114             {
1115 0         0 $encoding = 'utf-8-strict';
1116             }
1117              
1118             # try decoding as UTF-8
1119 5 50       28 if( !defined( $encoding ) )
1120             {
1121 5 50       24 $self->_load_class( 'Encode' ) || return( $self->pass_error );
1122 5         240 my $test = Encode::decode( 'utf-8-strict', $$data, Encode::FB_QUIET );
1123             # end if valid UTF-8 with at least one multi-byte character:
1124 5 50 33     357 if( $$data =~ /^(?: # nothing left over
1125             | [\xC2-\xDF] # incomplete 2-byte char
1126             | [\xE0-\xEF] [\x80-\xBF]? # incomplete 3-byte char
1127             | [\xF0-\xF4] [\x80-\xBF]{0,2} # incomplete 4-byte char
1128             )\z/x and $test =~ /[^\x00-\x7F]/ )
1129             {
1130 0         0 $encoding = 'utf-8-strict';
1131             }
1132             }
1133             # end if testing for UTF-8
1134 5 0 33     35 if( defined( $encoding ) and
      0        
1135             $opts->{object} and
1136             !ref( $encoding ) )
1137             {
1138 0 0       0 $self->_load_class( 'Encode' ) || return( $self->pass_error );
1139 0         0 $encoding = Encode::find_encoding( $encoding );
1140             }
1141 5 50       51 return( defined( $encoding ) ? $encoding : '' );
1142             }
1143              
1144 1     1 1 36807 sub header { return( shift->headers->header( @_ ) ); }
1145              
1146 529     529 1 33638 sub headers { return( shift->_set_get_object_without_init( 'headers','HTTP::Promise::Headers', @_ ) ); }
1147              
1148 0     0 1 0 sub header_as_string { return( shift->headers->as_string( @_ ) ); }
1149              
1150 196     196 1 41078 sub http_message { return( shift->_set_get_object_without_init( 'http_message', 'HTTP::Promise::Message', @_ ) ); }
1151              
1152             # Ref: <https://stackoverflow.com/questions/9956198/in-perl-how-can-i-can-check-if-an-encoding-specified-in-a-string-is-valid>
1153             sub io_encoding
1154             {
1155 13     13 1 475 my $self = shift( @_ );
1156 13         89 my $opts = $self->_get_args_as_hash( @_ );
1157             # body argument is necessary when content has been decoded, but not replaced with decode_body()
1158             # and then HTTP::Promise::Message::decoded_content calls io_encoding() to get the character encoding
1159 13   66     1787 my $body = $opts->{body} // $self->body;
1160 13         89 my $headers = $self->headers;
1161             # Use cache if it exists
1162 13 50 66     580 if( !exists( $opts->{content} ) &&
      66        
      66        
      66        
1163             ( ( $opts->{charset_strict} && $self->{_io_encoding_strict_cached} ) ||
1164             ( !$opts->{charset_strict} && $self->{_io_encoding_cached} )
1165             ) &&
1166             $body &&
1167             $self->{_checksum_md5} eq $body->checksum_md5 )
1168             {
1169 2 50       47 return( $opts->{charset_strict} ? $self->{_io_encoding_strict_cached} : $self->{_io_encoding_cached} );
1170             }
1171 11         24 my $data;
1172 11 50 33     60 if( exists( $opts->{content} ) && length( $opts->{content} ) )
1173             {
1174 0 0 0     0 return( $self->error( "Unsupported data type (", ref( $opts->{content} ), ")." ) ) if( ref( $opts->{content} ) && !$self->_is_scalar( $opts->{content} ) );
1175 0 0       0 $data = $self->_is_scalar( $opts->{content} ) ? $opts->{content} : \$opts->{content};
1176             }
1177             else
1178             {
1179             # my $body = $self->body || return( '' );
1180 11 50       34 return( '' ) if( !$body );
1181 11         98 $self->{_checksum_md5} = $body->checksum_md5;
1182 11   50     287 my $io = $body->open( '<', { binmode => 'raw' } ) ||
1183             return( $self->pass_error( $body->error ) );
1184 11         1928 my $buff;
1185 11         72 my $bytes = $io->read( $buff, 4096 );
1186 11 50       1439 return( $self->pass_error( $io->error ) ) if( !defined( $bytes ) );
1187 11 50       50 return( '' ) if( !$bytes );
1188 11         127 $data = \$buff;
1189             }
1190             # return( '' ) if( $self->is_binary( $data ) );
1191            
1192 11         1130 my $enc;
1193 11 100 100     146 if( $headers->content_is_text || ( my $is_xml = $headers->content_is_xml ) )
1194             {
1195             my $charset = lc(
1196             $opts->{charset} ||
1197             $headers->content_type_charset ||
1198             $opts->{default_charset} ||
1199             # content_type_charset to tell content_charset to not try to call this method since we just called it.
1200 9   100     430 $self->content_charset( content => $data, content_type_charset => 0 ) ||
1201             'UTF-8'
1202             );
1203 9 50 33     700 if( $charset eq 'none' )
    50          
1204             {
1205             # leave it as is
1206             }
1207             elsif( $charset eq 'us-ascii' || $charset eq 'iso-8859-1' )
1208             {
1209             # if( $$content_ref =~ /[^\x00-\x7F]/ && defined &utf8::upgrade )
1210 0 0       0 if( $$data =~ /[^\x00-\x7F]/ )
1211             {
1212 0         0 $enc = 'utf-8';
1213             }
1214             }
1215             else
1216             {
1217 9 50       65 $self->_load_class( 'Encode' ) || return( $self->pass_error );
1218             # try-catch
1219 9         310 local $@;
1220             eval
1221 9         25 {
1222 9 100       161 my $test = Encode::decode( $charset, $$data, ( ( $opts->{charset_strict} ? Encode::FB_CROAK : 0 ) | Encode::LEAVE_SRC ) );
1223 7         1112 $enc = $charset;
1224             };
1225 9 100       143 if( $@ )
1226             {
1227 2         12 my $retried = 0;
1228 2 50       24 if( $@ =~ /^Unknown encoding/ )
1229             {
1230 0   0     0 my $alt_charset = lc( $opts->{alt_charset} || '' );
1231 0 0 0     0 if( $alt_charset && $charset ne $alt_charset )
1232             {
1233             # Retry decoding with the alternative charset
1234 0 0       0 my $test = Encode::decode( $alt_charset, $$data, ( ( $opts->{charset_strict} ? Encode::FB_CROAK : 0 ) | Encode::LEAVE_SRC ) ) unless( $alt_charset eq 'none' );
    0          
1235 0         0 $retried++;
1236 0         0 $enc = $alt_charset;
1237             }
1238             }
1239 2 50       47 return( $self->error( $@ ) ) unless( $retried );
1240             }
1241             }
1242             }
1243 9 50       33 if( $opts->{charset_strict} )
1244             {
1245 0         0 $self->{_io_encoding_strict_cached} = $enc;
1246             }
1247             else
1248             {
1249 9         30 $self->{_io_encoding_cached} = $enc;
1250             }
1251 9 100       71 return( defined( $enc ) ? $enc : '' );
1252             }
1253              
1254             # <https://stackoverflow.com/questions/899206/how-does-perl-know-a-file-is-binary>
1255             # <https://github.com/morungos/perl-Data-Binary/blob/master/lib/Data/Binary.pm>
1256             # "The "-T" and "-B" tests work as follows. The first block or so of the file is examined to see if it is valid UTF-8 that includes non-ASCII characters. If so, it's a "-T" file.
1257             # Otherwise, that same portion of the file is examined for odd characters such as strange control codes or characters with the high bit set. If more than a third of the characters are strange, it's a "-B" file; otherwise it's a "-T" file.
1258             # Also, any file containing a zero byte in the examined portion is considered a binary file. (If executed within the scope of a use locale which includes "LC_CTYPE", odd characters are anything that isn't a printable nor space in the current locale.) If "-T" or "-B" is used on a filehandle, the current IO buffer is examined rather than the first block. Both "-T" and "-B" return true on an empty file, or a file at EOF when testing a filehandle. Because you have to read a file to do the "-T" test, on most occasions you want to use a "-f" against the file first, as in "next unless -f $file && -T $file"."
1259             sub is_binary
1260             {
1261 7     7 1 20 my $self = shift( @_ );
1262 7 50       24 $self->_load_class( 'Encode' ) || return( $self->pass_error );
1263 7         249 my $data;
1264 7 50       51 if( @_ )
1265             {
1266             # We need to make a copy
1267 7         29 my $this = shift( @_ );
1268 7 50 33     113 return(0) if( !defined( $this ) || !length( "$this" ) );
1269 7 50 33     124 return( $self->error( "Bad argument. You can only provide a string or a scalar reference." ) ) if( ref( $this ) && !$self->_is_scalar( $this ) );
1270 7 50       141 $data = ref( $this ) ? $this : \$this;
1271             }
1272             else
1273             {
1274 0         0 my $body = $self->body;
1275 0 0 0     0 return(0) if( !$body || $body->is_empty );
1276 0         0 my $buff;
1277 0   0     0 my $io = $body->open( '<', { binmode => 'raw' } ) ||
1278             return( $self->pass_error( $body->error ) );
1279 0         0 my $bytes = $io->read( $buff, 4096 );
1280 0         0 $io->close;
1281 0 0       0 return( $self->pass_error( $io->error ) ) if( !defined( $bytes ) );
1282 0 0 0     0 warn( "Body is ", $body->length, " bytes big, but somehow I could not read ny bytes out of it.\n" ) if( !$bytes && warnings::enabled() );
1283 0 0       0 return(0) if( !$bytes );
1284 0         0 $data = \$buff;
1285             }
1286            
1287             # There are various method to check if the data is or contains binary data
1288             # perl's -B function is very cautious and will lean on the false positive.
1289             # Data::Binary implements the perl algorithm, but still yield false positive if, for example,
1290             # there is even 1 \0 in the data
1291             # The most reliable yet is to use module Encode with the die flag on upon error and catch it.
1292            
1293             # Has the utf8 bit been set?
1294             # Then, let's try to encode it into utf-8
1295 7 50       44 if( utf8::is_utf8( $$data ) )
1296             {
1297             eval
1298 0         0 {
1299 0         0 Encode::encode( 'utf-8', $$data, ( Encode::FB_CROAK | Encode::LEAVE_SRC ) );
1300             };
1301 0 0       0 return( $@ ? 1 : 0 );
1302             }
1303             # otherwise, let's try to decode this into perl's internal utf8 representation
1304             # else
1305             # {
1306             # eval
1307             # {
1308             # Encode::decode( 'utf8', $$data, ( Encode::FB_CROAK | Encode::LEAVE_SRC ) );
1309             # };
1310             # }
1311             # return( $@ ? 1 : 0 );
1312              
1313 7 50       158 return(1) if( index( $$data, "\c@" ) != -1 );
1314 7         33 my $length = length( $$data );
1315 7         26 my $odd = ( $$data =~ tr/\x01\x02\x03\x04\x05\x06\x07\x09\x0b\x0c\x0e\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f//d );
1316             # Detecting >=128 and non-UTF-8 is interesting. Note that all UTF-8 >=128 has several bytes with
1317             # >=128 set, so a quick test is possible by simply checking if any are >=128. However, the count
1318             # from that is typically wrong, if this is binary data, it'll not have been decoded. So we do this
1319             # in two steps.
1320              
1321 7         18 my $copy = $$data;
1322 7 50       31 if( ( $copy =~ tr[\x80-\xff][]d ) > 0 )
1323             {
1324 0         0 my $modified = Encode::decode_utf8( $$data, Encode::FB_DEFAULT );
1325 0         0 my $substitions = ( $modified =~ tr/\x{fffd}//d );
1326 0         0 $odd += $substitions;
1327             }
1328 7 50       67 return(1) if( ( $odd / $length ) > 0.34 );
1329 7         34 return(0);
1330             }
1331              
1332             sub is_body_on_file
1333             {
1334 0     0 1 0 my $self = shift( @_ );
1335 0         0 my $body = $self->body;
1336 0 0 0     0 return(0) if( !$body || $body->is_empty );
1337 0         0 return( $self->_is_a( $body => 'HTTP::Promise::Body::File' ) );
1338             }
1339              
1340             sub is_body_in_memory
1341             {
1342 0     0 1 0 my $self = shift( @_ );
1343 0         0 my $body = $self->body;
1344 0 0 0     0 return(0) if( !$body || $body->is_empty );
1345 0         0 return( $self->_is_a( $body => 'HTTP::Promise::Body::Scalar' ) );
1346             }
1347              
1348             # Convenience
1349             sub is_decoded
1350             {
1351 14     14 1 101 my $self = shift( @_ );
1352 14 50       90 if( @_ )
1353             {
1354 14         67 my $bool = shift( @_ );
1355 14         143 return( !$self->is_encoded( !$bool ) );
1356             }
1357             else
1358             {
1359 0         0 return( !$self->is_encoded );
1360             }
1361             }
1362              
1363 99     99 1 4796 sub is_encoded { return( shift->_set_get_boolean( 'is_encoded', @_ ) ); }
1364              
1365             sub is_multipart
1366             {
1367 5     5 1 18 my $self = shift( @_ );
1368             # no head, so no MIME type!
1369 5 50       22 $self->headers or return;
1370 5         194 my $mime_type = $self->headers->type;
1371 5 100 66     52 return(0) if( !defined( $mime_type ) || !length( $mime_type ) );
1372 4 100       152 return( substr( lc( $mime_type ), 0, 9 ) eq 'multipart' ? 1 : 0 );
1373             }
1374              
1375 0     0 1 0 sub is_text { return( !shift->is_binary( @_ ) ); }
1376              
1377 4     4 1 9996 sub make_boundary { return( Data::UUID->new->create_str ); }
1378             # sub make_boundary
1379             # {
1380             # my $self = shift( @_ );
1381             # # my $uuid = $self->_uuid;
1382             # my $uuid = Data::UUID->new;
1383             # my $boundary = $uuid->create_str;
1384             # return( $boundary );
1385             # }
1386              
1387             sub make_multipart
1388             {
1389 5     5 1 29 my $self = shift( @_ );
1390 5         20 my $subtype = shift( @_ );
1391 5         41 my $opts = $self->_get_args_as_hash( @_ );
1392 5         39 my $tag;
1393 5   100     53 $subtype ||= 'form-data';
1394 5         24 my $force = $opts->{force};
1395              
1396             # Trap for simple case: already a multipart?
1397 5 100 66     37 return( $self ) if( $self->is_multipart and !$force );
1398 2         7 my $headers = $self->headers;
1399            
1400              
1401             # Rip out our guts, and spew them into our future part.
1402             # part is a shallow copy
1403             # my $part = bless( {%$self} => ref( $self ) );
1404             # my $part = $self->new(
1405             # headers => $headers->clone,
1406             # ( $self->body ? ( body => $self->body ) : () ),
1407             # debug => $self->debug,
1408             # );
1409             #
1410             # if( my $msg = $self->http_message )
1411             # {
1412             # my $clone = $msg->clone( clone_entity => 0 );
1413             # $clone->entity( $part );
1414             # $part->http_message( $clone );
1415             # }
1416             # $part->parts( $self->parts );
1417            
1418 2         66 my $part = $self->clone;
1419            
1420             # my $part = $self->clone;
1421             # lobotomize ourselves!
1422             # %$self = ();
1423             # clone the headers
1424              
1425             # Remove content headers from top-level, and set it up as a multipart
1426 2         24 my $removed = $headers->remove_content_headers;
1427 2   50     29 my $ct = $headers->new_field( 'Content-Type' => "multipart/${subtype}" ) ||
1428             return( $self->pass_error( $headers->error ) );
1429 2         20 $ct->boundary( $self->make_boundary );
1430 2         1078 my $ct_string = $ct->as_string;
1431 2         514171 $headers->header( 'Content-Type' => "${ct_string}" );
1432              
1433             # Remove non-content headers from the part
1434 2         12 $removed = $self->new_array;
1435 2         68 foreach $tag ( grep{ !/^content-/i } $part->headers->header_field_names )
  1         57  
1436             {
1437 0         0 $part->headers->delete( $tag );
1438 0         0 $removed->push( $tag );
1439             }
1440 2         42 $self->parts->reset;
1441 2 100 66     1101 $self->add_part( $part ) if( $part->body || $part->parts->length );
1442 2         35936 return( $self );
1443             }
1444              
1445             sub make_singlepart
1446             {
1447 0     0 1 0 my $self = shift( @_ );
1448             # Trap for simple cases:
1449             # already a singlepart?
1450 0 0       0 return( $self ) if( !$self->is_multipart );
1451             # can this even be done?
1452 0 0       0 return(0) if( $self->parts > 1 );
1453              
1454             # Get rid of all our existing content info
1455 0         0 my $tag;
1456 0         0 foreach $tag ( grep{ /^content-/i } $self->headers->header_field_names )
  0         0  
1457             {
1458 0         0 $self->headers->delete( $tag );
1459             }
1460              
1461             # one part
1462 0 0       0 if( $self->parts->length == 1 )
1463             {
1464 0         0 my $part = $self->parts->index(0);
1465             # Populate ourselves with any content info from the part:
1466 0         0 foreach $tag ( grep{ /^content-/i } $part->headers->header_field_names )
  0         0  
1467             {
1468 0         0 $self->headers->add( $tag => $_ ) for( $part->headers->get( $tag ) );
1469             }
1470              
1471             # Save reconstructed headers, replace our guts, and restore header:
1472 0         0 my $new_head = $self->headers;
1473             # shallow copy is ok!
1474 0         0 %$self = %$part;
1475 0         0 $self->headers( $new_head );
1476              
1477             # One more thing: the part *may* have been a multi with 0 or 1 parts!
1478 0 0       0 return( $self->make_singlepart( @_ ) ) if( $self->is_multipart );
1479             }
1480             # no parts!
1481             else
1482             {
1483 0         0 $self->headers->mime_attr( 'Content-type' => 'text/plain' ); ### simple
1484             }
1485 0         0 return( $self );
1486             }
1487              
1488             sub mime_type
1489             {
1490 105     105 1 17333 my $self = shift( @_ );
1491 105         356 my $headers = $self->headers;
1492 105 50       2944 return if( !defined( $headers ) );
1493 105         874 return( $headers->mime_type( @_ ) );
1494             }
1495              
1496             # NOTE name() is to associate a name for this entity for multipart/form-data
1497 34     34 1 357 sub name { return( shift->_set_get_scalar_as_object( 'name', @_ ) ); }
1498              
1499             sub new_body
1500             {
1501 59     59 1 174 my $self = shift( @_ );
1502 59   50     356 my $type = shift( @_ ) || 'scalar';
1503 59         763 my $map =
1504             {
1505             file => 'HTTP::Promise::Body::File',
1506             form => 'HTTP::Promise::Body::Form',
1507             scalar => 'HTTP::Promise::Body::Scalar',
1508             string => 'HTTP::Promise::Body::Scalar',
1509             };
1510 59   50     267 my $class = $map->{ $type } || return( $self->error( "Unsupported body type '$type'" ) );
1511 59 100       248 if( $type eq 'form' )
1512             {
1513 1 50       14 $self->_load_class( $class ) || return( $self->pass_error );
1514             }
1515 59         1379 my $body = $class->new( @_ );
1516 59 50       740 return( $self->pass_error( $class->error ) ) if( !defined( $body ) );
1517 59         1371 return( $body );
1518             }
1519              
1520             sub open
1521             {
1522 36     36 1 122 my $self = shift( @_ );
1523 36         94 my $body = $self->body;
1524 36 50       954 return( $self->error( "Unable to open the entity body, because none is currently set." ) ) if( !$body );
1525 36   50     473 my $io = $body->open( @_ ) ||
1526             return( $self->pass_error( $body->error ) );
1527 36         26258 return( $io );
1528             }
1529              
1530 0     0 1 0 sub output_dir { return( shift->_set_get_file( 'output_dir', @_ ) ); }
1531              
1532 182     182 1 81058 sub parts { return( shift->_set_get_array_as_object( '_parts', @_ ) ); }
1533              
1534 33     33 1 45491 sub preamble { return( shift->_set_get_array_as_object( 'preamble', @_ ) ); }
1535              
1536             sub print
1537             {
1538 59     59 1 351275 my $self = shift( @_ );
1539 59         306 my $out = shift( @_ );
1540 59         252 my $opts = $self->_get_args_as_hash( @_ );
1541 59   50     4715 my $eol = $opts->{eol} || $HTTP::Promise::Entity::BOUNDARY_DELIMITER || CRLF;
1542 59 100       236 $out = select if( !defined( $out ) );
1543 59 50       239 $out = Symbol::qualify( $out, scalar( caller ) ) unless( ref( $out ) );
1544 59 50       260 $self->_load_class( 'HTTP::Promise::IO' ) || return( $self->error );
1545 59 100       3180 my $io = $self->_is_a( $out => 'HTTP::Promise::IO' )
1546             ? $out
1547             : HTTP::Promise::IO->new( $out, debug => $self->debug );
1548 59 50       1204 return( $self->pass_error( HTTP::Promise::IO->error ) ) if( !defined( $io ) );
1549 59         165 $opts->{eol} = $eol;
1550             # The start-line
1551 59 50       390 $self->print_start_line( $io, $opts ) || return( $self->pass_error );
1552             # The headers
1553 59 50       242 $self->print_header( $io, $opts ) || return( $self->pass_error );
1554 59 50       209 $io->print( $eol ) ||
1555             return( $self->error( "Unable to print to filehandle provided '$io': $!" ) );
1556             # The body
1557 59 50       535 $self->print_body( $io, ( scalar( keys( %$opts ) ) ? $opts : () ) ) || return( $self->pass_error );
    50          
1558 59         1671 return( $self );
1559             }
1560              
1561             sub print_body
1562             {
1563 60     60 1 198 my $self = shift( @_ );
1564 60         159 my $out = shift( @_ );
1565 60         259 my $opts = $self->_get_args_as_hash( @_ );
1566 60 50 66     7700 return( $self->error( "Filehandle provided ($out) is not a proper filehandle and its not a HTTP::Promise::IO object." ) ) if( !$self->_is_glob( $out ) && !$self->_is_a( $out => 'HTTP::Promise::IO' ) );
1567 60   33     3118 $out ||= select;
1568 60         283 my $mime_type = $self->mime_type;
1569 60         142 my $toptype;
1570 60 50       326 $toptype = [split( '/', lc( $mime_type ), 2 )]->[0] if( defined( $mime_type ) );
1571             # my $crlf = $HTTP::Promise::Entity::BOUNDARY_DELIMITER || CRLF;
1572 60   50     387 my $crlf = $opts->{eol} || $HTTP::Promise::Entity::BOUNDARY_DELIMITER || CRLF;
1573              
1574             # Multipart... form-data or mixed
1575 60 100 100     494 if( defined( $toptype ) && $toptype eq 'multipart' )
    100          
1576             {
1577 9         102 my $boundary = $self->_prepare_multipart_headers();
1578              
1579             # Preamble. I do not think there should be any anyway for HTTP multipart
1580 9         68 my $plines = $self->preamble;
1581 9 50       6955 if( defined( $plines ) )
1582             {
1583             # Defined, so output the preamble if it exists (avoiding additional
1584             # newline as per ticket 60931)
1585 9 50       60 $out->print( join( $crlf, @$plines ) . $crlf ) if( @$plines > 0 );
1586             }
1587             # Otherwise, no preamble.
1588              
1589             # Parts
1590 9         56 foreach my $part ( $self->parts->list )
1591             {
1592 25 50       4967 $out->print( "--${boundary}${crlf}" ) ||
1593             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1594 25 50       560 $part->print( $out ) ||
1595             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1596             # Trailing CRLF
1597 25 50       127 $out->print( $crlf ) ||
1598             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1599             }
1600 9 50       213 $out->print( "--${boundary}--${crlf}" ) ||
1601             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1602              
1603             # Epilogue
1604 9         243 my $epilogue = $self->epilogue;
1605 9 50 33     7806 if( defined( $epilogue ) && !$epilogue->is_empty )
1606             {
1607 0 0       0 $out->print( $epilogue->join( $crlf )->scalar ) ||
1608             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1609 0 0       0 if( $epilogue !~ /(?:\015?\012)\Z/ )
1610             {
1611 0 0       0 $out->print( $crlf ) ||
1612             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1613             }
1614             }
1615             }
1616             # Singlepart type with parts...
1617             # This makes $ent->print handle message/rfc822 bodies
1618             # when parse_nested_messages('NEST') is on [idea by Marc Rouleau].
1619             elsif( !$self->parts->is_empty )
1620             {
1621 2         1162 my $need_sep = 0;
1622 2         6 my $part;
1623 2         6 my $parts = $self->parts;
1624             # foreach $part ( $self->parts->list )
1625 2         1517 foreach $part ( @$parts )
1626             {
1627 2 50       9 if( $need_sep++ )
1628             {
1629 0 0       0 $out->print( "${crlf}${crlf}" ) ||
1630             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1631             }
1632 2 50       11 $part->print( $out ) ||
1633             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1634             }
1635             }
1636             # Singlepart type, or no parts: output body...
1637             else
1638             {
1639 49 100       29866 if( $self->body )
1640             {
1641 36 50       481 $self->print_bodyhandle( $out, ( scalar( keys( %$opts ) ) ? $opts : () ) ) ||
    50          
1642             return( $self->pass_error );
1643             }
1644             }
1645 60         4223 return( $self );
1646             }
1647              
1648             sub print_bodyhandle
1649             {
1650 36     36 1 107 my $self = shift( @_ );
1651 36         69 my $out = shift( @_ );
1652 36         123 my $opts = $self->_get_args_as_hash( @_ );
1653 36   33     4428 $out ||= select;
1654 36 50 33     129 return( $self->error( "Filehandle provided ($out) is not a proper filehandle and its not a HTTP::Promise::IO object." ) ) if( !$self->_is_glob( $out ) && !$self->_is_a( $out => 'HTTP::Promise::IO' ) );
1655              
1656 36         1935 my $encoding = $self->headers->content_encoding;
1657 36 50 100     350 if( $encoding &&
      33        
      66        
1658             !$self->is_encoded &&
1659             ( !exists( $opts->{no_encode} ) ||
1660             ( exists( $opts->{no_encode} ) && !$opts->{no_encode} )
1661             ) )
1662             {
1663 6 50       4331 $self->encode_body( $encoding ) || return( $self->pass_error );
1664 6         174 $self->is_encoded(1);
1665             }
1666 36         8030 my $params = {};
1667 36 0 33     164 $params->{binmode} = $opts->{binmode} if( exists( $opts->{binmode} ) && $opts->{binmode} );
1668             # An opportunity here to specify the io layer, such as utf-8
1669 36   50     292 my $io = $self->open( 'r', ( scalar( keys( %$params ) ) ? $params : () ) ) || return( $self->pass_error );
1670 36         99 my $buff;
1671 36         193 while( $io->read( $buff, 8192 ) )
1672             {
1673 62 50       7348 $out->print( $buff ) ||
1674             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1675             }
1676 36         3299 $io->close;
1677 36         3278 return( $self );
1678             }
1679              
1680 59     59 1 201 sub print_header { shift->headers->print( @_ ); }
1681              
1682             # NOTE: An entity is encapsulated inside either a request or a response.
1683             # See rfc7230, section 3.1 <https://tools.ietf.org/html/rfc7230#section-3.1>
1684             sub print_start_line
1685             {
1686 59     59 1 164 my $self = shift( @_ );
1687 59         91 my $out = shift( @_ );
1688 59   33     163 $out ||= select;
1689 59 50 33     325 return( $self->error( "Filehandle provided ($out) is not a proper filehandle and its not a HTTP::Promise::IO object." ) ) if( !$self->_is_glob( $out ) && !$self->_is_a( $out => 'HTTP::Promise::IO' ) );
1690 59         2983 my $opts = $self->_get_args_as_hash( @_ );
1691 59   50     7922 my $eol = $opts->{eol} || CRLF;
1692 59 100       307 if( my $msg = $self->http_message )
1693             {
1694 40         1327 my $sl = $msg->start_line;
1695 40 100       229 return( $self ) unless( length( $sl ) );
1696 7         58 $out->print( $sl . $eol );
1697             }
1698 26         774 return( $self );
1699             }
1700              
1701             sub purge
1702             {
1703 0     0 1 0 my $self = shift( @_ );
1704             # purge me
1705 0 0       0 $self->body->purge if( $self->body );
1706             # recurse
1707 0         0 $_->purge for( $self->parts->list );
1708 0         0 return( $self );
1709             }
1710              
1711             sub save_file
1712             {
1713 0     0 1 0 my $self = shift( @_ );
1714 0         0 my $fname = shift( @_ );
1715 0         0 my $type = $self->type;
1716 0 0       0 return( '' ) if( lc( substr( $type, 0, 10 ) ) eq 'multipart/' );
1717 0 0 0     0 unless( defined( $fname ) && length( "$fname" ) )
1718             {
1719 0         0 my $headers = $self->headers;
1720 0 0       0 if( my $val = $headers->content_disposition )
1721             {
1722 0         0 my $cd = $headers->new_field( 'Content-Disposition' => "$val" );
1723 0 0       0 return( $self->pass_error( $headers->error ) ) if( !defined( $cd ) );
1724 0 0       0 if( my $orig_name = $cd->filename )
1725             {
1726 0         0 my $f = $self->new_file( $orig_name );
1727 0         0 my $ext = $f->extension;
1728 0 0 0     0 my $base = $f->basename( ( defined( $ext ) && length( $ext ) ) ? $ext : () );
1729            
1730 0         0 my @unsafe = map( quotemeta( $_ ), qw/ < > “ ‘ % ; ) ( & + $ [ ] : ./ );
1731 0         0 push( @unsafe, "\r", "\n", ' ', '/' );
1732 0         0 $base =~ s/(?<!\\)\.\.(?!\.)//g;
1733 0         0 local $" = '|';
1734 0         0 $base =~ s/(@unsafe)//g;
1735 0 0       0 unless( $ext )
1736             {
1737             # Guessing extension
1738 0   0     0 my $mime_type = $headers->mime_type( $DEFAULT_MIME_TYPE || 'application/octet-stream' );
1739 0 0       0 $self->_load_class( 'HTTP::Promise::MIME' ) || return( $self->pass_error );
1740 0         0 my $mime = HTTP::Promise::MIME->new;
1741 0         0 $ext = $mime->suffix( $mime_type );
1742 0 0       0 return( $self->pass_error( $mime->error ) ) if( !defined( $ext ) );
1743             }
1744 0   0     0 $ext ||= 'dat';
1745 0 0       0 $self->_load_class( 'Module::Generic::File' ) || return( $self->pass_error );
1746 0   0     0 my $output_dir = $self->outputdir || Module::Generic::File->sys_tmpdir;
1747 0         0 $fname = $output_dir->child( join( '.', $base, $ext ) );
1748             }
1749             }
1750            
1751 0 0 0     0 if( !defined( $fname ) || !length( $fname ) )
1752             {
1753             # Guessing extension
1754 0   0     0 my $mime_type = $headers->mime_type( $DEFAULT_MIME_TYPE || 'application/octet-stream' );
1755 0 0       0 $self->_load_class( 'HTTP::Promise::MIME' ) || return( $self->pass_error );
1756 0         0 my $mime = HTTP::Promise::MIME->new;
1757 0         0 my $ext = $mime->suffix( $mime_type );
1758 0 0       0 return( $self->pass_error( $mime->error ) ) if( !defined( $ext ) );
1759 0   0     0 $ext ||= 'dat';
1760 0         0 $fname = $self->new_tempfile( extension => $ext );
1761             }
1762             }
1763 0 0       0 if( my $enc = $self->headers->content_encoding )
1764             {
1765 0 0       0 $self->decode_body( $enc ) if( $self->is_encoded );
1766             }
1767 0 0       0 my $f = $self->_is_a( $fname => 'Module::Generic::File' ) ? $fname : $self->new_file( "$fname" );
1768 0   0     0 my $io = $f->open( '+>', { binmode => 'raw', autoflush => 1 } ) ||
1769             return( $self->pass_error( $f->error ) );
1770             # Pass no_encode to ensure the file does not get automatically encoded
1771 0 0       0 $self->print_body( $io, no_encode => 1 ) || return( $self->pass_error );
1772 0         0 $io->close;
1773 0         0 return( $f );
1774             }
1775              
1776 0     0 1 0 sub stringify { return( shift->as_string( @_ ) ); }
1777              
1778 0     0 1 0 sub stringify_body { return( shift->body_as_string( @_ ) ); }
1779              
1780 0     0 1 0 sub stringify_header { return( shift->headers->as_string( @_ ) ); }
1781              
1782             sub suggest_encoding
1783             {
1784 3     3 1 38 my $self = shift( @_ );
1785 3         41 my $mime_type = $self->effective_type;
1786 3         8 my $toptype;
1787 3 50       36 $toptype = [split( '/', $mime_type, 2 )]->[0] if( defined( $mime_type ) );
1788             # Defaults to 200Kb
1789 3         43 my $threshold = $self->compression_min;
1790 3         110605 my $rule = {qw(
1791             text/css gzip
1792             text/html gzip
1793             text/plain gzip
1794             text/x-component gzip
1795             application/atom+xml gzip
1796             application/javascript gzip
1797             application/json gzip
1798             application/pdf none
1799             application/rss+xml gzip
1800             application/vnd.ms-fontobject gzip
1801             application/x-font-opentype gzip
1802             application/x-font-ttf gzip
1803             application/x-javascript gzip
1804             application/x-web-app-manifest+json gzip
1805             application/xhtml+xml gzip
1806             application/xml gzip
1807             application/gzip none
1808             font/opentype gzip
1809             image/gif none
1810             image/jpeg none
1811             image/png none
1812             image/svg+xml gzip
1813             image/webp none
1814             image/x-icon none
1815             audio/mpeg none
1816             video/mp4 none
1817             audio/webm none
1818             video/webm none
1819             font/otf gzip
1820             font/ttf gzip
1821             font/woff2 none
1822            
1823             )};
1824             # Already usually quite compressed, not much benefit compared to CPU penalty; we are
1825             # not in 1998 anymore :)
1826             # <http://web.archive.org/web/20190708231140/http://www.ibm.com/developerworks/web/library/wa-httpcomp/>
1827             # Also small files, like less than 1,500 bytes are a waste o time due to MTU max size
1828             # (https://en.wikipedia.org/wiki/Maximum_transmission_unit)
1829             # See also <https://httpd.apache.org/docs/2.4/mod/mod_deflate.html>
1830             # <https://webmasters.stackexchange.com/questions/31750/what-is-recommended-minimum-object-size-for-gzip-performance-benefits>
1831 3 50 0     22 if( exists( $rule->{ $mime_type } ) )
    0 0        
    0 0        
      0        
1832             {
1833 3 100       26 return( '' ) if( $rule->{ $mime_type } eq 'none' );
1834 2 50 33     17 return( $rule->{ $mime_type } ) if( !$threshold || $self->body->length >= $threshold );
1835             }
1836             elsif( $toptype eq 'image' ||
1837             $toptype eq 'video' ||
1838             $toptype eq 'audio' ||
1839             $toptype eq 'multipart' )
1840             {
1841 0         0 return( '' );
1842             }
1843             elsif( $toptype eq 'text' || $self->is_binary )
1844             {
1845             # Suggest gzip compression if it exceeds 200Kb
1846 0 0 0     0 return( 'gzip' ) if( !$threshold || $self->body->length >= $threshold );
1847             }
1848 2         75421 return( '' );
1849             }
1850              
1851             sub textual_type
1852             {
1853 0     0 1 0 my $self = shift( @_ );
1854 0 0       0 return( $_[0] =~ m{^(text|message)(/|\Z)}i ? 1 : 0 );
1855             }
1856              
1857 5     5   45 sub _parts { return( shift->_set_get_array_as_object( '_parts', @_ ) ); }
1858              
1859             # NOTE: Used in both print_body() and dump()
1860             sub _prepare_multipart_headers
1861             {
1862 9     9   32 my $self = shift( @_ );
1863 9         36 my $mime_type = $self->mime_type;
1864 9         35 my $toptype;
1865 9 50       126 $toptype = [split( '/', lc( $mime_type ), 2 )]->[0] if( defined( $mime_type ) );
1866 9         63 my $boundary = $self->headers->multipart_boundary;
1867             # Ensure we have a boundary set.
1868             # This is the same code as in HTTP::Promise::Headers::as_string, but since
1869             # print_body() may be called separately, we need to check here too if a boundary
1870             # has been set.
1871 9 50       231 unless( $boundary )
1872             {
1873 0         0 $boundary = $self->make_boundary;
1874 0         0 my $ct = $self->headers->new_field( 'Content-Type' => $self->headers->content_type );
1875 0         0 $ct->boundary( $boundary );
1876 0         0 $self->headers->content_type( "$ct" );
1877             }
1878             # Parts
1879             # For reporting to the caller only when there are some issues.
1880 9         56 my $n = 0;
1881             # for generated part name, by default
1882 9         53 my $auto_name = 'part0';
1883 9         74 foreach my $part ( $self->parts->list )
1884             {
1885 25         248673 ++$n;
1886             # If this is a multipart/form-data, ensure we have a part name, or isse a warning
1887 25         65 my $name;
1888 25 100       138 if( $mime_type eq 'multipart/form-data' )
    50          
1889             {
1890 7         42 $name = $part->name;
1891 7 100       6159 if( !$name )
1892             {
1893 3 50       756 warn( "Warning: no part name set for this part No. ${n}\n" ) if( warnings::enabled() );
1894 3         19 $name = ++$auto_name;
1895 3         13 $part->name( $name );
1896             }
1897             }
1898             elsif( $mime_type eq 'multipart/mixed' )
1899             {
1900             # remove any Content-Disposition used for multipart/form-data
1901 18         52 $part->headers->remove( 'Content-Disposition' );
1902             }
1903            
1904 25 100       2934 if( defined( $name ) )
1905             {
1906 7         50 my $content_disposition = $part->headers->content_disposition;
1907 7 100 66     188 if( defined( $content_disposition ) && $content_disposition->length )
1908             {
1909             # A simple check to save time from generating the Content-Disposition object
1910 4 50 33     161078 if( $content_disposition->index( 'name=' ) == -1 ||
1911             $content_disposition->index( 'form-data' ) == -1 )
1912             {
1913 0         0 my $cd = $part->headers->new_field( 'Content-Disposition' => $part->headers->content_disposition );
1914 0 0       0 $cd->name( $name ) if( !length( $cd->name ) );
1915 0         0 $cd->disposition( 'form-data' );
1916             }
1917             }
1918             else
1919             {
1920 3         11 $part->headers->content_disposition( qq{form-data; name="${name}"} );
1921             }
1922             }
1923             }
1924 9         72333 return( $boundary );
1925             }
1926              
1927             # NOTE: sub FREEZE is inherited
1928             sub FREEZE
1929             {
1930 4     4 0 21 my $self = CORE::shift( @_ );
1931 4   50     37 my $serialiser = CORE::shift( @_ ) // '';
1932 4         30 my $class = CORE::ref( $self );
1933 4         25 my $ref = $self->_obj2h;
1934 4         132 my %hash = %$ref;
1935             # We remove this to prevent a circular reference that CBOR::XS does not seem to be managing
1936             # This relation is re-created in HTTP::Promise::Message::THAW
1937             # It is safe to remove it, because 1) if it is a standalone HTTP::Promise::Entity object,
1938             # then it would not be set anyway, and 2) if it is part of an HTTP::Promise::Message, it
1939             # is going to be recreated.
1940 4 50       38 CORE::delete( @hash{ qw( http_message ) } ) unless( $serialiser ne 'CBOR' );
1941             # Return an array reference rather than a list so this works with Sereal and CBOR
1942 4 50 33     46 CORE::return( [$class, \%hash] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) );
1943             # But Storable want a list with the first element being the serialised element
1944 4         304 CORE::return( $class, \%hash );
1945             }
1946              
1947 4     4 0 258 sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }
1948              
1949 4     4 0 318 sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }
1950              
1951             # NOTE: sub THAW is inherited
1952              
1953             1;
1954             # NOTE: POD
1955             __END__
1956              
1957             =encoding utf-8
1958              
1959             =head1 NAME
1960              
1961             HTTP::Promise::Entity - HTTP Entity Class
1962              
1963             =head1 SYNOPSIS
1964              
1965             use HTTP::Promise::Entity;
1966             my $this = HTTP::Promise::Entity->new || die( HTTP::Promise::Entity->error, "\n" );
1967              
1968             =head1 VERSION
1969              
1970             v0.2.1
1971              
1972             =head1 DESCRIPTION
1973              
1974             This class represents an HTTP entity, which is an object class containing an headers object and a body object. It is agnostic to the type of HTTP message (request or response) it is associated with and can be used recurrently, such as to represent a part in a multipart HTTP message. Its purpose is to provide an API to access and manipulate and HTTP message entity.
1975              
1976             Here is how it fits in overall relation with other classes.
1977            
1978             +-------------------------+ +--------------------------+
1979             | | | |
1980             | HTTP::Promise::Request | | HTTP::Promise::Response |
1981             | | | |
1982             +------------|------------+ +-------------|------------+
1983             | |
1984             | |
1985             | |
1986             | +------------------------+ |
1987             | | | |
1988             +--- HTTP::Promise::Message |---+
1989             | |
1990             +------------|-----------+
1991             |
1992             |
1993             +------------|-----------+
1994             | |
1995             | HTTP::Promise::Entity |
1996             | |
1997             +------------|-----------+
1998             |
1999             |
2000             +------------|-----------+
2001             | |
2002             | HTTP::Promise::Body |
2003             | |
2004             +------------------------+
2005              
2006             =head1 CONSTRUCTOR
2007              
2008             =head2 new
2009              
2010             This instantiate a new L<HTTP::Promise::Entity> object and returns it. It takes the following options, which can also be set or retrieved with their related method.
2011              
2012             =over 4
2013              
2014             =item * C<compression_min>
2015              
2016             Integer. Size threshold beyond which the associated body can be compressed. This defaults to 204800 (200Kb). Set it to 0 to disable it.
2017              
2018             =item * C<effective_type>
2019              
2020             String. The effective mime-type. Default to C<undef>
2021              
2022             =item * C<epilogue>
2023              
2024             An array reference of strings to be added after the headers and before the parts in a multipart message. Each array reference entry is treated as one line. This defaults to C<undef>
2025              
2026             =item * C<ext_vary>
2027              
2028             Boolean. Setting this to a true value and this will have L</decode_body> and L</encode_body> change the entity body file extension to reflect the encoding or decoding applied.
2029              
2030             See L</ext_vary> for an example.
2031              
2032             =item * C<headers>
2033              
2034             This is an L<HTTP::Promise::Headers> object. This defaults to C<undef>
2035              
2036             =item * C<is_encoded>
2037              
2038             Boolean. This is a flag used to determine whether the related entity body is decoded or not. This defaults to C<undef>
2039              
2040             See also L<HTTP::Promise::Headers/content_encoding>
2041              
2042             =item * C<output_dir>
2043              
2044             This is the path to the directory used when extracting body to files on the filesystem. This defaults to C<undef>
2045              
2046             =item * C<preamble>
2047              
2048             An array reference of strings to be added after all the parts in a multipart message. Each array reference entry is treated as one line. This defaults to C<undef>
2049              
2050             =back
2051              
2052             =head1 METHODS
2053              
2054             =head2 add_part
2055              
2056             Provided with an L<HTTP::Promise::Entity> object, and this will add it to the stack of parts for this entity.
2057              
2058             It returns the part added, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2059              
2060             =head2 as_form_data
2061              
2062             If the entity is of type C<multipart/form-data>, this will transform all of its parts into an L<HTTP::Promise::Body::Form::Data> object.
2063              
2064             It returns the new L<HTTP::Promise::Body::Form::Data> object upon success, or 0 if there was nothing to be done i the entity is not C<multipart/form-data> for example, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2065              
2066             Note that this is memory savvy, because even though it breaks down the parts into an L<HTTP::Promise::Body::Form::Data> object, original entity body that were stored on file remain on file. Each of the L<HTTP::Promise::Body::Form::Data> entry is a field name and its value is an L<HTTP::Promise::Body::Form::Field> object. Thus you could access data such as:
2067              
2068             my $form = $ent->as_form_data;
2069             my $name = $form->{fullname}->value;
2070             if( $form->{picture}->file )
2071             {
2072             say "Picture is stored on file.";
2073             }
2074             elsif( $form->{picture}->value->length )
2075             {
2076             say "Picture is in memory.";
2077             }
2078             else
2079             {
2080             say "There is no data.";
2081             }
2082              
2083             say "Content-Type for this form-data is: ", $form->{picture}->headers->content_type;
2084              
2085             =head2 as_string
2086              
2087             This returns a L<scalar object|Module::Generic::Scalar> containing a string representation of the message entity.
2088              
2089             It takes an optional string parameter containing an end of line separator, which defaults to C<\015\012>.
2090              
2091             Internally, this calls L</print>.
2092              
2093             If an error occurred, it set an L<error|Module::Generic/error> and returns C<undef>.
2094              
2095             Be mindful that because this returns a scalar object, it means the entire HTTP message entity is loaded into memory, which, depending on the content size, can potentially be big and thus take a lot of memory.
2096              
2097             You may want to check the body size first using: C<$ent->body->length> for example if this is not a multipart entity.
2098              
2099             =head2 attach
2100              
2101             Provided with a list of parameters and this add the created part entity to the stack of entity parts.
2102              
2103             This will transform the current entity into a multipart, if necessary, by calling L</make_multipart>
2104              
2105             Since it calls L</build> internally to build the message entity, see L</build> for the list of supported parameters.
2106              
2107             It returns the newly added L<part object|HTTP::Promise::Entity> upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2108              
2109             =head2 body
2110              
2111             Sets or gets this entity L<body object|HTTP::Promise::Body>.
2112              
2113             =head2 body_as_array
2114              
2115             This returns an L<array object|Module::Generic::Array> object containing body lines with each line terminated by an end-of-line sequence, which is optional and defaults to C<\015\012>.
2116              
2117             Upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2118              
2119             =head2 body_as_string
2120              
2121             This returns a L<scalar object|Module::Generic::Scalar> containing a string representation of the message body.
2122              
2123             =head2 build
2124              
2125             my $ent = HTTP::Promise::Entity->new(
2126             encoding => 'gzip',
2127             type => 'text/plain',
2128             data => 'Hello world',
2129             );
2130             my $ent = HTTP::Promise::Entity->new(
2131             encoding => 'guess',
2132             type => 'text/plain',
2133             data => '/some/where/file.txt',
2134             );
2135              
2136             This takes an hash or hash reference of parameters and build a new L<HTTP::Promise::Entity>.
2137              
2138             It returns the newly created L<entity object|HTTP::Promise::Entity> object upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2139              
2140             Supported arguments are:
2141              
2142             =over 4
2143              
2144             =item * C<boundary>
2145              
2146             The part boundary to be used if the entity is of type multipart.
2147              
2148             =item * C<data>
2149              
2150             The entity body content. If this is provided, the entity body will be an L<HTTP::Promise::Body::Scalar> object.
2151              
2152             =item * C<debug>
2153              
2154             An integer representing the level of debugging output. Defaults to 0.
2155              
2156             =item * C<disposition>
2157              
2158             A string representing the C<Content-Disposition>, such as C<form-data>. This defaults to C<inline>.
2159              
2160             =item * C<encoding>
2161              
2162             String. A comma-separated list of content encodings used in order you want the entity body to be encoded.
2163              
2164             For example: C<gzip, base64> or C<brotli>
2165              
2166             See L<HTTP::Promise::Stream> for a list of supported encodings.
2167              
2168             If C<encoding> is C<guess>, this will call L</suggest_encoding> to find a suitable encoding, if any at all.
2169              
2170             =item * C<filename>
2171              
2172             The C<filename> attribute value of a C<Content-Disposition> header value, if any.
2173              
2174             If the filename provided contains 8 bit characters like unicode characters, this will be detected and the filename will be encoded according to L<rfc2231|https://tools.ietf.org/html/rfc2231>
2175              
2176             See also L<HTTP::Promise::Headers/content_disposition> and L<HTTP::Promise::Headers::ContentDisposition>
2177              
2178             =item * C<path>
2179              
2180             The filepath to the content to be used as the entity body. This is useful if the body size is big and you do not want to load it in memory.
2181              
2182             =item * C<type>
2183              
2184             String. The entity mime-type. This defaults to C<text/plain>
2185              
2186             If the type is set to C<multipart/form-data> or C<multipart/mixed>, or any other multipart type, this will automatically create a boundary, which is basically a UUID generated with the XS module L<Data::UUID>
2187              
2188             =back
2189              
2190             =head2 compression_min
2191              
2192             Integer. This is the body size threshold in bytes beyond which this will make the encoding of the entity body possible. You can set this to zero to deactivate it.
2193              
2194             =head2 content_charset
2195              
2196             This will try to guess the character set of the body and returns a string the character encoding found, if any, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>. If nothing was found, it will return an empty string.
2197              
2198             It takes an optional hash or hash reference of options.
2199              
2200             Supported options are;
2201              
2202             =over 4
2203              
2204             =item * C<content>
2205              
2206             A string or scalar reference of some or all of the body data to be checked. If this is not provided, 4Kb of data will be read from the body to guess the character encoding.
2207              
2208             =back
2209              
2210             =head2 decode_body
2211              
2212             This takes a coma-separated list of encoding or an array reference of encodings, and an optional hash or hash reference of options and decodes the entity body.
2213              
2214             It returns the L<body object|HTTP::Promise::Body> upon success, and upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2215              
2216             Supported options are:
2217              
2218             =over 4
2219              
2220             =item * C<raise_error>
2221              
2222             Boolean. When set to true, this will cause this method to die upon error.
2223              
2224             =item * C<replace>
2225              
2226             Boolean. If true, this will replace the body content with the decoded version. Defaults to true.
2227              
2228             =back
2229              
2230             What this method does is instantiate a new L<HTTP::Promise::Stream> object for each encoding and pass it the data whether as a scalar reference if the data are in-memory body, or a file, until all decoding have been applied.
2231              
2232             When C<deflate> is one of the encoding, it will try to use L<IO::Uncompress::Inflate> to decompress data. However, some server encode data with C<deflate> but omit the zlib headers, which makes L<IO::Uncompress::Inflate> fail. This is detected and trapped and C<rawdeflate> is used as a fallback.
2233              
2234             =head2 dump
2235              
2236             This dumps the entity data into a string and returns it. It will encode the body if not yet encoded and will escape control and space characters, and show in hexadecimal representation the body content, so that even binary data is safe to dump.
2237              
2238             It takes some optional arguments, which are:
2239              
2240             =over 4
2241              
2242             =item * C<maxlength>
2243              
2244             Max body length to include in the dump.
2245              
2246             =item * C<no_content>
2247              
2248             The string to use when there is no content, i.e. when the body is empty.
2249              
2250             =back
2251              
2252             =head2 dump_skeleton
2253              
2254             This method is more for debugging, or to get a peek at the entity structure. This takes a filehandle to print the result to.
2255              
2256             This returns the current L<entity object|HTTP::Promise::Entity> on success, and upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2257              
2258             =head2 effective_type
2259              
2260             This set or get the effective mime-type. In assignment mode, this simply stores whatever mie-type you provide and in retrieval mode, this retrieve the value previously set, or by default the value returned from L</mime_type>
2261              
2262             =head2 encode_body
2263              
2264             This encode the entity body according to the encodings provided either as a comma-separated string or an array reference of encodings.
2265              
2266             The way it does this is to instantiate a new L<HTTP::Promise::Stream> object for each encoding and pass it the latest entity body.
2267              
2268             The resulting encoded body replaces the original one.
2269              
2270             It returns the L<entity body|HTTP::Promise::Body> upon success, and upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2271              
2272             =head2 epilogue
2273              
2274             Sets or gets an array of epilogue lines. An C<epilogue> is lines of text added after the last part of a C<multipart> message.
2275              
2276             This returns an L<array object|Module::Generic::Array>
2277              
2278             =head2 ext_vary
2279              
2280             Boolean. Setting this to a true value and this will have L</decode_body> and L</encode_body> change the entity body file extension to reflect the encoding or decoding applied.
2281              
2282             For example, if the entity body is stored in a text file C</tmp/DDAB03F0-F530-11EC-8067-D968FDB3E034.txt>, applying L</encode_body> with C<gzip> will create a new body text file such as C</tmp/DE13000E-F530-11EC-8067-D968FDB3E034.txt.gz>
2283              
2284             =head2 guess_character_encoding
2285              
2286             This will try to guess the entity body character encoding.
2287              
2288             It returns the encoding found as a string, if any otherwise it returns an empty string (not undef), and upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2289              
2290             This method tries to guess variation of unicode character sets, such as C<UTF-16BE>, C<UTF-16LE>, and C<utf-8-strict>
2291              
2292             It takes some optional parameters:
2293              
2294             =over 4
2295              
2296             =item * C<content>
2297              
2298             A string or scalar reference of content data to perform the guessing against.
2299              
2300             If this is not provided, this method will read up to 4096 bytes of data from the body to perform the guessing.
2301              
2302             =back
2303              
2304             See also L</content_charset>
2305              
2306             =head2 header
2307              
2308             Set or get the value returned by calling L<HTTP::Promise::Headers/header>
2309              
2310             This is just a shortcut.
2311              
2312             =head2 headers
2313              
2314             Sets or get the L<entity headers object|HTTP::Promise::Headers>
2315              
2316             =head2 header_as_string
2317              
2318             Returns the entity headers as a string.
2319              
2320             =head2 http_message
2321              
2322             Sets or get the L<HTTP message object|HTTP::Promise::Message>
2323              
2324             =head2 io_encoding
2325              
2326             This tries hard to find out the character set of the entity body to be used with L<perlfunc/open> or L<perlfunc/binmode>
2327              
2328             It returns a string, possibly empty if nothing could be guessed, and upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2329              
2330             It takes the following optional parameters:
2331              
2332             =over 4
2333              
2334             =item * C<alt_charset>
2335              
2336             Alternative character set to be used if none other could be found nor worked.
2337              
2338             =item * C<body>
2339              
2340             The entity L<body object|HTTP::Promise::Body> to use.
2341              
2342             =item * C<charset>
2343              
2344             A string containing the charset you think is used and this will perform checks against it.
2345              
2346             =item * C<charset_strict>
2347              
2348             Boolean. If true, this will enable the guessing in more strict mode (using the C<FB_CROAK> flag on L<Encode>)
2349              
2350             =item * C<content>
2351              
2352             A string or a scalar reference of content data to the guessing against.
2353              
2354             =item * C<default_charset>
2355              
2356             The default charset to use when nothing else was found.
2357              
2358             =back
2359              
2360             =head2 is_binary
2361              
2362             This checks if the data provided, or by default this entity body is binary data or not.
2363              
2364             It returns true (1) if it is, and false (0) otherwise. It returns false if the data is empty.
2365              
2366             This performs the similar checks that perl does (see L<perlfunc/-T>
2367              
2368             It sets and L<error|Module::Generic/error> and return C<undef> upon error
2369              
2370             You can optionally provide some data either as a string or as a scalar reference.
2371              
2372             See also L</is_text>
2373              
2374             For example:
2375              
2376             my $bool = $ent->is_binary;
2377             my $bool = $ent->is_binary( $string_of_data );
2378             my $bool = $ent->is_binary( \$string_of_data );
2379              
2380             =head2 is_body_in_memory
2381              
2382             Returns true if the entity body is an L<HTTP::Promise::Body::Scalar> object, false otherwise.
2383              
2384             =head2 is_body_on_file
2385              
2386             Returns true if the entity body is an L<HTTP::Promise::Body::File> object, false otherwise.
2387              
2388             =head2 is_decoded
2389              
2390             Boolean. Set get the decoded status of the entity body.
2391              
2392             =head2 is_encoded
2393              
2394             Boolean. Set get the encoded status of the entity body.
2395              
2396             =head2 is_multipart
2397              
2398             Returns true if this entity is a multipart message or not.
2399              
2400             =head2 is_text
2401              
2402             This checks if the data provided, or by default this entity body is text data or not.
2403              
2404             It returns true (1) if it is, and false (0) otherwise. It returns true if the data is empty.
2405              
2406             It sets and L<error|Module::Generic/error> and return C<undef> upon error
2407              
2408             You can optionally provide some data either as a string or as a scalar reference.
2409              
2410             See also L</is_binary>
2411              
2412             For example:
2413              
2414             my $bool = $ent->is_text;
2415             my $bool = $ent->is_text( $string_of_data );
2416             my $bool = $ent->is_text( \$string_of_data );
2417              
2418             =head2 make_boundary
2419              
2420             Returns a uniquely generated multipart boundary created using L<Data::UUID>
2421              
2422             =head2 make_multipart
2423              
2424             This transforms the current entity into the first part of a <multipart/form-data> HTTP message.
2425              
2426             For HTTP request, C<multipart/form-data> is the only valid C<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."
2427              
2428             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>
2429              
2430             Of course, technically, nothing prevents an HTTP message (request or response) from being a C<multipart/mixed> or something else.
2431              
2432             This method takes a multipart subtype, such as C<form-data>, or C<mixed>, etc and creates a multipart entity of which this current entity will become the first part. If no multipart subtype is specified, this defaults to C<form-data>.
2433              
2434             It takes also an optional hash or hash reference of parameters.
2435              
2436             Valid parameters are:
2437              
2438             =over 4
2439              
2440             =item * C<force>
2441              
2442             Boolean. Forces the creation of a multipart even when the current entity is already a multipart.
2443              
2444             This would have the effect of having the current entity become an embedded multipart into a new multipart entity.
2445              
2446             =back
2447              
2448             It returns the current entity object, modified, upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2449              
2450             =head2 make_singlepart
2451              
2452             This transform the current entity into a simple, i.e. no multipart, message entity.
2453              
2454             It returns false, but not C<undef> if this contains more than one part. It returns the current object upon success, or if this is already a simple entity message, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2455              
2456             =head2 mime_type
2457              
2458             Returns this entity mime-type by calling L<HTTP::Promise::Headers/mime_type> and passing it whatever arguments were provided.
2459              
2460             =head2 name
2461              
2462             The name of this entity used for C<multipart/form-data> as defined in L<rfc7578|https://tools.ietf.org/html/rfc7578>
2463              
2464             =head2 new_body
2465              
2466             This is a convenient constructor to instantiate a new entity body. It takes a single argument, one of C<file>, C<form>, C<scalar> or C<string>
2467              
2468             =over 4
2469              
2470             =item * C<file>
2471              
2472             Returns a new L<HTTP::Promise::Body::File> object
2473              
2474             =item * C<form>
2475              
2476             Returns a new L<HTTP::Promise::Body::Form> object
2477              
2478             =item * C<scalar> or C<string>
2479              
2480             Returns a new L<HTTP::Promise::Body::Scalar> object
2481              
2482             =back
2483              
2484             The constructor of each of those classes are passed whatever argument is provided to this method (except, of course, the initial argument).
2485              
2486             For example:
2487              
2488             my $body = $ent->new_body( file => '/some/where/file.txt' );
2489             my $body = $ent->new_body( string => 'Hello world!' );
2490             my $body = $ent->new_body( string => \$scalar );
2491             # Same, but using indistinctly 'scalar'
2492             my $body = $ent->new_body( scalar => \$scalar );
2493              
2494             It returns the newly instantiated object upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2495              
2496             =head2 open
2497              
2498             This calls C<open> on the entity body object, if any, and passing it whatever argument was provided.
2499              
2500             It returns the resulting L<filehandle object|Module::Generic::File::IO>, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2501              
2502             =head2 output_dir
2503              
2504             Sets or gets the path to the directory used to store extracted files, when applicable.
2505              
2506             =head2 parts
2507              
2508             Sets or gets the L<array object|Module::Generic::Array> of entity part objects.
2509              
2510             =head2 preamble
2511              
2512             Sets or gets the L<array object|Module::Generic::Array> of preamble lines. C<preamble> is the lines of text that precedes the first part in a multipart message. Normally, this is never used in HTTP parlance.
2513              
2514             =head2 print
2515              
2516             Provided with a filehandle, or an L<HTTP::Promise::IO> object, and an hash or hash reference of options and this will print the current entity with all its parts, if any.
2517              
2518             What this does internally is:
2519              
2520             =over 4
2521              
2522             =item 1. Call L</print_start_line>
2523              
2524             =item 2. Call L</print_header>
2525              
2526             =item 3. Call L</print_body>
2527              
2528             =back
2529              
2530             The only supported option is C<eol> which is the string to be used as a new line terminator. This is printed out just right after printing the headers. This defaults to C<\015\012>, which is C<\r\n>
2531              
2532             It returns the current entity object upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2533              
2534             =head2 print_body
2535              
2536             Provided with a filehandle, or an L<HTTP::Promise::IO> object, and an hash or hash reference of options and this will print the current entity body. This is possibly is a no-op if there is no entity body.
2537              
2538             If the entity is a multipart message, this will call L</print> on all its L<entity parts|HTTP::Promise::Entity>.
2539              
2540             It returns the current entity object upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2541              
2542             =head2 print_bodyhandle
2543              
2544             Provided with a filehandle, or an L<HTTP::Promise::IO> object, and an hash or hash reference of options and this will print the current entity body.
2545              
2546             This will first encode the body by calling L</encode> if encodings are set and the entity body is not yet marked as being encoded with L</is_encoded>
2547              
2548             Supported options are:
2549              
2550             =over 4
2551              
2552             =item * C<binmode>
2553              
2554             The character encoding to use for PerlIO when calling open.
2555              
2556             =back
2557              
2558             It returns the current entity object upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2559              
2560             =head2 print_header
2561              
2562             This calls L<HTTP::Promise::Headers/print>, passing it whatever arguments were provided, and returns whatever value is returned from this method call. This is basically a convenient shortcut.
2563              
2564             =head2 print_start_line
2565              
2566             Provided with a filehandle, and an hash or hash reference of options and this will print the message C<start line>, if any.
2567              
2568             A message C<start line> in HTTP parlance is the first line of a request or response, so something like:
2569              
2570             GET / HTTP/1.0
2571              
2572             or for a response:
2573              
2574             HTTP/1.0 200 OK
2575              
2576             It returns the current entity object upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2577              
2578             =head2 purge
2579              
2580             This calls C<purge> on the body object, if any, and calls it also on every parts.
2581              
2582             It returns the current entity object upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2583              
2584             =head2 save_file
2585              
2586             Provided with an optional filepath and this will save the body to it unless this is an HTTP multipart message.
2587              
2588             If no explicit filepath is provided, this will try to guess one from the C<Content-Disposition> header value, possibly striping it of any dangerous characters and making it a complete path using L</output_dir>
2589              
2590             If no suitable filename could be found, ultimately, this will use a generated one using L<Module::Generic/new_tempfile> inherited by this class.
2591              
2592             The file extension will be guessed from the entity body mime-type by checking the C<Content-Type> header or by looking directly at the entity body data using L<HTTP::Promise::MIME> that uses the XS module L<File::MMagic::XS> to perform the job.
2593              
2594             If the entity body is encoded, it will decode it before saving it to the resulting filepath.
2595              
2596             It returns the L<file object|Module::Generic::File> upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2597              
2598             =head2 stringify
2599              
2600             This is an alias for L</as_string>
2601              
2602             =head2 stringify_body
2603              
2604             This is an alias for L</body_as_string>
2605              
2606             =head2 stringify_header
2607              
2608             This is an alias for L<HTTP::Promise::Headers/as_string>
2609              
2610             =head2 suggest_encoding
2611              
2612             Based on the entity body mime-type, this will guess what encoding is appropriate.
2613              
2614             It does not provide any encoding for image, audio or video files who are usually already compressed and if the body size is below the threshold set with L</compression_min>.
2615              
2616             This returns the encoding as a string upon success, an empty string if no suitable encoding could be found, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
2617              
2618             =head2 textual_type
2619              
2620             Returns true if this entity mime-type starts with C<text>, such as C<text/plain> or C<text/html> or starts with C<message>, such as C<message/http>
2621              
2622             =head1 AUTHOR
2623              
2624             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
2625              
2626             =head1 SEE ALSO
2627              
2628             =over 4
2629            
2630             =item L<rfc2616 section 3.7.2 Multipart Types|http://tools.ietf.org/html/rfc2616#section-3.7.2>
2631            
2632             =item L<rfc2046 section 5.1.1 Common Syntax|http://tools.ietf.org/html/rfc2046#section-5.1.1>
2633            
2634             =item L<rfc2388 multipart/form-data|http://tools.ietf.org/html/rfc2388>
2635            
2636             =item L<rfc2045|https://tools.ietf.org/html/rfc2045>
2637            
2638             =back
2639              
2640             L<Mozilla documentation on Content-Disposition and international filename|https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Content-Disposition> and L<other Mozilla documentation|https://developer.mozilla.org/en-US/docs/Web/HTTP/Basics_of_HTTP/MIME_types.>
2641              
2642             L<Wikipedia|https://en.wikipedia.org/wiki/MIME#Multipart_messages>
2643              
2644             L<On Unicode|https://perldoc.perl.org/Encode::Unicode>
2645              
2646             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>
2647              
2648             =head1 COPYRIGHT & LICENSE
2649              
2650             Copyright(c) 2022 DEGUEST Pte. Ltd.
2651              
2652             All rights reserved
2653             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
2654              
2655             =cut