1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
#!/usr/bin/perl
use v5.14;
use strict;
use warnings;
no warnings 'redefine';
use Test::More;
use Data::Dumper;
use Encode qw(decode_utf8);
use URI;
use utf8;
binmode(\*STDOUT, ':utf8');
use IRI;
sub confirm_tests {
my $base = URI->new(shift->abs);
my $b = $base->as_string;
my $tests = shift;
while (my ($url, $expect) = each %$tests) {
my $u = URI->new_abs($url, $base)->as_string;
is($u, $expect, "CONFIRM: $url [$b]");
}
}
sub run_tests {
my $base = shift;
my $b = $base->abs;
my $tests = shift;
while (my ($url, $expect) = each %$tests) {
my $i = IRI->new(value => $url, base => $base);
is($i->abs, $expect, "$url [$b]");
}
}
subtest 'base resolution tests from rfc3986 5.4.1' => sub {
my $base = IRI->new(value => "http://a/b/c/d;p?q");
my %REL_TESTS = (
"g:h" => "g:h",
"g" => "http://a/b/c/g",
"./g" => "http://a/b/c/g",
"g/" => "http://a/b/c/g/",
"/g" => "http://a/g",
"//g" => "http://g",
"?y" => "http://a/b/c/d;p?y",
"g?y" => "http://a/b/c/g?y",
"#s" => "http://a/b/c/d;p?q#s",
"g#s" => "http://a/b/c/g#s",
"g?y#s" => "http://a/b/c/g?y#s",
";x" => "http://a/b/c/;x",
"g;x" => "http://a/b/c/g;x",
"g;x?y#s" => "http://a/b/c/g;x?y#s",
"" => "http://a/b/c/d;p?q",
"." => "http://a/b/c/",
"./" => "http://a/b/c/",
".." => "http://a/b/",
"../" => "http://a/b/",
"../g" => "http://a/b/g",
"../.." => "http://a/",
"../../" => "http://a/",
"../../g" => "http://a/g",
);
run_tests($base, \%REL_TESTS);
confirm_tests($base, \%REL_TESTS);
};
done_testing();
|
