File Coverage

blib/lib/Metabrik/Lookup/Countrycode.pm
Criterion Covered Total %
statement 9 98 9.1
branch 0 42 0.0
condition 0 6 0.0
subroutine 3 13 23.0
pod 2 8 25.0
total 14 167 8.3


}gcs) {
line stmt bran cond sub pod time code
1             #
2             # $Id$
3             #
4             # lookup::countrycode Brik
5             #
6             package Metabrik::Lookup::Countrycode;
7 1     1   1083 use strict;
  1         2  
  1         29  
8 1     1   6 use warnings;
  1         2  
  1         29  
9              
10 1     1   6 use base qw(Metabrik::Client::Www);
  1         2  
  1         1199  
11              
12             sub brik_properties {
13             return {
14 0     0 1   revision => '$Revision$',
15             tags => [ qw(unstable iana cc tld) ],
16             author => 'GomoR ',
17             license => 'http://opensource.org/licenses/BSD-3-Clause',
18             attributes => {
19             datadir => [ qw(datadir) ],
20             input => [ qw(file) ],
21             _data => [ qw(INTERNAL) ],
22             _data_by_tld => [ qw(INTERNAL) ],
23             },
24             commands => {
25             update => [ ],
26             load => [ qw(input|OPTIONAL) ],
27             load_by_tld => [ qw(input|OPTIONAL) ],
28             list_types => [ ],
29             list_tlds => [ ],
30             from_tld => [ qw(tld) ],
31             },
32             require_modules => {
33             'Metabrik::File::Csv' => [ ],
34             'Metabrik::System::File' => [ ],
35             },
36             };
37             }
38              
39             sub brik_use_properties {
40 0     0 1   my $self = shift;
41              
42 0           my $datadir = $self->datadir;
43              
44             return {
45 0           attributes_default => {
46             input => $datadir.'/country-codes.csv',
47             },
48             };
49             }
50              
51             sub _load {
52 0     0     my $self = shift;
53              
54 0           my $data = $self->_data;
55 0 0         if (! defined($data)) {
56 0 0         $data = $self->load or return;
57 0           $self->_data($data);
58             }
59              
60 0           return $data;
61             }
62              
63             sub _load_by_tld {
64 0     0     my $self = shift;
65              
66 0           my $data = $self->_data_by_tld;
67 0 0         if (! defined($data)) {
68 0 0         $data = $self->load_by_tld or return;
69 0           $self->_data_by_tld($data);
70             }
71              
72 0           return $data;
73             }
74              
75             sub list_types {
76 0     0 0   my $self = shift;
77              
78 0 0         my $data = $self->_load or return;
79              
80 0           my %list = ();
81 0           for my $this (@$data) {
82 0           $list{$this->{type}}++;
83             }
84              
85 0           my @types = sort { $a cmp $b } keys %list;
  0            
86              
87 0           return \@types;
88             }
89              
90             sub list_tlds {
91 0     0 0   my $self = shift;
92              
93 0 0         my $data = $self->_load or return;
94              
95 0           my %list = ();
96 0           for my $this (@$data) {
97 0           $list{$this->{tld}}++;
98             }
99              
100 0           my @tlds = sort { $a cmp $b } keys %list;
  0            
101              
102 0           return \@tlds;
103             }
104              
105             #
106             # Port numbers:
107             # http://www.iana.org/protocols
108             # http://www.iana.org/assignments/service-names-port-numbers/service-names-port-numbers.xhtml
109             #
110             sub update {
111 0     0 0   my $self = shift;
112              
113 0           my $input = $self->input;
114              
115 0 0         my $sf = Metabrik::System::File->new_from_brik_init($self) or return;
116 0           $sf->remove($input);
117              
118 0           my $uri = 'http://www.iana.org/domains/root/db';
119              
120 0 0         my $get = $self->get($uri) or return;
121 0           my $html = $get->{content};
122              
123 0           my @cc = ();
124 0           while ($html =~ m{(.*?)
125 0           my $this = $1;
126              
127 0           $this =~ s/\n//g;
128              
129 0           $self->log->debug("update: this[$this]");
130              
131             #
132             #
133             # .aaa
134             # generic
135             # American Automobile Association, Inc.
136             #
137              
138 0           my ($tld, $type, $sponsor) =
139             ($this =~ m{^.*?(.*?)<.*?(.*?)<.*?(.*?)<.*$});
140              
141             # Remove leading . and put to lowercase
142 0           $tld =~ s{^\.}{};
143 0           $tld = lc($tld);
144              
145 0           push @cc, {
146             tld => $tld,
147             type => "\"$type\"",
148             sponsor => "\"$sponsor\"",
149             };
150             }
151              
152 0 0         my $fc = Metabrik::File::Csv->new_from_brik_init($self) or return;
153 0           $fc->append(0);
154 0           $fc->overwrite(1);
155 0           $fc->encoding('utf8');
156 0           $fc->write_header(1);
157 0           $fc->separator(',');
158 0           $fc->header([qw(tld type sponsor)]);
159              
160 0 0         $fc->write(\@cc, $input) or return;
161              
162 0           return $input;
163             }
164              
165             sub load {
166 0     0 0   my $self = shift;
167 0           my ($input) = @_;
168              
169 0   0       $input ||= $self->input;
170 0 0         $self->brik_help_run_undef_arg('load', $input) or return;
171 0 0         $self->brik_help_run_file_not_found('load', $input) or return;
172              
173 0 0         my $fc = Metabrik::File::Csv->new_from_brik_init($self) or return;
174 0           $fc->encoding('utf8');
175 0           $fc->first_line_is_header(1);
176 0           $fc->separator(',');
177              
178 0 0         my $csv = $fc->read($input) or return;
179              
180 0           return $csv;
181             }
182              
183             sub load_by_tld {
184 0     0 0   my $self = shift;
185 0           my ($input) = @_;
186              
187 0   0       $input ||= $self->input;
188 0 0         $self->brik_help_run_undef_arg('load_by_tld', $input) or return;
189 0 0         $self->brik_help_run_file_not_found('load_by_tld', $input) or return;
190              
191 0 0         my $fc = Metabrik::File::Csv->new_from_brik_init($self) or return;
192 0           $fc->encoding('utf8');
193 0           $fc->first_line_is_header(1);
194 0           $fc->separator(',');
195              
196 0 0         my $csv = $fc->read($input) or return;
197              
198 0           my %by_tld = ();
199 0           for (@$csv) {
200 0           $by_tld{$_->{tld}} = $_;
201             }
202              
203 0           return \%by_tld;
204             }
205              
206             sub from_tld {
207 0     0 0   my $self = shift;
208 0           my ($tld) = @_;
209              
210 0 0         $self->brik_help_run_undef_arg('from_tld', $tld) or return;
211              
212 0 0         my $data = $self->_load_by_tld or return;
213              
214 0 0         if (exists($data->{lc($tld)})) {
215 0           return $data->{lc($tld)};
216             }
217              
218 0           return 0;
219             }
220              
221             1;
222              
223             __END__