File Coverage

blib/lib/Cookie/Domain.pm
Criterion Covered Total %
statement 345 1150 30.0
branch 126 1210 10.4
condition 49 447 10.9
subroutine 50 64 78.1
pod 15 15 100.0
total 585 2886 20.2


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Cookies API for Server & Client - ~/lib/Cookie/Domain.pm
3             ## Version v0.1.3
4             ## Copyright(c) 2022 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2021/05/06
7             ## Modified 2022/11/06
8             ## You can use, copy, modify and redistribute this package and associated
9             ## files under the same terms as Perl itself.
10             ##----------------------------------------------------------------------------
11             package Cookie::Domain;
12             BEGIN
13             {
14 3     3   111325 use strict;
  3         18  
  3         97  
15 3     3   15 use warnings;
  3         6  
  3         77  
16 3     3   15 use warnings::register;
  3         5  
  3         388  
17 3     3   528 use parent qw( Module::Generic );
  3         285  
  3         18  
18 3     3   13033578 use vars qw( $DOMAIN_RE $PUBLIC_SUFFIX_DATA $VERSION );
  3         6  
  3         165  
19 3     3   889 use DateTime;
  3         509455  
  3         100  
20 3     3   700 use DateTime::Format::Strptime;
  3         208921  
  3         37  
21 3     3   4191 use Module::Generic::File qw( tempfile );
  3         33891887  
  3         60  
22 3     3   3556 use JSON;
  3         28418  
  3         24  
23 3     3   2031 use Net::IDN::Encode ();
  3         283759  
  3         130  
24 3     3   29 use Nice::Try;
  3         6  
  3         37  
25 3     3   3866086 use Want;
  3         8  
  3         326  
26 3     3   25 use constant URL => 'https://publicsuffix.org/list/effective_tld_names.dat';
  3         6  
  3         724  
27             # Properly formed domain name according to rfc1123
28 3     3   22 our $DOMAIN_RE = qr/^
29             (?:
30             [[:alnum:]]
31             (?:
32             (?:[[:alnum:]-]){0,61}
33             [[:alnum:]]
34             )?
35             (?:
36             \.[[:alnum:]]
37             (?:
38             (?:[[:alnum:]-]){0,61}
39             [[:alnum:]]
40             )?
41             )*
42             )
43             $/x;
44 3         70 our $VERSION = 'v0.1.3';
45             };
46              
47 3     3   23 use strict;
  3         10  
  3         94  
48 3     3   18 use warnings;
  3         7  
  3         4815  
