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