view release on metacpan or  search on metacpan

lib/POE/Declare/HTTP/Online.pm  view on Meta::CPAN

	if ( $_[SELF]->running ) {
		# No definite answer yet
		return;
	}

	# We are not online, so far as we can tell
	return $_[SELF]->call( respond => 0 );
}

sub http_shutdown :Event {
	# Are there any active clients left
	if ( $_[SELF]->running ) {
		# No definite answer yet
		return;
	}

	# We are not online, so far as we can tell
	return $_[SELF]->call( respond => 0 );	
}

sub respond :Event {
	$_[SELF]->{result} = undef;

	# Abort any requests still running
	foreach my $client ( $_[SELF]->clients ) {
		$client->stop;
	}

	# Send the reponse message
	if ( $_[ARG0] ) {
		$_[SELF]->OnlineEvent;
	} elsif ( defined $_[ARG0] ) {
		$_[SELF]->OfflineEvent;
	} else {
		$_[SELF]->ErrorEvent;
	}

	# Clean up
	$_[SELF]->finish;
}





######################################################################
# Support Methods

sub conformant {
	my $self = shift;

	# A successful response should result in a redirect.
	my $response = shift;
	unless ( Params::Util::_INSTANCE($response, 'HTTP::Response') ) {
		return 0;
	}
	unless ( $response->is_redirect ) {
		return 0;
	}

	# Determine the location we are relocating to
	my $request  = $response->request;
	my $location = $response->header('Location') or return 0;
	my $uri      = $HTTP::URI_CLASS->new($location);
	unless ( Params::Util::_INSTANCE($uri, 'URI') and $uri->can('host') ) {
		return 0;
	}

	# It should redirect to the matching www.domain.com for some given domain.com
	my $original = quotemeta $request->uri->host;
	unless ( $uri->host =~ /^(?:.+\.)?$original$/ ) {
		return 0;
	}

	return 1;
}

compile;

=pod

=head1 SUPPORT

Bugs should be always be reported via the CPAN bug tracker at

L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=POE-Declare-HTTP-Online>

For other issues, or commercial enhancement or support, contact the author.

=head1 AUTHOR

Adam Kennedy E<lt>adamk@cpan.orgE<gt>

=head1 SEE ALSO

L<LWP::Simple>

=head1 COPYRIGHT

Copyright 2011 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