File Coverage

blib/lib/LWP/Online.pm
Criterion Covered Total %
statement 59 77 76.6
branch 10 24 41.6
condition 0 3 0.0
subroutine 13 13 100.0
pod 2 3 66.6
total 84 120 70.0


line stmt bran cond sub pod time code
1             package LWP::Online;
2              
3             =pod
4              
5             =head1 NAME
6              
7             LWP::Online - Does your process have access to the web
8              
9             =head1 SYNOPSIS
10              
11             use LWP::Online 'online';
12            
13             # "Is the internet working?"
14             die "NO INTARWWEB!!!" unless online();
15            
16             # The above means something like this
17             unless ( online('http') ) {
18             die "No basic http access to the web";
19             }
20            
21             # Special syntax for use in test scripts that need
22             # "real" access to the internet. Scripts will automatically
23             # skip if connection fails.
24             use LWP::Online ':skip_all';
25             use Test::More tests => 4; #after LWP::Online
26              
27             =head1 DESCRIPTION
28              
29             This module attempts to answer, as accurately as it can, one of the
30             nastiest technical questions there is.
31              
32             B
33              
34             The answer is useful in a wide range of decisions. For example...
35              
36             I
37             just skip them?>
38              
39             I
40              
41             I
42             because the server is offline?>
43              
44             And so on, and so forth.
45              
46             But a host of networking and security issues make this problem
47             very difficult. There are firewalls, proxies (both well behaved and
48             badly behaved). We might not have DNS. We might not have a network
49             card at all!
50              
51             You might have network access, but only to a for-money wireless network
52             that responds to ever HTTP request with a page asking you to enter your
53             credit card details for paid access. Which means you don't "REALLY" have
54             access.
55              
56             The mere nature of the question makes it practically unsolvable.
57              
58             But with the answer being so useful, and the only other alternative being
59             to ask the user "duh... are you online?" (when you might not have a user
60             at all) it's my gut feeling that it is worthwhile at least making an
61             attempt to solve the problem, if only in a limited way.
62              
63             =head2 Why LWP::Online? Why not Net::Online?
64              
65             The nice thing about LWP::Online is that LWP deals with a whole range of
66             different transports, and is very commonly installed. HTTP, HTTPS, FTP,
67             and so on and so forth.
68              
69             Attempting to do a more generalised Net::Online that might also check for
70             SSH and so on would end up most likely having to install a whole bunch of
71             modules that you most likely will never use.
72              
73             So LWP forms a nice base on which to write a module that covers most of
74             the situations in which you might care, while keeping the dependency
75             overhead down to a minimum.
76              
77             =head2 Scope
78              
79             "Am I online?" is inherently an Open Problem.
80              
81             That is, it's a problem that had no clean permanent solution, and for
82             which you could just keep writing more and more functionality
83             indefinitely, asymtopically approaching 100% correctness but never
84             reaching it.
85              
86             And so this module is intended to do as good a job as possible, without
87             having to resort to asking any human questions (who may well get it wrong
88             anyway), and limiting itself to a finite amount of programming work and
89             a reasonable level of memory overhead to load the code.
90              
91             It is thus understood the module will B be perfect, and that if
92             any new functionality is desired, it needs to be able to implemented by
93             the person that desires the new behaviour, and in a reasonably small
94             amount of additional code.
95              
96             This module is also B intended to compensate for malicious behaviour
97             of any kind, it is quite possible that some malicious person might proxy
98             fake versions of sites that pass our content checks and then proceed
99             to show you other bad pages.
100              
101             =head2 Test Mode
102              
103             use LWP::Online ':skip_all';
104              
105             As a convenience when writing tests scripts base on L, the
106             special ':skip_all' param can be provided when loading B.
107              
108             This implements the functional equivalent of the following.
109              
110             BEGIN {
111             require Test::More;
112             unless ( LWP::Online::online() ) {
113             Test::More->import(
114             skip_all => 'Test requires a working internet connection'
115             );
116             }
117             }
118              
119             The :skip_all special import flag can be mixed with regular imports.
120              
121             =head1 FUNCTIONS
122              
123             =cut
124              
125 3     3   35334 use 5.005;
  3         13  
  3         128  
