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   438472 use strict;
  12         39  
  12         395  
18 12     12   76 use warnings;
  12         41  
  12         310  
19 12     12   64 use warnings::register;
  12         64  
  12         1303  
20 12     12   81 use parent qw( Module::Generic );
  12         53  
  12         84  
21 12         1149 use vars qw( $VERSION $EXCEPTION_CLASS $BOUNDARY_DELIMITER $BOM2ENC $ENC2BOM $BOM_RE
22 12     12   865 $BOM_MAX_LENGTH $DEFAULT_MIME_TYPE );
  12         35  
23 12     12   942 use Data::UUID;
  12         1212  
  12         964  
24 12     12   2332 use HTTP::Promise::Exception;
  12         36  
  12         142  
25 12     12   9165 use HTTP::Promise::Headers;
  12         31  
  12         530  
26 12     12   5875 use HTTP::Promise::Body;
  12         37  
  12         128  
27 12     12   8610 use Module::Generic::HeaderValue;
  12         31557  
  12         127  
28             # use Nice::Try;
29 12     12   3200 use Symbol;
  12         26  
  12         826  
30 12     12   86 use URI::Escape::XS ();
  12         38  
  12         364  
31 12     12   64 use constant CRLF => "\015\012";
  12         75  
  12         1242  
32 12     12   49 our $EXCEPTION_CLASS = 'HTTP::Promise::Exception';
33 12         40 our $BOUNDARY_DELIMITER = "\015\012";
34 12         27 our $DEFAULT_MIME_TYPE = 'application/octet-stream';
35 12         248 our $VERSION = 'v0.2.1';
36             };
37              
38 12     12   84 use strict;
  12         33  
  12         292  
39 12     12   71 use warnings;
  12         33  
  12         75263  
40              
41             sub init
42             {
43 155     155 1 144717 my $self = shift( @_ );
44 155         1235 $self->{body} = undef;
45             # Sie minimum from which compression is enabled, if mime type is suitable.
46             # Defaults to 200Kb
47 155         742 $self->{compression_min}= 204800;
48 155         474 $self->{effective_type} = undef;
49 155         412 $self->{epilogue} = undef;
50 155         434 $self->{ext_vary} = undef;
51 155         507 $self->{headers} = undef;
52 155         633 $self->{is_encoded} = 0;
53 155         607 $self->{output_dir} = undef;
54 155         654 $self->{preamble} = undef;
55 155         487 $self->{_init_strict_use_sub} = 1;
56 155         551 $self->{_exception_class} = $EXCEPTION_CLASS;
57 155 50       988 $self->SUPER::init( @_ ) || return( $self->pass_error );
58 155         10324 $self->{_parts} = [];
59 155         505 return( $self );
60             }
61              
62             sub add_part
63             {
64 5     5 1 37296 my $self = shift( @_ );
65 5         29 my( $part, $index ) = @_;
66 5 50       78 return( $self->error( "Part provided is not a HTTP::Promise::Entity object." ) ) if( !$self->_is_a( $part => 'HTTP::Promise::Entity' ) );
67 5         409 my $parts = $self->_parts;
68 5 50       4108 $index = -1 if( !defined( $index ) );
69 5 50       64 $index = $parts->size + 2 + $index if( $index < 0 );
70 5         183731 $parts->splice( $index, 0, $part );
71 5         1535 return( $part );
72             }
73              
74             sub as_form_data
75             {
76 1     1 1 37143 my $self = shift( @_ );
77 1         17 my $type = $self->headers->type;
78 1 50       9 return(0) unless( lc( $type ) eq 'multipart/form-data' );
79 1 50       42 $self->_load_class( 'HTTP::Promise::Body::Form::Data' ) || return( $self->pass_error );
80 1         598 my $form = HTTP::Promise::Body::Form::Data->new;
81 1   50     782 $form->debug( $self->debug // 0 );
82 1         36626 my $parts = $self->parts;
83             # nothing to do
84 1 50       792 return( $form ) if( $parts->is_empty );
85 1         36 foreach my $part ( @$parts )
86             {
87 4         206 my $headers = $part->headers;
88 4         118 my $body = $part->body;
89 4         85 my $name;
90 4         24 my $dispo = $headers->content_disposition;
91 4 50       96 next unless( $dispo );
92 4         51 my $cd = $headers->new_field( 'Content-Disposition' => "$dispo" );
93 4 50       12 return( $self->pass_error( $headers->error ) ) if( !defined( $cd ) );
94 4         12 $name = $cd->name;
95 4 50 33     2167 next if( !defined( $name ) || !length( "$name" ) );
96 4         26 my $encodings = $headers->content_encoding;
97 4 50 33     54 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         2792 my $field = $form->new_field(
104             name => $name,
105             body => $body,
106             headers => $headers,
107             );
108 4 50       12 return( $self->pass_error( $form->error ) ) if( !defined( $field ) );
109            
110 4 50       100 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         98 $form->{ $name } = $field;
118             }
119             }
120 1         79 return( $form );
121             }
122              
123             sub as_string
124             {
125 30     30 1 2164 my $self = shift( @_ );
126 30         91 my $eol = shift( @_ );
127 30         160 my $opts = $self->_get_args_as_hash( @_ );
128 30 100       333 $opts->{eol} = $eol if( defined( $eol ) );
129 30         193 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         923 my $binmode;
134 30 0 33     150 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     212 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       20735 $self->print( $fh, ( scalar( keys( %$opts ) ) ? $opts : () ) ) || return( $self->pass_error );
    50          
144 30         153 $fh->close;
145 30 50       3002 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         141 return( $output );
160             }
161              
162             sub attach
163             {
164 3     3 1 1222 my $self = shift( @_ );
165 3   33     23 my $class = ref( $self ) || $self;
166 3 50       41 $self->make_multipart || return( $self->pass_error );
167 3   50     36 my $part = $class->build( @_, top => 0 ) ||
168             return( $self->pass_error( $class->error ) );
169 3         1590 return( $self->add_part( $part ) );
170             }
171              
172 371     371 1 9296 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 460 my $self = shift( @_ );
195 1         19 my $opts = $self->_get_args_as_hash( @_ );
196 1         22 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         37 my $binmode;
201 1 0 33     16 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     13 my $fh = $output->open( '>' ) ||
209             return( $self->pass_error( $output->error ) );
210 1 50       354 $self->print_body( $fh, ( scalar( keys( %$opts ) ) ? $opts : () ) ) || return( $self->pass_error );
    50          
