1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/lib/CPAN/lib/CGI/Session/Test/Default.pm Sat Jan 26 15:50:53 2008 +0100
1.3 @@ -0,0 +1,426 @@
1.4 +package CGI::Session::Test::Default;
1.5 +
1.6 +use strict;
1.7 +use Carp;
1.8 +use Test::More ();
1.9 +use Data::Dumper;
1.10 +use Scalar::Util "refaddr";
1.11 +
1.12 +our $AUTOLOAD;
1.13 +our $CURRENT;
1.14 +sub ok_later (&;$);
1.15 +
1.16 +
1.17 +$CGI::Session::Test::Default::VERSION = '4.20';
1.18 +
1.19 +=head1 CGI::Session::Test::Default
1.20 +
1.21 +Run a suite of tests for a given CGI::Session::Driver
1.22 +
1.23 +=head2 new()
1.24 +
1.25 + my $t = CGI::Session::Test::Default->new(
1.26 + # These are all optional, with default as follows
1.27 + dsn => "driver:file",
1.28 + args => undef,
1.29 + tests => 77,
1.30 + );
1.31 +
1.32 +Create a new test object, possibly overriding some defaults.
1.33 +
1.34 +=cut
1.35 +
1.36 +sub new {
1.37 + my $class = shift;
1.38 + my $self = bless {
1.39 + dsn => "driver:file",
1.40 + args => undef,
1.41 + tests => 101,
1.42 + test_number => 0,
1.43 + @_
1.44 + }, $class;
1.45 +
1.46 + if($self->{skip}) {
1.47 + $self->{_skip} = { map { $_ => $_ } @{$self->{skip}} };
1.48 + } else {
1.49 + $self->{_skip} = {};
1.50 + }
1.51 +
1.52 + return $self;
1.53 +}
1.54 +
1.55 +=head2 number_of_tests()
1.56 +
1.57 + my $new_num = $t->number_of_tests($new_num);
1.58 +
1.59 +A setter/accessor method to affect the number of tests to run,
1.60 +after C<new()> has been called and before C<run()>.
1.61 +
1.62 +=cut
1.63 +
1.64 +sub number_of_tests {
1.65 + my $self = shift;
1.66 +
1.67 + if ( @_ ) {
1.68 + $self->{tests} = $_[0];
1.69 + }
1.70 +
1.71 + return $self->{tests};
1.72 +}
1.73 +
1.74 +=head2 run()
1.75 +
1.76 + $t->run();
1.77 +
1.78 +Run the test suite. See C<new()> for setting related options.
1.79 +
1.80 +=cut
1.81 +
1.82 +sub run {
1.83 + my $self = shift;
1.84 +
1.85 + $CURRENT = $self;
1.86 + use_ok("CGI::Session", "CGI::Session loaded successfully!");
1.87 +
1.88 + my $sid = undef;
1.89 + FIRST: {
1.90 + ok(1, "=== 1 ===");
1.91 + my $session = CGI::Session->load() or die CGI::Session->errstr;
1.92 + ok($session, "empty session should be created");
1.93 + ok(!$session->id);
1.94 + ok($session->is_empty);
1.95 + ok(!$session->is_expired);
1.96 +
1.97 + undef $session;
1.98 +
1.99 + $session = CGI::Session->new($self->{dsn}, '_DOESN\'T EXIST_', $self->{args}) or die CGI::Session->errstr;
1.100 + ok( $session, "Session created successfully!");
1.101 +
1.102 + #
1.103 + # checking if the driver object created is really the driver requested:
1.104 + #
1.105 + my $dsn = $session->parse_dsn( $self->{dsn} );
1.106 + ok( ref $session->_driver eq "CGI::Session::Driver::" . $dsn->{driver}, ref $dsn->{Driver} );
1.107 +
1.108 + ok( $session->ctime && $session->atime, "ctime & atime are set");
1.109 + ok( $session->atime == $session->ctime, "ctime == atime");
1.110 + ok( !$session->etime, "etime not set yet");
1.111 +
1.112 + ok( $session->id, "session id is " . $session->id);
1.113 +
1.114 + $session->param('author', "Sherzod Ruzmetov");
1.115 + $session->param(-name=>'emails', -value=>['sherzodr@cpan.org', 'sherzodr@handalak.com']);
1.116 + $session->param('blogs', {
1.117 + './lost+found' => 'http://author.handalak.com/',
1.118 + 'Yigitlik sarguzashtlari' => 'http://author.handalak.com/uz/'
1.119 + });
1.120 +
1.121 + ok( ($session->param) == 3, "session holds 3 params" . scalar $session->param );
1.122 + ok( $session->param('author') eq "Sherzod Ruzmetov", "My name's correct!");
1.123 +
1.124 + ok( ref ($session->param('emails')) eq 'ARRAY', "'emails' holds list of values" );
1.125 + ok( @{ $session->param('emails') } == 2, "'emails' holds list of two values");
1.126 + ok( $session->param('emails')->[0] eq 'sherzodr@cpan.org', "first value of 'emails' is correct!");
1.127 + ok( $session->param('emails')->[1] eq 'sherzodr@handalak.com', "second value of 'emails' is correct!");
1.128 +
1.129 + ok( ref( $session->param('blogs') ) eq 'HASH', "'blogs' holds a hash");
1.130 + ok( $session->param('blogs')->{'./lost+found'} eq 'http://author.handalak.com/', "first blog is correct");
1.131 + ok( $session->param('blogs')->{'Yigitlik sarguzashtlari'} eq 'http://author.handalak.com/uz/', "second blog is correct");
1.132 +
1.133 + $sid = $session->id;
1.134 + $session->flush();
1.135 + }
1.136 +
1.137 + sleep(1);
1.138 +
1.139 + SECOND: {
1.140 + SKIP: {
1.141 + ok(1, "=== 2 ===");
1.142 + my $session;
1.143 + eval { $session = CGI::Session->load($self->{dsn}, $sid, $self->{args}) };
1.144 +
1.145 + if ($@ || CGI::Session->errstr) {
1.146 + Test::More::skip("couldn't load session, bailing out: SQLite/Storable support is TODO", 56);
1.147 + }
1.148 +
1.149 + is($@.CGI::Session->errstr,'','survived eval without error.');
1.150 + ok($session, "Session was retrieved successfully");
1.151 + ok(!$session->is_expired, "session isn't expired yet");
1.152 +
1.153 + is($session->id,$sid, "session IDs are consistent");
1.154 + ok($session->atime > $session->ctime, "ctime should be older than atime");
1.155 + ok(!$session->etime, "etime shouldn't be set yet");
1.156 +
1.157 + ok( ($session->param) == 3, "session should hold params" );
1.158 + ok( $session->param('author') eq "Sherzod Ruzmetov", "my name's correct");
1.159 +
1.160 + ok( ref ($session->param('emails')) eq 'ARRAY', "'emails' should hold list of values" );
1.161 + ok( @{ $session->param('emails') } == 2, "'emails' should hold list of two values");
1.162 + ok( $session->param('emails')->[0] eq 'sherzodr@cpan.org', "first value is correct!");
1.163 + ok( $session->param('emails')->[1] eq 'sherzodr@handalak.com', "second value is correct!");
1.164 +
1.165 + ok( ref( $session->param('blogs') ) eq 'HASH', "'blogs' holds a hash");
1.166 + ok( $session->param('blogs')->{'./lost+found'} eq 'http://author.handalak.com/', "first blog is correct!");
1.167 + ok( $session->param('blogs')->{'Yigitlik sarguzashtlari'} eq 'http://author.handalak.com/uz/', "second blog is correct!");
1.168 +
1.169 + # TODO: test many any other variations of expire() syntax
1.170 + $session->expire('+1s');
1.171 + ok($session->etime == 1, "etime set to 1 second");
1.172 +
1.173 + $session->expire("+1m");
1.174 + ok($session->etime == 60, "etime set to one minute");
1.175 +
1.176 + $session->expires("2h");
1.177 + ok($session->etime == 7200, "etime set to two hours");
1.178 +
1.179 + $session->expires("5d");
1.180 + ok($session->etime == 432000, "etime set to 5 days");
1.181 +
1.182 + $session->expires("-10s");
1.183 + ok($session->etime == -10, "etime set to 10 seconds in the past");
1.184 +
1.185 + #
1.186 + # Setting the expiration time back to 1s, so that subsequent tests
1.187 + # relying on this value pass
1.188 + #
1.189 + $session->expire("1s");
1.190 + ok($session->etime == 1, "etime set back to one second");
1.191 + eval { $session->close(); };
1.192 + is($@, '', 'calling close method survives eval');
1.193 + }
1.194 + }
1.195 +
1.196 + sleep(1); # <-- letting the time tick
1.197 +
1.198 + my $driver;
1.199 + THREE: {
1.200 + ok(1, "=== 3 ===");
1.201 + my $session = CGI::Session->load($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
1.202 + ok($session, "Session instance loaded ");
1.203 + ok(!$session->id, "session doesn't have ID");
1.204 + ok($session->is_empty, "session is empty, which is the same as above");
1.205 + #print $session->dump;
1.206 + ok($session->is_expired, "session was expired");
1.207 + ok(!$session->param('author'), "session data cleared");
1.208 +
1.209 + sleep(1);
1.210 +
1.211 + $session = $session->new() or die CGI::Session->errstr;
1.212 + #print $session->dump();
1.213 + ok($session, "new session created");
1.214 + ok($session->id, "session has id :" . $session->id );
1.215 + ok(!$session->is_expired, "session isn't expired");
1.216 + ok(!$session->is_empty, "session isn't empty");
1.217 + ok($session->atime == $session->ctime, "access and creation times are same");
1.218 +
1.219 + ok($session->id ne $sid, "it's a completely different session than above");
1.220 +
1.221 + $driver = $session->_driver();
1.222 + $sid = $session->id;
1.223 + }
1.224 +
1.225 +
1.226 +
1.227 + FOUR: {
1.228 + # We are intentionally removing the session stored in the datastore and will be requesting
1.229 + # re-initialization of that id. This test is necessary since I noticed weird behaviors in
1.230 + # some of my web applications that kept creating new sessions when the object requested
1.231 + # wasn't in the datastore.
1.232 + ok(1, "=== 4 ===");
1.233 +
1.234 + ok($driver->remove( $sid ), "Session '$sid' removed from datastore successfully");
1.235 +
1.236 + my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args} ) or die CGI::Session->errstr;
1.237 + ok($session, "session object created successfully");
1.238 + ok($session->id ne $sid, "claimed ID ($sid) couldn't be recovered. New ID is: " . $session->id);
1.239 + $sid = $session->id;
1.240 + }
1.241 +
1.242 +
1.243 +
1.244 + FIVE: {
1.245 + ok(1, "=== 5 ===");
1.246 + my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
1.247 + ok($session, "Session object created successfully");
1.248 + ok($session->id eq $sid, "claimed id ($sid) was recovered successfully!");
1.249 +
1.250 + # Remove the object, finally!
1.251 + $session->delete();
1.252 + }
1.253 +
1.254 +
1.255 + SIX: {
1.256 + ok(1, "=== 6 ===");
1.257 + my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
1.258 + ok($session, "Session object created successfully");
1.259 + ok($session->id ne $sid, "New object created, because previous object was deleted");
1.260 + $sid = $session->id;
1.261 +
1.262 + #
1.263 + # creating a simple object to be stored into session
1.264 + my $simple_class = SimpleObjectClass->new();
1.265 + ok($simple_class, "SimpleObjectClass created successfully");
1.266 +
1.267 + $simple_class->name("Sherzod Ruzmetov");
1.268 + $simple_class->emails(0, 'sherzodr@handalak.com');
1.269 + $simple_class->emails(1, 'sherzodr@cpan.org');
1.270 + $simple_class->blogs('lost+found', 'http://author.handalak.com/');
1.271 + $simple_class->blogs('yigitlik', 'http://author.handalak.com/uz/');
1.272 + $session->param('simple_object', $simple_class);
1.273 +
1.274 + ok($session->param('simple_object')->name eq "Sherzod Ruzmetov");
1.275 + ok($session->param('simple_object')->emails(1) eq 'sherzodr@cpan.org');
1.276 + ok($session->param('simple_object')->blogs('yigitlik') eq 'http://author.handalak.com/uz/');
1.277 +
1.278 + #
1.279 + # creating an overloaded object to be stored into session
1.280 + my $overloaded_class = OverloadedObjectClass->new("ABCDEFG");
1.281 + ok($overloaded_class, "OverloadedObjectClass created successfully");
1.282 + ok(overload::Overloaded($overloaded_class) , "OverloadedObjectClass is properly overloaded");
1.283 + ok(ref ($overloaded_class) eq "OverloadedObjectClass", "OverloadedObjectClass is an object");
1.284 + $session->param("overloaded_object", $overloaded_class);
1.285 +
1.286 + ok($session->param("overloaded_object") eq "ABCDEFG");
1.287 +
1.288 + my $simple_class2 = SimpleObjectClass->new();
1.289 + ok($simple_class2, "SimpleObjectClass created successfully");
1.290 +
1.291 + $simple_class2->name("Sherzod Ruzmetov");
1.292 + $simple_class2->emails(0, 'sherzodr@handalak.com');
1.293 + $simple_class2->emails(1, 'sherzodr@cpan.org');
1.294 + $simple_class2->blogs('lost+found', 'http://author.handalak.com/');
1.295 + $simple_class2->blogs('yigitlik', 'http://author.handalak.com/uz/');
1.296 + my $embedded = OverloadedObjectClass->new("Embedded");
1.297 + $session->param("embedded_simple_and_overloaded",[ undef, $simple_class2, $embedded, $embedded ]);
1.298 +
1.299 + ok(!defined($session->param("embedded_simple_and_overloaded")->[0]),"First element of anonymous array undef");
1.300 +
1.301 + ok($session->param("embedded_simple_and_overloaded")->[1]->name eq "Sherzod Ruzmetov");
1.302 + ok($session->param("embedded_simple_and_overloaded")->[1]->emails(1) eq 'sherzodr@cpan.org');
1.303 + ok($session->param("embedded_simple_and_overloaded")->[1]->blogs('yigitlik') eq 'http://author.handalak.com/uz/');
1.304 +
1.305 + ok($session->param("embedded_simple_and_overloaded")->[2] eq "Embedded");
1.306 +
1.307 + ok(refaddr($session->param("embedded_simple_and_overloaded")->[2]) == refaddr($session->param("embedded_simple_and_overloaded")->[3] ),
1.308 + "Overloaded objects have matching addresses");
1.309 + }
1.310 +
1.311 +
1.312 + SEVEN: {
1.313 + ok(1, "=== 7 ===");
1.314 + my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
1.315 + ok($session, "Session object created successfully");
1.316 + ok($session->id eq $sid, "Previously stored object loaded successfully");
1.317 +
1.318 +
1.319 + my $simple_object = $session->param("simple_object");
1.320 + ok(ref $simple_object eq "SimpleObjectClass", "SimpleObjectClass loaded successfully");
1.321 +
1.322 + my $dsn = CGI::Session->parse_dsn($self->{dsn});
1.323 + ok_later { $simple_object->name eq "Sherzod Ruzmetov" };
1.324 + ok_later { $simple_object->emails(1) eq 'sherzodr@cpan.org' };
1.325 + ok_later { $simple_object->emails(0) eq 'sherzodr@handalak.com' };
1.326 + ok_later { $simple_object->blogs('lost+found') eq 'http://author.handalak.com/' };
1.327 + ok(ref $session->param("overloaded_object") );
1.328 + ok($session->param("overloaded_object") eq "ABCDEFG", "Object is still overloaded");
1.329 + ok(overload::Overloaded($session->param("overloaded_object")), "Object is really overloaded");
1.330 +
1.331 + ok(!defined($session->param("embedded_simple_and_overloaded")->[0]),"First element of anonymous array undef");
1.332 +
1.333 + my $simple_object2 = $session->param("embedded_simple_and_overloaded")->[1];
1.334 + ok(ref $simple_object2 eq "SimpleObjectClass", "SimpleObjectClass loaded successfully");
1.335 +
1.336 + ok_later { $simple_object2->name eq "Sherzod Ruzmetov" };
1.337 + ok_later { $simple_object2->emails(1) eq 'sherzodr@cpan.org' };
1.338 + ok_later { $simple_object2->emails(0) eq 'sherzodr@handalak.com' };
1.339 + ok_later { $simple_object2->blogs('lost+found') eq 'http://author.handalak.com/' };
1.340 +
1.341 +
1.342 + ok($session->param("embedded_simple_and_overloaded")->[2] eq "Embedded");
1.343 + ok(overload::Overloaded($session->param("embedded_simple_and_overloaded")->[2]), "Object is really overloaded");
1.344 +
1.345 + ok(refaddr($session->param("embedded_simple_and_overloaded")->[2]) == refaddr($session->param("embedded_simple_and_overloaded")->[3]),
1.346 + "Overloaded objects have matching addresses");
1.347 + $session->delete();
1.348 + }
1.349 +
1.350 + $CURRENT = undef;
1.351 + $self->{test_number} = 0;
1.352 +}
1.353 +
1.354 +sub skip_or_run {
1.355 + my $test = shift;
1.356 +
1.357 + $CURRENT->{test_number} ++;
1.358 +
1.359 + SKIP: {
1.360 + if($CURRENT->{_skip}->{$CURRENT->{test_number}}) {
1.361 + Test::More::skip("Test does not apply to this setup.", 1);
1.362 + }
1.363 +
1.364 + no strict 'refs';
1.365 + &{"Test::More::$test"}(@_);
1.366 + }
1.367 +}
1.368 +
1.369 +sub ok { skip_or_run("ok", @_); }
1.370 +sub use_ok { skip_or_run("use_ok", @_); }
1.371 +sub is { skip_or_run("is", @_); }
1.372 +
1.373 +sub ok_later (&;$) {
1.374 + my($code, $name) = @_;
1.375 +
1.376 + $CURRENT->{test_number} ++;
1.377 + $name = '' unless $name;
1.378 +
1.379 + SKIP: {
1.380 + if($CURRENT->{_skip}->{$CURRENT->{test_number}}) {
1.381 + Test::More::skip("Test does not apply to this setup.", 1);
1.382 + fail($name);
1.383 + } else {
1.384 + Test::More::ok($code->(), $name);
1.385 + }
1.386 + }
1.387 +}
1.388 +
1.389 +sub DESTROY { 1; }
1.390 +
1.391 +
1.392 +package SimpleObjectClass;
1.393 +use strict;
1.394 +use Class::Struct;
1.395 +
1.396 +struct (
1.397 + name => '$',
1.398 + emails => '@',
1.399 + blogs => '%'
1.400 +);
1.401 +
1.402 +
1.403 +
1.404 +package OverloadedObjectClass;
1.405 +
1.406 +use strict;
1.407 +use overload (
1.408 + '""' => \&as_string,
1.409 + 'eq' => \&equals
1.410 +);
1.411 +
1.412 +sub new {
1.413 + return bless {
1.414 + str_value => $_[1]
1.415 + }, $_[0];
1.416 +}
1.417 +
1.418 +
1.419 +sub as_string {
1.420 + return $_[0]->{str_value};
1.421 +}
1.422 +
1.423 +sub equals {
1.424 + my ($self, $arg) = @_;
1.425 +
1.426 + return ($self->as_string eq $arg);
1.427 +}
1.428 +
1.429 +1;