diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/LWP/Online.pm')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/LWP/Online.pm | 372 |
1 files changed, 372 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/LWP/Online.pm b/Master/tlpkg/tlperl/lib/LWP/Online.pm new file mode 100755 index 00000000000..1ef4ef79774 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Online.pm @@ -0,0 +1,372 @@ +package LWP::Online; + +=pod + +=head1 NAME + +LWP::Online - Does your process have access to the web + +=head1 SYNOPSIS + + use LWP::Online 'online'; + + # "Is the internet working?" + die "NO INTARWWEB!!!" unless online(); + + # The above means something like this + unless ( online('http') ) { + die "No basic http access to the web"; + } + + # Special syntax for use in test scripts that need + # "real" access to the internet. Scripts will automatically + # skip if connection fails. + use LWP::Online ':skip_all'; + +=head1 DESCRIPTION + +This module attempts to answer, as accurately as it can, one of the +nastiest technical questions there is. + +B<Am I on the internet?> + +The answer is useful in a wide range of decisions. For example... + +I<Should my test scripts run the online portion of the tests or +just skip them?> + +I<Do I try to fetch fresh data from the server?> + +I<If my request to the server breaks, is it because I'm offline, or +because the server is offline?> + +And so on, and so forth. + +But a host of networking and security issues make this problem +very difficult. There are firewalls, proxies (both well behaved and +badly behaved). We might not have DNS. We might not have a network +card at all! + +You might have network access, but only to a for-money wireless network +that responds to ever HTTP request with a page asking you to enter your +credit card details for paid access. Which means you don't "REALLY" have +access. + +The mere nature of the question makes it practically unsolvable. + +But with the answer being so useful, and the only other alternative being +to ask the user "duh... are you online?" (when you might not have a user +at all) it's my gut feeling that it is worthwhile at least making an +attempt to solve the problem, if only in a limited way. + +=head2 Why LWP::Online? Why not Net::Online? + +The nice thing about LWP::Online is that LWP deals with a whole range of +different transports, and is very commonly installed. HTTP, HTTPS, FTP, +and so on and so forth. + +Attempting to do a more generalised Net::Online that might also check for +SSH and so on would end up most likely having to install a whole bunch of +modules that you most likely will never use. + +So LWP forms a nice base on which to write a module that covers most of +the situations in which you might care, while keeping the dependency +overhead down to a minimum. + +=head2 Scope + +"Am I online?" is inherently an Open Problem. + +That is, it's a problem that had no clean permanent solution, and for +which you could just keep writing more and more functionality +indefinitely, asymtopically approaching 100% correctness but never +reaching it. + +And so this module is intended to do as good a job as possible, without +having to resort to asking any human questions (who may well get it wrong +anyway), and limiting itself to a finite amount of programming work and +a reasonable level of memory overhead to load the code. + +It is thus understood the module will B<never> be perfect, and that if +any new functionality is desired, it needs to be able to implemented by +the person that desires the new behaviour, and in a reasonably small +amount of additional code. + +This module is also B<not> intended to compensate for malicious behaviour +of any kind, it is quite possible that some malicious person might proxy +fake versions of sites that pass our content checks and then proceed +to show you other bad pages. + +=head2 Test Mode + + use LWP::Online ':skip_all'; + +As a convenience when writing tests scripts base on L<Test::More>, the +special ':skip_all' param can be provided when loading B<LWP::Online>. + +This implements the functional equivalent of the following. + + BEGIN { + require Test::More; + unless ( LWP::Online::online() ) { + Test::More->import( + skip_all => 'Test requires a working internet connection' + ); + } + } + +The :skip_all special import flag can be mixed with regular imports. + +=head1 FUNCTIONS + +=cut + +use 5.005; +use strict; +use Carp 'croak'; +use LWP::Simple qw{ get $ua }; + +use vars qw{$VERSION @ISA @EXPORT_OK}; +BEGIN { + $VERSION = '1.07'; + + # We are an Exporter + require Exporter; + @ISA = qw{ Exporter }; + @EXPORT_OK = qw{ online offline }; + + # Set the useragent timeout + $ua->timeout(30); +} + +# Set up configuration data +use vars qw{%SUPPORTED @RELIABLE_HTTP}; +BEGIN { + # What transports do we support + %SUPPORTED = map { $_ => 1 } qw{ http }; + + # (Relatively) reliable websites + @RELIABLE_HTTP = ( + # These are some initial trivial checks. + # The regex are case-sensitive to at least + # deal with the "couldn't get site.com case". + 'http://google.com/' => sub { /About Google/ }, + 'http://yahoo.com/' => sub { /Yahoo!/ }, + 'http://amazon.com/' => sub { /Amazon/ and /Cart/ }, + 'http://cnn.com/' => sub { /CNN/ }, + ); +} + +sub import { + my $class = shift; + + # Handle the :skip_all special case + my @functions = grep { $_ ne ':skip_all' } @_; + if ( @functions != @_ ) { + require Test::More; + unless ( online() ) { + Test::More->import( skip_all => 'Test requires a working internet connection' ); + } + } + + # Hand the rest of the params off to Exporter + return $class->export_to_level( 1, $class, @functions ); +} + + + + + +##################################################################### +# Exportable Functions + +=pod + +=head2 online + + # Default check (uses http) + online() or die "No Internet"; + + # The above is equivalent to + online('http') or die "No Internet"; + +The importable B<online> function is the main functionality provided +by B<LWP::Online>. It takes a single optional transport name ('http' +by default) and checks that LWP connectivity is available for that +transport. + +Because it is intended as a Do What You Mean function, it checks not +only that a network connection is available, and http requests return +content, but also that it returns the CORRECT content instead of +unexpected content supplied by a man in the middle. + +For example, many wireless connections require login or payment, and +will return a service provider page for any URI that you attempt to +fetch. + +The set of websites used for the testing is the Google, Amazon, +Yahoo and CNN websites. The check is for a copyright statement on their +homepage, and the function returns true as soon as two of the website +return correctly, making the method relatively redundant. + +Returns true if the computer is "online" (has a working connection via +LWP) or false if not. + +=cut + +sub online { + # Shortcut the default to plain http_online test + return http_online() unless @_; + + while ( @_ ) { + # Get the transport to test + my $transport = shift; + unless ( $transport and $SUPPORTED{$transport} ) { + Carp::croak("Invalid or unsupported transport"); + } + + # Hand off to the transport function + if ( $transport eq 'http' ) { + http_online() or return ''; + } else { + Carp::croak("Invalid or unsupported transport"); + } + } + + # All required transports available + return 1; +} + +=pod + +=head2 offline + +The importable B<offline> function is provided as a convenience. + +It provides a simple pass-through (including any params) to the B<online> +function, but with a negated result. + +=cut + +sub offline { + ! online(@_); +} + + + + + +##################################################################### +# Transport Functions + +sub http_online { + # Check the reliable websites list. + # If networking is offline, an error/paysite page might still + # give us a page that matches a page check, while any one or + # two of the reliable websites might be offline for some + # unknown reason (DDOS, earthquake, chinese firewall, etc) + # So we want 2 or more sites to pass checks to make the + # judgement call that we are online. + my $good = 0; + my $bad = 0; + my @reliable = @RELIABLE_HTTP; + while ( @reliable ) { + # Check the current good/bad state and consider + # making the online/offline judgement call. + return 1 if $good > 1; + return '' if $bad > 2; + + # Try the next reliable site + my $site = shift @reliable; + my $check = shift @reliable; + + # Try to fetch the site + my $content; + SCOPE: { + local $@; + $content = eval { get($site) }; + if ( $@ ) { + # An exception is a simple failure + $bad++; + next; + } + } + unless ( defined $content ) { + # get() returns undef on failure + $bad++; + next; + } + + # We got _something_. + # Check if it looks like what we want + SCOPE: { + local $_ = $content; + if ( $check->() ) { + $good++; + } else { + $bad++; + } + } + } + + # We've run out of sites to check... erm... uh... + # We should probably fail conservatively and say not online. + return ''; +} + +1; + +=pod + +=head1 TO DO + +- Add more transport types that can be checked, somehow keeping the +code growth under control. + +=head1 SUPPORT + +This module is stored in an Open Repository at the following address. + +L<http://svn.ali.as/cpan/trunk/LWP-Online> + +Write access to the repository is made available automatically to any +published CPAN author, and to most other volunteers on request. + +If you are able to submit your bug report in the form of new (failing) +unit tests (which for this module will be extremely difficult), or can +apply your fix directly instead of submitting a patch, you are B<strongly> +encouraged to do so as the author currently maintains over 100 modules +and it can take some time to deal with non-Critical bug reports or patches. + +This will guarentee that your issue will be addressed in the next +release of the module. + +If you cannot provide a direct test or fix, or don't have time to do so, +then regular bug reports are still accepted and appreciated via the CPAN +bug tracker. + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=LWP-Online> + +For other issues, for commercial enhancement or support, or to have your +write access enabled for the repository, contact the author at the email +address above. + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 SEE ALSO + +L<LWP::Simple> + +=head1 COPYRIGHT + +Copyright 2006 - 2008 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut |