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
|
#!/usr/bin/perl
use strict;
use warnings;
no warnings 'syntax';
use Regexp::Common;
use Test::More;
my $r = eval "require Test::Regexp; 1";
unless ($r) {
print "1..0 # SKIP Test::Regexp not found\n";
exit;
}
sub make_test {
my ($name, $base, @options) = @_;
my $pat = $base;
while (@options) {
my $opt = shift @options;
if (@options && $options [0] !~ /^-/) {
my $val = shift @options;
$pat = $$pat {$opt => $val};
$name .= ", $opt => $val";
}
else {
$pat = $$pat {$opt};
$name .= ", $opt";
}
}
my $keep = $$pat {-keep};
Test::Regexp:: -> new -> init (
pattern => $pat,
keep_pattern => $keep,
name => $name,
);
}
#
# Combine places and bases
#
my $min = 3;
my $max = 6;
my $pattern = make_test "Integer pattern" =>
$RE {num} {int}, -base => 4,
-places => "$min,$max";
my $pattern_neg = make_test "Integer pattern" =>
$RE {num} {int}, -base => 4,
-places => "$min,$max",
-sign => '[-]';
my @numbers;
push @numbers => map {"0" x $_} 1 .. 7;
push @numbers => qw [
1201201 21013 120 123100 3210310 1231231013 2130130 2130 31230
13012302 13130
];
foreach my $number (@numbers) {
my $length = length $number;
if ($length < $min) {
foreach my $subj ($number, "-$number", "+$number") {
$pattern -> no_match ($number, reason => "Number too short");
$pattern_neg -> no_match ($number, reason => "Number too short");
}
}
elsif ($length > $max) {
foreach my $subj ($number, "-$number", "+$number") {
$pattern -> no_match ($number, reason => "Number too long");
$pattern_neg -> no_match ($number, reason => "Number too long");
}
}
else {
$pattern -> match ($number, [$number, "", $number],
test => "Number of correct length");
$pattern_neg -> no_match ($number, reason => "Number not signed");
$pattern -> match ("-$number", ["-$number", "-", $number],
test => "Signed number of correct length");
$pattern_neg -> match ("-$number", ["-$number", "-", $number],
test => "Signed number of correct length");
$pattern -> match ("+$number", ["+$number", "+", $number],
test => "Signed number of correct length");
$pattern_neg -> no_match ($number,
reason => "Number incorrectly signed");
}
}
my @bad_characters = (
["Number contains space", "12 12", "111 1"],
["Digit exceeds base", "1234", "4", "121212124", "9123123123"],
["Letter in number", "123A", "Q", "202O20", "123Z21"],
);
foreach my $entry (@bad_characters) {
my ($reason, @subjs) = @$entry;
foreach my $subj (@subjs) {
$pattern -> no_match ($subj, reason => $reason);
$pattern_neg -> no_match ($subj, reason => $reason);
}
}
done_testing ();
__END__
|
