lib/CPAN/lib/CGI/Session/Test/Default.pm
changeset 0 414e01d06fd5
     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;