Subversion Repositories SE.SVN

Rev

Details | Last modification | View Log | RSS feed

Rev Author Line No. Line
40 7u83 1 
#!perl
2 
 
3 
use strict;
4 
use warnings;
5 
 
6 
open my $fh, "<", "publicsuffix.dat";
7 
 
8 
my $tree = {};
9 
 
10 
while (<$fh>) {
11 
	chomp;
12 
	next if m{^//};
13 
	next if /^\s+$/;
14 
	next if /[^a-z\.]/; # skipping non latin1 domains
15 
	my @parts = reverse split /\./, $_;
16 
	my $head = $tree;
17 
	for my $p (@parts) {
18 
		if ( ! $head->{$p} ) {
19 
			$head->{$p} = {};
20 
		}
21 
		$head = $head->{$p};
22 
	}
23 
}
24 
 
25 
use Data::Dumper;
26 
 
27 
my $res = <<EOF;
28 
-module(publicsuffix).
29 
 
30 
-export([suffix/1, domain/1]).
31 
 
32 
%% This is autogenerated by script from
33 
%% http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1
34 
 
35 
suffix(Domain) ->
36 
	Parts = lists:reverse(string:tokens(Domain, ".")),
37 
	[First | Rest] = Parts,
38 
	parts(First, Rest).
39 
 
40 
domain(Domain) ->
41 
	Suffix = suffix(Domain),
42 
	case Suffix == Domain of
43 
		true ->
44 
    		Domain;
45 
    	false ->
46 
		    Subdomains = string:tokens(string:sub_string(Domain, 1, string:rstr(Domain, Suffix) - 2), "."),
47 
		    Subdomain = lists:last(Subdomains),
48 
		    Subdomain ++ "." ++ Suffix
49 
	end.
50 
 
51 
EOF
52 
 
53 
my $subres;
54 
 
55 
for (keys %$tree) {
56 
	if ( %{$tree->{$_}} ) {
57 
        $res .= <<EOF;
58 
parts("$_", []) ->
59 
    undefined;
60 
parts("$_", Parts) ->
61 
   [First | Rest] = Parts,
62 
   $_(First, Rest);
63 
EOF
64 
	} else {
65 
	    $res .= <<EOF;
66 
parts("$_", _Any) ->
67 
    "$_";
68 
EOF
69 
	}
70 
 
71 
	my $head = $tree->{$_};
72 
	if ( %$head ) {
73 
		$subres .= generate_for_node($_, $head);
74 
	}
75 
}
76 
 
77 
$res .= <<EOF;
78 
parts(First, _) ->
79 
	First;
80 
 
81 
EOF
82 
 
83 
$res =~ s/(;)\s+$/./; ## closing fun cases
84 
$res .= $subres;
85 
 
86 
sub generate_for_node {
87 
	my ($name, $head) = @_;
88 
	my $res;
89 
	## getting exception rules first
90 
	my $tmp;
91 
	(my $fun_name = $name) =~ s/[\.\-]/_/g;
92 
	for my $k ( keys %$head ) {
93 
		if ($k =~ /^!/) {
94 
			$k =~ s/!//;
95 
			$tmp .= <<EOF;
96 
$fun_name("$k", _Parts) ->
97 
    "$name";
98 
EOF
99 
		}
100 
	}
101 
	if ( $tmp ) {
102 
		$res .= "\n\n    %% exception rules\n";
103 
		$res .= $tmp;
104 
	}
105 
 
106 
	$tmp = '';
107 
	for my $k1 ( keys %$head ) {
108 
		(my $k1_fun = $k1) =~ s/-/_/g;
109 
		if ($k1 !~ /^!/ and $k1 ne '*' ) {
110 
			if ( %{$head->{$k1}} ) {
111 
			    $tmp .= <<EOF;
112 
$fun_name("$k1", []) ->
113 
    "$k1.$name";
114 
$fun_name("$k1", Parts) ->
115 
    [First | Rest] = Parts,
116 
    ${k1_fun}_$fun_name(First, Rest);
117 
 
118 
EOF
119 
	        } else {
120 
		        $tmp .= <<EOF;
121 
$fun_name("$k1", _Any) ->
122 
    "$k1.$name";
123 
 
124 
EOF
125 
	        }
126 
	    }
127 
	}
128 
	if ( $tmp ) {
129 
		$res .= "\n\n%% regular rules\n";
130 
		$res .= $tmp;
131 
		$res .= "\n$fun_name(_, _) ->\n    \"$name\"; ";
132 
	}
133 
 
134 
	if ( $head->{"*"} ) {
135 
		$res .= <<EOF;
136 
%% star rule
137 
$fun_name(Any, _Parts) ->
138 
    Any ++ ".$name";
139 
EOF
140 
	}
141 
 
142 
 
143 
	$res =~ s/(;)\s+$/./; ## closing fun cases
144 
 
145 
	## collecting subrules
146 
	my $subrules;
147 
	for my $k2 ( keys %$head ) {
148 
		if ( $k2 !~ /^!/ and $k2 ne '*' and keys %{$head->{$k2}} ) {
149 
			$subrules .= generate_for_node($k2.".".$name, $head->{$k2});
150 
		}
151 
	}
152 
	if ( $subrules ) {
153 
		$res .= $subrules;
154 
	}
155 
 
156 
	return $res;
157 
}
158 
 
159 
 
160 
$res .= <<EOF;
161 
 
162 
-ifdef(TEST).
163 
-include_lib("eunit/include/eunit.hrl").
164 
 
165 
rules_test() ->
166 
	?assertEqual(publicsuffix:domain("google.com"), "google.com"),
167 
	?assertEqual(publicsuffix:domain("fr.google.com"), "google.com"),
168 
	?assertEqual(publicsuffix:domain("fr.google.google"), "google.google"),
169 
	?assertEqual(publicsuffix:domain("foo.google.co.uk"), "google.co.uk"),
170 
	?assertEqual(publicsuffix:domain("t.co"), "t.co"),
171 
	?assertEqual(publicsuffix:domain("fr.t.co"), "t.co").
172 
 
173 
-endif.
174 
 
175 
EOF
176 
 
177 
print $res;