lib/CPAN/lib/CGI/Session/Test/Default.pm
changeset 0 414e01d06fd5
equal deleted inserted replaced
-1:000000000000 0:414e01d06fd5
       
     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;