View of /DadaFork/DADA/perllib/CGI/Session/Test/Default.pm

Parent Directory

Revision Log

Base version: DadaMail 2.10.12

package CGI::Session::Test::Default;

use strict;
use Carp;
use Test::More ();
use Data::Dumper;
use Scalar::Util "refaddr";

our $AUTOLOAD;
our $CURRENT;
sub ok_later (&;$);
    

$CGI::Session::Test::Default::VERSION = '1.54';

=head1 CGI::Session::Test::Default

Run a suite of tests for a given CGI::Session::Driver

=head2 new()

    my $t = CGI::Session::Test::Default->new(
        # These are all optional, with default as follows
        dsn   => "driver:file",
        args  => undef,
        tests => 77,
    );

Create a new test object, possibly overriding some defaults.

=cut

sub new {
    my $class   = shift;
    my $self    = bless {
            dsn     => "driver:file",
            args    => undef,
            tests   => 101,
            test_number =>  0,
            @_
    }, $class;
    
    if($self->{skip}) {
        $self->{_skip} = { map { $_ => $_ } @{$self->{skip}} };
    } else {
        $self->{_skip} = {};
    }

    return $self;
}

=head2 number_of_tests()

    my $new_num = $t->number_of_tests($new_num);

A setter/accessor method to affect the number of tests to run,
after C<new()> has been called and before C<run()>.

=cut

sub number_of_tests {
    my $self = shift;

    if ( @_ ) {
        $self->{tests} = $_[0];
    }

    return $self->{tests};
}

=head2 run()

    $t->run();

Run the test suite. See C<new()> for setting related options.

=cut

