File Coverage

lib/HTTP/Promise/Headers/Generic.pm
Criterion Covered Total %
statement 240 339 70.8
branch 72 164 43.9
condition 40 94 42.5
subroutine 51 64 79.6
pod 4 6 66.6
total 407 667 61.0


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Asynchronous HTTP Request and Promise - ~/lib/HTTP/Promise/Headers/Generic.pm
3             ## Version v0.1.1
4             ## Copyright(c) 2022 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2022/05/06
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::Headers::Generic;
15             BEGIN
16             {
17 11     11   6906 use strict;
  11         49  
  11         340  
18 11     11   74 use warnings;
  11         32  
  11         309  
19 11     11   74 use parent qw( Module::Generic );
  11         39  
  11         147  
20 11     11   100609 use vars qw( $VERSION $QV_ELEMENT $QV_VALUE );
  11         52  
  11         918  
21 11     11   84 use Encode ();
  11         30  
  11         294  
22 11     11   543 use URI::Escape::XS ();
  11         98382  
  11         301  
23 11     11   83 use Want;
  11         37  
  11         1538  
24             use overload (
25             '""' => 'as_string',
26 558     558   12536 'bool' => sub{1},
27             # No fallback on purpose
28 11     11   79 );
  11         34  
  11         221  
29             # Accept: audio/*; q=0.2, audio/basic
30 11     11   2631 our $QV_ELEMENT = qr/(?:[^\;\,]+)/;
31 11         61 our $QV_VALUE = qr/(?:0(?:\.[0-9]{0,3})?|1(?:\.0{0,3})?)/;
32 11         352 our $VERSION = 'v0.1.1';
33             };
34              
35 11     11   76 use strict;
  11         25  
  11         266  
36 11     11   62 use warnings;
  11         56  
  11         33648  
