summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/LWP/Online.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/LWP/Online.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/LWP/Online.pm372
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