126 3     3   17 use strict;
  3         4  
  3         109  
127 3     3   26 use Carp ();
  3         7  
  3         55  
128 3     3   3104 use URI 1.35 ();
  3         25885  
  3         120  
129 3     3   3526 use LWP::Simple 5.805 qw{ get $ua };
  3         288443  
  3         27  
130              
131 3     3   757 use vars qw{$VERSION @ISA @EXPORT_OK};
  3         6  
  3         347  
132             BEGIN {
133 3     3   7 $VERSION = '1.08';
134              
135             # We are an Exporter
136 3         15 require Exporter;
137 3         48 @ISA = qw{ Exporter };
138 3         7 @EXPORT_OK = qw{ online offline };
139              
140             # Set the useragent timeout
141 3         23 $ua->timeout(30);
142             }
143              
144             # Set up configuration data
145 3     3   173 use vars qw{%SUPPORTED @RELIABLE_HTTP};
  3         5  
  3         817  
146             BEGIN {
147             # What transports do we support
148 3     3   8 %SUPPORTED = map { $_ => 1 } qw{ http };
  3         43  
149              
150             # (Relatively) reliable websites
151             @RELIABLE_HTTP = (
152             # These are some initial trivial checks.
153             # The regex are case-sensitive to at least
154             # deal with the "couldn't get site.com case".
155 4         18 'http://www.msftncsi.com/ncsi.txt' => sub { $_ eq 'Microsoft NCSI' },
156 4         78 'http://google.com/' => sub { /About Google/ },
157 0         0 'http://yahoo.com/' => sub { /Yahoo!/ },
158 0 0       0 'http://amazon.com/' => sub { /Amazon/ and /Cart/ },
159 0         0 'http://cnn.com/' => sub { /CNN/ },
160 3         1478 );
161             }
162              
163             sub import {
164 3     3   32 my $class = shift;
165              
166             # Handle the :skip_all special case
167 3         7 my @functions = grep { $_ ne ':skip_all' } @_;
  3         10  
168 3 100       17 if ( @functions != @_ ) {
169 1         1453 require Test::More;
170 1 50       24504 unless ( online() ) {
171 0         0 Test::More->import( skip_all => 'Test requires a working internet connection' );
172             }
173             }
174              
175             # Hand the rest of the params off to Exporter
176 3         2848 return $class->export_to_level( 1, $class, @functions );
177             }
178              
179              
180              
181              
182              
183             #####################################################################
184             # Exportable Functions
185              
186             =pod
187              
188             =head2 online
189              
190             # Default check (uses http)
191             online() or die "No Internet";
192            
193             # The above is equivalent to
194             online('http') or die "No Internet";
195              
196             The importable B function is the main functionality provided
197             by B. It takes a single optional transport name ('http'
198             by default) and checks that LWP connectivity is available for that
199             transport.
200              
201             Because it is intended as a Do What You Mean function, it checks not
202             only that a network connection is available, and http requests return
203             content, but also that it returns the CORRECT content instead of
204             unexpected content supplied by a man in the middle.
205              
206             For example, many wireless connections require login or payment, and
207             will return a service provider page for any URI that you attempt to
208             fetch.
209              
210             The set of websites used for the testing is the Google, Amazon,
211             Yahoo and CNN websites. The check is for a copyright statement on their
212             homepage, and the function returns true as soon as two of the website
213             return correctly, making the method relatively redundant.
214              
215             Returns true if the computer is "online" (has a working connection via
216             LWP) or false if not.
217              
218             =cut
219              
220             sub online {
221             # Shortcut the default to plain http_online test
222 4 50   4 1 919 return http_online() unless @_;
223              
224 0         0 while ( @_ ) {
225             # Get the transport to test
226 0         0 my $transport = shift;
227 0 0 0     0 unless ( $transport and $SUPPORTED{$transport} ) {
228 0         0 Carp::croak("Invalid or unsupported transport");
229             }
230              
231             # Hand off to the transport function
232 0 0       0 if ( $transport eq 'http' ) {
233 0 0       0 http_online() or return '';
234             } else {
235 0         0 Carp::croak("Invalid or unsupported transport");
236             }
237             }
238              
239             # All required transports available
240 0         0 return 1;
241             }
242              
243             =pod
244              
245             =head2 offline
246              
247             The importable B function is provided as a convenience.
248              
249             It provides a simple pass-through (including any params) to the B
250             function, but with a negated result.
251              
252             =cut
253              
254             sub offline {
255 1     1 1 754 ! online(@_);
256             }
257              
258              
259              
260              
261              
262             #####################################################################
263             # Transport Functions
264              
265             sub http_online {
266             # Check the reliable websites list.
267             # If networking is offline, an error/paysite page might still
268             # give us a page that matches a page check, while any one or
269             # two of the reliable websites might be offline for some
270             # unknown reason (DDOS, earthquake, chinese firewall, etc)
271             # So we want 2 or more sites to pass checks to make the
272             # judgement call that we are online.
273 4     4 0 7 my $good = 0;
274 4         9 my $bad = 0;
275 4         24 my @reliable = @RELIABLE_HTTP;
276 4         18 while ( @reliable ) {
277             # Check the current good/bad state and consider
278             # making the online/offline judgement call.
279 12 100       270 return 1 if $good > 1;
280 8 50       29 return '' if $bad > 2;
281              
282             # Try the next reliable site
283 8         17 my $site = shift @reliable;
284 8         20 my $check = shift @reliable;
285              
286             # Try to fetch the site
287 8         13 my $content;
288 8         13 SCOPE: {
289 8         12 local $@;
290 8         12 $content = eval { get($site) };
  8         42  
291 8 50       1052668 if ( $@ ) {
292             # An exception is a simple failure
293 0         0 $bad++;
294 0         0 next;
295             }
296             }
297 8 50       38 unless ( defined $content ) {
298             # get() returns undef on failure
299 0         0 $bad++;
300 0         0 next;
301             }
302              
303             # We got _something_.
304             # Check if it looks like what we want
305             SCOPE: {
306 8         17 local $_ = $content;
  8         16  
307 8 50       36 if ( $check->() ) {
308 8         56 $good++;
309             } else {
310 0           $bad++;
311             }
312             }
313             }
314              
315             # We've run out of sites to check... erm... uh...
316             # We should probably fail conservatively and say not online.
317 0           return '';
318             }
319              
320             1;
321              
322             =pod
323              
324             =head1 TO DO
325              
326             - Add more transport types that can be checked, somehow keeping the
327             code growth under control.
328              
329             =head1 SUPPORT
330              
331             This module is stored in an Open Repository at the following address.
332              
333             L
334              
335             Write access to the repository is made available automatically to any
336             published CPAN author, and to most other volunteers on request.
337              
338             If you are able to submit your bug report in the form of new (failing)
339             unit tests (which for this module will be extremely difficult), or can
340             apply your fix directly instead of submitting a patch, you are B
341             encouraged to do so as the author currently maintains over 100 modules
342             and it can take some time to deal with non-Critical bug reports or patches.
343              
344             This will guarentee that your issue will be addressed in the next
345             release of the module.
346              
347             If you cannot provide a direct test or fix, or don't have time to do so,
348             then regular bug reports are still accepted and appreciated via the CPAN
349             bug tracker.
350              
351             L
352              
353             For other issues, for commercial enhancement or support, or to have your
354             write access enabled for the repository, contact the author at the email
355             address above.
356              
357             =head1 AUTHOR
358              
359             Adam Kennedy Eadamk@cpan.orgE
360              
361             =head1 SEE ALSO
362              
363             L
364              
365             =head1 COPYRIGHT
366              
367             Copyright 2006 - 2011 Adam Kennedy.
368              
369             This program is free software; you can redistribute
370             it and/or modify it under the same terms as Perl itself.
371              
372             The full text of the license can be found in the
373             LICENSE file included with this module.
374              
375             =cut