37              
38 0     0 1 0 sub as_string { return( shift->value ); }
39              
40 0     0 1 0 sub field_name { return( shift->_set_get_scalar( '_name', @_ ) ); }
41              
42 2     2 1 38 sub uri_escape_utf8 { return( URI::Escape::XS::uri_escape( Encode::encode( 'UTF-8', $_[1] ) ) ); }
43              
44             # By default and superseded by inheriting classes such as Content-Type that has more
45             # elaborate value with parameters
46 0     0 1 0 sub value { return( shift->_set_get_scalar( '_value', @_ ) ); }
47              
48 168     168   908 sub _field_name { return( shift->_set_get_scalar( '_name', @_ ) ); }
49              
50             # rfc2231 <https://tools.ietf.org/html/rfc2231>
51             sub _filename_decode
52             {
53 10     10   30 my $self = shift( @_ );
54 10         21 my $fname = shift( @_ );
55 10 50       35 $self->_load_class( 'HTTP::Promise::Headers' ) || return( $self->pass_error );
56 10         422 my( $new_fname, $charset, $lang ) = HTTP::Promise::Headers->decode_filename( $fname );
57 10 50       39 if( defined( $new_fname ) )
58             {
59 10         18 $fname = $new_fname;
60             }
61 10 50       48 return( wantarray() ? ( $fname, $charset, $lang ) : $fname );
62             }
63              
64             # rfc2231 <https://tools.ietf.org/html/rfc2231>
65             sub _filename_encode
66             {
67 2     2   9 my $self = shift( @_ );
68 2         7 my $fname = shift( @_ );
69 2         4 my $lang = shift( @_ );
70 2 50       18 if( $fname =~ /[^\x00-\x7f]/ )
71             {
72 2 50       9 $lang = '' if( !defined( $lang ) );
73 2         22 return( sprintf( "UTF-8'${lang}'%s", $self->uri_escape_utf8( $fname ) ) );
74             }
75             # Nothing to be done. We return undef on purpose to indicate nothing was done
76 0         0 return;
77             }
78              
79 316     316   1324 sub _hv { return( shift->_set_get_object_without_init( '_hv', 'Module::Generic::HeaderValue', @_ ) ); }
80              
81             sub _hv_as_string
82             {
83 48     48   158 my $self = shift( @_ );
84 48         322 my $hv = $self->_hv;
85 48 50       1411 return( '' ) if( !$hv );
86 48         569 return( $hv->as_string( @_ ) );
87             }
88              
89             sub _get_header_value_object
90             {
91 0     0   0 my $self = shift( @_ );
92 0 0       0 $self->_load_class( 'Module::Generic::HeaderValue' ) ||
93             return( $self->pass_error );
94 0   0     0 my $hv = Module::Generic::HeaderValue->new( shift( @_ ) ) ||
95             return( $self->pass_error( Module::Generic::HeaderValue->error ) );
96 0         0 return( $hv );
97             }
98              
99 0     0   0 sub _make_boundary { return( Data::UUID->new->create_str ); }
100              
101             sub _new_hv
102             {
103 5     5   32 my $self = shift( @_ );
104 5 50       30 $self->_load_class( 'Module::Generic::HeaderValue' ) || return( $self->pass_error );
105 5         242 return( Module::Generic::HeaderValue->new( @_ ) );
106             }
107              
108             sub _new_qv_object
109             {
110 35     35   73 my $self = shift( @_ );
111 35         184 my $o = HTTP::Promise::Field::QualityValue->new( @_ );
112 35 50       285 return( $self->pass_error( HTTP::Promise::Field::QualityValue->error ) ) if( !defined( $o ) );
113 35         111 return( $o );
114             }
115              
116             sub _parse_header_value
117             {
118 87     87   277 my $self = shift( @_ );
119 87         199 my $this = shift( @_ );
120 87 50 33     581 return( $self->error( "No header value was provided to parse." ) ) if( !defined( $this ) || !length( "$this" ) );
121 87 50       751 $self->_load_class( 'Module::Generic::HeaderValue' ) ||
122             return( $self->pass_error );
123 87   50     19769 my $hv = Module::Generic::HeaderValue->new_from_header( $this, @_ ) ||
124             return( $self->pass_error( Module::Generic::HeaderValue->error ) );
125 87         580198 return( $hv );
126             }
127              
128             # rfc7231, section 5.3.1
129             # <https://tools.ietf.org/html/rfc7231#section-5.3.1>
130             sub _parse_quality_value
131             {
132 10     10   28 my $self = shift( @_ );
133 10         27 my $str = shift( @_ );
134 10 50 33     79 return( $self->error( "No header value was provided to parse." ) ) if( !defined( $str ) || !length( "$str" ) );
135             # No blank
136 10         41 $str =~ s/[[:blank:]\h]]+//g;
137 10         74 my $choices = $self->new_array;
138             # Credits: HTTP::AcceptLanguage from Kazuhiro Osawa
139 10         12539 for my $def ( split( /,[[:blank:]\h]*/, $str ) )
140             {
141 35         868 my( $element, $quality ) = $def =~ /\A($QV_ELEMENT)(?:;[[:blank:]\h]*[qQ]=($QV_VALUE))?\z/;
142             # rfc7231, section 5.3.1:
143             # "If no "q" parameter is present, the default weight is 1."
144             # rfc7231, section 5.3.5
145             # "no value is the same as q=1"
146             # $quality = 1 unless( defined( $quality ) );
147             # next unless( $element && $quality > 0 );
148 35 50       139 next unless( $element );
149 35         193 my $qv = $self->_new_qv_object( $element => $quality );
150 35         198 $choices->push( $qv );
151             }
152 10         199 return( $choices );
153             }
154              
155             sub _qstring_join
156             {
157 6     6   152 my $self = shift( @_ );
158 6         18 my @parts = ();
159 6         19 foreach my $s ( @_ )
160             {
161 26         40 $s =~ s/^"//;
162 26         35 $s =~ s/(?!\\)"$//;
163 26         33 $s =~ s/(?!\\)\"/\\"/g;
164 26         62 push( @parts, qq{"${s}"} );
165             }
166 6         86 return( join( ', ', @parts ) );
167             }
168              
169             # Returns an array of tokens that were initially surrounded by double quotes, and
170             # separated by comma even if they contained double quotes inside.
171             # Example for Clear-Site-Data header field:
172             # "cache", "cookies", "storage", "executionContexts"
173             # "cache\"", "oh "la" la", "storage\", \"", "executionContexts"
174             sub _qstring_split
175             {
176 2     2   66 my $self = shift( @_ );
177 2         12 my $str = shift( @_ );
178 2         26 my @parts = split( /(?<=(?<!\\)\")[[:blank:]\h]*,[[:blank:]\h]*(?=\")/, $str );
179 2         12 for( @parts )
180             {
181             #substr( $_, 0, 1, '' );
182             #substr( $_, -1, 1, '' );
183             # s/^"|"$//g;
184 8         24 s/^"//;
185 8         28 s/"$//;
186             }
187 2         20 return( @parts );
188             }
189              
190             sub _qv_add
191             {
192 0     0   0 my $self = shift( @_ );
193 0         0 my( $elem, $val ) = @_;
194 0   0     0 my $qv = HTTP::Promise::Field::QualityValue->new( $elem => $val ) ||
195             return( $self->pass_error( HTTP::Promise::Field::QualityValue->error ) );
196 0         0 $self->elements->push( $qv );
197 0         0 return( $qv );
198             }
199              
200             sub _qv_as_string
201             {
202 15     15   53 my $self = shift( @_ );
203 15         59 my $all = $self->elements;
204 15 50       1125 return( '' ) if( $all->is_empty );
205 15     52   427 my $res = $all->map(sub{ $_->as_string });
  52         465  
206 15         1885 return( $res->join( ', ' )->scalar );
207             }
208              
209 49     49   253 sub _qv_elements { return( shift->_set_get_object_array_object( '_qv_elements', 'HTTP::Promise::Field::QualityValue', @_ ) ); }
210              
211             sub _qv_get
212             {
213 5     5   14 my $self = shift( @_ );
214 5         19 my $this = shift( @_ );
215 5 50 33     35 return( $self->error( "No a property name to get was provided." ) ) if( !defined( $this ) || !length( "$this" ) );
216 5         26 my $all = $self->elements;
217 5 100       359 if( $self->_is_a( $this => 'HTTP::Promise::Field::QualityValue' ) )
218             {
219 1         31 my $pos = $all->pos( $this );
220 1 50       35 return( $all->[$pos] ) if( defined( $pos ) );
221             }
222             else
223             {
224 4         62 foreach( @$all )
225             {
226 7 100       2456 return( $_ ) if( $_->element eq $this );
227             }
228             }
229 0         0 return( '' );
230             }
231              
232             sub _qv_match
233             {
234 0     0   0 my $self = shift( @_ );
235 0         0 my $this = shift( @_ );
236 0 0 0     0 return( '' ) if( !defined( $this ) || !length( "$this" ) );
237 0 0 0     0 $this = [split( /(?:[[:blank:]]+|[[:blank:]]*\,[[:blank:]]*)/, "$this" )] if( !$self->_is_array( $this ) && ( !ref( $this ) || overload::Method( $this => '""' ) ) );
      0        
238 0 0       0 return( $self->error( "Invalid argument provided. Provide either an array reference or a string or something that stringifies." ) ) if( !$self->_is_array( $this ) );
239 0         0 my $ordered = [map( lc( $_ ), @$this )];
240 0 0       0 return( '' ) if( !scalar( @$ordered ) );
241 0 0       0 my $acceptables = $self->can( 'sort' ) ? $self->sort : $self->_qv_sort;
242 0         0 my $ok = $self->new_array;
243 0         0 my $seen = {};
244 0         0 foreach my $e ( @$acceptables )
245             {
246 0         0 my $e_lc = $e->element->lc;
247 0 0       0 if( $e->element->index( '*' ) != -1 )
248             {
249 0         0 my $wildcard_ok = $self->_qv_match_wildcard( $e_lc => $ordered, $this );
250 0 0       0 return( $self->pass_error ) if( !defined( $wildcard_ok ) );
251 0 0       0 $ok->push( $wildcard_ok->list ) if( !$wildcard_ok->is_empty );
252             }
253             else
254             {
255 0         0 for( my $i = 0; $i < scalar( @$ordered ); $i++ )
256             {
257 0 0       0 if( $e_lc eq $ordered->[$i] )
258             {
259             # We'll return the caller's original value, not the lowercase one we use for comparison
260 0         0 $ok->push( $this->[$i] );
261             }
262             }
263             }
264             }
265 0         0 return( $ok->unique );
266             }
267              
268             # Works for language and content-type and content-encoding
269             sub _qv_match_wildcard
270             {
271 0     0   0 my $self = shift( @_ );
272             # $proposals contain the value offered in lower case, whereas $original contains
273             # the original value and we return our value from there. Both $proposals and $original
274             # are of the same size.
275 0         0 my( $acceptable, $proposals, $original, $seen ) = @_;
276 0 0       0 return( $self->error( "Bad arguments. Usage: \$h->_qv_match_wildcard( \$acceptable, \$proposals, \$original )" ) ) unless( @_ == 3 );
277 0 0       0 return( $self->error( "This is not a wildcard acceptable value." ) ) if( $acceptable->index( '*' ) == -1 );
278 0 0       0 return( $self->error( "Proposed values must be an array reference." ) ) unless( $self->_is_array( $proposals ) );
279 0 0       0 return( $self->error( "Original array of proposed values must be an array reference." ) ) unless( $self->_is_array( $original ) );
280 0         0 my $ok = $self->new_array;
281 0 0       0 if( $acceptable->index( '/' ) != -1 )
282             {
283 0         0 my( $main, $sub ) = $acceptable->element->split( qr/\// );
284 0         0 for( my $i = 0; $i < scalar( @$proposals ); $i++ )
285             {
286 0         0 my $supported = $proposals->[$i];
287 0         0 my( $this_main, $this_sub ) = split( /\//, "$supported", 2 );
288 0 0       0 if( $main eq '*' )
    0          
289             {
290 0 0       0 if( $sub eq '*' )
291             {
292 0         0 $ok->push( $original->[$i] );
293             }
294             else
295             {
296 0 0       0 $ok->push( $original->[$i] ) if( $this_sub eq $sub );
297             }
298             }
299             elsif( $main eq $this_main )
300             {
301 0 0       0 if( $sub eq '*' )
302             {
303 0         0 $ok->push( $original->[$i] );
304             }
305             else
306             {
307 0 0       0 $ok->push( $original->[$i] ) if( $this_sub eq $sub );
308             }
309             }
310             }
311             }
312             # simply return the proposal value since anything goes
313             else
314             {
315 0         0 $ok->push( $original->[0] );
316             }
317 0         0 return( $ok );
318             }
319              
320             sub _qv_remove
321             {
322 1     1   3 my $self = shift( @_ );
323 1         3 my $this = shift( @_ );
324 1         4 my $all = $self->elements;
325 1 50       74 if( $self->_is_a( $this => 'HTTP::Promise::Field::QualityValue' ) )
326             {
327 0         0 return( $all->delete( $this ) );
328             }
329             else
330             {
331 1         14 my $e;
332 1         6 for( my $i = 0; $i < scalar( @$all ); $i++ )
333             {
334 2 100       810 if( $all->[$i]->element eq "$this" )
335             {
336 1         836 $e = $all->splice( $i, 1 );
337 1         77 last;
338             }
339             }
340 1         11 return( $e );
341             }
342             }
343              
344             sub _qv_sort
345             {
346 1     1   3 my $self = shift( @_ );
347 1         11 my $opts = $self->_get_args_as_hash( @_ );
348 1 50       11 $opts->{asc} = 0 if( !exists( $opts->{asc} ) );
349 1         4 my $all = $self->elements;
350             my $sorted = $opts->{asc}
351 0   0 0   0 ? $all->sort(sub{ ( $_[0]->value // 1 ) <=> ( $_[1]->value // 1 ) })
      0        
352 1 50 100 5   78 : $all->sort(sub{ ( $_[1]->value // 1 ) <=> ( $_[0]->value // 1 ) });
  5   100     3394  
353 1         936 $self->elements( $sorted );
354 1         210 return( $sorted );
355             }
356              
357             sub _set_get_param_boolean
358             {
359 0     0   0 my $self = shift( @_ );
360 0   0     0 my $name = shift( @_ ) || return( $self->error( "No parameter name was provided." ) );
361 0   0     0 my $hv = $self->_hv || return( $self->error( "Header value object could not be found!" ) );
362 0 0       0 if( @_ )
363             {
364 0         0 my $v = shift( @_ );
365 0 0       0 if( $v )
366             {
367 0         0 $hv->param( $name => undef );
368             }
369             else
370             {
371 0         0 $hv->params->delete( $name );
372             }
373             }
374 0         0 return( $hv->param( $name ) );
375             }
376              
377             sub _set_get_param
378             {
379 107     107   259 my $self = shift( @_ );
380 107   50     445 my $name = shift( @_ ) || return( $self->error( "No parameter name was provided." ) );
381 107         303 my $hv = $self->_hv;
382             # If the HeaderValue object is not een set, and the caller just want to retrieve the
383             # value of a property, we return an empty string (undef is for errors)
384 107 50 66     3207 return( '' ) if( !scalar( @_ ) && !$hv );
385 107 50       994 return( $self->error( "Header value object (Module::Generic::HeaderValue) could not be found!" ) ) if( !$hv );
386 107 100       752 if( @_ )
387             {
388 18         116 $hv->param( $name => shift( @_ ) );
389             }
390 107         15757 return( $hv->param( $name ) );
391             }
392              
393             sub _set_get_params
394             {
395 0     0   0 my $self = shift( @_ );
396 0   0     0 my $hv = $self->_hv || return( $self->error( "Header value object could not be found!" ) );
397 0         0 my $params = $hv->params;
398 0 0       0 if( @_ )
399             {
400 0         0 while( my( $n, $v ) = splice( @_, 0, 2 ) )
401             {
402 0         0 $params->set( $n => $v );
403             }
404             }
405             else
406             {
407 0         0 return( $params );
408             }
409             }
410              
411             sub _set_get_properties_as_string
412             {
413 28     28   80 my $self = shift( @_ );
414 28         140 my $opts = $self->_get_args_as_hash( @_ );
415 28   100     2462 my $sep = $opts->{separator} || $opts->{sep} || ',';
416 28   100     128 my $eq = $opts->{equal} || '=';
417 28         89 my $params = $self->params;
418 28         21366 my $props = $self->properties;
419 28         21349 my $quotes = {};
420 28 100       236 $quotes = $self->_needs_quotes if( $self->can( '_needs_quotes' ) );
421 28         10526 my @res = ();
422 11     11   114 no overloading '""';
  11         36  
  11         7982  
423 28         108 foreach( @$params )
424             {
425 98 50       2746 if( !exists( $props->{ $_ } ) )
426             {
427             # warnings::warn( "Property is in our stack, but not in our repository of properties, skipping.\n" ) if( warnings::enabled( ref( $self ) ) );
428             # warn( "Property is in our stack, but not in our repository of properties, skipping.\n" ) if( $self->_warnings_is_enabled );
429 0         0 warn( "Property \"$_\" is in our stack, but not in our repository of properties, skipping.\n" );
430 0         0 next;
431             }
432             # If the property exists in our repo, but has no value it is a boolean
433 98 100       1999 push( @res, defined( $props->{ $_ } ) ? sprintf( "$_${eq}%s", ( $quotes->{ $_ } ? '"' : '' ) . $props->{ $_ } . ( $quotes->{ $_ } ? '"' : '' ) ) : $_ );
    100          
    100          
434             }
435 28         1630 return( join( "${sep} ", @res ) );
436             }
437              
438             # Used by Cache-Control
439             sub _set_get_property_boolean
440             {
441 32     32   76 my $self = shift( @_ );
442 32   50     109 my $prop = shift( @_ ) || return( $self->error( "No parameter name was provided." ) );
443 32         87 my $params = $self->params;
444 32         24345 my $props = $self->properties;
445 32         26249 my $pos = $params->pos( $prop );
446 32 100       771 if( @_ )
447             {
448 9         64 my $bool = shift( @_ );
449 9 100       42 if( defined( $pos ) )
450             {
451 4 100 100     47 if( defined( $bool ) && $bool )
452             {
453             # Nothing to do, it is already there
454             # Making sure we have it in our properties hash as well
455 1         9 $props->{ $prop } = undef;
456             }
457             # Undefined or false properties get removed
458             else
459             {
460 3         20 $params->splice( $pos, 1 );
461 3         263 $props->delete( $prop );
462             }
463             }
464             # Not there yet
465             else
466             {
467 5 50 33     25 if( defined( $bool ) && $bool )
468             {
469 5         18 $params->push( $prop );
470 5         51 $props->{ $prop } = undef;
471             }
472             # Nothing to do, it is not there yet
473             # Still make sure it is removed from the properties hash as well
474             else
475             {
476 0         0 $props->delete( $prop );
477             }
478             }
479 9         300 return( $bool );
480             }
481             else
482             {
483 23 100       216 return( defined( $pos ) ? 1 : 0 );
484             }
485             }
486              
487             # Used by Cache-Control, Expect-CT
488             sub _set_get_property_number
489             {
490 18     18   55 my $self = shift( @_ );
491 18   50     70 my $prop = shift( @_ ) || return( $self->error( "No parameter name was provided." ) );
492 18 100       62 if( @_ )
493             {
494 2         10 my $v = shift( @_ );
495 2 50 66     26 return( $self->error( "The value provided for property \"${prop}\" is not a number." ) ) if( defined( $v ) && !$self->_is_integer( $v ) );
496 2         24 return( $self->_set_get_property_value( $prop => $v ) );
497             }
498 16         85 return( $self->_set_get_property_value( $prop ) );
499             }
500              
501             # Used by Expect-CT
502             sub _set_get_property_value
503             {
504 76     76   145 my $self = shift( @_ );
505 76   50     251 my $prop = shift( @_ ) || return( $self->error( "No parameter name was provided." ) );
506 76         123 my $opts = {};
507 76 100       200 $opts = pop( @_ ) if( ref( $_[-1] ) eq 'HASH' );
508 76   100     362 $opts->{needs_quotes} //= 0;
509 76   100     289 $opts->{maybe_boolean} //= 0;
510 76         192 my $params = $self->params;
511 76         59161 my $props = $self->properties;
512 76         57157 my $pos = $params->pos( $prop );
513 76 100       2287 if( @_ )
514             {
515 4         37 my $v = shift( @_ );
516 4 100       14 if( !defined( $v ) )
517             {
518 2 50       10 $self->params->splice( $pos, 1 ) if( defined( $pos ) );
519 2         1166 return( $self->properties->delete( $prop ) );
520             }
521            
522             # Not there yet, add the value
523 2 50       8 if( !defined( $pos ) )
524             {
525 2 50 0     15 $params->push( $prop ) if( !$opts->{maybe_boolean} || ( $opts->{maybe_boolean} && $v ) );
      33        
526 2 50 33     26 if( exists( $opts->{maybe_boolean} ) && $opts->{maybe_boolean} )
527             {
528 0 0       0 if( $v == 1 )
    0          
529             {
530 0         0 $props->{ $prop } = undef;
531             }
532             elsif( !$v )
533             {
534 0         0 $props->delete( $prop );
535             }
536             else
537             {
538 0         0 $props->{ $prop } = $v;
539             }
540             }
541             else
542             {
543 2         14 $props->{ $prop } = $v;
544             }
545             }
546             else
547             {
548 0 0 0     0 if( exists( $opts->{maybe_boolean} ) && $opts->{maybe_boolean} )
549             {
550 0 0       0 if( !$v )
    0          
551             {
552 0         0 $params->splice( $pos, 1 );
553 0         0 $props->delete( $prop );
554             }
555             elsif( $v == 1 )
556             {
557 0         0 $props->{ $prop } = undef;
558             }
559             else
560             {
561 0         0 $props->{ $prop } = $v;
562             }
563             }
564             else
565             {
566 0         0 $props->{ $prop } = $v;
567             }
568             }
569             # Used for non-standard properties during stringification
570 2 100 66     78 if( $opts->{needs_quotes} && $self->can( '_needs_quotes' ) )
571             {
572 1         5 $self->_needs_quotes->set( $prop => 1 );
573             }
574 2         525 return( $v );
575             }
576             else
577             {
578 72 50       176 if( defined( $pos ) )
579             {
580             return(
581             $opts->{maybe_boolean}
582             ? defined( $pos ) ? 1 : 0
583 72 50       471 : $props->{ $prop }
    100          
584             );
585             }
586 0         0 return( '' );
587             }
588             }
589              
590             # Same as _set_get_param but with surrounding double quotes
591             sub _set_get_qparam
592             {
593 14     14   44 my $self = shift( @_ );
594 14   50     54 my $name = shift( @_ ) || return( $self->error( "No parameter name was provided." ) );
595 14   50     37 my $hv = $self->_hv || return( $self->error( "Header value object could not be found!" ) );
596 14         416 my $v;
597 14 50       45 if( @_ )
598             {
599 0         0 $v = shift( @_ );
600 0         0 $v =~ s/^\"//;
601 0         0 $v =~ s/(?<!\\)\"$//;
602 0         0 $hv->param( $name => qq{"${v}"} );
603             }
604             else
605             {
606 14         52 $v = $hv->param( $name );
607 14 100 100     8180 return( '' ) if( !defined( $v ) || !length( "$v" ) );
608 11         41 $v =~ s/^\"//;
609 11         26 $v =~ s/(?<!\\)\"$//;
610             }
611 11         45 return( $v );
612             }
613              
614             sub _set_get_value
615             {
616 0     0   0 my $self = shift( @_ );
617 0         0 my $hv = $self->_hv;
618 0 0       0 if( @_ )
619             {
620 0         0 $hv->value( shift( @_ ) );
621             }
622 0         0 return( $hv->value_data );
623             }
624              
625             # NOTE: sub FREEZE is inherited
626              
627 21     21 0 1691 sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }
628              
629 21     21 0 13225 sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }
630              
631             # NOTE: sub THAW is inherited
632              
633             # NOTE: HTTP::Promise::Field::QualityValue class
634             {
635             package
636             HTTP::Promise::Field::QualityValue;
637             BEGIN
638 0         0 {
639 11     11   17512 use strict;
  11         40  
  11         398  
640 11     11   76 use warnings;
  11         48  
  11         553  
641 11     11   76 use parent qw( Module::Generic );
  11         38  
  11         113  
642             use overload (
643             '""' => 'as_string',
644 70     70   2563 'bool' => sub{1},
645 11     11   1166 );
  11     0   50  
  11         142  
646             };
647            
648             sub as_string
649             {
650 67     67   1233 my $self = shift( @_ );
651 67         151 my $elem = $self->element;
652 67         53918 my $val = $self->value;
653 67 100 66     51118 return( $elem ) if( !defined( $val ) || !length( "${val}" ) );
654 44         391 return( "${elem};q=${val}" );
655             }
656            
657             sub init
658             {
659 35     35   2787 my $self = shift( @_ );
660 35         92 my $elem = shift( @_ );
661 35 50 33     241 return( $self->error( "No element was provided for this quality value." ) ) if( !defined( $elem ) || !length( "$elem" ) );
662 35         94 my $val = shift( @_ );
663 35 50       146 $self->SUPER::init( @_ ) || return( $self->pass_error );
664 35         163 $self->element( $elem );
665 35         69036 $self->value( $val );
666 35         1064577 return( $self );
667             }
668            
669 123     123   5473 sub element { return( shift->_set_get_scalar_as_object( 'element', @_ ) ); }
670            
671 124     124   10671 sub value { return( shift->_set_get_number( { field => 'value', undef_ok => 1 }, @_ ) ); }
672              
673             # NOTE: sub FREEZE is inherited
674              
675 17     17   10592 sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); }
676              
677 17     17   13941 sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }
678              
679             # NOTE: sub THAW is inherited
680              
681             }
682              
683             1;
684             # NOTE: POD
685             __END__
686              
687             =encoding utf-8
688              
689             =head1 NAME
690              
691             HTTP::Promise::Headers::Generic - Generic HTTP Header Class
692              
693             =head1 SYNOPSIS
694              
695             package HTTP::Promise::Headers::MyHeader;
696             use strict;
697             use warnings;
698             use parent qw( HTTP::Promise::Headers::Generic );
699              
700             =head1 VERSION
701              
702             v0.1.1
703              
704             =head1 DESCRIPTION
705              
706             This is a generic module to be inherited by HTTP header modules. See for example: L<HTTP::Promise::Headers::AcceptEncoding>, L<HTTP::Promise::Headers::AcceptLanguage>, L<HTTP::Promise::Headers::Accept>, L<HTTP::Promise::Headers::AltSvc>, L<HTTP::Promise::Headers::CacheControl>, L<HTTP::Promise::Headers::ClearSiteData>, L<HTTP::Promise::Headers::ContentDisposition>, L<HTTP::Promise::Headers::ContentRange>, L<HTTP::Promise::Headers::ContentSecurityPolicy>, L<HTTP::Promise::Headers::ContentSecurityPolicyReportOnly>, L<HTTP::Promise::Headers::ContentType>, L<HTTP::Promise::Headers::Cookie>, L<HTTP::Promise::Headers::ExpectCT>, L<HTTP::Promise::Headers::Forwarded>, L<HTTP::Promise::Headers::Generic>, L<HTTP::Promise::Headers::KeepAlive>, L<HTTP::Promise::Headers::Link>, L<HTTP::Promise::Headers::Range>, L<HTTP::Promise::Headers::ServerTiming>, L<HTTP::Promise::Headers::StrictTransportSecurity>, L<HTTP::Promise::Headers::TE>
707              
708             =head1 METHODS
709              
710             =head2 as_string
711              
712             Return a string representation of this header field object.
713              
714             =head2 field_name
715              
716             Sets or gets the object headers field name
717              
718             =head2 uri_escape_utf8
719              
720             Provided with some string and this returns the URI-escaped version of this using L<URI::Escape::XS>
721              
722             =head2 value
723              
724             By default and superseded by inheriting classes such as Content-Type that has more elaborate value with parameters
725              
726             =head1 PRIVATE METHODS
727              
728             =head2 _filename_decode
729              
730             Provided with a filename, and this will decode it, if necessary, by calling L<HTTP::Promise::Headers/decode_filename>
731              
732             It returns in list context the decoded filename, the character-set and language used and in scalar context the decoded filename.
733              
734             If the filename did not need to be decoded, it will return the filename untouched, so this is quite safe to use.
735              
736             See L<rfc2231|https://tools.ietf.org/html/rfc2231>
737              
738             =head2 _filename_encode
739              
740             Provided with a filename, and an optional language, and this will encode it, if necessary, following the L<rfc2231|https://tools.ietf.org/html/rfc2231>
741              
742             If the filename did not need to be encoded, it returns C<undef>, so be sure to check for the return value.
743              
744             See L<rfc2231|https://tools.ietf.org/html/rfc2231>
745              
746             =head2 _hv
747              
748             Sets or gets the L<header value object|Module::Generic::HeaderValue>
749              
750             =head2 _hv_as_string
751              
752             Returns the L<header value object|Module::Generic::HeaderValue> as a string, if a header value object is set, or an empty string otherwise.
753              
754             =head2 _get_header_value_object
755              
756             This instantiates a new L<header value object|Module::Generic::HeaderValue>, passing it whatever arguments were provided, and return the new object.
757              
758             =head2 _make_boundary
759              
760             Returns a new boundary using L<Data::UUID>
761              
762             =head2 _new_hv
763              
764             Does the same thing as L</_get_header_value_object>
765              
766             =head2 _new_qv_object
767              
768             This instantiates a new quality value object using C<HTTP::Promise::Field::QualityValue>, passing it whatever arguments were provided, and return the new object.
769              
770             =head2 _parse_header_value
771              
772             Provided with a string, and this instantiates a new L<header value object|Module::Generic::HeaderValue>, by calling L<Module::Generic::HeaderValue/new_from_header> passing it the string and any other arguments that were provided, and return the new object.
773              
774             Upon error, this sets an L<error|Module::Generic/error> and returns C<undef>
775              
776             =head2 _parse_quality_value
777              
778             Provided with a string representing a quality value, and this will parse it and return a new L<array object|Module::Generic::Array>
779              
780             See L<rfc7231, section 5.3.1|https://tools.ietf.org/html/rfc7231#section-5.3.1>
781              
782             =head2 _qstring_join
783              
784             Provided with a list of strings and this will ensure any special characters are escaped before returning them as one string separated by comma.
785              
786             See also L</_qstring_split>
787              
788             =head2 _qstring_split
789              
790             Provided with a string, and this will split it by comma, mindful of any special characters.
791              
792             It returns an array of the parts split.
793              
794             =head2 _qv_add
795              
796             Provided with an element and its value, and this will instantiate a new C<HTTP::Promise::Field::QualityValue> object and add it to the list of objects contained with the method C<elements> (implemented in each specific header module)
797              
798             =head2 _qv_as_string
799              
800             This takes the list of all elements contained with the method C<elements> (implemented in each specific header module) and returns them as a string separated by comma.
801              
802             =head2 _qv_elements
803              
804             Sets or gets the L<array object|Module::Generic::Array> containing the list of quality values.
805              
806             =head2 _qv_get
807              
808             Provided with a quality value element, and this returns its corresponding object if it exists, or an empty string otherwise.
809              
810             Upon error, this sets an L<error|Module::Generic/error> and returns C<undef>
811              
812             =head2 _qv_match
813              
814             Provided with a string, and this returns an L<array object|Module::Generic::Array> of matching quality value objects in their order of preference.
815              
816             Upon error, this sets an L<error|Module::Generic/error> and returns C<undef>
817              
818             =head2 _qv_match_wildcard
819              
820             This method is used to do the actual work of matching a requested value such as C<fr-FR> or <text/html> depending on the type of header, against the ones announced in the header.
821              
822             For example:
823              
824             Accept: image/*
825             Accept: text/html
826             Accept: */*
827             Accept: text/html, application/xhtml+xml, application/xml;q=0.9, image/webp, */*;q=0.8
828              
829             Accept-Encoding: gzip
830              
831             Accept-Encoding: deflate, gzip;q=1.0, *;q=0.5
832              
833             Accept-Language: fr-FR, fr;q=0.9, en;q=0.8, de;q=0.7, *;q=0.5
834              
835              
836             This takes an "acceptable" L<scalar object|Module::Generic::Scalar>, an L<array object|Module::Generic::Array> of proposed quality-value objects, and an L<array object|Module::Generic::Array> of original proposed value, and possibly an hash reference of already seen object address.
837              
838             It returns an L<array object|Module::Generic::Array> of matching quality-value objects.
839              
840             =head2 _qv_remove
841              
842             Provided with a quality-value string or object, and this will remove it from the list of elements.
843              
844             It returns the element removed, or upon error, this sets an L<error|Module::Generic/error> and returns C<undef>
845              
846             =head2 _qv_sort
847              
848             This takes an optional hash or hash reference of options and returns an L<array object|Module::Generic::Array> of sorted element by their quality-value.
849              
850             Supported options are:
851              
852             =over 4
853              
854             =item * C<asc>
855              
856             Boolean. If true, the elements will be sorted in their ascending order, otherwise in their descending order.
857              
858             =back
859              
860             =head2 _set_get_param_boolean
861              
862             In retrieval mode, this takes a header value parameter, and this returns its value.
863              
864             In assignment mode, this takes a header value parameter, and a value, possibly C<undef> and assign it to the given parameter.
865              
866             Upon error, this sets an L<error|Module::Generic/error> and returns C<undef>
867              
868             =head2 _set_get_param
869              
870             In retrieval mode, this takes a header value parameter, and it returns its corresponding value.
871              
872             In assignment mode, this takes a header value parameter, and a value and assign it.
873              
874             Upon error, this sets an L<error|Module::Generic/error> and returns C<undef>
875              
876             =head2 _set_get_params
877              
878             This takes a list of header-value parameter and their corresponding value and set them.
879              
880             If no argument is provided, this returns the L<array object|Module::Generic::Array> containing all the header-value parameters.
881              
882             =head2 _set_get_properties_as_string
883              
884             This takes an hash or hash reference of options and returns the header-value parameters as a regular string.
885              
886             Supported options are:
887              
888             =over 4
889              
890             =item * C<equal>
891              
892             =item * C<separator> or C<sep>
893              
894             =back
895              
896             =head2 _set_get_property_boolean
897              
898             This sets or gets a boolean value for the given header-value property.
899              
900             It returns the boolean value for the given property.
901              
902             Upon error, this sets an L<error|Module::Generic/error> and returns C<undef>
903              
904             =head2 _set_get_property_number
905              
906             This sets or gets a number for the given header-value property.
907              
908             It returns the number value for the given property.
909              
910             Upon error, this sets an L<error|Module::Generic/error> and returns C<undef>
911              
912             =head2 _set_get_property_value
913              
914             This sets or gets a value for the given header-value property.
915              
916             It returns the value for the given property.
917              
918             Upon error, this sets an L<error|Module::Generic/error> and returns C<undef>
919              
920             =head2 _set_get_qparam
921              
922             Sets or gets a quality-value parameter. If a value is provided, any double quote found at the bginning or end are removed.
923              
924             It returns the current value.
925              
926             Upon error, this sets an L<error|Module::Generic/error> and returns C<undef>
927              
928             =head2 _set_get_value
929              
930             This sets or gets a header main value.
931              
932             For example C<text/html> in C<text/html; charset=utf-8>
933              
934             =head1 AUTHOR
935              
936             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
937              
938             =head1 SEE ALSO
939              
940             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>
941              
942             =head1 COPYRIGHT & LICENSE
943              
944             Copyright(c) 2022 DEGUEST Pte. Ltd.
945              
946             All rights reserved.
947              
948             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
949              
950             =cut