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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
|
#!/usr/bin/perl
BEGIN {
die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n"
unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH};
unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib";
};
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use PerconaTest ();
use Test::More;
sub dies_ok (&;$) {
my $code = shift;
my $name = shift;
ok( !eval{ $code->() }, $name )
or diag( "expected an exception but none was raised" );
}
sub lives_ok (&;$) {
my $code = shift;
my $name = shift;
eval{ $code->() };
is($@, '', $name );
}
package Foo::isa;
use Lmo qw(isa);
my @types = qw(Bool Num Int Str ArrayRef CodeRef HashRef RegexpRef);
my @refs = ([], sub { }, {}, qr( ));
has( "my$_" => ( isa => $_ ) ) for @types;
has( myFoo => ( isa => "Foo::isa" ) );
package main;
my $foo = Foo::isa->new( myStr => "abcdefg" );
# Bool:
lives_ok {
ok !defined($foo->myBool(undef)),
"myBool set to undef"
} "Bool attr set to undef";
lives_ok {
is $foo->myBool(1), 1,
"myBool set to 1"
} "Bool attr set to 1";
is $foo->myBool, 1, "new value of \$foo->myBool as expected";
lives_ok {
is $foo->myBool(1e0), 1,
"myBool set to 1e0 becomes 1"
} "Bool attr set to 1e0";
dies_ok { $foo->myBool("1f0") } "Bool attr set to 1f0 dies";
lives_ok {
is $foo->myBool(""), "",
"myBool set to an emptry string"
} "Bool attr set to empty string";
is $foo->myBool, "", "new value of \$foo->myBool as expected";
lives_ok {
is $foo->myBool(0), 0,
"myBool set to 0"
} "Bool attr set to 0";
lives_ok {
is $foo->myBool(0.0), 0,
"myBool set to 0.0 becomes 0"
} "Bool attr set to 0.0";
lives_ok {
is $foo->myBool(0e0), 0,
"myBool set to 0e0 becomes 0"
} "Bool attr set to 0e0";
dies_ok { $foo->myBool("0.0") } "Bool attr set to stringy 0.0 dies";
# Bool tests from Mouse:
open(my $FH, "<", $0) or die "Could not open $0 for the test";
# Bool rejects anything which is not a 1 or 0 or "" or undef:
lives_ok { $foo->myBool(0) } "Bool lives with 0";
lives_ok { $foo->myBool(1) } "Bool lives with 1";
dies_ok { $foo->myBool(100) } "Bool dies with 100";
lives_ok { $foo->myBool("") } "Bool lives with ''";
dies_ok { $foo->myBool("Foo") } "Bool dies with a string";
dies_ok { $foo->myBool([]) } "Bool dies with an arrayref";
dies_ok { $foo->myBool({}) } "Bool dies with a hashref";
dies_ok { $foo->myBool(sub {}) } "Bool dies with a coderef";
dies_ok { $foo->myBool(\"") } "Bool dies with a scalar ref";
dies_ok { $foo->myBool(*STDIN) } "Bool dies with a glob";
dies_ok { $foo->myBool(\*STDIN) } "Bool dies with a globref";
dies_ok { $foo->myBool($FH) } "Bool dies with a lexical filehandle";
dies_ok { $foo->myBool(qr/../) } "Bool dies with a regex";
dies_ok { $foo->myBool(bless {}, "Foo") } "Bool dies with an object";
lives_ok { $foo->myBool(undef) } "Bool lives with undef";
# Num:
lives_ok {
is $foo->myNum(5.5),
5.5,
"myNum was set to 5.5"
} "Num attr set to decimal";
is $foo->myNum, 5.5, "new value of \$foo->myNum as expected";
lives_ok {
is $foo->myNum(5),
5,
"myNum was set to 5"
} "Num attr set to integer";
lives_ok {
is $foo->myNum(5e0),
5,
"myNum was set to 5e0"
} "Num attr set to 5e0";
dies_ok { $foo->myBool("5f0") } "Bool attr set to 5f0 dies";
lives_ok {
is $foo->myNum("5.5"),
5.5,
"myNum was set to q<5.5>"
} "Num attr set to stringy decimal";
# Int:
lives_ok {
is $foo->myInt(0),
0,
"myInt was set to 0"
} "Int attr set to 0";
lives_ok {
is $foo->myInt(1),
1,
"myInt was set to 1"
} "Int attr set to 1";
lives_ok {
is $foo->myInt(1e0),
1,
"myInt was set to 1e0"
} "Int attr set to 1e0";
is $foo->myInt, 1, "new value of \$foo->myInt as expected";
dies_ok { $foo->myInt("") } "Int attr set to empty string dies";
dies_ok { $foo->myInt(5.5) } "Int attr set to decimal dies";
# Str:
is $foo->myStr, "abcdefg", "Str passed to constructor accepted";
lives_ok {
is $foo->myStr("hijklmn"), "hijklmn",
"myStr was set to a string",
} "Str attr set to a string";
is $foo->myStr, "hijklmn", "new value of \$foo->myStr as expected";
lives_ok {
is $foo->myStr(5.5), 5.5,
"myStr was set to 5.5"
} "Str attr set to a decimal value";
# Class instance:
lives_ok {
is $foo->myFoo($foo), $foo,
"myFoo set to self"
} "Class instance attr set to self";
isa_ok $foo->myFoo, "Foo::isa", "new value of \$foo->myFoo as expected";
dies_ok { $foo->myFoo({}) } "Class instance attr set to hash dies";
# Class name:
my $class = ref($foo);
lives_ok {
is $foo->myFoo($class),
$class,
"myFoo set to a classname"
} "Class instance attr set to classname";
is $foo->myFoo, $class, "new value of \$foo->myFoo as expected";
# Refs:
for my $i (4..7) {
my $method = "my" . $types[$i];
lives_ok(
sub { $foo->$method($refs[$i - 4]) },
"$types[$i] attr set to correct reference type" ); }
for my $i (4..7) {
my $method = "my" . $types[$i];
dies_ok(
sub { $foo->$method($refs[(3 + $i) % 4]) },
"$types[$i] attr set to incorrect reference type dies" ); }
# All but Bool vs undef:
for my $type (@types[1..$#types]) {
my $method = "my$type";
dies_ok { $foo->$method(undef) } "$type attr set to undef dies" }
use Config;
use File::Spec;
use IPC::Cmd ();
my $thisperl = $^X;
if ($^O ne 'VMS')
{$thisperl .= $Config{_exe} unless $thisperl =~ m/$Config{_exe}$/i;}
my $pm_test = "$PerconaTest::trunk/t/lib/Lmo/isa_subtest.pm";
ok(
scalar(IPC::Cmd::run(command => [$thisperl, $pm_test])),
"Lmo types work with Scalar::Util::PP",
);
done_testing;
|
