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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
#!/usr/bin/perl
use strict;
use lib qw {blib/lib}, ".";
use Regexp::Common;
use t::Common;
$^W = 1;
$DEBUG = 1;
sub create_parts;
my $prospero = $RE {URI} {prospero};
# No point in crosschecking, URI creation is tag independent.
my @tests = (
[prospero => $prospero => {prospero => NORMAL_PASS | FAIL}],
);
my ($good, $bad) = create_parts;
run_tests version => "Regexp::Common::URI::prospero",
tests => \@tests,
good => $good,
bad => $bad,
query => \&prospero,
wanted => \&wanted,
filter => \&filter,
;
sub prospero {
my ($tag, $host, $port, $ppath, $fieldnames, $fieldvalues) =
($_ [0], @{$_ [1]});
my $prospero = "prospero://";
$prospero .= $host if defined $host;
$prospero .= ":$port" if defined $port;
$prospero .= "/$ppath" if defined $ppath;
if (defined $fieldnames) {
foreach my $i (0 .. $#$fieldnames) {
$prospero .= ";$fieldnames->[$i]";
$prospero .= "=$fieldvalues->[$i]" if defined $fieldvalues -> [$i];
}
}
$prospero;
}
sub wanted {
my ($tag, $parts) = @_;
my @wanted;
$wanted [0] = $_;
$wanted [1] = "prospero";
$wanted [2] = $$parts [0]; # host.
$wanted [3] = $$parts [1]; # port.
$wanted [4] = $$parts [2]; # ppart.
$wanted [5] = "";
if (defined $$parts [3]) {
foreach my $i (0 .. $#{$$parts [3]}) {
$wanted [5] .= ";${$$parts [3]}[$i]=${$$parts [4]}[$i]";
}
}
\@wanted;
}
sub create_parts {
my (@good, @bad);
# Hosts.
$good [0] = [qw /www.abigail.freedom.nl www.PERL.com a.b.c.d.e.f.g.h.i.j.k.x
127.0.0.1 w--w--w.abigail.freedom.nl w3.abigail.freedom.nl/];
$bad [0] = [qw /www.example..com w+w.example.com w--.example.com
127.0.0.0.1 -w.example.com www.example.1com/];
# Ports.
$good [1] = [undef, 1525];
$bad [1] = ["", qw /: port/];
# Ppart
$good [2] = ["", qw {part foo/bar fnord:&=?%FF}];
$bad [2] = [undef, qw {~}, ' '];
# Fieldname
$good [3] = [undef, [qw /name/], [qw /name1 name2/], [""], ["", ""],
["", qw /name/], [qw /fnord:&?%FF/]];
$bad [3] = [[qw /name==/], ['~']];
# Fieldvalue
$good [4] = [undef, [qw /value/], [qw /value1 value2/], [""], ["", ""],
["", qw /value/], [qw /fnord:&?%FF/]];
$bad [4] = [[qw /value==/], ['~'], [undef], [undef, undef]];
return (\@good, \@bad);
}
sub filter {
return 1 if !defined ${$_ [0]} [3] && !defined ${$_ [0]} [4];
return 0 if defined ${$_ [0]} [3] && !defined ${$_ [0]} [4] ||
!defined ${$_ [0]} [3] && defined ${$_ [0]} [4];
return 0 if @{${$_ [0]} [3]} != @{${$_ [0]} [4]};
return 1;
}
__END__
|
