#!perl -wT

use strict;
use warnings;
use Test::Most tests => 25;
use Test::NoWarnings;
use Sys::Hostname;

BEGIN {
	use_ok('CGI::Info');
}

HOSTNAMES: {
        delete $ENV{'HTTP_HOST'};
        delete $ENV{'SERVER_NAME'};
	$ENV{'SERVER_PORT'} = 80;

	my $i = new_ok('CGI::Info' => [ logger => MyLogger->new() ]);

	my $hostname = hostname;

	ok($i->host_name() eq $hostname);
	ok($i->cgi_host_url() eq "http://$hostname");

	# Check rereading returns the same value
	ok($i->host_name() eq $hostname);

	if($i->host_name() =~ /^www\.(.+)/) {
		ok($i->domain_name() eq $1);
	} else {
		ok($i->domain_name() eq $hostname);
	}

	$ENV{'HTTP_HOST'} = 'www.example.com';
	$i = $i->new();	# Test creating a new object from an existing object
	ok($i->domain_name() eq 'example.com');
	ok($i->host_name() eq 'www.example.com');

	# Dots at the end should be ignored
	$ENV{'HTTP_HOST'} = 'www.example.com.';
	$i = new_ok('CGI::Info');
	ok($i->host_name() eq 'www.example.com');
	ok($i->domain_name() eq 'example.com');

	# Check rereading returns the same value
	ok($i->domain_name() eq 'example.com');

        delete $ENV{'HTTP_HOST'};
	delete $ENV{'SCRIPT_URI'};
	$ENV{'SERVER_NAME'} = 'www.bandsman.co.uk';

	$i = new_ok('CGI::Info' => [ logger => MyLogger->new() ]);
	ok($i->cgi_host_url() eq 'http://www.bandsman.co.uk');
	ok($i->host_name() eq 'www.bandsman.co.uk');
	# Check calling twice return path
	ok($i->cgi_host_url() eq 'http://www.bandsman.co.uk');

	$ENV{'SERVER_NAME'} = 'www.bandsman.co.uk';
	$ENV{'SERVER_PORT'} = 443;

	$i = new_ok('CGI::Info');
	ok($i->cgi_host_url() eq 'https://www.bandsman.co.uk');
	ok($i->host_name() eq 'www.bandsman.co.uk');
	# Check calling twice return path
	ok($i->cgi_host_url() eq 'https://www.bandsman.co.uk');

	$ENV{'SERVER_PORT'} = 80;

	$i = new_ok('CGI::Info' => [ logger => MyLogger->new() ]);
	ok($i->cgi_host_url() eq 'http://www.bandsman.co.uk');
	ok($i->host_name() eq 'www.bandsman.co.uk');
	# Check calling twice return path
	ok($i->cgi_host_url() eq 'http://www.bandsman.co.uk');
}

# On some platforms it's failing - find out why
package MyLogger;

sub new {
	my ($proto, %args) = @_;

	my $class = ref($proto) || $proto;

	return bless { }, $class;
}

sub warn {
	my $self = shift;
	my $message = shift;

	if($ENV{'TEST_VERBOSE'}) {
		::diag($message);
	}
}

sub trace {
	my $self = shift;
	my $message = shift;

	if($ENV{'TEST_VERBOSE'}) {
		::diag($message);
	}
}