File Coverage

lib/HTTP/Promise/Body/Form.pm
Criterion Covered Total %
statement 108 172 62.7
branch 30 86 34.8
condition 16 66 24.2
subroutine 16 25 64.0
pod 15 15 100.0
total 185 364 50.8


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Asynchronous HTTP Request and Promise - ~/lib/HTTP/Promise/Body/Form.pm
3             ## Version v0.2.0
4             ## Copyright(c) 2022 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2022/05/18
7             ## Modified 2023/09/08
8             ## All rights reserved.
9             ##
10             ##
11             ## This program is free software; you can redistribute it and/or modify it
12             ## under the same terms as Perl itself.
13             ##----------------------------------------------------------------------------
14             package HTTP::Promise::Body::Form;
15             BEGIN
16             {
17 5     5   272213 use strict;
  5         21  
  5         180  
18 5     5   49 use warnings;
  5         21  
  5         154  
19 5     5   38 use warnings::register;
  5         16  
  5         832  
20 5     5   33 use parent qw( Module::Generic::Hash );
  5         15  
  5         65  
21 5     5   320434 use vars qw( $VERSION );
  5         11  
  5         311  
22             # use Nice::Try;
23 5     5   2547 use URL::Encode::XS ();
  5         3121  
  5         166  
24 5     5   96 our $VERSION = 'v0.2.0';
25             };
26              
27 5     5   36 use strict;
  5         17  
  5         115  
28 5     5   31 use warnings;
  5         16  
  5         10542  
