File Coverage

lib/HTTP/Promise/Body/Form/Data.pm
Criterion Covered Total %
statement 75 128 58.5
branch 12 54 22.2
condition 7 29 24.1
subroutine 15 21 71.4
pod 9 9 100.0
total 118 241 48.9


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Asynchronous HTTP Request and Promise - ~/lib/HTTP/Promise/Body/Form/Data.pm
3             ## Version v0.1.0
4             ## Copyright(c) 2022 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2022/06/13
7             ## Modified 2022/06/13
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::Body::Form::Data;
15             BEGIN
16             {
17 3     3   3584 use strict;
  3         11  
  3         126  
18 3     3   19 use warnings;
  3         16  
  3         142  
19 3     3   22 use warnings::register;
  3         12  
  3         899  
20 3     3   29 use parent qw( HTTP::Promise::Body::Form );
  3         18  
  3         42  
21 3     3   236 use vars qw( $VERSION $CRLF );
  3         10  
  3         199  
22 3     3   29 use Data::UUID;
  3         7  
  3         359  
23 3     3   19 our $CRLF = "\015\012";
24 3         61 our $VERSION = 'v0.1.0';
25             };
26              
27 3     3   21 use strict;
  3         7  
  3         88  
28 3     3   25 use warnings;
  3         15  
  3         3748  
