The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
use strict;
use warnings;

BEGIN {
    # mock up a gethostbyname that always works :-)
    *CORE::GLOBAL::gethostbyname = sub {
	my $name = shift;
	#print "# gethostbyname [$name]\n";
	die if wantarray;
	return 1 if $name =~ /^www\.perl\.(com|org|ca|su)\.$/;
	return 1 if $name eq "www.perl.co.uk\.";
	return 0;
    };
}

print "1..26\n";

use URI::Heuristic qw(uf_urlstr uf_url);
if (shift) {
    $URI::Heuristic::DEBUG++;
    open(STDERR, ">&STDOUT");  # redirect STDERR
}

print "not " unless uf_urlstr("http://www.sn.no/") eq "http://www.sn.no/";
print "ok 1\n";

if ($^O eq "MacOS") {
    print "not " unless uf_urlstr("etc:passwd") eq "file:/etc/passwd";
} else {
print "not " unless uf_urlstr("/etc/passwd") eq "file:/etc/passwd";
}
print "ok 2\n";

if ($^O eq "MacOS") {
    print "not " unless uf_urlstr(":foo.txt") eq "file:./foo.txt";
} else {
print "not " unless uf_urlstr("./foo.txt") eq "file:./foo.txt";
}
print "ok 3\n";

print "not " unless uf_urlstr("ftp.aas.no/lwp.tar.gz") eq "ftp://ftp.aas.no/lwp.tar.gz";
print "ok 4\n";

if($^O eq "MacOS") {
#  its a weird, but valid, MacOS path, so it can't be left alone
    print "not " unless uf_urlstr("C:\\CONFIG.SYS") eq "file:/C/%5CCONFIG.SYS";
} else {
print "not " unless uf_urlstr("C:\\CONFIG.SYS") eq "file:C:\\CONFIG.SYS";
}
print "ok 5\n";

{
    local $ENV{LC_ALL} = "";
    local $ENV{LANG} = "";
    local $ENV{HTTP_ACCEPT_LANGUAGE} = "";

    $ENV{LC_ALL} = "en_GB.UTF-8";
    undef $URI::Heuristic::MY_COUNTRY;
    print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.(org|co)\.uk/camel\.gif$,;
    print "ok 6\n";

    use Net::Domain;
    $ENV{LC_ALL} = "C";
    { no warnings; *Net::Domain::hostfqdn = sub { return 'vasya.su' } }
    undef $URI::Heuristic::MY_COUNTRY;
    print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.su/camel\.gif$,;
    print "ok 7\n";

    $ENV{LC_ALL} = "C";
    { no warnings; *Net::Domain::hostfqdn = sub { return '' } }
    undef $URI::Heuristic::MY_COUNTRY;
    print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.(com|org)/camel\.gif$,;
    print "ok 8\n";

    $ENV{HTTP_ACCEPT_LANGUAGE} = "en-ca";
    undef $URI::Heuristic::MY_COUNTRY;
    print "not " unless uf_urlstr("perl/camel.gif") eq "http://www.perl.ca/camel.gif";
    print "ok 9\n";
}

$URI::Heuristic::MY_COUNTRY = "bv";
print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.(com|org)/camel\.gif$,;
print "ok 10\n";

# Backwards compatibility; uk != United Kingdom in ISO 3166
$URI::Heuristic::MY_COUNTRY = "uk";
print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.(org|co)\.uk/camel\.gif$,;
print "ok 11\n";

$URI::Heuristic::MY_COUNTRY = "gb";
print "not " unless uf_urlstr("perl/camel.gif") =~ m,^http://www\.perl\.(org|co)\.uk/camel\.gif$,;
print "ok 12\n";

$ENV{URL_GUESS_PATTERN} = "www.ACME.org www.ACME.com";
print "not " unless uf_urlstr("perl") eq "http://www.perl.org";
print "ok 13\n";

{
    local $ENV{URL_GUESS_PATTERN} = "";
    print "not " unless uf_urlstr("perl") eq "http://perl";
    print "ok 14\n";

    print "not " unless uf_urlstr("http:80") eq "http:80";
    print "ok 15\n";

    print "not " unless uf_urlstr("mailto:gisle\@aas.no") eq "mailto:gisle\@aas.no";
    print "ok 16\n";

    print "not " unless uf_urlstr("gisle\@aas.no") eq "mailto:gisle\@aas.no";
    print "ok 17\n";

    print "not " unless uf_urlstr("Gisle.Aas\@aas.perl.org") eq "mailto:Gisle.Aas\@aas.perl.org";
    print "ok 18\n";

    print "not " unless uf_url("gopher.sn.no")->scheme eq "gopher";
    print "ok 19\n";

    print "not " unless uf_urlstr("123.3.3.3:8080/foo") eq "http://123.3.3.3:8080/foo";
    print "ok 20\n";

    print "not " unless uf_urlstr("123.3.3.3:443/foo") eq "https://123.3.3.3:443/foo";
    print "ok 21\n";

    print "not " unless uf_urlstr("123.3.3.3:21/foo") eq "ftp://123.3.3.3:21/foo";
    print "ok 22\n";

    print "not " unless uf_url("FTP.example.com")->scheme eq "ftp";
    print "ok 23\n";

    print "not " unless uf_url("ftp2.example.com")->scheme eq "ftp";
    print "ok 24\n";

    print "not " unless uf_url("ftp")->scheme eq "ftp";
    print "ok 25\n";

    print "not " unless uf_url("https.example.com")->scheme eq "https";
    print "ok 26\n";
}