sub run {
    my $self = shift;

    $CURRENT = $self;
    use_ok("CGI::Session", "CGI::Session loaded successfully!");

    my $sid = undef;
    FIRST: {
        ok(1, "=== 1 ===");
        my $session = CGI::Session->load() or die CGI::Session->errstr;
        ok($session, "empty session should be created");
        ok(!$session->id);
        ok($session->is_empty);
        ok(!$session->is_expired);

        undef $session;

        $session = CGI::Session->new($self->{dsn}, '_DOESN\'T EXIST_', $self->{args}) or die CGI::Session->errstr;
        ok( $session, "Session created successfully!");

        #
        # checking if the driver object created is really the driver requested:
        #
        my $dsn = $session->parse_dsn( $self->{dsn} );
        ok( ref $session->_driver eq "CGI::Session::Driver::" . $dsn->{driver}, ref $dsn->{Driver} );

        ok( $session->ctime && $session->atime, "ctime & atime are set");
        ok( $session->atime == $session->ctime, "ctime == atime");
        ok( !$session->etime, "etime not set yet");

        ok( $session->id, "session id is " . $session->id);

        $session->param('author', "Sherzod Ruzmetov");
        $session->param(-name=>'emails', -value=>['sherzodr@cpan.org', 'sherzodr@handalak.com']);
        $session->param('blogs', {
            './lost+found'              => 'http://author.handalak.com/',
            'Yigitlik sarguzashtlari'   => 'http://author.handalak.com/uz/'
        });

        ok( ($session->param) == 3, "session holds 3 params" . scalar $session->param );
        ok( $session->param('author') eq "Sherzod Ruzmetov", "My name's correct!");

        ok( ref ($session->param('emails')) eq 'ARRAY', "'emails' holds list of values" );
        ok( @{ $session->param('emails') } == 2, "'emails' holds list of two values");
        ok( $session->param('emails')->[0] eq 'sherzodr@cpan.org', "first value of 'emails' is correct!");
        ok( $session->param('emails')->[1] eq 'sherzodr@handalak.com', "second value of 'emails' is correct!");

        ok( ref( $session->param('blogs') ) eq 'HASH', "'blogs' holds a hash");
        ok( $session->param('blogs')->{'./lost+found'} eq 'http://author.handalak.com/', "first blog is correct");
        ok( $session->param('blogs')->{'Yigitlik sarguzashtlari'} eq 'http://author.handalak.com/uz/', "second blog is correct");

        $sid = $session->id;
        $session->flush();
    }

    sleep(1);

    SECOND: {
            SKIP: {
            ok(1, "=== 2 ===");
            my $session;
            eval { $session = CGI::Session->load($self->{dsn}, $sid, $self->{args}) };

            if ($@ || CGI::Session->errstr) {
                Test::More::skip("couldn't load session, bailing out: SQLite/Storable support is TODO", 56);
            }

            is($@.CGI::Session->errstr,'','survived eval without error.');
            ok($session, "Session was retrieved successfully");
            ok(!$session->is_expired, "session isn't expired yet");

            is($session->id,$sid, "session IDs are consistent: " . $session->id);
            ok($session->atime > $session->ctime, "ctime should be older than atime");
            ok(!$session->etime, "etime shouldn't be set yet");

            ok( ($session->param) == 3, "session should hold params" );
            ok( $session->param('author') eq "Sherzod Ruzmetov", "my name's correct");

            ok( ref ($session->param('emails')) eq 'ARRAY', "'emails' should hold list of values" );
            ok( @{ $session->param('emails') } == 2, "'emails' should hold list of two values");
            ok( $session->param('emails')->[0] eq 'sherzodr@cpan.org', "first value is correct!");
            ok( $session->param('emails')->[1] eq 'sherzodr@handalak.com', "second value is correct!");

            ok( ref( $session->param('blogs') ) eq 'HASH', "'blogs' holds a hash");
            ok( $session->param('blogs')->{'./lost+found'} eq 'http://author.handalak.com/', "first blog is correct!");
            ok( $session->param('blogs')->{'Yigitlik sarguzashtlari'} eq 'http://author.handalak.com/uz/', "second blog is correct!");

            # TODO: test many any other variations of expire() syntax
            $session->expire('+1s');
            ok($session->etime == 1, "etime set to 1 second");

            $session->expire("+1m");
            ok($session->etime == 60, "etime set to one minute");

            $session->expires("2h");
            ok($session->etime == 7200, "etime set to two hours");

            $session->expires("5d");
            ok($session->etime == 432000, "etime set to 5 days");

            $session->expires("-10s");
            ok($session->etime == -10, "etime set to 10 seconds in the past");

            #
            # Setting the expiration time back to 1s, so that subsequent tests
            # relying on this value pass
            #
            $session->expire("1s");
            ok($session->etime == 1, "etime set back to one second");
            eval { $session->close(); };
            is($@, '', 'calling close method survives eval');
        }
    }

    sleep(1);   # <-- letting the time tick

    my $driver;
    THREE: {
        ok(1, "=== 3 ===");
        my $session = CGI::Session->load($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
        ok($session, "Session instance loaded ");
        ok(!$session->id, "session doesn't have ID");
        ok($session->is_empty, "session is empty, which is the same as above");
        #print $session->dump;
        ok($session->is_expired, "session was expired");
        ok(!$session->param('author'), "session data cleared");

        sleep(1);

        $session = $session->new() or die CGI::Session->errstr;
        #print $session->dump();
        ok($session, "new session created");
        ok($session->id, "session has id :" . $session->id );
        ok(!$session->is_expired, "session isn't expired");
        ok(!$session->is_empty, "session isn't empty");
        ok($session->atime == $session->ctime, "access and creation times are same");

        ok($session->id ne $sid, "it's a completely different session than above");

        $driver     = $session->_driver();
        $sid        = $session->id;
    }



    FOUR: {
        # We are intentionally removing the session stored in the datastore and will be requesting
        # re-initialization of that id. This test is necessary since I noticed weird behaviors in
        # some of my web applications that kept creating new sessions when the object requested
        # wasn't in the datastore.
        ok(1, "=== 4 ===");

        ok($driver->remove( $sid ), "Session '$sid' removed from datastore successfully");

        my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args} ) or die CGI::Session->errstr;
        ok($session, "session object created successfully");
        ok($session->id ne $sid, "claimed ID ($sid) couldn't be recovered. New ID is: " . $session->id);
        $sid = $session->id;
    }



    FIVE: {
        ok(1, "=== 5 ===");
        my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
        ok($session, "Session object created successfully");
        ok($session->id eq $sid, "claimed id ($sid) was recovered successfully!");

        # Remove the object, finally!
        $session->delete();
    }


    SIX: {
        ok(1, "=== 6 ===");
        my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
        ok($session, "Session object created successfully");
        ok($session->id ne $sid, "New object created, because previous object was deleted");
        $sid = $session->id;

        #
        # creating a simple object to be stored into session
        my $simple_class = SimpleObjectClass->new();
        ok($simple_class, "SimpleObjectClass created successfully");

        $simple_class->name("Sherzod Ruzmetov");
        $simple_class->emails(0, 'sherzodr@handalak.com');
        $simple_class->emails(1, 'sherzodr@cpan.org');
        $simple_class->blogs('lost+found', 'http://author.handalak.com/');
        $simple_class->blogs('yigitlik', 'http://author.handalak.com/uz/');
        $session->param('simple_object', $simple_class);

        ok($session->param('simple_object')->name eq "Sherzod Ruzmetov");
        ok($session->param('simple_object')->emails(1) eq 'sherzodr@cpan.org');
        ok($session->param('simple_object')->blogs('yigitlik') eq 'http://author.handalak.com/uz/');
        
        #
        # creating an overloaded object to be stored into session
        my $overloaded_class = OverloadedObjectClass->new("ABCDEFG");
        ok($overloaded_class, "OverloadedObjectClass created successfully");
        ok(overload::Overloaded($overloaded_class) , "OverloadedObjectClass is properly overloaded");
        ok(ref ($overloaded_class) eq "OverloadedObjectClass", "OverloadedObjectClass is an object");
        $session->param("overloaded_object", $overloaded_class);
        
        ok($session->param("overloaded_object") eq "ABCDEFG");
        
        my $simple_class2 = SimpleObjectClass->new();
        ok($simple_class2, "SimpleObjectClass created successfully");

        $simple_class2->name("Sherzod Ruzmetov");
        $simple_class2->emails(0, 'sherzodr@handalak.com');
        $simple_class2->emails(1, 'sherzodr@cpan.org');
        $simple_class2->blogs('lost+found', 'http://author.handalak.com/');
        $simple_class2->blogs('yigitlik', 'http://author.handalak.com/uz/');
        my $embedded = OverloadedObjectClass->new("Embedded");
        $session->param("embedded_simple_and_overloaded",[ undef, $simple_class2, $embedded, $embedded ]);

        ok(!defined($session->param("embedded_simple_and_overloaded")->[0]),"First element of anonymous array undef");

        ok($session->param("embedded_simple_and_overloaded")->[1]->name eq "Sherzod Ruzmetov");
        ok($session->param("embedded_simple_and_overloaded")->[1]->emails(1) eq 'sherzodr@cpan.org');
        ok($session->param("embedded_simple_and_overloaded")->[1]->blogs('yigitlik') eq 'http://author.handalak.com/uz/');
  
        ok($session->param("embedded_simple_and_overloaded")->[2] eq "Embedded");
        
        ok(refaddr($session->param("embedded_simple_and_overloaded")->[2]) == refaddr($session->param("embedded_simple_and_overloaded")->[3] ),
            "Overloaded objects have matching addresses");
    }


    SEVEN: {
        ok(1, "=== 7 ===");
        my $session = CGI::Session->new($self->{dsn}, $sid, $self->{args}) or die CGI::Session->errstr;
        ok($session, "Session object created successfully");
        ok($session->id eq $sid, "Previously stored object loaded successfully");


        my $simple_object = $session->param("simple_object");
        ok(ref $simple_object eq "SimpleObjectClass", "SimpleObjectClass loaded successfully");

        my $dsn = CGI::Session->parse_dsn($self->{dsn});
        ok_later { $simple_object->name eq "Sherzod Ruzmetov" };
        ok_later { $simple_object->emails(1) eq 'sherzodr@cpan.org' };
        ok_later { $simple_object->emails(0) eq 'sherzodr@handalak.com' };
        ok_later { $simple_object->blogs('lost+found') eq 'http://author.handalak.com/' };
        ok(ref $session->param("overloaded_object") );
        ok($session->param("overloaded_object") eq "ABCDEFG", "Object is still overloaded");
        ok(overload::Overloaded($session->param("overloaded_object")), "Object is really overloaded");

        ok(!defined($session->param("embedded_simple_and_overloaded")->[0]),"First element of anonymous array undef");
        
        my $simple_object2 = $session->param("embedded_simple_and_overloaded")->[1];
        ok(ref $simple_object2 eq "SimpleObjectClass", "SimpleObjectClass loaded successfully");

        ok_later { $simple_object2->name eq "Sherzod Ruzmetov" };
        ok_later { $simple_object2->emails(1) eq 'sherzodr@cpan.org' };
        ok_later { $simple_object2->emails(0) eq 'sherzodr@handalak.com' };
        ok_later { $simple_object2->blogs('lost+found') eq 'http://author.handalak.com/' };

        
        ok($session->param("embedded_simple_and_overloaded")->[2] eq "Embedded");
        ok(overload::Overloaded($session->param("embedded_simple_and_overloaded")->[2]), "Object is really overloaded");
        
        ok(refaddr($session->param("embedded_simple_and_overloaded")->[2]) == refaddr($session->param("embedded_simple_and_overloaded")->[3]),
            "Overloaded objects have matching addresses");        
        $session->delete();
    }
    
    $CURRENT = undef;
    $self->{test_number} = 0;
}