49              
50             sub init
51             {
52 11     11 1 1255 my $self = shift( @_ );
53 11         142 my $base = Module::Generic::File::file( __FILE__ )->parent;
54 11         3414458 $self->{file} = $base->child( 'public_suffix_list.txt' );
55 11         753850 $self->{json_file} = Module::Generic::File->sys_tmpdir->child( 'public_suffix.json' );
56 11         2393084 $self->{meta} = {};
57 11         56561 $self->{min_suffix} = 0;
58 11         152 $self->{suffixes} = {};
59 11         129 $self->{_init_strict_use_sub} = 1;
60 11 50       266 $self->SUPER::init( @_ ) || return( $self->pass_error );
61 11 50       1606 unless( $self->{no_load} )
62             {
63 11 50       256 $self->load || return( $self->pass_error );
64             }
65 11         197 return( $self );
66             }
67              
68             sub cron_fetch
69             {
70             # Cookie::Domain->cron_fetch
71             # $obj->cron_fetch
72             # Cookie::Domain->cron_fetch( $hash_ref );
73             # $obj->cron_fetch( $hash_ref );
74             # Cookie::Domain->cron_fetch( %options );
75             # $obj->cron_fetch( %options );
76 0     0 1 0 my( $this, $self );
77 0         0 my $opts = {};
78 0 0 0     0 if( scalar( @_ ) && ( ref( $_[0] ) eq __PACKAGE__ || $_[0] eq __PACKAGE__ ) )
      0        
79             {
80 0         0 $this = shift( @_ );
81             }
82 0 0 0     0 if( @_ == 1 && ref( $_[0] ) eq 'HASH' )
    0          
83             {
84 0         0 $opts = shift( @_ );
85             }
86             elsif( !( scalar( @_ ) % 2 ) )
87             {
88 0         0 $opts = { @_ };
89             }
90            
91 0 0       0 if( ref( $this ) )
92             {
93 0         0 $self = $this;
94             }
95             else
96             {
97 0   0     0 $this //= __PACKAGE__;
98 0         0 $self = $this->new( $opts );
99             }
100 0   0     0 $opts->{file} //= '';
101 0   0     0 my $file = $opts->{file} || $self->file;
102 0 0       0 $file = $self->_is_a( $file, 'Module::Generic::File' ) ? $file : Module::Generic::File::file( $file );
103 0         0 require LWP::UserAgent;
104 0         0 my $ua = LWP::UserAgent->new(
105             agent => "Cookie::Domain/" . $VERSION,
106             );
107 0         0 my $meta = $self->meta;
108 0         0 my $req_headers = {};
109 0         0 my $dont_have_etag = 0;
110             my $mtime = $meta->{db_last_modified}
111             ? $meta->{db_last_modified}
112 0 0 0     0 : ( $file->exists && !$file->is_empty )
    0          
113             ? $file->mtime
114             : undef;
115             # If we have already a local file and it is not empty, let's use the etag when making the request
116 0 0 0     0 if( $meta->{etag} && $file->exists && !$file->is_empty )
    0 0        
117             {
118 0         0 $meta->{etag} =~ s/^\"([^"]+)\"$/$1/;
119 0         0 $req_headers->{'If-None-Match'} = qq{"$meta->{etag}"};
120             }
121             elsif( !$meta->{etag} )
122             {
123 0         0 $dont_have_etag = 1;
124             # <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/If-Modified-Since>
125 0 0 0     0 if( defined( $mtime ) && $mtime )
126             {
127 0         0 my $dt = $self->_parse_timestamp( $mtime );
128 0 0       0 if( $dt )
129             {
130             # HTTP Date format
131 0         0 my $dt_fmt = DateTime::Format::Strptime->new(
132             pattern => '%a, %d %b %Y %H:%M:%S GMT',
133             locale => 'en_GB',
134             time_zone => 'GMT',
135             );
136 0         0 $dt->set_formatter( $dt_fmt );
137 0         0 $req_headers->{ 'If-Modified-Since' } = $dt;
138             }
139             }
140             }
141            
142 0 0 0     0 try
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
143 0     0   0 {
144 0         0 my $resp = $ua->get( URL, %$req_headers );
145 0         0 my $code = $resp->code;
146 0         0 my $data = $resp->decoded_content( default_charset => 'utf-8', alt_charset => 'utf-8' );
147 0         0 my $last_mod = $resp->header( 'Last-Modified' );
148              
149 0         0 my $tz;
150             # DateTime::TimeZone::Local will die ungracefully if the local timezeon is not set with the error:
151             # "Cannot determine local time zone"
152 0 0 0     0 try
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
153 0         0 {
154 0         0 $tz = DateTime::TimeZone->new( name => 'local' );
155             }
156 0 0 0     0 catch( $e )
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
157 0         0 {
158 0         0 $tz = DateTime::TimeZone->new( name => 'UTC' );
159 3 0 0 3   25 }
  3 0 0     14  
  3 0 0     4056  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
160            
161 0 0       0 if( $last_mod )
162             {
163 0         0 $last_mod = $self->_parse_timestamp( $last_mod )->set_time_zone( $tz );
164             }
165             else
166             {
167 0         0 $last_mod = DateTime->now( time_zone => $tz );
168             }
169 0         0 my $epoch = $last_mod->epoch;
170 0 0       0 if( $resp->header( 'etag' ) )
171             {
172 0 0 0     0 $dont_have_etag = $resp->header( 'etag' ) eq ( $meta->{etag} // '' ) ? 0 : 1;
173 0         0 $meta->{etag} = $resp->header( 'etag' );
174 0         0 $meta->{etag} =~ s/^\"([^"]+)\"$/$1/;
175             }
176            
177 0 0 0     0 if( $code == 304 ||
    0 0        
    0 0        
178             ( !$file->is_empty && $mtime && $mtime == $epoch ) )
179             {
180 0 0       0 if( !$self->suffixes->length )
181             {
182 0 0       0 $self->load_public_suffix || return( $self->pass_error );
183             }
184             # Did not have an etag, but I do have one now
185 0 0 0     0 if( $dont_have_etag && $meta->{etag} )
186             {
187 0 0       0 $self->save_as_json || return( $self->pass_error );
188             }
189 0         0 return( $self );
190             }
191             elsif( $code ne 200 )
192             {
193 0         0 return( $self->error( "Failed to get the remote public domain list. Server responded with code '$code': ", $resp->as_string ) );
194             }
195             elsif( !length( $data ) )
196             {
197 0         0 return( $self->error( "Remote server returned no data." ) );
198             }
199 0 0       0 $file->unload_utf8( $data, { lock => 1 } ) || return( $self->error( "Unable to open public suffix data file \"$file\" in write mode: ", $file->error ) );
200 0         0 $file->unlock;
201 0         0 $file->utime( $epoch, $epoch );
202 0 0       0 $self->load_public_suffix || return( $self->pass_error );
203 0 0       0 $self->save_as_json || return( $self->pass_error );
204             }
205 0 0 0     0 catch( $e )
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
206 0     0   0 {
207 0         0 return( $self->error( "An error occurred while trying to get the latest version of the public domain list: $e" ) );
208 3 0 0 3   33 }
  3 0 0     11  
  3 0 0     3417  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