29              
30             sub init
31             {
32 0     0 1 0 my $self = shift( @_ );
33 0         0 $self->{order} = [];
34 0         0 $self->{_init_strict_use_sub} = 1;
35 0 0       0 $self->SUPER::init( @_ ) || return( $self->pass_error );
36 0         0 return( $self );
37             }
38              
39             sub as_string
40             {
41 1     1 1 30 my $self = shift( @_ );
42 1         15 my $opts = $self->_get_args_as_hash( @_ );
43 1   33     214 my $boundary = $opts->{boundary} ||= Data::UUID->new->create_str;
44 1   33     9 my $eol = $opts->{eol} || $CRLF;
45 1         7 my $parts = $self->make_parts( $opts );
46 1 50       15 return( $self->pass_error ) if( !defined( $parts ) );
47 1         38 my $res = $self->new_scalar;
48 1         41 for( @$parts )
49             {
50 4         17 my $part = $_->as_string( $eol ) . $eol;
51 4 50       471 return( $self->pass_error( $_->error ) ) if( !defined( $part ) );
52 4         122 $$res .= "--${boundary}" . $eol . $part;
53             }
54 1 50       31 $res .= "--${boundary}--${eol}" if( $res->length );
55 1         35659 return( $res );
56             }
57              
58             sub as_urlencoded
59             {
60 0     0 1 0 my $self = shift( @_ );
61 0         0 my $hash = {};
62 0         0 my $keys = $self->keys->sort;
63             my $process = sub
64             {
65 0     0   0 my( $n, $v ) = @_;
66 0 0       0 if( $self->_is_a( $v => 'HTTP::Promise::Body::Form::Field' ) )
67             {
68 0         0 my $this = $v;
69 0         0 $v = $this->as_string( binmode => 'utf-8' );
70 0 0       0 return( $self->pass_error( $this->error ) ) if( !defined( $v ) );
71             }
72 0 0       0 if( exists( $hash->{ $n } ) )
73             {
74 0 0       0 $hash->{ $n } = [$hash->{ $n }] if( ref( $hash->{ $n } ) ne 'ARRAY' );
75 0         0 push( @{$hash->{ $n }}, $v );
  0         0  
76             }
77             else
78             {
79 0         0 $hash->{ $n } = $v;
80             }
81 0         0 return(1);
82 0         0 };
83            
84 0         0 foreach my $n ( @$keys )
85             {
86 0         0 my $v = $self->{ $n };
87 0 0       0 if( $self->_is_array( $v ) )
88             {
89 0         0 foreach my $v2 ( @$v )
90             {
91 0 0       0 $process->( $n, $v2 ) || return( $self->pass_error );
92             }
93             }
94             else
95             {
96 0 0       0 $process->( $n, $v ) || return( $self->pass_error );
97             }
98             }
99 0 0       0 $self->_load_class( 'HTTP::Promise::Body::Form' ) || return( $self->pass_error );
100 0   0     0 my $form = HTTP::Promise::Body::Form->new( $hash ) ||
101             return( $self->pass_error( HTTP::Promise::Body::Form->error ) );
102 0         0 return( $form );
103             }
104              
105 1     1 1 673 sub length { return( shift->Module::Generic::Hash::length ); }
106              
107             sub make_parts
108             {
109 1     1 1 2 my $self = shift( @_ );
110 1         4 my $opts = $self->_get_args_as_hash( @_ );
111 1         158 my $order = $self->order;
112             my $keys = $self->_is_array( $opts->{fields} )
113             ? $self->new_array( $opts->{fields} )
114 1 0 0     970 : ( defined( $order ) && scalar( @$order ) )
    50          
115             ? $order
116             : $self->keys->sort;
117 1 50       67 $self->_load_class( 'HTTP::Promise::Entity' ) || return( $self->pass_error );
118 1 50       53 $self->_load_class( 'HTTP::Promise::Headers' ) || return( $self->pass_error );
119 1         32 my $parts = $self->new_array;
120            
121             my $process = sub
122             {
123 4     4   12 my( $n, $v ) = @_;
124 4         7 my( $headers, $body );
125 4 50       27 if( $self->_is_a( $v => 'HTTP::Promise::Body::Form::Field' ) )
126             {
127 4   33     184 $headers = $v->headers || HTTP::Promise::Headers->new;
128 4         119 $body = $v->body;
129             }
130             else
131             {
132 0         0 $headers = HTTP::Promise::Headers->new;
133             # $body = HTTP::Promise::Entity->new_body( string => $v ) ||
134             # return( $self->pass_error( HTTP::Promise::Entity->error ) );
135 0         0 $body = HTTP::Promise::Entity->new_body( string => $v );
136 0 0       0 if( !defined( $body ) )
137             {
138 0         0 return( $self->pass_error( HTTP::Promise::Entity->error ) );
139             }
140             }
141 4         103 my $dispo = $headers->content_disposition;
142 4 50       92 my $cd = $dispo
143             ? $headers->new_field( 'Content-Disposition' => $dispo )
144             : $headers->new_field( 'Content-Disposition' );
145 4 50       19 return( $self->pass_error( $headers->error ) ) if( !defined( $cd ) );
146 4         17 $cd->disposition( 'form-data' );
147 4         28 $cd->name( $n );
148 4 50 33     2111 if( $self->_is_a( $body => 'HTTP::Promise::Body::File' ) &&
149             !$cd->filename )
150             {
151 0         0 my $basename = $body->basename;
152 0         0 $cd->filename( $basename );
153             }
154 4         176 $headers->content_disposition( "$cd" );
155            
156 4   50     24 my $ent = HTTP::Promise::Entity->new( headers => $headers, body => $body ) ||
157             return( $self->pass_error( HTTP::Promise::Entity->error ) );
158 4         44 $ent->name( $n );
159 4         3615 return( $ent );
160 1         22 };
161            
162 1         5 foreach my $n ( @$keys )
163             {
164 4         50 my $v = $self->{ $n };
165 4 50       112 if( ref( $v ) eq 'ARRAY' )
166             {
167 0         0 foreach my $v2 ( @$v )
168             {
169 0   0     0 my $ent = $process->( $n, $v2 ) ||
170             return( $self->pass_error );
171 0         0 $ent->name( $n );
172 0         0 $parts->push( $ent );
173             }
174             }
175             else
176             {
177 4   50     13 my $ent = $process->( $n, $v ) ||
178             return( $self->pass_error );
179 4         1306 $ent->name( $n );
180 4         3624 $parts->push( $ent );
181             }
182             }
183 1         23 return( $parts );
184             }
185              
186             sub new_field
187             {
188 4     4 1 13 my $self = shift( @_ );
189 4 50       22 $self->_load_class( 'HTTP::Promise::Body::Form::Field' ) || return( $self->pass_error );
190 4   50     430 my $f = HTTP::Promise::Body::Form::Field->new( @_ ) ||
191             return( $self->pass_error( HTTP::Promise::Body::Form::Field->error ) );
192 4         26 return( $f );
193             }
194              
195             sub open
196             {
197 0     0 1 0 my $self = shift( @_ );
198 0         0 my $s = $self->as_string;
199 0 0       0 return( $self->pass_error ) if( !defined( $s ) );
200 0   0     0 my $io = $s->open( @_ ) ||
201             return( $self->pass_error( $s->error ) );
202 0         0 return( $io );
203             }
204              
205 1     1 1 14 sub order { return( shift->_set_get_array_as_object( 'order', @_ ) ); }
206              
207             sub print
208             {
209 0     0 1   my( $self, $fh ) = @_;
210 0           my $nread;
211             # Get output filehandle, and ensure that it's a printable object:
212 0   0       $fh ||= select;
213 0 0         return( $self->error( "Filehandle provided ($fh) is not a valid filehandle." ) ) if( !$self->_is_glob( $fh ) );
214 0           my $encoded = $self->as_string;
215 0 0         return( $self->pass_error ) if( !defined( $encoded ) );
216 0 0         print( $fh $$encoded ) || return( $self->error( "Unable to print on given filehandle '$fh': $!" ) );
217 0           return(1);
218             }
219              
220 0     0     sub _is_warnings_enabled { return( warnings::enabled( $_[0] ) ); }
221              
222             # NOTE: FREEZE is inherited
223              
224             # NOTE: STORABLE_freeze is inherited
225              
226             # NOTE: STORABLE_thaw is inherited
227              
228             # NOTE: THAW is inherited
229              
230             1;
231             # NOTE: POD
232             __END__
233              
234             =encoding utf-8
235              
236             =head1 NAME
237              
238             HTTP::Promise::Body::Form::Data - A multipart/form-data Representation Class
239              
240             =head1 SYNOPSIS
241              
242             use HTTP::Promise::Body::Form;
243             my $form = HTTP::Promise::Body::Form::Data->new;
244             my $form = HTTP::Promise::Body::Form::Data->new({
245             fullname => 'Jigoro Kano',
246             location => HTTP::Promise::Body::Form::Data->new_field(
247             name => 'location',
248             value => 'Tokyo',
249             ),
250             picture => HTTP::Promise::Body::Form::Data->new_field(
251             name => 'picture',
252             file => '/some/where/file.txt',
253             ),
254             });
255             my $form = HTTP::Promise::Body::Form::Data->new( $hash_ref );
256             my $form = HTTP::Promise::Body::Form::Data->new( q{e%3Dmc2} );
257             die( HTTP::Promise::Body::Form->error, "\n" ) if( !defined( $form ) );
258              
259             =head1 VERSION
260              
261             v0.1.0
262              
263             =head1 DESCRIPTION
264              
265             This class represents a C<form-data> content as key-value pairs and is designed to make construction and manipulation of C<multipart/form-data> easier. It inherits from L<HTTP::Promise::Body::Form>
266              
267             For C<x-www-form-urlencoded>, use L<HTTP::Promise::Body::Form> instead.
268              
269             Each key represents a C<form-data> field and its value can either be a simple string or a C<HTTP::Promise::Body::Form::Field> object.
270              
271             C<multipart/form-data> is the only valid Content-Type for sending multiple data. L<rfc7578 in section 4.3|https://tools.ietf.org/html/rfc7578#section-4.3> states: "[RFC2388] suggested that multiple files for a single form field be transmitted using a nested "multipart/mixed" part. This usage is deprecated."
272              
273             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>
274              
275             =head1 CONSTRUCTOR
276              
277             =head2 new
278              
279             This takes an optional data, and some options and returns a new L<HTTP::Promise::Body::Form> object.
280              
281             Acceptable data are:
282              
283             =over 4
284              
285             =item An hash reference
286              
287             =item An url encoded string
288              
289             =back
290              
291             If a string is provided, it will be automatically decoded into an hash of name-value pairs. When a name is found more than once, its values are added as an array reference.
292              
293             my $form = HTTP::Promise::Body->new( 'name=John+Doe&foo=bar&foo=baz&foo=' );
294              
295             Would result in a C<HTTP::Promise::Body::Form> object containing:
296              
297             name => 'John Doe', foo => ['bar', 'baz', '']
298              
299             =head1 METHODS
300              
301             L<HTTP::Promise::Body::Form> inherits all the methods from L<Module::Generic::Hash>, and adds or override the following ones.
302              
303             =head2 as_string
304              
305             Provided with an hash or hash reference of options and this returns a L<scalar object|Module::Generic::Scalar> of the C<form-data> properly formatted as multipart elements.
306              
307             Be mindful of the size of the parts and that this is not cached, so each time this is called, it creates the parts.
308              
309             Supported options are:
310              
311             =over 4
312              
313             =item * C<boundary>
314              
315             A string used as a part delimiter. Note, however, that even if you provide this value, it will not replace the C<boundary> value of a C<HTTP::Promise::Body::Form::Field> C<Content-Disposition> field if it is set.
316              
317             If this is not provided, a new one will be automatically generated using L<Data::UUID/create_str>
318              
319             =item * C<eol>
320              
321             The end-of-line terminator. This defaults to C<\015\012>
322              
323             =item * C<fields>
324              
325             An array reference of form field names. This is used to set the order of appearance.
326              
327             If not provided, it will default to alphabetic order.
328              
329             =back
330              
331             =head2 as_urlencoded
332              
333             This returns a new L<HTTP::Promise::Body::Form> object based on the current data, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
334              
335             =head2 make_parts
336              
337             This takes an hash or hash reference of options and creates L<entity part objects|HTTP::Promise::Entity> and returns them as an L<array object|Module::Generic::Array>
338              
339             Supported options are:
340              
341             =over 4
342              
343             =item * C<boundary>
344              
345             A string used as a part delimiter. Note, however, that even if you provide this value, it will not replace the C<boundary> value of a C<HTTP::Promise::Body::Form::Field> C<Content-Disposition> field if it is set.
346              
347             If this is not provided, a new one will be automatically generated using L<Data::UUID/create_str>
348              
349             =back
350              
351             =head2 make_parts
352              
353             Provided with an hash or hash reference of options and this returns an L<array object|Module::Generic::Array> of L<parts|HTTP::Promise::Entity>
354              
355             Note that at this point, the body is not encoded and the C<Content-Length> is not added. You can use L<HTTP::Promise::Entity/encode_body> on each part to encode a form part value.
356              
357             Supported options are:
358              
359             =over 4
360              
361             =item * C<fields>
362              
363             An array reference of form field names. This is used to set the order of appearance.
364              
365             If not provided, it will default to alphabetic order.
366              
367             =back
368              
369             =head2 new_field
370              
371             This takes an hash or hash reference of options and returns the new C<HTTP::Promise::Body::Form::Data> object, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
372              
373             Supported options are:
374              
375             =over 4
376              
377             =item * C<headers>
378              
379             This is optional. Either as L<HTTP::Promise::Headers> object or as an array reference.
380              
381             =item * C<name>
382              
383             Field name
384              
385             =item * C<value>
386              
387             Field value as a string, scalar reference or a L<file object|Module::Generic::File>
388              
389             =back
390              
391             =head2 open
392              
393             This transform all the C<form-data> elements into a proper C<multipart/form-data> using L</as_string> and returns a new L<Module::Generic::Scalar::IO> object.
394              
395             It then opens the scalar passing L<Module::Generic::Scalar/open> whatever arguments were provided and returns an L<Module::Generic::Scalar::IO> object.
396              
397             =head2 order
398              
399             Sets or gets an L<array object|Module::Generic::Array> of form fields in the desired order of appearance when stringified.
400              
401             =head2 print
402              
403             Provided with a valid filehandle, and this print the C<form-data> representation of the form fields and their values, to the given filehandle, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>
404              
405             =head1 AUTHOR
406              
407             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
408              
409             =head1 SEE ALSO
410              
411             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>
412              
413             L<Module::Generic::Scalar>
414              
415             =head1 COPYRIGHT & LICENSE
416              
417             Copyright(c) 2022 DEGUEST Pte. Ltd.
418              
419             All rights reserved.
420              
421             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
422              
423             =cut