Permalink
Browse files

tweak pod, get release tests passing ahead of first release

  • Loading branch information...
1 parent 978cdf3 commit 6e56bd3c6f80d61c500693ca597bf7f8d1772197 Richard Simões committed Mar 6, 2012
Showing with 152 additions and 95 deletions.
  1. +13 −0 .gitignore
  2. +25 −19 Build.PL
  3. +2 −0 Changes
  4. +4 −1 dist.ini
  5. +36 −70 lib/Mozilla/PublicSuffix.pm
  6. +66 −0 lib/Mozilla/PublicSuffix.pod
  7. +6 −5 t/01-psuffix.t
View
@@ -0,0 +1,13 @@
+blib*
+Makefile
+Makefile.old
+Build
+_build*
+.build*
+pm_to_blib*
+*.tar.gz
+.lwpcookies
+Mozilla-PublicSuffix*
+cover_db
+*#*
+~*
View
@@ -8,17 +8,31 @@ use HTTP::Tiny;
use Module::Build;
use Tie::File;
+my $builder = Module::Build->new(
+ dist_name => "Mozilla-PublicSuffix",
+ license => "LGPL_3_0",
+ dist_abstract => q(Get a domain name's public suffix via Mozilla's Public Suffix List),
+ dist_author => q"Richard Simões <rsimoes AT cpan DOT org>",
+ dist_version_from => "lib/Mozilla/PublicSuffix.pm",
+ # Prerequisites inserted by DistZilla:
+ ##{ $plugin->get_prereqs ##}
+ );
+
my $DAT = "effective_tld_names.dat";
-if ( -M $DAT > 30 ) {
- my $http = HTTP::Tiny->new( timeout => 6 );
- my $list_uri = "http://mxr.mozilla.org"
- . "/mozilla-central/source/netwerk/dns/$DAT?raw=1";
- my %options = (
- headers => {
- "If-Modified-Since" => "Wed, 22 Feb 2012 16:00:41 GMT" } );
- my $response = $http->get( $list_uri, \%options );
- $response->{status} == 200
- and IO::File->new($DAT, "w")->print( $response->{content} ); }
+-M $DAT > 30 and do {
+ $builder->y_n(
+ "Check for a new version of the Public Suffix List?", "Y" )
+ and do {
+ my $http = HTTP::Tiny->new( timeout => 6 );
+ my $list_uri = "http://mxr.mozilla.org"
+ . "/mozilla-central/source/netwerk/dns/$DAT?raw=1";
+ my %options = (
+ headers => {
+ "If-Modified-Since" => "Wed, 22 Feb 2012 16:00:41 GMT" } );
+ my $response = $http->get( $list_uri, \%options );
+ $response->{status} == 200
+ and IO::File->new($DAT, "w")->print(
+ $response->{content} ); } };
# Divide rules from list into sets:
my $rules = join " ", map {
@@ -33,12 +47,4 @@ tie my @pm, "Tie::File", "lib/Mozilla/PublicSuffix.pm";
for (@pm) { s/(my %rules = qw\()/$1$rules/ and last }
untie @pm;
-my $builder = Module::Build->new(
- dist_name => "Mozilla-PublicSuffix",
- license => "LGPL_3_0",
- dist_abstract => q(Get a domain name's "public suffix" via Mozilla's Public Suffix List),
- dist_author => q"Richard Simões <rsimoes AT cpan DOT org>",
- dist_version_from => "lib/Mozilla/PublicSuffix.pm",
- # Prerequisites inserted by DistZilla:
- ##{ $plugin->get_prereqs ##}
- )->create_build_script;
+$builder->create_build_script;
View
@@ -0,0 +1,2 @@
+{{$NEXT}}
+ - First version, released on an unsuspecting world.
View
@@ -12,7 +12,7 @@ version = v0.0.1
[ModuleBuild::Custom]
[@TestingMania]
-disable = NoTabsTest
+disable = NoTabsTests
[@Git]
commit_msg = %v%n%n%c
@@ -31,6 +31,8 @@ skip = ^(?:base|strict|warnings|if|utf8|charnames|open|parent|re|subs|version|Ca
[Clean]
+[CoalescePod]
+
[ExtraTests]
[Git::CommitBuild]
@@ -45,3 +47,4 @@ skip = ^(?:base|strict|warnings|if|utf8|charnames|open|parent|re|subs|version|Ca
[Test::PodSpelling]
stopwords = Simões
+stopwords = Mozilla's
View
@@ -4,6 +4,8 @@ use strict;
use warnings FATAL => "all";
use utf8;
use parent "Exporter";
+use Carp ();
+use Net::LibIDN qw(idn_prep_name idn_to_ascii idn_to_unicode);
our @EXPORT_OK = qw(public_suffix);
@@ -12,75 +14,39 @@ our @EXPORT_OK = qw(public_suffix);
my %rules = qw();
sub public_suffix {
- my ($domain) = @_;
-
- # Test domain well-formedness:
- return undef if !$domain || ! eval {
- use Net::LibIDN qw(idn_prep_name idn_to_ascii idn_to_unicode);
- $domain = idn_to_unicode idn_to_ascii idn_prep_name $domain };
-
- # Gather matching rules:
- my @labels = split /\./, $domain;
- my @matches;
- for my $i ( 0 .. $#labels) {
- my $label = join ".", @labels[ $i .. $#labels ];
- exists $rules{$label} and push @matches, { type => $rules{$label},
- label => $label }; }
- @matches = sort { $b->{label} =~ /\./g <=> $a->{label} =~ /\./g } @matches;
-
- # Choose prevailing rule and return suffix, if one is to be found:
- return do {
- @matches == 0
- ? undef
- : do {
- my @exc_rules = grep { $_->{type} eq "e" } @matches;
- @exc_rules > 0
- ? do {
- @exc_rules == 1
- ? undef
- : do {
- # Recheck domain with label trimmed off
- @_ = $exc_rules[0]{label} =~ /^[^.]+\.(.*)$/;
- goto &public_suffix; } }
- : do {
- my ($type, $label) = @{$matches[0]}{qw(type label)};
- $type eq "w" and
- ($label) = $domain =~ /((?:[^.]+\.)$label)$/;
- $label ||= undef; } } }; }
-
-
-# Definitions
-
-# - The Public Suffix List consists of a series of lines, separated by \n.
-# - Each line is only read up to the first whitespace; entire lines can also be
-# commented using //.
-# - Each line which is not entirely whitespace or begins with a comment contains
-# a rule.
-# - A rule may begin with a "!" (exclamation mark). If it does, it is labelled
-# as a "exception rule" and then treated as if the exclamation mark is not
-# present.
-# - A domain or rule can be split into a list of labels using the separator "."
-# (dot). The separator is not part of any of the labels.
-# - A domain is said to match a rule if, when the domain and rule are both
-# split, and one compares the labels from the rule to the labels from the
-# domain, beginning at the right hand end, one finds that for every pair
-# either they are identical, or that the label from the rule is "*" (star).
-# - The domain may legitimately have labels remaining at the end of this
-# matching process.
-
-# Algorithm
-
-# - Match domain against all rules and take note of the matching ones.
-# - If no rules match, the prevailing rule is "*".
-# - If more than one rule matches, the prevailing rule is the one which is an
-# exception rule.
-# - If there is no matching exception rule, the prevailing rule is the one with
-# the most labels.
-# - If the prevailing rule is a exception rule, modify it by removing the
-# leftmost label.
-# - The public suffix is the set of labels from the domain which directly
-# match the labels of the prevailing rule (joined by dots).
-# - The registered or registrable domain is the public suffix plus one
-# additional label.
+ my ($domain) = @_;
+
+ # Test domain well-formedness:
+ eval { $domain = idn_to_unicode idn_to_ascii idn_prep_name $domain }
+ or Carp::croak("Argument passed is not a well-formed domain name");
+
+ # Gather matching rules:
+ my @labels = split /\./, $domain;
+ my @matches;
+ for my $i ( 0 .. $#labels) {
+ my $label = join ".", @labels[ $i .. $#labels ];
+ exists $rules{$label} and push @matches, { type => $rules{$label},
+ label => $label }; }
+ @matches = sort { $b->{label} =~ /\./g <=> $a->{label} =~ /\./g } @matches;
+
+ # Choose prevailing rule and return suffix, if one is to be found:
+ return do {
+ @matches == 0
+ ? undef
+ : do {
+ my @exc_rules = grep { $_->{type} eq "e" } @matches;
+ @exc_rules > 0
+ ? do {
+ @exc_rules == 1
+ ? undef
+ : do {
+ # Recheck with left-mode label chopped off
+ @_ = $exc_rules[0]{label} =~ /^[^.]+\.(.*)$/;
+ goto &public_suffix; } }
+ : do {
+ my ($type, $label) = @{$matches[0]}{qw(type label)};
+ $type eq "w"
+ and ($label) = $domain =~ /((?:[^.]+\.)$label)$/;
+ $label ||= undef; } } }; }
1;
@@ -0,0 +1,66 @@
+=encoding utf8
+
+=head1 NAME
+
+Mozilla::PublicSuffix - Get a domain name's public suffix via Mozilla's Public Suffix List
+
+=head1 SYNOPSIS
+
+ use feature "say";
+ use Mozilla::PublicSuffix "public_suffix";
+
+ say public_suffix("org"); # "org"
+ say public_suffix("perl.org"); # "org"
+ say public_suffix("perl.orc"); # undef
+ say public_suffix("ga.gov.au"); # "gov.au"
+ say public_suffix("ga.goo.au"); # undef
+
+=head1 DESCRIPTION
+
+This module provides a single function that returns the I<public suffix> of a
+domain name by referencing a parsed copy of Mozilla's Public Suffix List
+(official website at L<http://publicsuffix.org>). The algorithm is not the one
+prescribed on Mozilla's website, but a robust test battery included in this
+distribution should provide sufficient evidence that the one used in its placed
+is an acceptable substitute.
+
+A copy of the official list is bundled with the distribution. As the official
+list continues to be updated, the bundled copy will inevitably fall out of date.
+Therefore, if the bundled copy of found to be over thirty days old, this
+distribution's installer provides the option to check for a new version of the
+list and download/use it if one is found.
+
+=head1 FUNCTIONS
+
+=over
+
+=item public_suffix
+
+Exported on request. Simply returns the public suffix of the passed argument,
+or C<undef> if the public suffix is not found. Croaks if the passed argument
+is not a well-formed domain name.
+
+=back
+
+=head1 SEE ALSO
+
+=over
+
+=item L<Domain::PublicSuffix>
+
+An alternative to this module, with an object-oriented interface and slightly
+difference interpretation of the rules Mozilla stipulates for determining a
+public suffix.
+
+=back
+
+=head1 AUTHOR
+
+Richard Simões C<< <rsimoes AT cpan DOT org> >>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright © 2012 Richard Simões. This module is released under the terms of the
+L<GNU Lesser General Public License v. 3.0|http://gnu.org/licenses/lgpl.html>
+and may be modified and/or redistributed under the same or any compatible
+license.
View
@@ -3,19 +3,20 @@
use strict;
use warnings FATAL => "all";
use Test::More tests => 62;
+use Test::Exception;
use Mozilla::PublicSuffix "public_suffix";
# undef input.
-is public_suffix(undef), undef;
+dies_ok { public_suffix(undef) };
# Mixed case.
is public_suffix("COM"), "com";
is public_suffix("example.COM"), "com";
is public_suffix("WwW.example.COM"), "com";
# Leading dot.
-is public_suffix(".com"), undef;
-is public_suffix(".example"), undef;
-is public_suffix(".example.com"), undef;
-is public_suffix(".example.example"), undef;
+dies_ok { public_suffix(".com") };
+dies_ok { public_suffix(".example") };
+dies_ok { public_suffix(".example.com") };
+dies_ok { public_suffix(".example.example") };
# Unlisted TLD.
is public_suffix("example"), undef;
is public_suffix("example.example"), undef;

0 comments on commit 6e56bd3

Please sign in to comment.