211 1         10 $fh->close;
212 1 50       106 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         11 return( $output );
227             }
228              
229             sub build
230             {
231 17     17 1 102147 my $self = shift( @_ );
232 17         150 my( $opts, $order ) = $self->_get_args_as_hash( @_ );
233 17         3628 my( $field, $filename, $boundary );
234 17   100     190 my $type = delete( $opts->{type} ) || 'text/plain';
235 17         71 my $charset = delete( $opts->{charset} );
236 17 100       213 my $is_multipart = ( $type =~ m{^multipart/}i ? 1 : 0 );
237 17   100     162 my $encoding = delete( $opts->{encoding} ) || '';
238 17         111 my $desc = delete( $opts->{description} );
239 17 100       98 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         90 my $disposition = delete( $opts->{disposition} );
248 17         66 my $id = delete( $opts->{id} );
249 17   100     148 my $debug = delete( $opts->{debug} ) // 0;
250             # Ensure this is an object
251 17   50     123 my $new = $self->new( debug => $debug ) || return( $self->pass_error );
252 17   50     151 my $headers = HTTP::Promise::Headers->new( { debug => $self->debug } ) ||
253             return( $self->pass_error( HTTP::Promise::Headers->error ) );
254 17         100 $new->headers( $headers );
255            
256             # Either data or path
257 17         753 my $data = delete( $opts->{data} );
258 17         58 my $path = delete( $opts->{path} );
259 17   100     268 my( $path_fname ) = ( ( $path || '' ) =~ m{([^/]+)\Z} );
260 17 100       117 $filename = ( exists( $opts->{filename} ) ? delete( $opts->{filename} ) : $path_fname );
261 17 50 66     150 $filename = undef() if( defined( $filename ) and $filename eq '' );
262 17         44 my $filename_utf8;
263 17 100 66     245 if( defined( $filename ) && length( $filename ) && $filename =~ /[^\w\.]+/ )
      100        
264             {
265 3         30 $filename_utf8 = $new->headers->encode_filename( $filename );
266             }
267 17 100 66     832 if( defined( $encoding ) &&
268             $type =~ m{^(multipart/|message/(rfc822|partial|external-body|delivery-status|disposition-notification|feedback-report|http)$)}i )
269             {
270 3         20 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       10 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       32 $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     162 if( defined( $path ) && length( $path ) )
    50 33        
298             {
299 12   50     167 my $f = HTTP::Promise::Body::File->new( $path ) ||
300             return( $self->pass_error( HTTP::Promise::Body::File->error ) );
301 12 50       420 $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     58 my $s = HTTP::Promise::Body::InCore->new( $data ) ||
308             return( $self->pass_error( HTTP::Promise::Body::InCore->error ) );
309 3 50       20 $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         1286 my $ct = Module::Generic::HeaderValue->new_from_header( $type );
319 17 50       89476 return( $self->pass_error( Module::Generic::HeaderValue->error ) ) if( !defined( $ct ) );
320 17 100       91 $ct->param( charset => $charset ) if( $charset );
321 17 100       1166 if( defined( $filename_utf8 ) )
    100          
322             {
323 3         64 $ct->param( 'name*' => sprintf( "UTF-8''%s", $filename_utf8 ) );
324             }
325             elsif( defined( $filename ) )
326             {
327 8         48 $ct->param( name => $filename );
328             }
329 17 100       11430 $ct->param( boundary => $boundary ) if( defined( $boundary ) );
330 17         2315 $headers->replace( 'Content-Type' => "$ct" );
331            
332 17 100 100     276 if( defined( $encoding ) && lc( $encoding ) eq 'suggest' )
333             {
334 3         59 $encoding = $new->suggest_encoding;
335             }
336            
337             # unless( $is_multipart )
338 17 100 100     553 if( !$is_multipart && ( defined( $disposition ) || defined( $filename ) ) )
      100        
339             {
340 11 100       88 $disposition = 'attachment' if( !defined( $disposition ) );
341 11 50       125 $field = Module::Generic::HeaderValue->new_from_header( ( defined( $disposition ) ? $disposition : () ) );
342 11 50       56027 return( $self->pass_error( Module::Generic::HeaderValue->error ) ) if( !defined( $field ) );
343 11 100       93 if( defined( $filename_utf8 ) )
    50          
344             {
345 3         44 $field->param( 'filename*' => sprintf( "UTF-8''%s", $filename_utf8 ) );
346             }
347             elsif( defined( $filename ) )
348             {
349 8         33 $field->param( filename => $filename );
350             }
351 11         11573 $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     111 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       93 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         82 foreach( @$order )
365             {
366             # Maybe it has been removed since then? So that only headers remain
367 40 50       197 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         156 return( $new );
383             }
384              
385             sub clone
386             {
387 10     10 1 54 my $self = shift( @_ );
388 10         54 my $opts = $self->_get_args_as_hash( @_ );
389 10   100     1270 $opts->{clone_message} //= 1;
390 10         123 my $addr = $self->_refaddr( $self );
391 10         107 my $new = $self->new;
392 10         104 my( $new_headers, $new_body, $new_parts );
393 10         74 my $headers = $self->headers;
394 10         292 my $body = $self->body;
395 10 50       344 $new_headers = $headers->clone if( defined( $headers ) );
396 10 100       235 $new_body = $body->clone if( defined( $body ) );
397 10         370 my $parts = $self->parts;
398 10 100       8504 if( !$parts->is_empty )
399             {
400 1         22 $new_parts = $self->new_array;
401             # Each part is an HTTP::Promise::Entity
402 1         27 for( @$parts )
403             {
404 1         4 my $paddr = $self->_refaddr( $_ );
405             # This would be weird, but let's do it anyway
406 1 50       13 if( $paddr eq $addr )
407             {
408 0         0 $new_parts->push( $new );
409 0         0 next;
410             }
411 1         8 my $new_part = $_->clone;
412 1         7 $new_parts->push( $new_part );
413             }
414 1         13 $new->parts( $new_parts );
415             }
416 10 50       1185 $new->headers( $new_headers ) if( defined( $new_headers ) );
417 10 100       479 $new->body( $new_body ) if( defined( $new_body ) );
418 10 50       325 $new->name( $self->name ) if( $self->name );
419 10         7205 $new->is_encoded( $self->is_encoded );
420 10         8990 $new->debug( $self->debug );
421 10         547 $new->preamble( $self->preamble->clone );
422 10         8748 $new->epilogue( $self->epilogue->clone );
423 10         8460 $new->compression_min( $self->compression_min );
424 10         376824 $new->effective_type( $self->effective_type );
425 10         5281 my $msg;
426 10 100 66     69 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         13 $new_msg->headers( $new_headers );
431 3         15 $new_msg->entity( $new );
432 3         670 $new->http_message( $new_msg );
433             }
434 10         599 return( $new );
435             }
436              
437 23     23 1 298350 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 739 my $self = shift( @_ );
445 11         65 my $opts = $self->_get_args_as_hash( @_ );
446 11         961 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     830 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       742 $self->_load_class( 'Encode' ) || return( $self->pass_error );
456 11 100 100     484 unless( defined( $BOM2ENC ) && scalar( %$BOM2ENC ) )
457             {
458             # Credits: Matthew Lawrence (File::BOM)
459             our $BOM2ENC = +{
460 2         13 map{ Encode::encode( $_, "\x{feff}" ) => $_ } qw(
  10         8276  
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         87 map{ $_ => Encode::encode( $_, "\x{feff}" ) } qw(
  6         2602  
472             UCS-2
473             iso-10646-1
474             utf8
475             )
476             };
477 2         90 my @boms = sort{ length( $b ) <=> length( $a ) } keys( %$BOM2ENC );
  14         40  
478 2         16 our $BOM_MAX_LENGTH = length( $boms[0] );
479             {
480 2         15 local $" = '|';
  2         17  
481 2         98 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         40 my $cref;
488 11 100 66     105 if( exists( $opts->{content} ) && length( $opts->{content} ) )
489             {
490 6 50 33     81 return( $self->error( "Unsupported data type (", ref( $opts->{content} ), ")." ) ) if( ref( $opts->{content} ) && !$self->_is_scalar( $opts->{content} ) );
491 6 50       108 $cref = $self->_is_scalar( $opts->{content} ) ? $opts->{content} : \$opts->{content};
492             }
493             else
494             {
495 5   50     13 my $body = $self->body || return( '' );
496 5   50     30 my $io = $body->open( '<', { binmode => 'raw' } ) ||
497             return( $self->pass_error( $body->error ) );
498 5         198 my $buff;
499 5         22 my $bytes = $io->read( $buff, 4096 );
500 5 50       577 return( $self->pass_error( $io->error ) ) if( !defined( $bytes ) );
501 5 50       28 return( '' ) if( !$bytes );
502 5         24 $cref = \$buff;
503             }
504            
505             # Is there a Byte Order Mark?
506 11 100       635 if( $$cref =~ /^($BOM_RE)/ )
507             {
508 6         16 my $bom = $1;
509 6         113 return( $BOM2ENC->{ $bom } );
510             }
511              
512             # Unicode BOM
513 5 50       62 return( 'UTF-8' ) if( $$cref =~ /^\xEF\xBB\xBF/ );
514 5 50       31 return( 'UTF-32LE' ) if( $$cref =~ /^\xFF\xFE\x00\x00/ );
515 5 50       38 return( 'UTF-32BE' ) if( $$cref =~ /^\x00\x00\xFE\xFF/ );
516 5 50       33 return( 'UTF-16LE' ) if( $$cref =~ /^\xFF\xFE/ );
517 5 50       32 return( 'UTF-16BE' ) if( $$cref =~ /^\xFE\xFF/ );
518              
519 5 50       44 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         144 my $encoding = $self->guess_character_encoding( content => $cref, object => 1 );
544 5 0       32 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       34 if( $headers->content_type =~ /^text\// )
557             {
558 5 50       154 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         27 return( '' );
578             }
579              
580             sub decode_body
581             {
582 21     21 1 2595 my $self = shift( @_ );
583 21         66 my $this = shift( @_ );
584 21         114 my $opts = $self->_get_args_as_hash( @_ );
585 21 50       1625 return( $self->error( "No decoding string or array has been provided." ) ) if( !defined( $this ) );
586 21 50 33     101 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       1219 my $encodings = $self->_is_array( $this ) ? $this : [split( /[[:blank:]\h]*,[[:blank:]\h]*/, "${this}" )];
588 21   100     800 $opts->{replace} //= 1;
589 21   100     334 $opts->{raise_error} //= 0;
590 21 50       158 $self->_load_class( 'HTTP::Promise::Stream' ) || return( $self->error );
591 21         1332 my $body = $self->body;
592 21 50 33     729 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     474 return( $self ) if( !$body || !scalar( @$encodings ) );
595             # Parameters to be passed. Transparent set to 0 allow for failure
596 21         650 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       509 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         70 my $temp = $body;
691 21 50       152 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         279 foreach my $enc ( @$encodings )
698             {
699 32 100 100     18456 next if( $enc eq 'identity' || $enc eq 'none' );
700 30         111 my $params = {};
701 30 100       172 $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     259 debug => $self->debug
706             ) || return( $self->pass_error( HTTP::Promise::Stream->error ) );
707 27         520 my $decoded = $self->new_scalar;
708             # my $len = $s->read( $decoded, ( exists( $params->{ $enc } ) ? ( $params->{ $enc } ) : () ) );
709 27         1104 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       8505 if( !defined( $len ) )
713             {
714 1 50 33     41 if( $enc eq 'deflate' || $enc eq 'inflate' )
715             {
716             # Try again, but using rawinflate this time
717 1 50       17 if( $s->error->message =~ /Header Error: CRC mismatch/ )
718             {
719 1         890 $enc = "raw${enc}";
720 1         11 $params = {};
721 1 50       20 $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     21 debug => $self->debug
726             ) || return( $self->pass_error( HTTP::Promise::Stream->error ) );
727             # $len = $s->read( $decoded, ( exists( $params->{ $enc } ) ? $params->{ $enc } : () ) );
728 1         26 $len = $s->read( $decoded, $params );
729 1 50       70 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       2189 return( $self->error( "The decoding pass on the HTTP body in memory with encoding '$enc' resulted in 0 byte decoded!" ) ) if( !$len );
742 27         856 $temp = $decoded;
743             }
744             # Replace content (default)
745 18 100       35653 if( $opts->{replace} )
746             {
747 14         320 $body->set( $temp );
748 14         579 $self->body( $body );
749 14         1371 $self->is_decoded(1);
750             }
751             # Make a copy to return it
752             else
753             {
754 4         93 $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         12183 return( $body );
762             }
763              
764             sub dump
765             {
766 2     2 1 2023 my $self = shift( @_ );
767 2         18 my $opts = $self->_get_args_as_hash( @_ );
768 2         430 my $content = '';
769 2         21 my $maxlen = $opts->{maxlength};
770 2 50       12 $maxlen = 512 unless( defined( $maxlen ) );
771 2         12 my $no_content = $opts->{no_content};
772 2 50       10 $no_content = "(no content)" unless( defined( $no_content ) );
773 2         10 my $body = $self->body;
774 2         57 my $chopped = 0;
775 2         8 my $mime_type = $self->mime_type;
776 2         7 my $toptype;
777 2 50       12 $toptype = [split( '/', lc( $mime_type ), 2 )]->[0] if( defined( $mime_type ) );
778 2   50     11 my $crlf = $HTTP::Promise::Entity::BOUNDARY_DELIMITER || CRLF;
779              
780 2 50       9 if( defined( $body ) )
    0          
781             {
782 2   50     35 my $io = $body->open( '<', { binmode => 'raw' } ) ||
783             return( $self->pass_error( $body->error ) );
784 2   66     140 my $bytes = $io->read( $content, ( $maxlen || $body->length ) );
785 2 50       37378 return( $self->pass_error( $io->error ) ) if( !defined( $bytes ) );
786 2         132 $io->close;
787 2         204 my $encoding = $self->headers->mime_encoding;
788 2         8 my $encodings = [];
789 2 50 33     19 $encodings = [split( /[[:blank:]\h]*,[[:blank:]\h]*/, $encoding )] if( defined( $encoding ) && length( $encoding ) );
790 2 50       17 $self->_load_class( 'HTTP::Promise::Stream' ) || return( $self->error );
791             # Process encoding
792 2 50 33     108 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     30 if( $maxlen && $body->length > $maxlen )
823             {
824 1         37338 $content .= '...';
825 1         6 $chopped = $body->length - $maxlen;
826             }
827 2         37337 $content =~ s/\\/\\\\/g;
828 2         273 $content =~ s/\t/\\t/g;
829 2         5 $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         4 $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
  0         0  
840 2         5 $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       13 $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         282 my @dump;
912 2 50       8 push( @dump, $opts->{preheader} ) if( $opts->{preheader} );
913 2         4 my $start_line;
914 2 50 33     8 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         9 my $dump = join( "\n", @dump, '' );
921 2 50       8 $dump =~ s/^/$opts->{prefix}/gm if( $opts->{prefix} );
922 2         20 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   132 no strict 'refs';
  12         59  
  12         33464  
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 171 my $self = shift( @_ );
990 23 100       104 if( @_ )
991             {
992 10         47 $self->_set_get_scalar_as_object( 'effective_type', @_ );
993             }
994 23   66     8320 return( $self->_set_get_scalar_as_object( 'effective_type' ) || $self->mime_type );
995             }
996              
997             sub encode_body
998             {
999 12     12 1 71 my $self = shift( @_ );
1000 12         75 my $this = shift( @_ );
1001 12 50 33     198 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       1445 my $encodings = $self->new_array( $self->_is_array( $this ) ? $this : [split( /[[:blank:]\h]*,[[:blank:]\h]*/, "${this}" )] );
1003 12 50       1008 $self->_load_class( 'HTTP::Promise::Stream' ) || return( $self->error );
1004 12         1107 my $body = $self->body;
1005 12 50 33     476 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       539 return( $self ) if( !$body );
1008 12         49 my $seen = {};
1009 12 100       329 if( $body->isa( 'HTTP::Promise::Body::File' ) )
    50          
1010             {
1011 1         2 my $f = $body;
1012 1 50       22 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         36974 my $ext = $f->extension;
1018 1         162 foreach my $enc ( @$encodings )
1019             {
1020 2 50 33     1908 next if( $enc eq 'identity' || $enc eq 'none' );
1021 2 50       18 next if( ++$seen->{ $enc } > 1 );
1022 2   50     29 my $s = HTTP::Promise::Stream->new( $f, encoding => $enc ) ||
1023             return( $self->pass_error( HTTP::Promise::Stream->error ) );
1024 2 50       55 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         1425 my $tempfile = $self->new_tempfile( extension => $ext );
1034 2         110454 my $len = $s->read( $tempfile );
1035 2 50       92 return( $self->pass_error( $s->error ) ) if( !defined( $len ) );
1036 2 50       12 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         44 $f = $tempfile;
1038             }
1039 1   50     3528 $body = HTTP::Promise::Body::File->new( $f ) ||
1040             return( $self->pass_error( HTTP::Promise::Body::File->error ) );
1041 1         58 $self->body( $body );
1042             }
1043             elsif( $body->isa( 'HTTP::Promise::Body::Scalar' ) )
1044             {
1045 11         43 my $temp = $body;
1046 11 50       124 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         188 foreach my $enc ( @$encodings )
1053             {
1054 13 100 100     4129 next if( $enc eq 'identity' || $enc eq 'none' );
1055 11 50       95 next if( ++$seen->{ $enc } > 1 );
1056 11   100     174 my $s = HTTP::Promise::Stream->new( $temp, encoding => $enc ) ||
1057             return( $self->pass_error( HTTP::Promise::Stream->error ) );
1058 10         130 my $encoded = $self->new_scalar;
1059 10         401 my $len = $s->read( $encoded );
1060 10 50       318 return( $self->pass_error( $s->error ) ) if( !defined( $len ) );
1061 10 50       70 return( $self->error( "The encoding pass on the HTTP body in memory with encoding '$enc' resulted in 0 byte encoded!" ) ) if( !$len );
1062 10         242 $temp = $encoded;
1063             }
1064 10         15655 $body->set( $temp );
1065 10         384 $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         2934 return( $body );
1072             }
1073              
1074 32     32 1 7138 sub epilogue { return( shift->_set_get_array_as_object( 'epilogue', @_ ) ); }
1075              
1076 2     2 1 19 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 23 my $self = shift( @_ );
1083 5         32 my $opts = $self->_get_args_as_hash( @_ );
1084 5         733 my $data;
1085 5 50 33     71 if( exists( $opts->{content} ) && length( $opts->{content} ) )
1086             {
1087 5 50 33     78 return( $self->error( "Unsupported data type (", ref( $opts->{content} ), ")." ) ) if( ref( $opts->{content} ) && !$self->_is_scalar( $opts->{content} ) );
1088 5 50       80 $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       94 return( '' ) if( $self->is_binary( $data ) );
1103              
1104 5         15 my $encoding;
1105 5 50       69 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       19 if( !defined( $encoding ) )
1120             {
1121 5 50       27 $self->_load_class( 'Encode' ) || return( $self->pass_error );
1122 5         236 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     345 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     21 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       69 return( defined( $encoding ) ? $encoding : '' );
1142             }
1143              
1144 1     1 1 39487 sub header { return( shift->headers->header( @_ ) ); }
1145              
1146 529     529 1 32541 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 42071 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 459 my $self = shift( @_ );
1156 13         66 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     1981 my $body = $opts->{body} // $self->body;
1160 13         50 my $headers = $self->headers;
1161             # Use cache if it exists
1162 13 50 66     600 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       42 return( $opts->{charset_strict} ? $self->{_io_encoding_strict_cached} : $self->{_io_encoding_cached} );
1170             }
1171 11         26 my $data;
1172 11 50 33     74 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       38 return( '' ) if( !$body );
1181 11         100 $self->{_checksum_md5} = $body->checksum_md5;
1182 11   50     421 my $io = $body->open( '<', { binmode => 'raw' } ) ||
1183             return( $self->pass_error( $body->error ) );
1184 11         1892 my $buff;
1185 11         73 my $bytes = $io->read( $buff, 4096 );
1186 11 50       1363 return( $self->pass_error( $io->error ) ) if( !defined( $bytes ) );
1187 11 50       53 return( '' ) if( !$bytes );
1188 11         122 $data = \$buff;
1189             }
1190             # return( '' ) if( $self->is_binary( $data ) );
1191            
1192 11         1127 my $enc;
1193 11 100 100     152 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     672 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       53 $self->_load_class( 'Encode' ) || return( $self->pass_error );
1218             # try-catch
1219 9         284 local $@;
1220             eval
1221 9         30 {
1222 9 100       136 my $test = Encode::decode( $charset, $$data, ( ( $opts->{charset_strict} ? Encode::FB_CROAK : 0 ) | Encode::LEAVE_SRC ) );
1223 7         1030 $enc = $charset;
1224             };
1225 9 100       154 if( $@ )
1226             {
1227 2         19 my $retried = 0;
1228 2 50       15 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       42 return( $self->error( $@ ) ) unless( $retried );
1240             }
1241             }
1242             }
1243 9 50       42 if( $opts->{charset_strict} )
1244             {
1245 0         0 $self->{_io_encoding_strict_cached} = $enc;
1246             }
1247             else
1248             {
1249 9         34 $self->{_io_encoding_cached} = $enc;
1250             }
1251 9 100       59 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 33 my $self = shift( @_ );
1262 7 50       36 $self->_load_class( 'Encode' ) || return( $self->pass_error );
1263 7         328 my $data;
1264 7 50       48 if( @_ )
1265             {
1266             # We need to make a copy
1267 7         39 my $this = shift( @_ );
1268 7 50 33     112 return(0) if( !defined( $this ) || !length( "$this" ) );
1269 7 50 33     80 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       127 $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       37 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       141 return(1) if( index( $$data, "\c@" ) != -1 );
1314 7         16 my $length = length( $$data );
1315 7         24 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         36 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       56 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 88 my $self = shift( @_ );
1352 14 50       87 if( @_ )
1353             {
1354 14         68 my $bool = shift( @_ );
1355 14         174 return( !$self->is_encoded( !$bool ) );
1356             }
1357             else
1358             {
1359 0         0 return( !$self->is_encoded );
1360             }
1361             }
1362              
1363 99     99 1 5520 sub is_encoded { return( shift->_set_get_boolean( 'is_encoded', @_ ) ); }
1364              
1365             sub is_multipart
1366             {
1367 5     5 1 24 my $self = shift( @_ );
1368             # no head, so no MIME type!
1369 5 50       29 $self->headers or return;
1370 5         178 my $mime_type = $self->headers->type;
1371 5 100 66     55 return(0) if( !defined( $mime_type ) || !length( $mime_type ) );
1372 4 100       167 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 8892 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 33 my $self = shift( @_ );
1390 5         35 my $subtype = shift( @_ );
1391 5         41 my $opts = $self->_get_args_as_hash( @_ );
1392 5         43 my $tag;
1393 5   100     49 $subtype ||= 'form-data';
1394 5         17 my $force = $opts->{force};
1395              
1396             # Trap for simple case: already a multipart?
1397 5 100 66     29 return( $self ) if( $self->is_multipart and !$force );
1398 2         10 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         60 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         51 my $removed = $headers->remove_content_headers;
1427 2   50     18 my $ct = $headers->new_field( 'Content-Type' => "multipart/${subtype}" ) ||
1428             return( $self->pass_error( $headers->error ) );
1429 2         13 $ct->boundary( $self->make_boundary );
1430 2         1175 my $ct_string = $ct->as_string;
1431 2         535320 $headers->header( 'Content-Type' => "${ct_string}" );
1432              
1433             # Remove non-content headers from the part
1434 2         17 $removed = $self->new_array;
1435 2         65 foreach $tag ( grep{ !/^content-/i } $part->headers->header_field_names )
  1         61  
1436             {
1437 0         0 $part->headers->delete( $tag );
1438 0         0 $removed->push( $tag );
1439             }
1440 2         49 $self->parts->reset;
1441 2 100 66     1164 $self->add_part( $part ) if( $part->body || $part->parts->length );
1442 2         37194 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 16762 my $self = shift( @_ );
1491 105         339 my $headers = $self->headers;
1492 105 50       2739 return if( !defined( $headers ) );
1493 105         824 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 337 sub name { return( shift->_set_get_scalar_as_object( 'name', @_ ) ); }
1498              
1499             sub new_body
1500             {
1501 59     59 1 175 my $self = shift( @_ );
1502 59   50     313 my $type = shift( @_ ) || 'scalar';
1503 59         1071 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     266 my $class = $map->{ $type } || return( $self->error( "Unsupported body type '$type'" ) );
1511 59 100       220 if( $type eq 'form' )
1512             {
1513 1 50       11 $self->_load_class( $class ) || return( $self->pass_error );
1514             }
1515 59         1758 my $body = $class->new( @_ );
1516 59 50       1089 return( $self->pass_error( $class->error ) ) if( !defined( $body ) );
1517 59         1283 return( $body );
1518             }
1519              
1520             sub open
1521             {
1522 36     36 1 100 my $self = shift( @_ );
1523 36         88 my $body = $self->body;
1524 36 50       932 return( $self->error( "Unable to open the entity body, because none is currently set." ) ) if( !$body );
1525 36   50     381 my $io = $body->open( @_ ) ||
1526             return( $self->pass_error( $body->error ) );
1527 36         25396 return( $io );
1528             }
1529              
1530 0     0 1 0 sub output_dir { return( shift->_set_get_file( 'output_dir', @_ ) ); }
1531              
1532 182     182 1 81580 sub parts { return( shift->_set_get_array_as_object( '_parts', @_ ) ); }
1533              
1534 33     33 1 44051 sub preamble { return( shift->_set_get_array_as_object( 'preamble', @_ ) ); }
1535              
1536             sub print
1537             {
1538 59     59 1 342683 my $self = shift( @_ );
1539 59         359 my $out = shift( @_ );
1540 59         286 my $opts = $self->_get_args_as_hash( @_ );
1541 59   50     4931 my $eol = $opts->{eol} || $HTTP::Promise::Entity::BOUNDARY_DELIMITER || CRLF;
1542 59 100       223 $out = select if( !defined( $out ) );
1543 59 50       234 $out = Symbol::qualify( $out, scalar( caller ) ) unless( ref( $out ) );
1544 59 50       287 $self->_load_class( 'HTTP::Promise::IO' ) || return( $self->error );
1545 59 100       3125 my $io = $self->_is_a( $out => 'HTTP::Promise::IO' )
1546             ? $out
1547             : HTTP::Promise::IO->new( $out, debug => $self->debug );
1548 59 50       1137 return( $self->pass_error( HTTP::Promise::IO->error ) ) if( !defined( $io ) );
1549 59         157 $opts->{eol} = $eol;
1550             # The start-line
1551 59 50       353 $self->print_start_line( $io, $opts ) || return( $self->pass_error );
1552             # The headers
1553 59 50       235 $self->print_header( $io, $opts ) || return( $self->pass_error );
1554 59 50       197 $io->print( $eol ) ||
1555             return( $self->error( "Unable to print to filehandle provided '$io': $!" ) );
1556             # The body
1557 59 50       529 $self->print_body( $io, ( scalar( keys( %$opts ) ) ? $opts : () ) ) || return( $self->pass_error );
    50          
1558 59         1304 return( $self );
1559             }
1560              
1561             sub print_body
1562             {
1563 60     60 1 140 my $self = shift( @_ );
1564 60         120 my $out = shift( @_ );
1565 60         198 my $opts = $self->_get_args_as_hash( @_ );
1566 60 50 66     7729 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     3105 $out ||= select;
1568 60         242 my $mime_type = $self->mime_type;
1569 60         116 my $toptype;
1570 60 50       339 $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         85 my $boundary = $self->_prepare_multipart_headers();
1578              
1579             # Preamble. I do not think there should be any anyway for HTTP multipart
1580 9         49 my $plines = $self->preamble;
1581 9 50       7110 if( defined( $plines ) )
1582             {
1583             # Defined, so output the preamble if it exists (avoiding additional
1584             # newline as per ticket 60931)
1585 9 50       87 $out->print( join( $crlf, @$plines ) . $crlf ) if( @$plines > 0 );
1586             }
1587             # Otherwise, no preamble.
1588              
1589             # Parts
1590 9         49 foreach my $part ( $self->parts->list )
1591             {
1592 25 50       5086 $out->print( "--${boundary}${crlf}" ) ||
1593             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1594 25 50       564 $part->print( $out ) ||
1595             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1596             # Trailing CRLF
1597 25 50       107 $out->print( $crlf ) ||
1598             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1599             }
1600 9 50       219 $out->print( "--${boundary}--${crlf}" ) ||
1601             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1602              
1603             # Epilogue
1604 9         240 my $epilogue = $self->epilogue;
1605 9 50 33     8113 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         1247 my $need_sep = 0;
1622 2         4 my $part;
1623 2         7 my $parts = $self->parts;
1624             # foreach $part ( $self->parts->list )
1625 2         1521 foreach $part ( @$parts )
1626             {
1627 2 50       11 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       30785 if( $self->body )
1640             {
1641 36 50       433 $self->print_bodyhandle( $out, ( scalar( keys( %$opts ) ) ? $opts : () ) ) ||
    50          
1642             return( $self->pass_error );
1643             }
1644             }
1645 60         4062 return( $self );
1646             }
1647              
1648             sub print_bodyhandle
1649             {
1650 36     36 1 139 my $self = shift( @_ );
1651 36         80 my $out = shift( @_ );
1652 36         124 my $opts = $self->_get_args_as_hash( @_ );
1653 36   33     4468 $out ||= select;
1654 36 50 33     196 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         1989 my $encoding = $self->headers->content_encoding;
1657 36 50 100     381 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       4400 $self->encode_body( $encoding ) || return( $self->pass_error );
1664 6         160 $self->is_encoded(1);
1665             }
1666 36         8149 my $params = {};
1667 36 0 33     149 $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     303 my $io = $self->open( 'r', ( scalar( keys( %$params ) ) ? $params : () ) ) || return( $self->pass_error );
1670 36         112 my $buff;
1671 36         238 while( $io->read( $buff, 8192 ) )
1672             {
1673 62 50       7201 $out->print( $buff ) ||
1674             return( $self->error( "Unable to print request body to filehandle provided '$out': $!" ) );
1675             }
1676 36         3228 $io->close;
1677 36         3368 return( $self );
1678             }
1679              
1680 59     59 1 192 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         130 my $out = shift( @_ );
1688 59   33     163 $out ||= select;
1689 59 50 33     297 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         2966 my $opts = $self->_get_args_as_hash( @_ );
1691 59   50     8154 my $eol = $opts->{eol} || CRLF;
1692 59 100       345 if( my $msg = $self->http_message )
1693             {
1694 40         1333 my $sl = $msg->start_line;
1695 40 100       196 return( $self ) unless( length( $sl ) );
1696 7         62 $out->print( $sl . $eol );
1697             }
1698 26         1101 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 15 my $self = shift( @_ );
1785 3         24 my $mime_type = $self->effective_type;
1786 3         8 my $toptype;
1787 3 50       45 $toptype = [split( '/', $mime_type, 2 )]->[0] if( defined( $mime_type ) );
1788             # Defaults to 200Kb
1789 3         43 my $threshold = $self->compression_min;
1790 3         107676 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     18 if( exists( $rule->{ $mime_type } ) )
    0 0        
    0 0        
      0        
1832             {
1833 3 100       21 return( '' ) if( $rule->{ $mime_type } eq 'none' );
1834 2 50 33     13 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         71971 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   63 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   53 my $self = shift( @_ );
1863 9         51 my $mime_type = $self->mime_type;
1864 9         55 my $toptype;
1865 9 50       112 $toptype = [split( '/', lc( $mime_type ), 2 )]->[0] if( defined( $mime_type ) );
1866 9         53 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       239 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         33 my $n = 0;
1881             # for generated part name, by default
1882 9         68 my $auto_name = 'part0';
1883 9         105 foreach my $part ( $self->parts->list )
1884             {
1885 25         221605 ++$n;
1886             # If this is a multipart/form-data, ensure we have a part name, or isse a warning
1887 25         67 my $name;
1888 25 100       104 if( $mime_type eq 'multipart/form-data' )
    50          
1889             {
1890 7         46 $name = $part->name;
1891 7 100       5907 if( !$name )
1892             {
1893 3 50       829 warn( "Warning: no part name set for this part No. ${n}\n" ) if( warnings::enabled() );
1894 3         22 $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         59 $part->headers->remove( 'Content-Disposition' );
1902             }
1903            
1904 25 100       2939 if( defined( $name ) )
1905             {
1906 7         56 my $content_disposition = $part->headers->content_disposition;
1907 7 100 66     154 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     143385 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         10 $part->headers->content_disposition( qq{form-data; name="${name}"} );
1921             }
1922             }
1923             }
1924 9         72514 return( $boundary );
1925             }
1926              
1927             # NOTE: sub FREEZE is inherited
1928             sub FREEZE
1929             {
1930 4     4 0 12 my $self = CORE::shift( @_ );
1931 4   50     32 my $serialiser = CORE::shift( @_ ) // '';
1932 4         24 my $class = CORE::ref( $self );
1933 4         27 my $ref = $self->_obj2h;
1934 4         137 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       41 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     35 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         290 CORE::return( $class, \%hash );
1945             }
1946              
1947 4     4 0 330 sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }
1948              
1949 4     4 0 229 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