lib/CPAN/lib/CGI/Session/Test/Default.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
permissions -rw-r--r--
RELEASE 4.2.0 freetown
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;