29              
30             sub new
31             {
32 13     13 1 13979 my $this = shift( @_ );
33 13 100       58 if( @_ )
34             {
35 11         22 my $data = shift( @_ );
36 11 100 0     55 if( ref( $data ) eq 'HASH' )
    50 33        
37             {
38 5         38 return( $this->SUPER::new( $data, @_ ) );
39             }
40             elsif( !ref( $data ) ||
41             ( ref( $data ) ne 'HASH' && overload::Method( $data => '""' ) ) )
42             {
43 6   50     41 my $ref = $this->decode_to_hash( "${data}" ) ||
44             return( $this->pass_error );
45 6         31 return( $this->SUPER::new( $ref, @_ ) );
46             }
47             else
48             {
49 0         0 return( $this->error( "Unsupported data type '", ref( $data ), "'." ) );
50             }
51             }
52             else
53             {
54 2         18 return( $this->SUPER::new );
55             }
56             }
57              
58             sub init
59             {
60 0     0 1 0 my $self = shift( @_ );
61 0         0 $self->{_init_strict_use_sub} = 1;
62 0 0       0 $self->SUPER::init( @_ ) || return( $self->pass_error );
63 0         0 return( $self );
64             }
65              
66             sub as_form_data
67             {
68 0     0 1 0 my $self = shift( @_ );
69 0         0 my $hash = {};
70 0         0 my $keys = $self->keys->sort;
71 0 0       0 $self->_load_class( 'HHTP::Promise::Body::Form' ) || return( $self->pass_error );
72 0         0 my $form = HHTP::Promise::Body::Form->new;
73 0         0 foreach my $n ( @$keys )
74             {
75 0         0 my $v = $self->{ $n };
76 0 0       0 if( $self->_is_array( $v ) )
77             {
78 0         0 foreach my $v2 ( @$v )
79             {
80 0 0       0 my $e = $self->_is_a( $v2 => 'HTTP::Promise::Body::Form::Field' )
81             ? $v2
82             : $form->new_field(
83             name => $n,
84             body => $v2,
85             );
86 0 0       0 if( exists( $form->{ $n } ) )
87             {
88 0 0       0 $form->{ $n } = [$form->{ $n }] unless( $self->_is_array( $form->{ $n } ) );
89 0         0 push( @{$form->{ $n }}, $e );
  0         0  
90             }
91             else
92             {
93 0         0 $form->{ $n } = $e;
94             }
95             }
96             }
97             else
98             {
99 0 0       0 my $e = $self->_is_a( $v => 'HTTP::Promise::Body::Form::Field' )
100             ? $v
101             : $form->new_field(
102             name => $n,
103             body => $v,
104             );
105 0 0       0 if( exists( $form->{ $n } ) )
106             {
107 0 0       0 $form->{ $n } = [$form->{ $n }] unless( $self->_is_array( $form->{ $n } ) );
108 0         0 push( @{$form->{ $n }}, $e );
  0         0  
109             }
110             else
111             {
112 0         0 $form->{ $n } = $e;
113             }
114             }
115             }
116 0         0 return( $form );
117             }
118              
119             sub as_string
120             {
121 1     1 1 556 my $self = shift( @_ );
122 1         3 my $keys = [];
123 1 50 33     6 if( @_ && $self->_tie_object->_is_array( $_[0] ) )
124             {
125 0         0 $keys = shift( @_ );
126             }
127             else
128             {
129 1         7 $keys = $self->keys->sort;
130             }
131 1         296 my @pairs = ();
132             # try-catch
133 1         28 local $@;
134             eval
135 1         2 {
136 1         4 $self->_tie_object->enable(1);
137 1         12 foreach my $n ( @$keys )
138             {
139 4         15 my $v = $self->{ $n };
140 4 100       78 if( ref( $v ) eq 'ARRAY' )
141             {
142 1         3 foreach my $v2 ( @$v )
143             {
144 2 50       19 if( $self->_is_a( $v2 => 'HTTP::Promise::Body::Form::Field' ) )
145             {
146 0         0 $v2 = $v2->body->as_string( binmode => 'utf-8' );
147             }
148 2 0 33     34 warn( "Found a value, within an array for item '$n', that is a reference, but does not stringifies.\n" ) if( ref( $v2 ) && !overload::Method( $v2 => '""' ) && $self->_is_warnings_enabled );
      33        
149 2         10 push( @pairs, join( '=', $n, URL::Encode::XS::url_encode_utf8( "$v2" ) ) );
150             }
151             }
152             else
153             {
154 3 50       14 if( $self->_is_a( $v => 'HTTP::Promise::Body::Form::Field' ) )
155             {
156 0         0 $v = $v->body->as_string( binmode => 'utf-8' );
157             }
158 3 0 33     55 warn( "Found a value, for item '$n', that is a reference, but does not stringifies.\n" ) if( ref( $v ) && !overload::Method( $v => '""' ) && $self->_is_warnings_enabled );
      33        
159 3         24 push( @pairs, join( '=', $n, URL::Encode::XS::url_encode_utf8( "$v" ) ) );
160             }
161             }
162             };
163 1 50       6 if( $@ )
164             {
165 0         0 return( $self->error( "Error while Trying to url-encode ", scalar( @$keys ), " form elements: $@" ) );
166             }
167 1         7 return( join( '&', @pairs ) );
168             }
169              
170 0     0 1 0 sub decode { return( shift->decode_to_array( @_ ) ); }
171              
172             sub decode_string
173             {
174 1     1 1 3 my $self = shift( @_ );
175 1         2 my $data = shift( @_ );
176 1 50 33     10 warn( "No data to url-decode was provided.\n" ) if( ( !defined( $data ) || !length( "$data" ) ) && $self->_is_warnings_enabled );
      33        
177 1 50 33     4 return( $self->error( "Invalid parameter provided. You can only pass a string or an object that stringifies." ) ) if( ref( $data ) && !overload::Method( $data => '""' ) );
178 1         1 my $decoded;
179             # try-catch
180 1         2 local $@;
181             eval
182 1         2 {
183 1         7 $decoded = URL::Encode::XS::url_decode_utf8( "${data}" );
184             };
185 1 50       4 if( $@ )
186             {
187 0         0 return( $self->error( "Error while Trying to url-decode ", length( $data ), " bytes of data: $@" ) );
188             }
189 1         15 return( $decoded );
190             }
191              
192             sub decode_to_array
193             {
194 6     6 1 69 my $self = shift( @_ );
195 6         9 my $data = shift( @_ );
196             # warn( "No data to url-decode was provided.\n" ) if( ( !defined( $data ) || !length( "$data" ) ) && $self->_is_warnings_enabled );
197 6 50 33     38 warn( "No data to url-decode was provided.\n" ) if( ( !defined( $data ) || !length( "$data" ) ) && $self->_is_warnings_enabled );
      33        
198 6 50 33     16 return( $self->error( "Invalid parameter provided. You can only pass a string or an object that stringifies." ) ) if( ref( $data ) && !overload::Method( $data => '""' ) );
199 6         11 my $ref;
200             # try-catch
201 6         9 local $@;
202             eval
203 6         9 {
204 6         37 $ref = URL::Encode::XS::url_params_flat( "${data}" );
205             };
206 6 50       14 if( $@ )
207             {
208 0         0 return( $self->error( "Error while Trying to url-decode ", length( $data ), " bytes of data: $@" ) );
209             }
210 6         14 return( $ref );
211             }
212              
213             sub decode_to_hash
214             {
215 6     6 1 10 my $self = shift( @_ );
216 6 50       34 my $ref = $self->_is_array( $_[0] ) ? shift( @_ ) : $self->decode_to_array( @_ );
217 6 50       14 return( $self->pass_error ) if( !defined( $ref ) );
218 6         9 my $hash = {};
219 6         24 while( my( $n, $v ) = splice( @$ref, 0, 2 ) )
220             {
221 14 100       28 if( exists( $hash->{ $n } ) )
222             {
223 3 100       11 $hash->{ $n } = [ $hash->{ $n } ] unless( ref( $hash->{ $n } ) eq 'ARRAY' );
224 3         3 push( @{$hash->{ $n }}, $v );
  3         10  
225             }
226             else
227             {
228 11         41 $hash->{ $n } = $v;
229             }
230             }
231 6         18 return( $hash );
232             }
233              
234             # TODO: This is redundant with code in as_string. as_string should be revamped to call encode()
235             sub encode
236             {
237 1     1 1 499 my $self = shift( @_ );
238 1         3 my $ref = shift( @_ );
239 1 50 33     8 return( $self->error( "Invalid argument provided. I was expecting an array or an hash reference." ) ) if( ref( $ref ) ne 'ARRAY' && ref( $ref ) ne 'HASH' );
240             # Work on a copy
241 1 50       9 my $this = ref( $ref ) eq 'ARRAY' ? [@$ref] : [%$ref];
242 1 50       4 return( '' ) if( !scalar( @$this ) );
243 1         2 my $rv;
244 1         2 my @pairs = ();
245             # try-catch
246 1         2 local $@;
247             eval
248 1         2 {
249 1         9 while( my( $n, $v ) = splice( @$this, 0, 2 ) )
250             {
251 1 50       4 if( ref( $v ) eq 'ARRAY' )
252             {
253 0         0 foreach my $v2 ( @$v )
254             {
255 0 0       0 if( $self->_is_a( $v2 => 'HTTP::Promise::Body::Form::Field' ) )
256             {
257 0         0 $v2 = $v2->body->as_string( binmode => 'utf-8' );
258             }
259 0 0 0     0 warn( "Found a value, within an array for item '$n', that is a reference, but does not stringifies.\n" ) if( ref( $v2 ) && !overload::Method( $v2 => '""' ) && $self->_is_warnings_enabled );
      0        
260 0         0 push( @pairs, join( '=', $n, URL::Encode::XS::url_encode_utf8( "$v2" ) ) );
261             }
262             }
263             else
264             {
265 1 50       4 if( $self->_is_a( $v => 'HTTP::Promise::Body::Form::Field' ) )
266             {
267 0         0 $v = $v->body->as_string( binmode => 'utf-8' );
268             }
269 1 0 33     32 warn( "Found a value, for item '$n', that is a reference, but does not stringifies.\n" ) if( ref( $v ) && !overload::Method( $v => '""' ) && $self->_is_warnings_enabled );
      33        
270 1         13 push( @pairs, join( '=', $n, URL::Encode::XS::url_encode_utf8( "$v" ) ) );
271             }
272             }
273 1         4 $rv = join( '&', @pairs );
274             };
275 1 50       4 if( $@ )
276             {
277 0         0 return( $self->error( "Error while Trying to url-encode ", scalar( @$this ), " elements provided: $@" ) );
278             }
279 1         4 return( $rv );
280             }
281              
282             sub encode_string
283             {
284 1     1 1 535 my $self = shift( @_ );
285 1         2 my $encoded;
286             # try-catch
287 1         3 local $@;
288             eval
289 1         2 {
290 1         5 $encoded = URL::Encode::XS::url_encode_utf8( shift( @_ ) );
291             };
292 1 50       3 if( $@ )
293             {
294 0         0 return( $self->error( "Error while trying to url-encode: $@" ) );
295             }
296 1         5 return( $encoded );
297             }
298              
299             sub error
300             {
301 0     0 1   my $self = shift( @_ );
302 0           $self->_tie_object->enable(0);
303 0           return( $self->SUPER::error( @_ ) );
304             }
305              
306 0     0 1   sub length { return( CORE::length( shift->as_string ) ); }
307              
308             sub open
309             {
310 0     0 1   my $self = shift( @_ );
311 0           my $encoded = $self->as_string;
312 0 0         return( $self->pass_error ) if( !defined( $encoded ) );
313 0   0       my $s = $self->_tie_object->new_scalar( \$encoded ) ||
314             return( $self->pass_error );
315 0   0       my $io = $s->open( @_ ) ||
316             return( $self->pass_error( $s->error ) );
317 0           return( $io );
318             }
319              
320             sub pass_error
321             {
322 0     0 1   my $self = shift( @_ );
323 0           $self->_tie_object->enable(0);
324 0           return( $self->SUPER::pass_error( @_ ) );
325             }
326              
327             sub print
328             {
329 0     0 1   my( $self, $fh ) = @_;
330 0           my $nread;
331             # Get output filehandle, and ensure that it's a printable object:
332 0   0       $fh ||= select;
333 0 0 0       return( $self->error( "Filehandle provided ($fh) is not a proper filehandle and its not a HTTP::Promise::IO object." ) ) if( !$self->_tie_object->_is_glob( $fh ) && !$self->_tie_object->_is_a( $fh => 'HTTP::Promise::IO' ) );
334 0           my $encoded = $self->as_string;
335 0 0         return( $self->pass_error ) if( !defined( $encoded ) );
336 0 0         $fh->print( $encoded ) || return( $self->error( "Unable to print on given filehandle '$fh': $!" ) );
337 0           return(1);
338             }
339              
340 0     0     sub _is_warnings_enabled { return( warnings::enabled( $_[0] ) ); }
341              
342             # NOTE: FREEZE is inherited
343              
344             # NOTE: STORABLE_freeze is inherited
345              
346             # NOTE: STORABLE_thaw is inherited
347              
348             # NOTE: THAW is inherited
349              
350             1;
351             # NOTE: POD
352             __END__
353              
354             =encoding utf-8
355              
356             =head1 NAME
357              
358             HTTP::Promise::Body::Form - x-www-form-urlencoded Data Class
359              
360             =head1 SYNOPSIS
361              
362             use HTTP::Promise::Body::Form;
363             my $form = HTTP::Promise::Body::Form->new;
364             my $form = HTTP::Promise::Body::Form->new( $hash_ref );
365             my $form = HTTP::Promise::Body::Form->new( q{e%3Dmc2} );
366             die( HTTP::Promise::Body::Form->error, "\n" ) if( !defined( $form ) );
367              
368             =head1 VERSION
369              
370             v0.2.0
371              
372             =head1 DESCRIPTION
373              
374             This class represents C<x-www-form-urlencoded> HTTP body. It inherits from L<Module::Generic::Hash>
375              
376             This is different from a C<multipart/form-data>. For this, please check the module L<HTTP::Promise::Body::Form::Data>
377              
378             =head1 CONSTRUCTOR
379              
380             =head2 new
381              
382             This takes an optional data, and some options and returns a new L<HTTP::Promise::Body::Form> object.
383              
384             Acceptable data are:
385              
386             =over 4
387              
388             =item An hash reference
389              
390             =item An url encoded string
391              
392             =back
393              
394             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.
395              
396             my $form = HTTP::Promise::Body->new( 'name=John+Doe&foo=bar&foo=baz&foo=' );
397              
398             Would result in a C<HTTP::Promise::Body::Form> object containing:
399              
400             name => 'John Doe', foo => ['bar', 'baz', '']
401              
402             As an historical note, C<x-www-form-urlencoded> is not an rfc-defined standard, and differs from URI encoding defined by L<rfc3986|https://tools.ietf.org/html/rfc3986> in that it uses C<+> to represent whitespace. It was L<defined back then by Mosaic|https://web.archive.org/web/19961220100435/http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/Docs/fill-out-forms/overview.html> as a non-standard way of encoding form data. This also L<this historical note|http://1997.webhistory.org/www.lists/www-talk.1993q3/0812.html> and this L<Stackoverflow discussion|https://stackoverflow.com/questions/42276418/why-does-x-www-form-urlencoded-begin-with-x-www-when-other-standard-content>.
403              
404             =head1 METHODS
405              
406             L<HTTP::Promise::Body::Form> inherits all the methods from L<Module::Generic::Hash>, and adds or override the following ones.
407              
408             =head2 as_form_data
409              
410             This returns a new L<HTTP::Promise::Body::Form::Data> object based on the current data, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>.
411              
412             =head2 as_string
413              
414             This returns a properly urlencoded representation of the name-value pairs stored in this hash object.
415              
416             Each value will be encoded into utf8 before being urlencoded. This is all done fast with L<URL::Encode::XS>
417              
418             =head2 decode
419              
420             Provided with an C<x-www-form-urlencoded> string and this will return a decoded string taking under account utf8 characters.
421              
422             my $params = $form->decode( 'tengu=%E5%A4%A9%E7%8B%97' );
423             # [ 'tengu', '天狗' ]
424              
425             If an error occurs, this will set an L<error object|Module::Generic/error> and return C<undef>
426              
427             =head2 decode_string
428              
429             Provided with an url-encoded string, included utf-8 string, and this returns its corresponding decoded version.
430              
431             my $deity = $form->decode( '%E5%A4%A9%E7%8B%97' );
432              
433             results in: C<天狗>
434              
435             =head2 decode_to_array
436              
437             Takes an C<x-www-form-urlencoded> string and returns an array reference of name-value pairs. If a name is seen more than once, its value will be an array reference.
438              
439             If an error occurs, this will set an L<error object|Module::Generic/error> and return C<undef>
440              
441             =head2 decode_to_hash
442              
443             Takes an C<x-www-form-urlencoded> string or an array reference of name-value pairs and returns an hash reference of name-value pairs.
444              
445             If a name is seen more than once, its value will be an array reference.
446              
447             If an error occurs, this will set an L<error object|Module::Generic/error> and return C<undef>
448              
449             =head2 encode
450              
451             Takes an array reference or an hash reference and this returns a properly url-encoded string representation.
452              
453             If an error occurs, this will set an L<error object|Module::Generic/error> and return C<undef>
454              
455             =head2 encode_string
456              
457             Takes a string and returns an encoded string. UTF-8 strings are ok too as long as they are in L<perl's internal representation|perlunicode>.
458              
459             If an error occurs, this will set an L<error object|Module::Generic/error> and return C<undef>
460              
461             =head2 length
462              
463             Returns the number of keys currently set in this key-value pairs held in the object.
464              
465             =head2 open
466              
467             This encodes the key-pairs as C<x-www-form-urlencoded> by calling L</as_string>, which returns a new L<scalar object|Module::Generic::Scalar>, opens it, passing whatever arguments it received to L<Module::Generic::Scalar/open> and return the resulting object upon success, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>
468              
469             =for Pod::Coverage pass_error
470              
471             =head2 print
472              
473             Provided with a valid filehandle, and this print the C<x-www-form-urlencoded> representation of the key-value pairs contained in this object, to the given filehandle, or upon error, sets an L<error|Module::Generic/error> and returns C<undef>
474              
475             =head1 AUTHOR
476              
477             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
478              
479             =head1 SEE ALSO
480              
481             L<Specifications|https://html.spec.whatwg.org/multipage/form-control-infrastructure.html#url-encoded-form-data>, L<old rfc1867|https://tools.ietf.org/html/rfc1867.html>
482              
483             L<rfc7578 on multipart/form-data|https://tools.ietf.org/html/rfc7578>
484              
485             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>
486              
487             =head1 COPYRIGHT & LICENSE
488              
489             Copyright(c) 2022 DEGUEST Pte. Ltd.
490              
491             All rights reserved.
492              
493             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
494              
495             =cut