colas@0
|
1 |
package CGI::Session::Test::Default;
|
colas@0
|
2 |
|
colas@0
|
3 |
use strict;
|
colas@0
|
4 |
use Carp;
|
colas@0
|
5 |
use Test::More ();
|
colas@0
|
6 |
use Data::Dumper;
|
colas@0
|
7 |
use Scalar::Util "refaddr";
|
colas@0
|
8 |
|
colas@0
|
9 |
our $AUTOLOAD;
|
colas@0
|
10 |
our $CURRENT;
|
colas@0
|
11 |
sub ok_later (&;$);
|
colas@0
|
12 |
|
colas@0
|
13 |
|
colas@0
|
14 |
$CGI::Session::Test::Default::VERSION = '4.20';
|
colas@0
|
15 |
|
colas@0
|
16 |
=head1 CGI::Session::Test::Default
|
colas@0
|
17 |
|
colas@0
|
18 |
Run a suite of tests for a given CGI::Session::Driver
|
colas@0
|
19 |
|
colas@0
|
20 |
=head2 new()
|
colas@0
|
21 |
|
colas@0
|
22 |
my $t = CGI::Session::Test::Default->new(
|
colas@0
|
23 |
# These are all optional, with default as follows
|
colas@0
|
24 |
dsn => "driver:file",
|
colas@0
|
25 |
args => undef,
|
colas@0
|
26 |
tests => 77,
|
colas@0
|
27 |
);
|
colas@0
|
28 |
|
colas@0
|
29 |
Create a new test object, possibly overriding some defaults.
|
colas@0
|
30 |
|
colas@0
|
31 |
=cut
|
colas@0
|
32 |
|
colas@0
|
33 |
sub new {
|
colas@0
|
34 |
my $class = shift;
|
colas@0
|
35 |
my $self = bless {
|
colas@0
|
36 |
dsn => "driver:file",
|
colas@0
|
37 |
args => undef,
|
colas@0
|
38 |
tests => 101,
|
colas@0
|
39 |
test_number => 0,
|
colas@0
|
40 |
@_
|
colas@0
|
41 |
}, $class;
|
colas@0
|
42 |
|
colas@0
|
43 |
if($self->{skip}) {
|
colas@0
|
44 |
$self->{_skip} = { map { $_ => $_ } @{$self->{skip}} };
|
colas@0
|
45 |
} else {
|
colas@0
|
46 |
$self->{_skip} = {};
|
colas@0
|
47 |
}
|
colas@0
|
48 |
|
colas@0
|
49 |
return $self;
|
colas@0
|
50 |
}
|
colas@0
|
51 |
|
colas@0
|
52 |
=head2 number_of_tests()
|
colas@0
|
53 |
|
colas@0
|
54 |
my $new_num = $t->number_of_tests($new_num);
|
colas@0
|
55 |
|
colas@0
|
56 |
A setter/accessor method to affect the number of tests to run,
|
colas@0
|
57 |
after C<new()> has been called and before C<run()>.
|
colas@0
|
58 |
|
colas@0
|
59 |
=cut
|
colas@0
|
60 |
|
colas@0
|
61 |
sub number_of_tests {
|
colas@0
|
62 |
my $self = shift;
|
colas@0
|
63 |
|
colas@0
|
64 |
if ( @_ ) {
|
colas@0
|
65 |
$self->{tests} = $_[0];
|
colas@0
|
66 |
}
|
colas@0
|
67 |
|
colas@0
|
68 |
return $self->{tests};
|
colas@0
|
69 |
}
|
colas@0
|
70 |
|
colas@0
|
71 |
=head2 run()
|
colas@0
|
72 |
|
colas@0
|
73 |
$t->run();
|
colas@0
|
74 |
|
colas@0
|
75 |
Run the test suite. See C<new()> for setting related options.
|
colas@0
|
76 |
|
colas@0
|
77 |
=cut
|
colas@0
|
78 |
|
colas@0
|
79 |
sub run {
|
colas@0
|
80 |
my $self = shift;
|
colas@0
|
81 |
|
colas@0
|
82 |
$CURRENT = $self;
|
colas@0
|
83 |
use_ok("CGI::Session", "CGI::Session loaded successfully!");
|
colas@0
|
84 |
|
colas@0
|
85 |
my $sid = undef;
|
colas@0
|
86 |
FIRST: {
|
colas@0
|
87 |
ok(1, "=== 1 ===");
|
colas@0
|
88 |
my $session = CGI::Session->load() or die CGI::Session->errstr;
|
colas@0
|
89 |
ok($session, "empty session should be created");
|
colas@0
|
90 |
ok(!$session->id);
|
colas@0
|
91 |
ok($session->is_empty);
|
colas@0
|
92 |
ok(!$session->is_expired);
|
colas@0
|
93 |
|
colas@0
|
94 |
undef $session;
|
colas@0
|
95 |
|
colas@0
|
96 |
$session = CGI::Session->new($self->{dsn}, '_DOESN\'T EXIST_', $self->{args}) or die CGI::Session->errstr;
|
colas@0
|
97 |
ok( $session, "Session created successfully!");
|
colas@0
|
98 |
|
colas@0
|
99 |
#
|
colas@0
|
100 |
# checking if the driver object created is really the driver requested:
|
colas@0
|
101 |
#
|
colas@0
|
102 |
my $dsn = $session->parse_dsn( $self->{dsn} );
|
colas@0
|
103 |
ok( ref $session->_driver eq "CGI::Session::Driver::" . $dsn->{driver}, ref $dsn->{Driver} );
|
colas@0
|
104 |
|
colas@0
|
105 |
ok( $session->ctime && $session->atime, "ctime & atime are set");
|
colas@0
|
106 |
ok( $session->atime == $session->ctime, "ctime == atime");
|
colas@0
|
107 |
ok( !$session->etime, "etime not set yet");
|
colas@0
|
108 |
|
colas@0
|
109 |
ok( $session->id, "session id is " . $session->id);
|
colas@0
|
110 |
|
colas@0
|
111 |
$session->param('author', "Sherzod Ruzmetov");
|
colas@0
|
112 |
$session->param(-name=>'emails', -value=>['sherzodr@cpan.org', 'sherzodr@handalak.com']);
|
colas@0
|
113 |
$session->param('blogs', {
|
colas@0
|
114 |
'./lost+found' => 'http://author.handalak.com/',
|
colas@0
|
115 |
'Yigitlik sarguzashtlari' => 'http://author.handalak.com/uz/'
|
colas@0
|
116 |
});
|
colas@0
|
117 |
|
colas@0
|
118 |
ok( ($session->param) == 3, "session holds 3 params" . scalar $session->param );
|
colas@0
|
119 |
ok( $session->param('author') eq "Sherzod Ruzmetov", "My name's correct!");
|
colas@0
|
120 |
|
colas@0
|
121 |
ok( ref ($session->param('emails')) eq 'ARRAY', "'emails' holds list of values" );
|
colas@0
|
122 |
ok( @{ $session->param('emails') } == 2, "'emails' holds list of two values");
|
colas@0
|
123 |
ok( $session->param('emails')->[0] eq 'sherzodr@cpan.org', "first value of 'emails' is correct!");
|
colas@0
|
124 |
ok( $session->param('emails')->[1] eq 'sherzodr@handalak.com', "second value of 'emails' is correct!");
|
colas@0
|
125 |
|
colas@0
|
126 |
ok( ref( $session->param('blogs') ) eq 'HASH', "'blogs' holds a hash");
|
colas@0
|
127 |
ok( $session->param('blogs')->{'./lost+found'} eq 'http://author.handalak.com/', "first blog is correct");
|
colas@0
|
128 |
ok( $session->param('blogs')->{'Yigitlik sarguzashtlari'} eq 'http://author.handalak.com/uz/', "second blog is correct");
|
colas@0
|
129 |
|
colas@0
|
130 |
$sid = $session->id;
|
colas@0
|
131 |
$session->flush();
|
colas@0
|
132 |
}
|
colas@0
|
133 |
|
colas@0
|
134 |
sleep(1);
|
colas@0
|
135 |
|
colas@0
|
136 |
SECOND: {
|
colas@0
|
137 |
SKIP: {
|
colas@0
|
138 |
ok(1, "=== 2 ===");
|
colas@0
|
139 |
my $session;
|
colas@0
|
140 |
eval { $session = CGI::Session->load($self->{dsn}, $sid, $self->{args}) };
|
colas@0
|
141 |
|
colas@0
|
142 |
if ($@ || CGI::Session->errstr) {
|
colas@0
|
143 |
Test::More::skip("couldn't load session, bailing out: SQLite/Storable support is TODO", 56);
|
colas@0
|
144 |
}
|
colas@0
|
145 |
|
colas@0
|
146 |
is($@.CGI::Session->errstr,'','survived eval without error.');
|
colas@0
|
147 |
ok($session, "Session was retrieved successfully");
|
colas@0
|
148 |
ok(!$session->is_expired, "session isn't expired yet");
|
colas@0
|
149 |
|
colas@0
|
150 |
is($session->id,$sid, "session IDs are consistent");
|
colas@0
|
151 |
ok($session->atime > $session->ctime, "ctime should be older than atime");
|
colas@0
|
152 |
ok(!$session->etime, "etime shouldn't be set yet");
|
colas@0
|
153 |
|
colas@0
|
154 |
ok( ($session->param) == 3, "session should hold params" );
|
colas@0
|
155 |
ok( $session->param('author') eq "Sherzod Ruzmetov", "my name's correct");
|
colas@0
|
156 |
|
colas@0
|
157 |
ok( ref ($session->param('emails')) eq 'ARRAY', "'emails' should hold list of values" );
|
colas@0
|
158 |
ok( @{ $session->param('emails') } == 2, "'emails' should hold list of two values");
|
colas@0
|
159 |
ok( $session->param('emails')->[0] eq 'sherzodr@cpan.org', "first value is correct!");
|
colas@0
|
160 |
ok( $session->param('emails')->[1] eq 'sherzodr@handalak.com', "second value is correct!");
|
colas@0
|
161 |
|
colas@0
|
162 |
ok( ref( $session->param('blogs') ) eq 'HASH', "'blogs' holds a hash");
|
colas@0
|
163 |
ok( $session->param('blogs')->{'./lost+found'} eq 'http://author.handalak.com/', "first blog is correct!");
|
colas@0
|
164 |
ok( $session->param('blogs')->{'Yigitlik sarguzashtlari'} eq 'http://author.handalak.com/uz/', "second blog is correct!");
|
colas@0
|
165 |
|
colas@0
|
166 |
# TODO: test many any other variations of expire() syntax
|
colas@0
|
167 |
$session->expire('+1s');
|
colas@0
|
168 |
ok($session->etime == 1, "etime set to 1 second");
|
colas@0
|
169 |
|
colas@0
|
170 |
$session->expire("+1m");
|
colas@0
|
171 |
ok($session->etime == 60, "etime set to one minute");
|
colas@0
|
172 |
|
colas@0
|
173 |
$session->expires("2h");
|
colas@0
|
174 |
ok($session->etime == 7200, "etime set to two hours");
|
colas@0
|
175 |
|
colas@0
|
176 |
$session->expires("5d");
|
colas@0
|
177 |
ok($session->etime == 432000, "etime set to 5 days");
|
colas@0
|
178 |
|
colas@0
|
179 |
$session->expires("-10s");
|
colas@0
|
180 |
ok($session->etime == -10, "etime set to 10 seconds in the past");
|
colas@0
|
181 |
|
colas@0
|
182 |
#
|
colas@0
|
183 |
# Setting the expiration time back to 1s, so that subsequent tests
|
colas@0
|
184 |
# relying on this value pass
|
colas@0
|
185 |
#
|
colas@0
|
186 |
$session->expire("1s");
|
colas@0
|
187 |
ok($session->etime == 1, "etime set back to one second");
|
colas@0
|
188 |
eval { $session->close(); };
|
colas@0
|
189 |
is($@, '', 'calling close method survives eval');
|
colas@0
|
190 |
}
|
colas@0
|
191 |
}
|
colas@0
|
192 |
|
colas@0
|
193 |
sleep(1); # <-- letting the time tick
|
colas@0
|
194 |
|
colas@0
|
195 |
my $driver;
|
colas@0
|
196 |
THREE: {
|
colas@0
|
197 |
ok(1, "=== 3 ===");
|
colas@0
|
198 |
my $session = CGI::Session->load($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
|
colas@0
|
199 |
ok($session, "Session instance loaded ");
|
colas@0
|
200 |
ok(!$session->id, "session doesn't have ID");
|
colas@0
|
201 |
ok($session->is_empty, "session is empty, which is the same as above");
|
colas@0
|
202 |
#print $session->dump;
|
colas@0
|
203 |
ok($session->is_expired, "session was expired");
|
colas@0
|
204 |
ok(!$session->param('author'), "session data cleared");
|
colas@0
|
205 |
|
colas@0
|
206 |
sleep(1);
|
colas@0
|
207 |
|
colas@0
|
208 |
$session = $session->new() or die CGI::Session->errstr;
|
colas@0
|
209 |
#print $session->dump();
|
colas@0
|
210 |
ok($session, "new session created");
|
colas@0
|
211 |
ok($session->id, "session has id :" . $session->id );
|
colas@0
|
212 |
ok(!$session->is_expired, "session isn't expired");
|
colas@0
|
213 |
ok(!$session->is_empty, "session isn't empty");
|
colas@0
|
214 |
ok($session->atime == $session->ctime, "access and creation times are same");
|
colas@0
|
215 |
|
colas@0
|
216 |
ok($session->id ne $sid, "it's a completely different session than above");
|
colas@0
|
217 |
|
colas@0
|
218 |
$driver = $session->_driver();
|
colas@0
|
219 |
$sid = $session->id;
|
colas@0
|
220 |
}
|
colas@0
|
221 |
|
colas@0
|
222 |
|
colas@0
|
223 |
|
colas@0
|
224 |
FOUR: {
|
colas@0
|
225 |
# We are intentionally removing the session stored in the datastore and will be requesting
|
colas@0
|
226 |
# re-initialization of that id. This test is necessary since I noticed weird behaviors in
|
colas@0
|
227 |
# some of my web applications that kept creating new sessions when the object requested
|
colas@0
|
228 |
# wasn't in the datastore.
|
colas@0
|
229 |
ok(1, "=== 4 ===");
|
colas@0
|
230 |
|
colas@0
|
231 |
ok($driver->remove( $sid ), "Session '$sid' removed from datastore successfully");
|
colas@0
|
232 |
|
colas@0
|
233 |
my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args} ) or die CGI::Session->errstr;
|
colas@0
|
234 |
ok($session, "session object created successfully");
|
colas@0
|
235 |
ok($session->id ne $sid, "claimed ID ($sid) couldn't be recovered. New ID is: " . $session->id);
|
colas@0
|
236 |
$sid = $session->id;
|
colas@0
|
237 |
}
|
colas@0
|
238 |
|
colas@0
|
239 |
|
colas@0
|
240 |
|
colas@0
|
241 |
FIVE: {
|
colas@0
|
242 |
ok(1, "=== 5 ===");
|
colas@0
|
243 |
my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
|
colas@0
|
244 |
ok($session, "Session object created successfully");
|
colas@0
|
245 |
ok($session->id eq $sid, "claimed id ($sid) was recovered successfully!");
|
colas@0
|
246 |
|
colas@0
|
247 |
# Remove the object, finally!
|
colas@0
|
248 |
$session->delete();
|
colas@0
|
249 |
}
|
colas@0
|
250 |
|
colas@0
|
251 |
|
colas@0
|
252 |
SIX: {
|
colas@0
|
253 |
ok(1, "=== 6 ===");
|
colas@0
|
254 |
my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
|
colas@0
|
255 |
ok($session, "Session object created successfully");
|
colas@0
|
256 |
ok($session->id ne $sid, "New object created, because previous object was deleted");
|
colas@0
|
257 |
$sid = $session->id;
|
colas@0
|
258 |
|
colas@0
|
259 |
#
|
colas@0
|
260 |
# creating a simple object to be stored into session
|
colas@0
|
261 |
my $simple_class = SimpleObjectClass->new();
|
colas@0
|
262 |
ok($simple_class, "SimpleObjectClass created successfully");
|
colas@0
|
263 |
|
colas@0
|
264 |
$simple_class->name("Sherzod Ruzmetov");
|
colas@0
|
265 |
$simple_class->emails(0, 'sherzodr@handalak.com');
|
colas@0
|
266 |
$simple_class->emails(1, 'sherzodr@cpan.org');
|
colas@0
|
267 |
$simple_class->blogs('lost+found', 'http://author.handalak.com/');
|
colas@0
|
268 |
$simple_class->blogs('yigitlik', 'http://author.handalak.com/uz/');
|
colas@0
|
269 |
$session->param('simple_object', $simple_class);
|
colas@0
|
270 |
|
colas@0
|
271 |
ok($session->param('simple_object')->name eq "Sherzod Ruzmetov");
|
colas@0
|
272 |
ok($session->param('simple_object')->emails(1) eq 'sherzodr@cpan.org');
|
colas@0
|
273 |
ok($session->param('simple_object')->blogs('yigitlik') eq 'http://author.handalak.com/uz/');
|
colas@0
|
274 |
|
colas@0
|
275 |
#
|
colas@0
|
276 |
# creating an overloaded object to be stored into session
|
colas@0
|
277 |
my $overloaded_class = OverloadedObjectClass->new("ABCDEFG");
|
colas@0
|
278 |
ok($overloaded_class, "OverloadedObjectClass created successfully");
|
colas@0
|
279 |
ok(overload::Overloaded($overloaded_class) , "OverloadedObjectClass is properly overloaded");
|
colas@0
|
280 |
ok(ref ($overloaded_class) eq "OverloadedObjectClass", "OverloadedObjectClass is an object");
|
colas@0
|
281 |
$session->param("overloaded_object", $overloaded_class);
|
colas@0
|
282 |
|
colas@0
|
283 |
ok($session->param("overloaded_object") eq "ABCDEFG");
|
colas@0
|
284 |
|
colas@0
|
285 |
my $simple_class2 = SimpleObjectClass->new();
|
colas@0
|
286 |
ok($simple_class2, "SimpleObjectClass created successfully");
|
colas@0
|
287 |
|
colas@0
|
288 |
$simple_class2->name("Sherzod Ruzmetov");
|
colas@0
|
289 |
$simple_class2->emails(0, 'sherzodr@handalak.com');
|
colas@0
|
290 |
$simple_class2->emails(1, 'sherzodr@cpan.org');
|
colas@0
|
291 |
$simple_class2->blogs('lost+found', 'http://author.handalak.com/');
|
colas@0
|
292 |
$simple_class2->blogs('yigitlik', 'http://author.handalak.com/uz/');
|
colas@0
|
293 |
my $embedded = OverloadedObjectClass->new("Embedded");
|
colas@0
|
294 |
$session->param("embedded_simple_and_overloaded",[ undef, $simple_class2, $embedded, $embedded ]);
|
colas@0
|
295 |
|
colas@0
|
296 |
ok(!defined($session->param("embedded_simple_and_overloaded")->[0]),"First element of anonymous array undef");
|
colas@0
|
297 |
|
colas@0
|
298 |
ok($session->param("embedded_simple_and_overloaded")->[1]->name eq "Sherzod Ruzmetov");
|
colas@0
|
299 |
ok($session->param("embedded_simple_and_overloaded")->[1]->emails(1) eq 'sherzodr@cpan.org');
|
colas@0
|
300 |
ok($session->param("embedded_simple_and_overloaded")->[1]->blogs('yigitlik') eq 'http://author.handalak.com/uz/');
|
colas@0
|
301 |
|
colas@0
|
302 |
ok($session->param("embedded_simple_and_overloaded")->[2] eq "Embedded");
|
colas@0
|
303 |
|
colas@0
|
304 |
ok(refaddr($session->param("embedded_simple_and_overloaded")->[2]) == refaddr($session->param("embedded_simple_and_overloaded")->[3] ),
|
colas@0
|
305 |
"Overloaded objects have matching addresses");
|
colas@0
|
306 |
}
|
colas@0
|
307 |
|
colas@0
|
308 |
|
colas@0
|
309 |
SEVEN: {
|
colas@0
|
310 |
ok(1, "=== 7 ===");
|
colas@0
|
311 |
my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
|
colas@0
|
312 |
ok($session, "Session object created successfully");
|
colas@0
|
313 |
ok($session->id eq $sid, "Previously stored object loaded successfully");
|
colas@0
|
314 |
|
colas@0
|
315 |
|
colas@0
|
316 |
my $simple_object = $session->param("simple_object");
|
colas@0
|
317 |
ok(ref $simple_object eq "SimpleObjectClass", "SimpleObjectClass loaded successfully");
|
colas@0
|
318 |
|
colas@0
|
319 |
my $dsn = CGI::Session->parse_dsn($self->{dsn});
|
colas@0
|
320 |
ok_later { $simple_object->name eq "Sherzod Ruzmetov" };
|
colas@0
|
321 |
ok_later { $simple_object->emails(1) eq 'sherzodr@cpan.org' };
|
colas@0
|
322 |
ok_later { $simple_object->emails(0) eq 'sherzodr@handalak.com' };
|
colas@0
|
323 |
ok_later { $simple_object->blogs('lost+found') eq 'http://author.handalak.com/' };
|
colas@0
|
324 |
ok(ref $session->param("overloaded_object") );
|
colas@0
|
325 |
ok($session->param("overloaded_object") eq "ABCDEFG", "Object is still overloaded");
|
colas@0
|
326 |
ok(overload::Overloaded($session->param("overloaded_object")), "Object is really overloaded");
|
colas@0
|
327 |
|
colas@0
|
328 |
ok(!defined($session->param("embedded_simple_and_overloaded")->[0]),"First element of anonymous array undef");
|
colas@0
|
329 |
|
colas@0
|
330 |
my $simple_object2 = $session->param("embedded_simple_and_overloaded")->[1];
|
colas@0
|
331 |
ok(ref $simple_object2 eq "SimpleObjectClass", "SimpleObjectClass loaded successfully");
|
colas@0
|
332 |
|
colas@0
|
333 |
ok_later { $simple_object2->name eq "Sherzod Ruzmetov" };
|
colas@0
|
334 |
ok_later { $simple_object2->emails(1) eq 'sherzodr@cpan.org' };
|
colas@0
|
335 |
ok_later { $simple_object2->emails(0) eq 'sherzodr@handalak.com' };
|
colas@0
|
336 |
ok_later { $simple_object2->blogs('lost+found') eq 'http://author.handalak.com/' };
|
colas@0
|
337 |
|
colas@0
|
338 |
|
colas@0
|
339 |
ok($session->param("embedded_simple_and_overloaded")->[2] eq "Embedded");
|
colas@0
|
340 |
ok(overload::Overloaded($session->param("embedded_simple_and_overloaded")->[2]), "Object is really overloaded");
|
colas@0
|
341 |
|
colas@0
|
342 |
ok(refaddr($session->param("embedded_simple_and_overloaded")->[2]) == refaddr($session->param("embedded_simple_and_overloaded")->[3]),
|
colas@0
|
343 |
"Overloaded objects have matching addresses");
|
colas@0
|
344 |
$session->delete();
|
colas@0
|
345 |
}
|
colas@0
|
346 |
|
colas@0
|
347 |
$CURRENT = undef;
|
colas@0
|
348 |
$self->{test_number} = 0;
|
colas@0
|
349 |
}
|
colas@0
|
350 |
|
colas@0
|
351 |
sub skip_or_run {
|
colas@0
|
352 |
my $test = shift;
|
colas@0
|
353 |
|
colas@0
|
354 |
$CURRENT->{test_number} ++;
|
colas@0
|
355 |
|
colas@0
|
356 |
SKIP: {
|
colas@0
|
357 |
if($CURRENT->{_skip}->{$CURRENT->{test_number}}) {
|
colas@0
|
358 |
Test::More::skip("Test does not apply to this setup.", 1);
|
colas@0
|
359 |
}
|
colas@0
|
360 |
|
colas@0
|
361 |
no strict 'refs';
|
colas@0
|
362 |
&{"Test::More::$test"}(@_);
|
colas@0
|
363 |
}
|
colas@0
|
364 |
}
|
colas@0
|
365 |
|
colas@0
|
366 |
sub ok { skip_or_run("ok", @_); }
|
colas@0
|
367 |
sub use_ok { skip_or_run("use_ok", @_); }
|
colas@0
|
368 |
sub is { skip_or_run("is", @_); }
|
colas@0
|
369 |
|
colas@0
|
370 |
sub ok_later (&;$) {
|
colas@0
|
371 |
my($code, $name) = @_;
|
colas@0
|
372 |
|
colas@0
|
373 |
$CURRENT->{test_number} ++;
|
colas@0
|
374 |
$name = '' unless $name;
|
colas@0
|
375 |
|
colas@0
|
376 |
SKIP: {
|
colas@0
|
377 |
if($CURRENT->{_skip}->{$CURRENT->{test_number}}) {
|
colas@0
|
378 |
Test::More::skip("Test does not apply to this setup.", 1);
|
colas@0
|
379 |
fail($name);
|
colas@0
|
380 |
} else {
|
colas@0
|
381 |
Test::More::ok($code->(), $name);
|
colas@0
|
382 |
}
|
colas@0
|
383 |
}
|
colas@0
|
384 |
}
|
colas@0
|
385 |
|
colas@0
|
386 |
sub DESTROY { 1; }
|
colas@0
|
387 |
|
colas@0
|
388 |
|
colas@0
|
389 |
package SimpleObjectClass;
|
colas@0
|
390 |
use strict;
|
colas@0
|
391 |
use Class::Struct;
|
colas@0
|
392 |
|
colas@0
|
393 |
struct (
|
colas@0
|
394 |
name => '$',
|
colas@0
|
395 |
emails => '@',
|
colas@0
|
396 |
blogs => '%'
|
colas@0
|
397 |
);
|
colas@0
|
398 |
|
colas@0
|
399 |
|
colas@0
|
400 |
|
colas@0
|
401 |
package OverloadedObjectClass;
|
colas@0
|
402 |
|
colas@0
|
403 |
use strict;
|
colas@0
|
404 |
use overload (
|
colas@0
|
405 |
'""' => \&as_string,
|
colas@0
|
406 |
'eq' => \&equals
|
colas@0
|
407 |
);
|
colas@0
|
408 |
|
colas@0
|
409 |
sub new {
|
colas@0
|
410 |
return bless {
|
colas@0
|
411 |
str_value => $_[1]
|
colas@0
|
412 |
}, $_[0];
|
colas@0
|
413 |
}
|
colas@0
|
414 |
|
colas@0
|
415 |
|
colas@0
|
416 |
sub as_string {
|
colas@0
|
417 |
return $_[0]->{str_value};
|
colas@0
|
418 |
}
|
colas@0
|
419 |
|
colas@0
|
420 |
sub equals {
|
colas@0
|
421 |
my ($self, $arg) = @_;
|
colas@0
|
422 |
|
colas@0
|
423 |
return ($self->as_string eq $arg);
|
colas@0
|
424 |
}
|
colas@0
|
425 |
|
colas@0
|
426 |
1;
|