File Coverage

lib/Net/Domain/TldMozilla.pm
Criterion Covered Total %
statement 24 41 58.5
branch 3 12 25.0
condition 4 17 23.5
subroutine 6 7 85.7
pod 1 1 100.0
total 38 78 48.7


line stmt bran cond sub pod time code
1             package Net::Domain::TldMozilla;
2             #
3             # Masatoshi Mizuno E<lt>lusheE(<64>)cpan.orgE<gt>
4             #
5             # $Id: TldMozilla.pm 375 2009-01-22 06:17:35Z lushe $
6             #
7 2     2   6255 use strict;
  2         5  
  2         64  
8 2     2   11 use warnings;
  2         4  
  2         56  
9 2     2   1800 use LWP::Simple;
  2         197085  
  2         28  
10 2     2   3363 use File::Slurp;
  2         31970  
  2         224  
11 2     2   2135 use Jcode;
  2         57881  
  2         1235  
12              
13             our $VERSION = '0.03';
14              
15             our $SOURCE_URL= 'http://mxr.mozilla.org/firefox/source/netwerk/dns/src/effective_tld_names.dat?raw=1';
16              
17             sub get_tld {
18             #
19             # ------------------------------------------------------------------------------------------
20 1   50 1 1 16 my $span= $ENV{TLD_MOZILLA_DOWN_SPAN} || 3;
21 1   33     6 my $url = $ENV{TLD_MOZILLA_URL} || $SOURCE_URL;
22 1   50     6 my $temp= ($ENV{TLD_MOZILLA_TEMP} || '/tmp'). '/mozilla_tld.cache';
23             # ------------------------------------------------------------------------------------------
24             #
25 1         3 my $TLD= do {
26 1     0   4 my $read= sub { my $plain= read_file($temp); [ split /\s*\n\s*/, $plain ] };
  0         0  
  0         0  
27             (! -e $temp or (-M _)> $span) ? do {
28 1 50       7 if (my $source= LWP::Simple::get($url)) {
29 0         0 my @tld;
30 0         0 for (split /\n/, $source) {
31 0 0 0     0 next if (! $_ or /^\s*(?:\/|\#)/);
32 0   0     0 my $icode= Jcode::getcode(\$_) || next;
33 0 0       0 next if $icode ne 'ascii';
34 0         0 s/^\s*\*\.?//;
35 0         0 s/^\s*\!\s*\.?//;
36 0         0 push @tld, $_;
37             }
38 0   0     0 write_file($temp, ( join("\n", @tld) || '' ));
39 0         0 warn __PACKAGE__. " - data save. [$temp]";
40 0         0 \@tld;
41             } else {
42             -e $temp ? do {
43 0         0 warn __PACKAGE__. " - Unable to get document: $!";
44 0         0 $read->();
45 1 50       413796 }: do {
46 1         59 die __PACKAGE__. " - Unable to get document: $!";
47             };
48             }
49 1 50 33     29 }: do {
50 0           $read->();
51             };
52             };
53 0 0         wantarray ? @$TLD: $TLD;
54             }
55              
56             1;
57              
58             __END__
59              
60             =head1 NAME
61              
62             Net::Domain::TldMozilla - TLD of the Mozilla source is returned.
63              
64             =head1 SYNOPSIS
65              
66             use Net::Domain::TldMozilla;
67            
68             my @Tld= Net::Domain::TldMozilla->get;
69              
70             =head1 DESCRIPTION
71              
72             TLD is acquired and returned from the source open to the public on the Mozilla site.
73              
74             Please set HTTP_PROXY of the environment variable if you use Proxy.
75              
76             $ENV{HTTP_PROXY}= '192.168.0.1:8080';
77              
78             =head1 METHODS
79              
80             =head2 get_tld
81              
82             The list of TLD is returned.
83              
84             my $TLD= Net::Domain::TldMozilla->get;
85              
86             =head1 ENVIRONMENT VARIABLE
87              
88             The following environment variables are treated.
89              
90             =over 4
91              
92             =item * TLD_MOZILLA_URL
93              
94             So that URL of the Mozilla site may change.
95              
96             =item * TLD_MOZILLA_TEMP
97              
98             Passing preservation of cache file ahead.
99              
100             Default is '/tmp'.
101              
102             =back
103              
104             =head1 SEE ALSO
105              
106             L<LWP::Simple>,
107             L<File::Slurp>,
108             L<Jcode>,
109              
110             =head1 AUTHOR
111              
112             Masatoshi Mizuno E<lt>lushe(E<64>)cpan.orgE<gt>
113              
114             =head1 COPYRIGHT AND LICENSE
115              
116             Copyright (C) 2008 by Bee Flag, Corp. E<lt>http://egg.bomcity.com/E<gt>.
117              
118             This library is free software; you can redistribute it and/or modify
119             it under the same terms as Perl itself, either Perl version 5.8.8 or,
120             at your option, any later version of Perl 5 you may have available.
121              
122             =cut
123