sub skip_or_run {
    my $test = shift;
    
    $CURRENT->{test_number} ++;

    SKIP: {
        if($CURRENT->{_skip}->{$CURRENT->{test_number}}) {
            Test::More::skip("Test does not apply to this setup.", 1);
        }
        
        no strict 'refs';
        &{"Test::More::$test"}(@_);
    }
}

sub ok { skip_or_run("ok", @_); }
sub use_ok { skip_or_run("use_ok", @_); }
sub is { skip_or_run("is", @_); }

sub ok_later (&;$) {
    my($code, $name) = @_;
    
    $CURRENT->{test_number} ++;
    $name = '' unless $name;

    SKIP: {
        if($CURRENT->{_skip}->{$CURRENT->{test_number}}) {
            Test::More::skip("Test does not apply to this setup.", 1);
            fail($name);
        } else {
            Test::More::ok($code->(), $name);
        }
    }
}

sub DESTROY { 1; }


package SimpleObjectClass;
use strict;
use Class::Struct;

struct (
    name    => '$',
    emails  => '@',
    blogs   => '%'
);



package OverloadedObjectClass;

use strict;
use overload (
    '""'    => \&as_string,
    'eq'    => \&equals
);

sub new {
    return bless {
        str_value => $_[1]
    }, $_[0];
}


sub as_string {
    return $_[0]->{str_value};
}

sub equals {
    my ($self, $arg) = @_;

    return ($self->as_string eq $arg);
}

1;