Cookie
view release on metacpan or search on metacpan
lib/Cookie/Domain.pm view on Meta::CPAN
}
if( $code == 304 ||
( !$file->is_empty && $mtime && $mtime == $epoch ) )
{
if( !$self->suffixes->length )
{
$self->load_public_suffix || return( $self->pass_error );
}
# Did not have an etag, but I do have one now
if( $dont_have_etag && $meta->{etag} )
{
$self->save_as_json || return( $self->pass_error );
}
return( $self );
}
elsif( $code ne 200 )
{
return( $self->error( "Failed to get the remote public domain list. Server responded with code '$code': ", $resp->as_string ) );
}
elsif( !length( $data ) )
{
return( $self->error( "Remote server returned no data." ) );
}
$file->unload_utf8( $data, { lock => 1 } ) || return( $self->error( "Unable to open public suffix data file \"$file\" in write mode: ", $file->error ) );
$file->unlock;
$file->utime( $epoch, $epoch );
$self->load_public_suffix || return( $self->pass_error );
$self->save_as_json || return( $self->pass_error );
return( $self );
}
sub decode
{
my $self = shift( @_ );
my $name = shift( @_ );
return( '' ) if( !length( $name ) );
# try-catch
local $@;
my $rv = eval
{
return( Net::IDN::Encode::domain_to_ascii( $name ) );
};
if( $@ )
{
return( $self->error( "An unexpected error occurred while decoding a domain name: $@" ) );
}
return( $rv );
}
sub encode
{
my $self = shift( @_ );
my $name = shift( @_ );
return( '' ) if( !length( $name ) );
# try-catch
local $@;
my $rv = eval
{
return( Net::IDN::Encode::domain_to_unicode( $name ) );
};
if( $@ )
{
return( $self->error( "An unexpected error occurred while encoding a domain name: $@" ) );
}
return( $rv );
}
sub file { return( shift->_set_get_object_without_init( 'file', 'Module::Generic::File', @_ ) ); }
sub json_file { return( shift->_set_get_object_without_init( 'json_file', 'Module::Generic::File', @_ ) ); }
sub load
{
my $self = shift( @_ );
my $f = $self->file;
my $json_file = $self->json_file;
if( defined( $PUBLIC_SUFFIX_DATA ) && ref( $PUBLIC_SUFFIX_DATA ) eq 'HASH' )
{
$self->suffixes( $PUBLIC_SUFFIX_DATA );
$self->meta( {} );
}
elsif( $json_file && $json_file->exists )
{
$self->load_json( $json_file ) || return( $self->pass_error );
my $meta = $self->meta;
if( $f && $f->exists )
{
if( defined( $meta->{db_last_modified} ) && $meta->{db_last_modified} =~ /^\d{10}$/ )
{
my $mtime = $f->mtime;
if( $mtime > $meta->{db_last_modified} )
{
$self->load_public_suffix( $f ) || return( $self->pass_error );
$self->save_as_json( $json_file ) || return( $self->pass_error );
}
}
else
{
$self->load_public_suffix( $f ) || return( $self->pass_error );
$self->save_as_json( $json_file ) || return( $self->pass_error );
}
}
}
else
{
return( $self->error( "No public suffix data file or json cache data file was specified." ) ) if( !$json_file && !$f );
$self->load_public_suffix( $f ) || return( $self->pass_error );
$self->save_as_json( $json_file ) || return( $self->pass_error );
}
return( $self );
}
sub load_json
{
my $self = shift( @_ );
my $file = shift( @_ ) || $self->json_file || return( $self->error( "No json file was specified." ) );
$file = $self->_is_a( $file, 'Module::Generic::File' ) ? $file : Module::Generic::File::file( "$file" );
# Basic error checking
if( !$file->exists )
lib/Cookie/Domain.pm view on Meta::CPAN
}
my $dt_fmt = DateTime::Format::Strptime->new(
pattern => '%FT%T%z',
locale => 'en_GB',
time_zone => $tz->name,
);
my $today = DateTime->now( time_zone => $tz, formatter => $dt_fmt );
my $meta = $self->meta;
my $ref =
{
metadata =>
{
created => $today->stringify,
module => 'Cookie::Domain',
( $self->file && $self->file->exists ? ( db_last_modified => $self->file->mtime ) : () ),
( $meta->{etag} ? ( etag => $meta->{etag} ) : () ),
},
suffixes => $data
};
my $j = JSON->new->canonical->pretty->convert_blessed;
# try-catch
my $json = eval
{
$j->encode( $ref );
};
if( $@ )
{
return( $self->error( "An error occurred while trying to save data to json file \"$file\": $@" ) );
}
$file->unload_utf8( $json ) ||
return( $self->error( "Unable to write json data to file \"$file\": ", $file->error ) );
return( $self );
}
sub stat
{
my $self = shift( @_ );
my $name = shift( @_ ) || return( $self->error( "No host name was provided" ) );
my $opts = $self->_get_args_as_hash( @_ );
$opts->{min_suffix} = $self->min_suffix if( !exists( $opts->{min_suffix} ) );
my $idn;
# Punnycode
if( $name !~ /^[\x00-\x7f]*$/ )
{
$idn = $name;
$name = Net::IDN::Encode::domain_to_ascii( $name );
$name = lc( $name );
$name =~ s/^[[:blank:]\h]+|[[:blank:]\h]+$//g;
$name =~s/\.$//;
}
else
{
$name =~ s/^\.|\.$//g;
$name = lc( $name );
}
return( $self->error( "Malformed domain name \"$name\"" ) ) if( $name !~ /$DOMAIN_RE/ );
my $labels = $self->new_array( [split( /\./, $name )] );
# if( $labels->length == 1 && !$opts->{min_suffix} )
# {
# my $single = $labels->[0];
# my $name_out = defined( $idn ) ? Net::IDN::Encode::domain_to_unicode( $single ) : $single;
# return( Cookie::Domain::Result->new({ name => $name_out, sub => undef, suffix => '' }) );
# }
my $any = {};
my $host = {};
my $expt = {};
my $ref = $self->suffixes;
my $def = $ref;
my $stack = [];
# The following algorithm is borrowed from IO-Socket-SSL
# for( my $i = 0; $i < scalar( @$labels ); $i++ )
# $labels->reverse->for(sub
my $reverse = $labels->reverse;
for( my $i = 0; $i < scalar( @$reverse ); $i++ )
{
my $label = $reverse->[$i];
# my( $i, $label ) = @_;
my $buff = [];
if( my $public_label_def = $def->{ $label } )
{
# name match, continue with next path element
push( @$buff, $public_label_def );
if( exists( $public_label_def->{_is_neg} ) && $public_label_def->{_is_neg} )
{
$expt->{ $i + 1 }->{ $i + 1 } = -1;
}
else
{
$host->{ $i + 1 }->{ $i + 1 } = 1;
}
}
elsif( exists( $def->{ '*' } ) )
{
my $public_label_def = $def->{ '*' };
push( @$buff, $public_label_def );
if( exists( $public_label_def->{_is_neg} ) && $public_label_def->{_is_neg} )
{
$expt->{ $i + 1 }->{ $i + 1 } = -1;
}
else
{
$any->{ $i + 1 }->{ $i + 1 } = 1;
}
}
no warnings 'exiting';
LABEL:
# We found something
if( @$buff )
{
# take out the one we just added
$def = shift( @$buff );
# if we are circling within the next_choice loop, add the previous step to $stack
push( @$stack, [ $buff, $i ] ) if( @$buff );
# go deeper
next;
# The following works too by the way, but let's keep it traditional
# return(1);
}
# We did not find anything, so we backtrack
last if( !scalar( @$stack ) );
# The following works too by the way, but let's keep it traditional
# return if( !scalar( @$stack ) );
# Recall our last entry
( $buff, $_[0] ) = @{ pop( @$stack ) };
goto LABEL;
# });
}
# remove all exceptions from wildcards
delete( @$any{ keys( %$expt ) } ) if( scalar( keys( %$expt ) ) );
# get longest match
my( $len ) = sort{ $b <=> $a } (
keys( %$any ), keys( %$host ), map{ $_-1 } keys( %$expt )
);
$len = $opts->{min_suffix} if( !defined( $len ) );
$len += int( $opts->{add} ) if( $opts->{add} );
my $suffix;
my $sub;
if( $len < $labels->length )
{
$suffix = $self->new_array( [ $labels->splice( -$len, $len ) ] );
}
elsif( $len > 0 )
{
$suffix = $labels;
$labels = $self->new_array;
}
else
{
$suffix = $self->new_array;
}
if( !$suffix->length )
{
if( want( 'OBJECT' ) )
{
rreturn( Module::Generic::Null->new );
}
else
{
return( '' );
}
}
$suffix = $suffix->join( '.' );
$name = $labels->pop;
$sub = $labels->join( '.' ) if( $labels->length );
if( defined( $idn ) )
{
$suffix = Net::IDN::Encode::domain_to_unicode( $suffix );
$name = Net::IDN::Encode::domain_to_unicode( $name ) if( defined( $name ) );
$sub = Net::IDN::Encode::domain_to_unicode( $sub ) if( defined( $sub ) );
}
return(Cookie::Domain::Result->new({ name => $name, sub => $sub, suffix => $suffix }));
}
sub suffixes { return( shift->_set_get_hash_as_mix_object( 'suffixes', @_ ) ); }
# NOTE: Cookie::Domain::Result class
{
package
Cookie::Domain::Result;
BEGIN
{
use strict;
use warnings;
use parent qw( Module::Generic::Hash );
use Wanted;
our $VERSION = 'v0.1.0';
};
sub domain
{
my $self = shift( @_ );
if( !$self->name->length && !$self->suffix->length )
{
return( Module::Generic::Scalar->new( '' ) );
}
return( $self->name->join( '.', $self->suffix ) );
}
sub name { return( shift->_set_get_scalar_as_object( 'name', @_ ) ); }
sub sub { return( shift->_set_get_scalar_as_object( 'sub', @_ ) ); }
sub suffix { return( shift->_set_get_scalar_as_object( 'suffix', @_ ) ); }
}
1;
# NOTE: POD
__END__
=encoding utf-8
=head1 NAME
Cookie::Domain - Domain Name Public Suffix Query Interface
=head1 SYNOPSIS
use Cookie::Domain;
my $dom = Cookie::Domain->new( min_suffix => 1, debug => 3 ) ||
die( Cookie::Domain->error, "\n" );
my $res = $dom->stat( 'www.example.or.uk' ) || die( $dom->error, "\n" );
# Check for potential errors;
die( $dom->error ) if( !defined( $res ) );
# stat() returns an empty string if nothing was found and undef upon error
print( "Nothing found\n" ), exit(0) if( !$res );
print( $res->domain, "\n" ); # example.co.uk
print( $res->name, "\n" ); # example
print( $res->sub, "\n" ); # www
print( $res->suffix, "\n" ); # co.uk
lib/Cookie/Domain.pm view on Meta::CPAN
=item * C<no_load>
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</sta...
=back
=head2 cron_fetch
You need to have installed the package L<LWP::UserAgent> to use this method.
This method can also be called as a package subroutine, such as C<Cookie::Domain::cron_fetch>
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.
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 docum...
This is important to save bandwidth and useless processing.
If the file has indeed changed, L</save_as_json> is invoked to refresh the cache.
It returns the object it was called with for chaining.
=head2 decode
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 example...
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>
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>
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.
It uses L<Net::IDN::Encode/domain_to_ascii> to perform the actual decoding.
=head2 encode
This does the reverse operation from L</decode>.
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...
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>
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:
use Cookie::Domain;
use open ':std' => ':utf8';
my $d = Cookie::Domain->new;
say $d->encode( "xn--wmq0m700b.jp" );
Or
use Cookie::Domain;
use Encode;
my $d = Cookie::Domain->new;
my $encoded = $d->encode( "xn--wmq0m700b.jp" );
say Encode::encode_utf8( $encoded );
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.
It uses L<Net::IDN::Encode/domain_to_unicode> to perform the actual encoding.
=head2 file
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/>
=head2 json_file
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 mod...
=head2 load
This method takes no parameter and relies on the properties set with L</file> and L</json_file>.
If the hash data is already accessibly in a module-wide variable, the data is taken from it.
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.
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 aga...
That way, all you need to do is set up a crontab to fetch the latest version of that public suffix data file.
For example, to fetch it every day at 1:00 in the morning:
0 1 * * * perl -MCookie::Domain -e 'Cookie::Domain::cron_fetch' >/dev/null 2>&1
But if you want to store the public suffix data file somewhere other than the default location:
0 1 * * * perl -MCookie::Domain -e 'my $d=Cookie::Domain->new(file=>"/some/system/file.txt"); $d->cron_fetch' >/dev/null 2>&1
See your machine manpage for C<crontab> for more detail.
The data read are loaded into L</suffixes>.
It returns the current object for chaining.
=head2 load_json
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>.
If an error occurs, it set an error object using L<Module::Generic/error> and returns L<perlfunc/undef>
It returns its current object for chaining.
=head2 load_public_suffix
This is similar to the method L</load_json> above.
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 ...
If an error occurs, it set an error object using L<Module::Generic/error> and returns L<perlfunc/undef>
It returns its current object for chaining.
=head2 meta
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>
=head2 min_suffix
Sets or gets the minimum suffix required as an integer value.
( run in 1.537 second using v1.01-cache-2.11-cpan-63c85eba8c4 )