File Coverage

lib/HTTP/Promise/Headers/Link.pm
Criterion Covered Total %
statement 62 82 75.6
branch 15 32 46.8
condition 8 21 38.1
subroutine 13 17 76.4
pod 10 10 100.0
total 108 162 66.6


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Asynchronous HTTP Request and Promise - ~/lib/HTTP/Promise/Headers/Link.pm
3             ## Version v0.1.0
4             ## Copyright(c) 2022 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2022/05/08
7             ## Modified 2022/05/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::Link;
15             BEGIN
16             {
17 3     3   3172 use strict;
  3         10  
  3         97  
18 3     3   14 use warnings;
  3         7  
  3         84  
19 3     3   16 use warnings::register;
  3         6  
  3         433  
20 3     3   17 use parent qw( HTTP::Promise::Headers::Generic );
  3         5  
  3         17  
21 3     3   251 our $VERSION = 'v0.1.0';
22             };
23              
24 3     3   18 use strict;
  3         7  
  3         59  
25 3     3   14 use warnings;
  3         7  
  3         2465  
26              
27             sub init
28             {
29 4     4 1 4007 my $self = shift( @_ );
30 4         149 $self->{anchor} = undef;
31 4         23 $self->{rel} = undef;
32 4         21 $self->{title} = undef;
33 4         20 $self->{uri} = undef;
34 4 50 66     49 @_ = () if( @_ == 1 && $self->_is_a( $_[0] => 'Module::Generic::Null' ) );
35 4 100       76 if( @_ )
36             {
37 2         6 my $str = shift( @_ );
38 2 50 33     24 return( $self->error( "No value was provided for Link field." ) ) if( !defined( $str ) || !length( "$str" ) );
39 2         16 my $params = $self->_get_args_as_hash( @_ );
40 2   50     34 my $hv = $self->_parse_header_value( $str ) ||
41             return( $self->pass_error );
42 2 50       20 $hv->params( $params ) if( scalar( keys( %$params ) ) );
43 2         23 $self->_hv( $hv );
44             }
45 4 50       119 $self->SUPER::init( @_ ) || return( $self->pass_error );
46 4         97 $self->_field_name( 'Link' );
47 4         3227 return( $self );
48             }
49              
50 4     4 1 343801 sub as_string { return( shift->_hv_as_string( [qw( rel title title* anchor )] ) ); }
51              
52             # sub as_string
53             # {
54             # my $self = shift( @_ );
55             # my $uri = $self->uri || return( '' );
56             # my $rel = $self->rel;
57             # return( "<${uri}>; rel=\"${rel}\"" ) if( $rel );
58             # return( "<${uri}>" );
59             # }
60              
61 3     3 1 342710 sub anchor { return( shift->_set_get_param( anchor => @_ ) ); }
62              
63             sub link
64             {
65 4     4 1 257664 my $self = shift( @_ );
66 4 100       21 if( @_ )
67             {
68 1         5 my $link = shift( @_ );
69 1         10 $link =~ s/^\<|(?<!\\)\>$//g;
70 1         11 my $link2 = qq{<${link}>};
71 1         4 my $hv = $self->_hv;
72 1 50       28 if( $hv )
73             {
74 0         0 $hv->value( $link2 );
75             }
76             else
77             {
78 1   50     16 $hv = $self->_new_hv( $link2 ) || return( $self->pass_error );
79 1         231 $self->_hv( $hv );
80             }
81 1         55 return( $link );
82             }
83             else
84             {
85             # No header value object, means there is just nothing set yet
86 3   50     23 my $hv = $self->_hv || return( '' );
87 3         126 my $link = $hv->value_data;
88 3         111224 $link =~ s/^\<|(?<!\\)\>$//g;
89 3         578 return( $link );
90             }
91             }
92              
93 0     0 1 0 sub param { return( shift->_set_get_param( @_ ) ); }
94              
95 0     0 1 0 sub params { return( shift->_set_get_params( @_ ) ); }
96              
97 4     4 1 1637 sub rel { return( shift->_set_get_param( rel => @_ ) ); }
98              
99             sub title
100             {
101 3     3 1 520 my $self = shift( @_ );
102 3 100       16 if( @_ )
103             {
104 1         4 my( $title, $lang ) = @_;
105 1 50       5 if( !defined( $title ) )
106             {
107 0         0 $self->params->delete( 'title' );
108 0         0 $self->params->delete( 'title*' );
109             }
110             else
111             {
112 1   33     4 $lang //= $self->title_lang;
113 1 50       10 if( my $enc = $self->_filename_encode( $title, $lang ) )
114             {
115 1 50       95 $self->_set_get_param( 'title*' => $enc ) || return( $self->pass_error );
116             }
117             else
118             {
119 0         0 $self->_set_get_qparam( title => $title );
120             }
121             }
122             }
123             else
124             {
125 2         23 my $v = $self->_set_get_qparam( 'title' );
126 2 50 33     20 if( !defined( $v ) || !length( $v ) )
127             {
128 0 0       0 if( $v = $self->_set_get_param( 'title*' ) )
129             {
130 0         0 my( $f_charset, $f_lang );
131 0         0 ( $v, $f_charset, $f_lang ) = $self->_filename_decode( $v );
132 0         0 $self->title_charset( $f_charset );
133 0         0 $self->title_lang( $f_lang );
134             }
135             }
136 2         25 return( $v );
137             }
138             }
139              
140             sub title_charset
141             {
142 0     0 1   my $self = shift( @_ );
143 0 0         if( @_ )
144             {
145 0           my $v = shift( @_ );
146 0 0 0       return( $self->error( "Only supported charset is 'utf-8'." ) ) if( lc( $v ) ne 'utf-8' && lc( $v ) ne 'utf8' );
147             # Convenience
148 0 0         $v = 'utf-8' if( lc( $v ) eq 'utf8' );
149 0           $v = uc( $v );
150 0           return( $self->_set_get_scalar_as_object( 'title_charset', $v ) );
151             }
152 0           return( $self->_set_get_scalar_as_object( 'title_charset' ) );
153             }
154              
155 0     0 1   sub title_lang { return( shift->_set_get_scalar_as_object( 'title_lang', @_ ) ); }
156              
157             1;
158             # NOTE: POD
159             __END__
160              
161             =encoding utf-8
162              
163             =head1 NAME
164              
165             HTTP::Promise::Headers::Link - Link Header Field
166              
167             =head1 SYNOPSIS
168              
169             use HTTP::Promise::Headers::Link;
170             my $link = HTTP::Promise::Headers::Link->new ||
171             die( HTTP::Promise::Headers::Link->error, "\n" );
172             my $uri = $link->link;
173             $link->link( 'https://example.org' );
174             $link->rel( 'preconnect' );
175             $h->link( "$link" );
176             # Link: <https://example.org>; rel="preconnect"
177             $link->title( 'Foo' );
178             $link->anchor( '#bar' );
179             $cd->params( rel => 'preconnect', anchor => 'bar' );
180              
181             =head1 VERSION
182              
183             v0.1.0
184              
185             =head1 DESCRIPTION
186              
187             The following is an extract from Mozilla documentation.
188              
189             The HTTP Link entity-header field provides a means for serializing one or more links in HTTP headers. It is semantically equivalent to the HTML C<link> element.
190              
191             Example:
192              
193             Link: <https://example.com>; rel="preconnect"; title="Foo"; anchor="#bar"
194              
195             =head1 METHODS
196              
197             =head2 anchor
198              
199             Sets or gets the C<anchor> property.
200              
201             =head2 as_string
202              
203             Returns a string representation of the C<Link> object.
204              
205             =head2 rel
206              
207             Sets or gets the C<relationship> of the C<Link> as a scalar.
208              
209             =head2 link
210              
211             Sets or gets an URI. It returns the URI value (not an object).
212              
213             When you set this value, it will be automatically surrounded by C<< <> >>
214              
215             =head2 param
216              
217             Sets or gets an arbitrary C<Link> property.
218              
219             Note that if you use this, you bypass other specialised method who do some additional processing, so be mindful.
220              
221             =head2 params
222              
223             Sets or gets multiple arbitrary C<Link> properties at once.
224              
225             If called without any arguments, this returns the L<hash object|Module::Generic::Hash> used to store the C<Link> properties.
226              
227             =head2 title
228              
229             Without any argument, this returns the string containing the original title of the link. The C<title> is always optional.
230              
231             If the property C<title*> is set instead, then it will be decoded and used instead, and the value for L</title_charset> and L</title_lang> will be set.
232              
233             When setting the title value, this takes an optional language iso 639 code (see L<rfc5987|https://tools.ietf.org/html/rfc5987> and L<rfc2231|https://tools.ietf.org/html/rfc2231>).
234             If the title contains non ascii characters, it will be automatically encoded according to L<rfc5987|https://tools.ietf.org/html/rfc5987>. and the property C<title*> set instead. That property, by rfc standard, takes precedence over the C<title> one.
235              
236             See L<rfc8288, section 3|https://tools.ietf.org/html/rfc8288#section-3> for more information.
237              
238             The language provided, if any, will be used then.
239              
240             For example:
241              
242             $h->link( 'https://www.example.com' );
243             $h->rel( 'preconnect' );
244             $h->title( q{Foo} );
245             say "$h";
246             # <https://www.example.com>; rel="preconnect"; title="Foo"
247              
248             $h->link( 'https://www.example.com' );
249             $h->rel( 'previous' );
250             $h->title( q{「お早う」小津安二郎} );
251             say "$h";
252             # https://www.example.com; rel="previous"; title*="UTF-8''%E3%81%8A%E6%97%A9%E3%81%86%E3%80%8D%E5%B0%8F%E6%B4%A5%E5%AE%89%E4%BA%8C%E9%83%8E"
253            
254             $h->link( 'https://www.example.com' );
255             $h->rel( 'previous' );
256             $h->title( q{「お早う」小津安二郎}, 'ja-JP' );
257             say "$h";
258             # https://www.example.com; rel="previous"; title*="UTF-8'ja-JP'%E3%81%8A%E6%97%A9%E3%81%86%E3%80%8D%E5%B0%8F%E6%B4%A5%E5%AE%89%E4%BA%8C%E9%83%8E"
259              
260             # Using default value
261             $h->title_lang( 'ja-JP' );
262             $h->link( 'https://www.example.com' );
263             $h->rel( 'previous' );
264             $h->title( q{「お早う」小津安二郎}, 'ja-JP' );
265             say "$h";
266             # https://www.example.com; rel="previous"; title*="UTF-8'ja-JP'%E3%81%8A%E6%97%A9%E3%81%86%E3%80%8D%E5%B0%8F%E6%B4%A5%E5%AE%89%E4%BA%8C%E9%83%8E"
267              
268             $headers->header( Link => "$h" );
269              
270             The C<Link> header value would then contain a property C<title*> (with the trailing wildcard).
271              
272             =head2 title_charset
273              
274             Sets or gets the encoded title charset.
275              
276             This is used when the title contains non-ascii characters, such as Japanese, Korean, or Cyrillic.
277             Although theoretically one can set any character set, by design this only accepts C<UTF-8> (case insensitive).
278              
279             This is set automatically when calling L</title>. You actually need to call L</title> first to have a value set.
280              
281             Returns a L<scalar object|Module::Generic::Scalar> containing the title charset.
282              
283             =head2 title_lang
284              
285             Sets or gets the encoded title language. This takes an iso 639 language code (see L<rfc1766|https://tools.ietf.org/html/rfc1766>).
286              
287             This is set automatically when calling L</title>. You actually need to call L</title> first to have a value set.
288              
289             Returns a L<scalar object|Module::Generic::Scalar> containing the title language.
290              
291             =head1 AUTHOR
292              
293             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
294              
295             =head1 SEE ALSO
296              
297             See also L<rfc8288, section 3|https://tools.ietf.org/html/rfc8288#section-3> and L<Mozilla documentation|https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Link>
298              
299             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>
300              
301             =head1 COPYRIGHT & LICENSE
302              
303             Copyright(c) 2022 DEGUEST Pte. Ltd.
304              
305             All rights reserved.
306              
307             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
308              
309             =cut