209 0         0 return( $self );
210             }
211              
212             sub decode
213             {
214 0     0 1 0 my $self = shift( @_ );
215 0         0 my $name = shift( @_ );
216 0 0       0 return( '' ) if( !length( $name ) );
217 0 0 0     0 try
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
218 0     0   0 {
219 0         0 return( Net::IDN::Encode::domain_to_ascii( $name ) );
220             }
221 0 0 0     0 catch( $e )
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
222 0     0   0 {
223 0         0 return( $self->error( "An unexpected error occurred while decoding a domain name: $e" ) );
224 3 0 0 3   26 }
  3 0 0     6  
  3 0 0     3283  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
225             }
226              
227             sub encode
228             {
229 0     0 1 0 my $self = shift( @_ );
230 0         0 my $name = shift( @_ );
231 0 0       0 return( '' ) if( !length( $name ) );
232 0 0 0     0 try
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
233 0     0   0 {
234 0         0 return( Net::IDN::Encode::domain_to_unicode( $name ) );
235             }
236 0 0 0     0 catch( $e )
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
237 0     0   0 {
238 0         0 return( $self->error( "An unexpected error occurred while encoding a domain name: $e" ) );
239 3 0 0 3   25 }
  3 0 0     35  
  3 0 0     4658  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
240             }
241              
242 14     14 1 1280 sub file { return( shift->_set_get_object_without_init( 'file', 'Module::Generic::File', @_ ) ); }
243              
244 11     11 1 163 sub json_file { return( shift->_set_get_object_without_init( 'json_file', 'Module::Generic::File', @_ ) ); }
245              
246             sub load
247             {
248 11     11 1 60 my $self = shift( @_ );
249 11         252 my $f = $self->file;
250 11         817 my $json_file = $self->json_file;
251 11 100 66     752 if( defined( $PUBLIC_SUFFIX_DATA ) && ref( $PUBLIC_SUFFIX_DATA ) eq 'HASH' )
    100 66        
252             {
253 9         200 $self->suffixes( $PUBLIC_SUFFIX_DATA );
254 9         292490 $self->meta( {} );
255             }
256             elsif( $json_file && $json_file->exists )
257             {
258 1 50       115 $self->load_json( $json_file ) || return( $self->pass_error );
259 1         8 my $meta = $self->meta;
260 1 50 33     967 if( $f && $f->exists )
261             {
262 1 50 33     104 if( defined( $meta->{db_last_modified} ) && $meta->{db_last_modified} =~ /^\d{10}$/ )
263             {
264 1         74 my $mtime = $f->mtime;
265 1 50       6672 if( $mtime > $meta->{db_last_modified} )
266             {
267 0 0       0 $self->load_public_suffix( $f ) || return( $self->pass_error );
268 0 0       0 $self->save_as_json( $json_file ) || return( $self->pass_error );
269             }
270             }
271             else
272             {
273 0 0       0 $self->load_public_suffix( $f ) || return( $self->pass_error );
274 0 0       0 $self->save_as_json( $json_file ) || return( $self->pass_error );
275             }
276             }
277             }
278             else
279             {
280 1 0 33     99 return( $self->error( "No public suffix data file or json cache data file was specified." ) ) if( !$json_file && !$f );
281 1 50       36 $self->load_public_suffix( $f ) || return( $self->pass_error );
282 1 50       15 $self->save_as_json( $json_file ) || return( $self->pass_error );
283             }
284 11         16187 return( $self );
285             }
286              
287             sub load_json
288             {
289 1     1 1 12 my $self = shift( @_ );
290 1   50     10 my $file = shift( @_ ) || $self->json_file || return( $self->error( "No json file was specified." ) );
291 1 50       58 $file = $self->_is_a( $file, 'Module::Generic::File' ) ? $file : Module::Generic::File::file( "$file" );
292             # Basic error checking
293 1 50       132 if( !$file->exists )
    50          
    50          
294             {
295 0         0 return( $self->error( "Json data file provided \"$file\" does not exist." ) );
296             }
297             elsif( !$file->can_read )
298             {
299 0         0 return( $self->error( "Json data file provided \"$file\" lacks enough permission to read." ) );
300             }
301             elsif( $file->is_empty )
302             {
303 0         0 return( $self->error( "Json data file provided \"$file\" is empty." ) );
304             }
305 1         51810 my $json = $file->load_utf8;
306 1 50       10576 return( $self->error( "Unable to open the public suffix json data file in read mode: $!" ) ) if( !defined( $json ) );
307 1 50       1321 return( $self->error( "No data found from public domain json file \"$file\"." ) ) if( !CORE::length( $json ) );
308 1 50 33     8 try
  1         9  
  1         6  
  1         20  
  0         0  
  1         6  
  1         13  
  1         8  
309 1     1   8 {
310 1         107 my $j = JSON->new->relaxed;
311 1         21641 my $ref = $j->decode( $json );
312 1 50       16 if( ref( $ref->{suffixes} ) eq 'HASH' )
313             {
314 1         14 $PUBLIC_SUFFIX_DATA = $ref->{suffixes};
315 1         28 $self->suffixes( $ref->{suffixes} );
316             }
317 1 50       25723 $ref->{meta} = {} if( ref( $ref->{meta} ) ne 'HASH' );
318 1         14 $self->meta( $ref->{metadata} );
319 1         1619 return( $self );
320             }
321 1 0 0     28 catch( $e )
  0 0 33     0  
  0 0       0  
  1 0       10  
  1 0       6  
  1 0       4  
  1 0       3  
  1 0       23  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 0       0  
  0 50       0  
  0         0  
  0         0  
  0         0  
  1         20  
  0         0  
  1         15  
  0         0  
  0         0  
  1         9  
  1         6  
  1         4  
  1         6  
  0         0  
  0         0  
  0         0  
  0         0  
322 0     0   0 {
323 0         0 return( $self->error( "An unexpected error occurred while trying to load json data of public suffixes: $e" ) );
324 3 0 0 3   28 }
  3 0 0     7  
  3 0 33     4355  
  0 0 33     0  
  0 0 33     0  
  0 0 33     0  
  0 0 33     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  1 0       7  
  0 0       0  
  1 50       46  
  1 50       23  
  1 50       20  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         128  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
325             }
326              
327             sub load_public_suffix
328             {
329 1     1 1 20 my $self = shift( @_ );
330 1   50     14 my $file = shift( @_ ) || $self->file || return( $self->error( "No public suffix data file was provided." ) );
331 1 50       61 $file = $self->_is_a( $file, 'Module::Generic::File' ) ? $file : Module::Generic::File::file( "$file" );
332             # Basic error checking
333 1 50       116 if( !$file->exists )
    50          
    50          
334             {
335 0         0 return( $self->error( "Public suffix data file provided \"$file\" does not exist." ) );
336             }
337             elsif( !$file->can_read )
338             {
339 0         0 return( $self->error( "Public suffix data file provided \"$file\" lacks enough permission to read." ) );
340             }
341             elsif( $file->is_empty )
342             {
343 0         0 return( $self->error( "Public suffix data file provided \"$file\" is empty." ) );
344             }
345 1 50       51005 $file->open( '<', { binmode => 'utf-8' }) || return( $self->error( "Unable to open the public suffix data file in read mode: ", $file->error ) );
346 1         8349 my $ref = {};
347 1 50 33     8 try
  1         11  
  1         12  
  1         21  
  0         0  
  1         8  
  1         9  
  1         7  
348 1     1   8 {
349             $file->line(sub
350             {
351 13756         17418894 my $l = shift( @_ );
352 13756         27884 chomp( $l );
353 13756         41603 $l =~ s,//.*$,,;
354 13756         31629 $l =~ s,[[:blank:]\h]+$,,g;
355 13756 100       43227 return(1) if( !CORE::length( $l ) );
356 9021         11317 my $orig;
357 9021 100       34583 if( $l !~ /^[\x00-\x7f]*$/ )
358             {
359 461         749 $orig = $l;
360 461         1368 $l = Net::IDN::Encode::domain_to_ascii( $l );
361             }
362 9021         265415 my $is_neg = $l =~ s,^\!,,;
363 9021         31269 my @labels = split( /\./, $l );
364 9021         13404 my $h = $ref;
365 9021         16643 foreach my $label ( reverse( @labels ) )
366             {
367 19365   100     89802 $h = $h->{ $label } ||= {};
368             }
369 9021 100       18527 $h->{_is_neg} = $is_neg if( $is_neg );
370 9021 100       34935 $h->{_original} = $orig if( defined( $orig ) );
371 1         28 });
372             }
373 1 0 50     28 catch( $e )
  1 0 33     1301  
  1 0       5  
  1 0       10  
  1 0       8  
  1 0       6  
  1 0       6  
  1 0       20  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 0       0  
  0 50       0  
  0         0  
  0         0  
  0         0  
  1         22  
  0         0  
  1         12  
  0         0  
  0         0  
  1         12  
  1         8  
  1         5  
  1         6  
  0         0  
  0         0  
  0         0  
  0         0  
374 0     0   0 {
375 0         0 return( $self->error( "An unexpected error occurred while parsing the public suffix data file content: $e" ) );
376 3 0 0 3   29 }
  3 0 0     7  
  3 0 33     3906  
  0 0 33     0  
  0 0 33     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 33     0  
  0 0 33     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  1 0       8  
  0 0       0  
  1 0       69  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         125  
  1         10  
  0         0  
  0         0  
  0         0  
  1         4  
377 1         8 $file->close;
378 1         2597 $self->suffixes( $ref );
379 1         24951 $PUBLIC_SUFFIX_DATA = $ref;
380 1         7 return( $self );
381             }
382              
383 12     12 1 152 sub meta { return( shift->_set_get_hash_as_mix_object( 'meta', @_ ) ); }
384              
385 82     82 1 558 sub min_suffix { return( shift->_set_get_number( 'min_suffix', @_ ) ); }
386              
387 0     0 1 0 sub no_load { return( shift->_set_get_boolean( 'no_load', @_ ) ); }
388              
389             sub save_as_json
390             {
391 1     1 1 3 my $self = shift( @_ );
392 1   50     193 my $file = shift( @_ ) || $self->json_file || return( $self->error( "No json file was specified." ) );
393 1 50       28 $file = $self->_is_a( $file, 'Module::Generic::File' ) ? $file : Module::Generic::File::file( "$file" );
394 1         62 my $data = $self->suffixes;
395 1         950 my $tz;
396             # DateTime::TimeZone::Local will die ungracefully if the local timezeon is not set with the error:
397             # "Cannot determine local time zone"
398 1 50 33     3 try
  1         2  
  1         2  
  1         6  
  0         0  
  1         2  
  1         4  
  1         2  
399 1     1   3 {
400 1         36 $tz = DateTime::TimeZone->new( name => 'local' );
401             }
402 1 0 50     16 catch( $e )
  1 0 33     5669  
  1 0       4  
  1 0       4  
  1 0       1  
  1 0       2  
  1 0       2  
  1 0       5  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 0       0  
  0 50       0  
  0         0  
  0         0  
  0         0  
  1         6  
  0         0  
  1         3  
  0         0  
  0         0  
  1         3  
  1         6  
  1         3  
  1         4  
  0         0  
  0         0  
  0         0  
  0         0  
403 0     0   0 {
404 0         0 $tz = DateTime::TimeZone->new( name => 'UTC' );
405 3 0 0 3   37 }
  3 0 0     6  
  3 0 33     3407  
  0 0 33     0  
  0 0 33     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 33     0  
  0 0 33     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  1 0       3  
  0 0       0  
  1 0       46  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         5  
  0         0  
  0         0  
  0         0  
  0         0  
  1         5  
406 1         20 my $dt_fmt = DateTime::Format::Strptime->new(
407             pattern => '%FT%T%z',
408             locale => 'en_GB',
409             time_zone => $tz->name,
410             );
411 1         4715 my $today = DateTime->now( time_zone => $tz, formatter => $dt_fmt );
412 1         1084 my $meta = $self->meta;
413             my $ref =
414             {
415             metadata =>
416             {
417             created => $today->stringify,
418             module => 'Cookie::Domain',
419             ( $self->file && $self->file->exists ? ( db_last_modified => $self->file->mtime ) : () ),
420 1 50 33     1468 ( $meta->{etag} ? ( etag => $meta->{etag} ) : () ),
    50          
421             },
422             suffixes => $data
423             };
424 1         3360242 my $j = JSON->new->canonical->pretty->convert_blessed;
425 1 50 33     6 try
  1         2  
  1         3  
  1         6  
  0         0  
  1         2  
  1         4  
  1         2  
426 1     1   2 {
427 1         24 my $json = $j->encode( $ref );
428 1 50       36334 $file->unload_utf8( $json ) ||
429             return( $self->error( "Unable to write json data to file \"$file\": ", $file->error ) );
430 1         56015 return( $self );
431             }
432 1 0 0     17 catch( $e )
  0 0 33     0  
  0 0       0  
  1 0       4  
  1 0       2  
  1 0       2  
  1 0       3  
  1 0       6  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 50       0  
  0 0       0  
  0 50       0  
  0         0  
  0         0  
  0         0  
  1         5  
  0         0  
  1         4  
  0         0  
  0         0  
  1         5  
  1         6  
  1         3  
  1         4  
  0         0  
  0         0  
  0         0  
  0         0  
433 0     0   0 {
434 0         0 return( $self->error( "An error occurred while trying to save data to json file \"$file\": $e" ) );
435 3 0 0 3   26 }
  3 0 0     6  
  3 0 33     1829  
  0 0 33     0  
  0 0 33     0  
  0 0 33     0  
  0 0 33     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0 0     0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  1 0       4  
  0 0       0  
  1 50       38  
  1 50       14  
  1 50       7  
  0 0       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         295  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
436             }
437              
438             sub stat
439             {
440 97     97 1 220692 my $self = shift( @_ );
441 97   100     555 my $name = shift( @_ ) || return( $self->error( "No host name was provided" ) );
442 95         680 my $opts = $self->_get_args_as_hash( @_ );
443 95 100       3280 $opts->{min_suffix} = $self->min_suffix if( !exists( $opts->{min_suffix} ) );
444 95         520563 my $idn;
445             # Punnycode
446 95 100       1079 if( $name !~ /^[\x00-\x7f]*$/ )
447             {
448 12         31 $idn = $name;
449 12         64 $name = Net::IDN::Encode::domain_to_ascii( $name );
450 12         4738 $name = lc( $name );
451 12         88 $name =~ s/^[[:blank:]\h]+|[[:blank:]\h]+$//g;
452 12         48 $name =~s/\.$//;
453             }
454             else
455             {
456 83         555 $name =~ s/^\.|\.$//g;
457 83         324 $name = lc( $name );
458             }
459 95 50       1472 return( $self->error( "Malformed domain name \"$name\"" ) ) if( $name !~ /$DOMAIN_RE/ );
460 95         929 my $labels = $self->new_array( [split( /\./, $name )] );
461 95         3162 my $any = {};
462 95         231 my $host = {};
463 95         199 my $expt = {};
464 95         475 my $ref = $self->suffixes;
465 95         85536 my $def = $ref;
466 95         257 my $stack = [];
467             # The following algorithm is borrowed from IO-Socket-SSL
468             # for( my $i = 0; $i < scalar( @$labels ); $i++ )
469             $labels->reverse->for(sub
470             {
471             # my $label = $labels->[$i];
472 201     201   6444 my( $i, $label ) = @_;
473 201         343 my $buff = [];
474 201 100       1276 if( my $public_label_def = $def->{ $label } )
    100          
475             {
476             # name match, continue with next path element
477 121         2371 push( @$buff, $public_label_def );
478 121 100 66     693 if( exists( $public_label_def->{_is_neg} ) && $public_label_def->{_is_neg} )
479             {
480 4         40 $expt->{ $i + 1 }->{ $i + 1 } = -1;
481             }
482             else
483             {
484 117         665 $host->{ $i + 1 }->{ $i + 1 } = 1;
485             }
486             }
487             elsif( exists( $def->{ '*' } ) )
488             {
489 8         24 my $public_label_def = $def->{ '*' };
490 8         21 push( @$buff, $public_label_def );
491 8 50 33     45 if( exists( $public_label_def->{_is_neg} ) && $public_label_def->{_is_neg} )
492             {
493 0         0 $expt->{ $i + 1 }->{ $i + 1 } = -1;
494             }
495             else
496             {
497 8         35 $any->{ $i + 1 }->{ $i + 1 } = 1;
498             }
499             }
500            
501 3     3   28 no warnings 'exiting';
  3         8  
  3         1335  
502             LABEL:
503             # We found something
504 201 100       1304 if( @$buff )
505             {
506             # take out the one we just added
507 129         269 $def = shift( @$buff );
508             # if we are circling within the next_choice loop, add the previous step to $stack
509 129 50       435 push( @$stack, [ $buff, $i ] ) if( @$buff );
510             # go deeper
511 129         514 next;
512             # The following works too by the way, but let's keep it traditional
513             # return(1);
514             }
515              
516             # We did not find anything, so we backtrack
517 72 50       364 last if( !scalar( @$stack ) );
518             # The following works too by the way, but let's keep it traditional
519             # return if( !scalar( @$stack ) );
520             # Recall our last entry
521 0         0 ( $buff, $_[0] ) = @{ pop( @$stack ) };
  0         0  
522 0         0 goto LABEL;
523 95         710 });
524            
525             # remove all exceptions from wildcards
526 95 100       1519 delete( @$any{ keys( %$expt ) } ) if( scalar( keys( %$expt ) ) );
527             # get longest match
528 49         225 my( $len ) = sort{ $b <=> $a } (
529 95         1820 keys( %$any ), keys( %$host ), map{ $_-1 } keys( %$expt )
  4         33  
530             );
531 95 100       376 $len = $opts->{min_suffix} if( !defined( $len ) );
532 95 100       412 $len += int( $opts->{add} ) if( $opts->{add} );
533 95         290 my $suffix;
534             my $sub;
535 95 100       480 if( $len < $labels->length )
    50          
536             {
537 71         2899681 $suffix = $self->new_array( [ $labels->splice( -$len, $len ) ] );
538             }
539             elsif( $len > 0 )
540             {
541 24         977489 $suffix = $labels;
542 24         139 $labels = $self->new_array;
543             }
544             else
545             {
546 0         0 $suffix = $self->new_array;
547             }
548 95 100       83048 if( !$suffix->length )
549             {
550 10 50       410082 if( want( 'OBJECT' ) )
551             {
552 0         0 rreturn( Module::Generic::Null->new );
553             }
554             else
555             {
556 10         723 return( '' );
557             }
558             }
559 85         3466432 $suffix = $suffix->join( '.' );
560 85         17611 $name = $labels->pop;
561 85 100       6081 $sub = $labels->join( '.' ) if( $labels->length );
562 85 100       3455854 if( defined( $idn ) )
563             {
564 12         1909 $suffix = Net::IDN::Encode::domain_to_unicode( $suffix );
565 12 100       4078 $name = Net::IDN::Encode::domain_to_unicode( $name ) if( defined( $name ) );
566 12 100       2058 $sub = Net::IDN::Encode::domain_to_unicode( $sub ) if( defined( $sub ) );
567             }
568 85         11926 return(Cookie::Domain::Result->new({ name => $name, sub => $sub, suffix => $suffix }));
569             }
570              
571 107     107 1 672 sub suffixes { return( shift->_set_get_hash_as_mix_object( 'suffixes', @_ ) ); }
572              
573             # NOTE: Cookie::Domain::Result class
574             {
575             package
576             Cookie::Domain::Result;
577             BEGIN
578             {
579 3     3   26 use strict;
  3         7  
  3         78  
580 3     3   18 use warnings;
  3         6  
  3         108  
581 3     3   18 use parent qw( Module::Generic::Hash );
  3         6  
  3         27  
582 3     3   10251407 use Want;
  3         8  
  3         187  
583 3     3   510 our $VERSION = 'v0.1.0';
584             };
585            
586             sub domain
587             {
588 15     15   1200 my $self = shift( @_ );
589 15 50 33     88 if( !$self->name->length || !$self->suffix->length )
590             {
591 0         0 return( Module::Generic::Scalar->new( '' ) );
592             }
593 15         616882 return( $self->name->join( '.', $self->suffix ) );
594             }
595            
596 105     105   95749 sub name { return( shift->_set_get_scalar_as_object( 'name', @_ ) ); }
597              
598 75     75   147726 sub sub { return( shift->_set_get_scalar_as_object( 'sub', @_ ) ); }
599              
600 105     105   762813 sub suffix { return( shift->_set_get_scalar_as_object( 'suffix', @_ ) ); }
601             }
602              
603             1;
604             # NOTE: POD
605             __END__
606              
607             =encoding utf-8
608              
609             =head1 NAME
610              
611             Cookie::Domain - Domain Name Public Suffix Query Interface
612              
613             =head1 SYNOPSIS
614              
615             use Cookie::Domain;
616             my $dom = Cookie::Domain->new( min_suffix => 1, debug => 3 ) ||
617             die( Cookie::Domain->error, "\n" );
618             my $res = $dom->stat( 'www.example.or.uk' ) || die( $dom->error, "\n" );
619             # Check for potential errors;
620             die( $dom->error ) if( !defined( $res ) );
621             # stat() returns an empty string if nothing was found and undef upon error
622             print( "Nothing found\n" ), exit(0) if( !$res );
623             print( $res->domain, "\n" ); # example.co.uk
624             print( $res->name, "\n" ); # example
625             print( $res->sub, "\n" ); # www
626             print( $res->suffix, "\n" ); # co.uk
627              
628             # Load the public suffix. This is done automatically, so no need to do it
629             $dom->load_public_suffix( '/some/path/on/the/filesystem/data.txt' ) ||
630             die( $dom->error );
631             # Then, save it as json data for next time
632             $dom->save_as_json( '/var/domain/public_suffix.json' ) ||
633             die( $dom->error, "\n" );
634             say $dom->suffixes->length, " suffixes data loaded.";
635              
636             =head1 VERSION
637              
638             v0.1.3
639              
640             =head1 DESCRIPTION
641              
642             This is an interface to query the C<Public Suffix> list courtesy of the mozilla project.
643              
644             This list contains all the top level domains, a.k.a. zones and is used to determine what part of a domain name constitute the top level domain, what part is the domain, a.k.a. C<label> and what part (the rest) constitute the subdomain.
645              
646             Consider C<www.example.org>. In this example, C<org> is the top level domain, C<example> is the name, C<example.org> is the domain, and C<www> is the subdomain.
647              
648             This is easy enough, but there are cases where it is tricky to know which label (or part) is the domain part or the top level domain part. For example, C<www.example.com.sg>, C<com.sg> is the top level domain, C<example> the name, C<example.com.sg> is the domain, and C<www> the subdomain.
649              
650             This module will use a json cache data file to speed up the loading of the suffixes, a.k.a, top level domains, data.
651              
652             By default the location of this json file will be C<public_suffix.json> under your system temporary directory, but you can override this by specifying your own location upon object instantiation:
653              
654             my $dom = Cookie::Domain->new( json_file => '/home/joe/var/public_suffix.json' );
655              
656             =head1 METHODS
657              
658             =head2 new
659              
660             This initiates the package and take the following parameters either as an hash or hash reference:
661              
662             =over 4
663              
664             =item I<debug>
665              
666             Optional. If set with a positive integer, this will activate verbose debugging message
667              
668             =item I<file>
669              
670             Specify the location of the Public Suffix data file. The default one is under the same directory as this module with the file name C<public_suffix_list.txt>
671              
672             You can download a different (new) version and specify with this parameter where it will be found.
673              
674             =item I<json_file>
675              
676             Specify the location of the json cache data file. The default location is set using L<Module::Generic::File> to get the system temporary directory and the file name C<public_suffix.json>.
677              
678             This json file is created once upon initiating an object and if it does not already exist. See the L</json_file> method for more information.
679              
680             =item I<min_suffix>
681              
682             Sets the minimum suffix length required. Default to 0.
683              
684             =item I<no_load>
685              
686             If this is set to true, this will prevent the object instantiation method from loading the public suffix file upon object instantiation. Normally you would not want to do that, unless you want to control when the file is loaded before you call L</stat>. This is primarily used by L</cron_fetch>
687              
688             =back
689              
690             =head2 cron_fetch
691              
692             You need to have installed the package L<LWP::UserAgent> to use this method.
693              
694             This method can also be called as a package subroutine, such as C<Cookie::Domain::cron_fetch>
695            
696             Its purpose is to perform a remote connection to L<https://publicsuffix.org/list/effective_tld_names.dat> and check for an updated copy of the public suffix data file.
697              
698             It checks if the remote file has changed by using the http header field C<Last-Modified> in the server response, or if there is already an C<etag> stored in the cache, it performs a conditional http query using C<If-None-Matched>. See L<Mozilla documentation|https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/ETag> for more information on those types of query.
699              
700             This is important to save bandwidth and useless processing.
701              
702             If the file has indeed changed, L</save_as_json> is invoked to refresh the cache.
703              
704             It returns the object it was called with for chaining.
705              
706             =head2 decode
707              
708             Takes a domain name, or rather called a host name, such as C<www.東京.jp> or C<今何年.jp> and this will return its punycode ascii representation prefixed with a so-called ASCII Compatible Encoding, a.k.a. C<ACE>. Thus, using our previous examples, this would produce respectively C<www.xn--1lqs71d.jp> and C<xn--wmq0m700b.jp>
709              
710             Even if the host name contains non-ascii dots, they will be recognised. For example C<www。東京。jp> would still be successfully decoded to C<www.xn--1lqs71d.jp>
711              
712             If the host name provided is not an international domain name (a.k.a. IDN), it is simply returned as is. Thus, if C<www.example.org> is provided, it would return C<www.example.org>
713              
714             If an error occurred, it sets an error object and returns L<perlfunc/undef>. The error can then be retrieved using L<Module::Generic/error> inherited by this module.
715              
716             It uses L<Net::IDN::Encode/domain_to_ascii> to perform the actual decoding.
717              
718             =head2 encode
719              
720             This does the reverse operation from L</decode>.
721              
722             It takes a domain name, or rather called a host name, already decoded, and with its so called ASCII Compatible Encoding a.k.a. C<ACE> prefix C<xn--> such as C<xn--wmq0m700b.jp> and returns its encoded version in perl internal utf8 encoding. Using the previous example, and this would return C<今何年.jp>. The C<ACE> prefix is required to tell apart international domain name (a.k.a. IDN) from other pure ascii domain names.
723              
724             Just like in L</decode>, if a non-international domain name is provided, it is returned as is. Thus, if C<www.example.org> is provided, it would return C<www.example.org>
725              
726             Note that this returns the name in perl's internal utf8 encoding, so if you need to save it to an utf8 file or print it out as utf8 string, you still need to encode it in utf8 before. For example:
727              
728             use Cookie::Domain;
729             use open ':std' => ':utf8';
730             my $d = Cookie::Domain->new;
731             say $d->encode( "xn--wmq0m700b.jp" );
732              
733             Or
734              
735             use Cookie::Domain;
736             use Encode;
737             my $d = Cookie::Domain->new;
738             my $encoded = $d->encode( "xn--wmq0m700b.jp" );
739             say Encode::encode_utf8( $encoded );
740              
741             If an error occurred, it sets an error object and returns L<perlfunc/undef>. The error can then be retrieved using L<Module::Generic/error> inherited by this module.
742              
743             It uses L<Net::IDN::Encode/domain_to_unicode> to perform the actual encoding.
744              
745             =head2 file
746              
747             Sets the file path to the Public Suffix file. This file is a public domain file at the initiative of Mozilla Foundation and its latest version can be accessed here: L<https://publicsuffix.org/list/>
748              
749             =head2 json_file
750              
751             Sets the file path of the json cache data file. THe purpose of this file is to contain a json representation of the parsed data from the Public Suffix data file. This is to avoid re-parsing it each time and instead load the json file using the XS module L<JSON>
752              
753             =head2 load
754              
755             This method takes no parameter and relies on the properties set with L</file> and L</json_file>.
756              
757             If the hash data is already accessibly in a module-wide variable, the data is taken from it.
758              
759             Otherwise, if json_file is set and accessible, this will load the data from it, otherwise, it will load the data from the file specified with L</file> and save it as json.
760              
761             If the json file meta data enclosed, specifically the property I<db_last_modified> has a unix timestamp value lower than the last modification timestamp of the public suffix data file, then, L</load> will reload that data file and save it as json again.
762              
763             That way, all you need to do is set up a crontab to fetch the latest version of that public suffix data file.
764              
765             For example, to fetch it every day at 1:00 in the morning:
766              
767             0 1 * * * perl -MCookie::Domain -e 'Cookie::Domain::cron_fetch' >/dev/null 2>&1
768              
769             But if you want to store the public suffix data file somewhere other than the default location:
770              
771             0 1 * * * perl -MCookie::Domain -e 'my $d=Cookie::Domain->new(file=>"/some/system/file.txt"); $d->cron_fetch' >/dev/null 2>&1
772              
773             See your machine manpage for C<crontab> for more detail.
774              
775             The data read are loaded into L</suffixes>.
776              
777             It returns the current object for chaining.
778              
779             =head2 load_json
780              
781             This takes a file path to the json cache data as the only argument, and attempt to read its content and set it onto the data accessible with L</suffixes>.
782              
783             If an error occurs, it set an error object using L<Module::Generic/error> and returns L<perlfunc/undef>
784              
785             It returns its current object for chaining.
786              
787             =head2 load_public_suffix
788              
789             This is similar to the method L</load_json> above.
790              
791             This takes a file path to the Public Suffix data as the only argument, read its content, parse it using the algorithm described at L<https://publicsuffix.org/list/> and set it onto the data accessible with L</suffixes> and also onto the package-wide global variable to make the data available across object instantiations.
792              
793             If an error occurs, it set an error object using L<Module::Generic/error> and returns L<perlfunc/undef>
794              
795             It returns its current object for chaining.
796              
797             =head2 meta
798              
799             Returns an L<hash object|Module::Generic::Hash> of meta information pertaining to the public suffix file. This is used primarily by L</cron_fetch>
800              
801             =head2 min_suffix
802              
803             Sets or gets the minimum suffix required as an integer value.
804              
805             It returns the current value as a L<Module::Generic::Number> object.
806              
807             =head2 no_load
808              
809             If this is set to true, this will prevent the object instantiation method from loading the public suffix file upon object instantiation. Normally you would not want to do that, unless you want to control when the file is loaded before you call L</stat>. This is primarily used by L</cron_fetch>
810              
811             =head2 save_as_json
812              
813             This takes as sole argument the file path where to save the json cache data and save the data accessible with L</suffixes>.
814              
815             It returns the current object for chaining.
816              
817             If an error occurs, it set an error object using L<Module::Generic/error> and returns L<perlfunc/undef>
818              
819             =head2 stat
820              
821             This takes a domain name, such as C<www.example.org> and optionally an hash reference of options and returns:
822              
823             =over 4
824              
825             =item C<undef()>
826              
827             If an error occurred.
828              
829             my $rv = $d->stat( 'www.example.org' );
830             die( "Error: ", $d->error ) if( !defined( $rv ) );
831              
832             =item empty string
833              
834             If there is no data available such as when querying a non existing top level domain.
835              
836             =item A C<Cookie::Domain::Result> object
837              
838             An object with the following properties and methods, although not all are necessarily defined, depending on the results.
839              
840             Accessed as an hash property and this return a regular string, but accessed as a method and they will return a L<Module::Generic::Scalar> object.
841              
842             =over 8
843              
844             =item I<name>
845              
846             The label that immediately follows the suffix (i.e. on its lefthand side).
847              
848             For example, in C<www.example.org>, the I<name> would be C<example>
849              
850             my $res = $dom->stat( 'www.example.org' ) || die( $dom->error );
851             say $res->{name}; # example
852             # or alternatively
853             say $res->name; # example
854              
855             =item I<sub>
856              
857             The sub domain or sub domains that follows the domain on its lefthand side.
858              
859             For example, in C<www.paris.example.fr>, C<www.paris> is the I<sub> and C<example> the I<name>
860              
861             my $res = $dom->stat( 'www.paris.example.fr' ) || die( $dom->error );
862             say $res->{sub}; # www.paris
863             # or alternatively
864             say $res->sub; # www.paris
865              
866             =item I<suffix>
867              
868             The top level domain or I<suffix>. For example, in C<example.com.sg>, C<com.sg> is the suffix and C<example> the I<name>
869              
870             my $res = $dom->stat( 'example.com.sg' ) || die( $dom->error );
871             say $res->{suffix}; # com.sg
872             # or alternatively
873             say $res->suffix; # com.sg
874              
875             What constitute a suffix varies from zone to zone or country to country, hence the necessity of this public domain suffix data file.
876              
877             =back
878              
879             C<Cookie::Domain::Result> objects inherit from L<Module::Generic::Hash>, thus you can do:
880              
881             my $res = $dom->stat( 'www.example.org' ) || die( $dom->error );
882             say $res->length, " properties set.";
883             # which should say 3 since we alway return suffix, name and sub
884              
885             The following additional method is also available as a convenience:
886              
887             =over 8
888              
889             =item I<domain>
890              
891             This is a read only method which returns and empty L<Module::Generic::Scalar> object if the I<name> property is empty, or the properties I<name> and I<suffix> join by a dot '.' and returned as a new L<Module::Generic::Scalar> object.
892              
893             my $res = $dom->stat( 'www.example.com.sg' ) || die( $dom->error );
894             say $res->domain; # example.com.sg
895             say $res->domain->length; # 14
896              
897             =back
898              
899             =back
900              
901             The options accepted are:
902              
903             =over 4
904              
905             =item I<add>
906              
907             This is an integer, and represent the additional length to be added, for the domain name.
908              
909             =item I<min_suffix>
910              
911             This is an integer, and if provided, will override the default value set with L</min_suffix>
912              
913             =back
914              
915             =head2 suffixes
916              
917             This method is used to access the hash repository of all the public suffix data.
918              
919             It is actually an L<Module::Generic::Hash> object. So you could do:
920              
921             say "There are ", $dom->suffixes->length, " rules.";
922              
923             =head1 AUTHOR
924              
925             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
926              
927             =head1 SEE ALSO
928              
929             L<Cookie>, L<Cookie::Jar>, L<Mozilla::PublicSuffix>, L<Domain::PublicSuffix>, L<Net::PublicSuffixList>
930              
931             L<https://publicsuffix.org/list/>
932              
933             =head1 COPYRIGHT & LICENSE
934              
935             Copyright (c) 2021 DEGUEST Pte. Ltd.
936              
937             You can use, copy, modify and redistribute this package and associated files under the same terms as Perl itself.
938              
939             =cut