diff --git a/devel/t-dynamic/PERL-790-cursor-sessions.t b/t/sessions-cursors.t similarity index 73% rename from devel/t-dynamic/PERL-790-cursor-sessions.t rename to t/sessions-cursors.t index 79a1848e..ea826740 100644 --- a/devel/t-dynamic/PERL-790-cursor-sessions.t +++ b/t/sessions-cursors.t @@ -28,11 +28,6 @@ use MongoDB; use MongoDB::Error; use lib "t/lib"; -use lib "devel/lib"; - -use if $ENV{MONGOVERBOSE}, qw/Log::Any::Adapter Stderr/; - -use MongoDBTest::Orchestrator; use MongoDBTest qw/ build_client @@ -44,16 +39,15 @@ use MongoDBTest qw/ uuid_to_string /; -my $orc = -MongoDBTest::Orchestrator->new( - config_file => "devel/config/replicaset-single-3.6.yml" ); -$orc->start; - -$ENV{MONGOD} = $orc->as_uri; +my @events; -print $ENV{MONGOD}; +sub clear_events { @events = () } +sub event_count { scalar @events } +sub event_cb { push @events, $_[0] } -my $conn = build_client(); +my $conn = build_client( + monitoring_callback => \&event_cb, +); my $testdb = get_test_db($conn); my $server_version = server_version($conn); my $server_type = server_type($conn); @@ -62,15 +56,15 @@ my $coll = $testdb->get_collection('test_collection'); plan skip_all => "Requires MongoDB 3.6" if $server_version < v3.6.0; -use Test::Role::BSONDebug; +plan skip_all => "Sessions unsupported on standalone server" + if $server_type eq 'Standalone'; -Role::Tiny->apply_roles_to_package( - 'BSON', 'Test::Role::BSONDebug', -); +plan skip_all => "deployment does not support sessions" + unless $conn->_topology->_supports_sessions; $coll->insert_many( [ map { { wanted => 1, score => $_ } } 0 .. 400 ] ); -Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; +clear_events(); subtest 'Shared session in explicit cursor' => sub { @@ -83,9 +77,9 @@ subtest 'Shared session in explicit cursor' => sub { my $lsid = uuid_to_string( $session->_server_session->session_id->{id}->data ); - my $cursor_command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $cursor_command = $events[-2]->{ command }; - my $cursor_command_sid = uuid_to_string( $cursor_command->FETCH('lsid')->{id}->data ); + my $cursor_command_sid = uuid_to_string( $cursor_command->{'lsid'}->{id}->data ); is $cursor_command_sid, $lsid, "Cursor sent with correct lsid"; @@ -97,9 +91,9 @@ subtest 'Shared session in explicit cursor' => sub { # Call first batch run outside of loop as doesnt fetch intially my @items = $cursor->batch; while ( @items = $cursor->batch ) { - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - ok $command->EXISTS('lsid'), "cursor has session"; - my $cursor_session_id = uuid_to_string( $command->FETCH('lsid')->{id}->data ); + my $command = $events[-2]->{ command }; + ok exists $command->{'lsid'}, "cursor has session"; + my $cursor_session_id = uuid_to_string( $command->{'lsid'}->{id}->data ); is $cursor_session_id, $lsid, "Cursor is using given session"; } }; @@ -114,7 +108,7 @@ subtest 'Shared session in explicit cursor' => sub { }; -Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; +clear_events(); subtest 'Shared session in implicit cursor' => sub { @@ -123,9 +117,9 @@ subtest 'Shared session in implicit cursor' => sub { # pull out implicit session my $lsid = uuid_to_string( $cursor->_session->session_id->{id}->data ); - my $cursor_command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $cursor_command = $events[-2]->{ command }; - my $cursor_command_sid = uuid_to_string( $cursor_command->FETCH('lsid')->{id}->data ); + my $cursor_command_sid = uuid_to_string( $cursor_command->{'lsid'}->{id}->data ); is $cursor_command_sid, $lsid, "Cursor sent with correct lsid"; @@ -133,9 +127,9 @@ subtest 'Shared session in implicit cursor' => sub { # Call first batch run outside of loop as doesnt fetch intially my @items = $cursor->batch; while ( @items = $cursor->batch ) { - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - ok $command->EXISTS('lsid'), "cursor has session"; - my $cursor_session_id = uuid_to_string( $command->FETCH('lsid')->{id}->data ); + my $command = $events[-2]->{ command }; + ok exists $command->{'lsid'}, "cursor has session"; + my $cursor_session_id = uuid_to_string( $command->{'lsid'}->{id}->data ); is $cursor_session_id, $lsid, "Cursor is using given session"; } }; diff --git a/devel/t-dynamic/PERL-790-driver-sessions.t b/t/sessions-driver.t similarity index 82% rename from devel/t-dynamic/PERL-790-driver-sessions.t rename to t/sessions-driver.t index 11e7efc2..fbe985eb 100644 --- a/devel/t-dynamic/PERL-790-driver-sessions.t +++ b/t/sessions-driver.t @@ -27,11 +27,6 @@ use MongoDB; use MongoDB::Error; use lib "t/lib"; -use lib "devel/lib"; - -use if $ENV{MONGOVERBOSE}, qw/Log::Any::Adapter Stderr/; - -use MongoDBTest::Orchestrator; use MongoDBTest qw/ build_client @@ -42,19 +37,15 @@ use MongoDBTest qw/ get_unique_collection /; -# This test starts servers on localhost ports 27017, 27018 and 27019. We skip if -# these aren't available. - -my $orc = -MongoDBTest::Orchestrator->new( - config_file => "devel/config/replicaset-single-3.6.yml" ); -$orc->start; +my @events; -$ENV{MONGOD} = $orc->as_uri; +sub clear_events { @events = () } +sub event_count { scalar @events } +sub event_cb { push @events, $_[0] } -print $ENV{MONGOD}; - -my $conn = build_client(); +my $conn = build_client( + monitoring_callback => \&event_cb, +); my $testdb = get_test_db($conn); my $server_version = server_version($conn); my $server_type = server_type($conn); @@ -63,6 +54,12 @@ my $coll = $testdb->get_collection('test_collection'); plan skip_all => "Requires MongoDB 3.6" if $server_version < v3.6.0; +plan skip_all => "Sessions unsupported on standalone server" + if $server_type eq 'Standalone'; + +plan skip_all => "deployment does not support sessions" + unless $conn->_topology->_supports_sessions; + # Last in First out subtest 'LIFO Pool' => sub { my $session_a = $conn->start_session; @@ -92,35 +89,28 @@ subtest 'LIFO Pool' => sub { subtest 'clusterTime in commands' => sub { - use Test::Role::BSONDebug; - - Role::Tiny->apply_roles_to_package( - 'BSON', 'Test::Role::BSONDebug', - ); - subtest 'ping' => sub { my $local_client = get_high_heartbeat_client(); my $ping_result = $local_client->send_admin_command(Tie::IxHash->new('ping' => 1)); - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - my $result = Test::Role::BSONDebug::GET_LAST_DECODE_ONE; + my $command = $events[-2]->{ command }; + my $result = $events[-1]->{ reply }; - ok $command->EXISTS('ping'), 'ping in sent command'; + ok exists $command->{'ping'}, 'ping in sent command'; - ok $command->EXISTS('$clusterTime'), 'clusterTime in sent command'; + ok exists $command->{'$clusterTime'}, 'clusterTime in sent command'; my $ping_result2 = $local_client->send_admin_command(Tie::IxHash->new('ping' => 1)); - my $command2 = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $command2 = $events[-2]->{ command }; - is $command2->FETCH('$clusterTime')->{clusterTime}->{sec}, - $result->{'$clusterTime'}->{clusterTime}->{sec}, + ok $command2->{'$clusterTime'}->{clusterTime} + == $result->{'$clusterTime'}->{clusterTime}, "clusterTime matches"; }; - Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; - Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; + clear_events(); subtest 'aggregate' => sub { my $local_client = get_high_heartbeat_client(); @@ -140,25 +130,24 @@ subtest 'clusterTime in commands' => sub { { '$group' => { _id => 1, 'avgScore' => { '$avg' => '$score' } } } ] ); - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - my $result = Test::Role::BSONDebug::GET_LAST_DECODE_ONE; + my $command = $events[-2]->{ command }; + my $result = $events[-1]->{ reply }; - ok $command->EXISTS('aggregate'), 'aggregate in sent command'; + ok exists $command->{'aggregate'}, 'aggregate in sent command'; - ok $command->EXISTS('$clusterTime'), 'clusterTime in sent command'; + ok exists $command->{'$clusterTime'}, 'clusterTime in sent command'; my $agg_result2 = $local_coll->aggregate( [ { '$match' => { wanted => 1 } }, { '$group' => { _id => 1, 'avgScore' => { '$avg' => '$score' } } } ] ); - my $command2 = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $command2 = $events[-2]->{ command }; - is $command2->FETCH('$clusterTime')->{clusterTime}->{sec}, - $result->{'$clusterTime'}->{clusterTime}->{sec}, + ok $command2->{'$clusterTime'}->{clusterTime} + == $result->{'$clusterTime'}->{clusterTime}, "clusterTime matches"; }; - Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; - Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; + clear_events(); subtest 'find' => sub { my $local_client = get_high_heartbeat_client(); @@ -171,24 +160,23 @@ subtest 'clusterTime in commands' => sub { # explain 1 to get it to show the whole returned result my $find_result = $local_coll->find({_id => 1})->result; - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - my $result = Test::Role::BSONDebug::GET_LAST_DECODE_ONE; + my $command = $events[-2]->{ command }; + my $result = $events[-1]->{ reply }; - ok $command->EXISTS('find'), 'find in sent command'; + ok exists $command->{'find'}, 'find in sent command'; - ok $command->EXISTS('$clusterTime'), 'clusterTime in sent command'; + ok exists $command->{'$clusterTime'}, 'clusterTime in sent command'; my $find_result2 = $local_coll->find({_id => 1})->result; - my $command2 = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $command2 = $events[-2]->{ command }; - is $command2->FETCH('$clusterTime')->{clusterTime}->{sec}, - $result->{'$clusterTime'}->{clusterTime}->{sec}, + ok $command2->{'$clusterTime'}->{clusterTime} + == $result->{'$clusterTime'}->{clusterTime}, "clusterTime matches"; }; - Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; - Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; + clear_events(); subtest 'insert_one' => sub { my $local_client = get_high_heartbeat_client(); @@ -197,30 +185,28 @@ subtest 'clusterTime in commands' => sub { my $insert_result = $local_coll->insert_one({_id => 1}); - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - my $result = Test::Role::BSONDebug::GET_LAST_DECODE_ONE; + my $command = $events[-2]->{ command }; + my $result = $events[-1]->{ reply }; - ok $command->EXISTS('insert'), 'insert in sent command'; + ok exists $command->{'insert'}, 'insert in sent command'; - ok $command->EXISTS('$clusterTime'), 'clusterTime in sent command'; + ok exists $command->{'$clusterTime'}, 'clusterTime in sent command'; my $insert_result2 = $local_coll->insert_one({_id => 2}); - my $command2 = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $command2 = $events[-2]->{ command }; - is $command2->FETCH('$clusterTime')->{clusterTime}->{sec}, - $result->{'$clusterTime'}->{clusterTime}->{sec}, + ok $command2->{'$clusterTime'}->{clusterTime} + == $result->{'$clusterTime'}->{clusterTime}, "clusterTime matches"; }; - - Test::Role::BSONDebug::CLEAR_ENCODE_ONE_QUEUE; - Test::Role::BSONDebug::CLEAR_DECODE_ONE_QUEUE; }; sub get_high_heartbeat_client { my $local_client = build_client( # You want big number? we give you big number heartbeat_frequency_ms => 9_000_000_000, + monitoring_callback => \&event_cb, ); # Make sure we have clusterTime already populated diff --git a/devel/t-dynamic/PERL-790-end-sessions.t b/t/sessions-end.t similarity index 90% rename from devel/t-dynamic/PERL-790-end-sessions.t rename to t/sessions-end.t index c37d1246..97c315e5 100644 --- a/devel/t-dynamic/PERL-790-end-sessions.t +++ b/t/sessions-end.t @@ -29,11 +29,6 @@ use MongoDB; use MongoDB::Error; use lib "t/lib"; -use lib "devel/lib"; - -use if $ENV{MONGOVERBOSE}, qw/Log::Any::Adapter Stderr/; - -use MongoDBTest::Orchestrator; use MongoDBTest qw/ build_client @@ -45,21 +40,15 @@ use MongoDBTest qw/ uuid_to_string /; -use Test::Role::BSONDebug; -Role::Tiny->apply_roles_to_package( - 'BSON', 'Test::Role::BSONDebug', -); - -my $orc = -MongoDBTest::Orchestrator->new( - config_file => "devel/config/replicaset-single-3.6.yml" ); -$orc->start; +my @events; -$ENV{MONGOD} = $orc->as_uri; +sub clear_events { @events = () } +sub event_count { scalar @events } +sub event_cb { push @events, $_[0] } -print $ENV{MONGOD}; - -my $conn = build_client(); +my $conn = build_client( + monitoring_callback => \&event_cb, +); my $testdb = get_test_db($conn); my $server_version = server_version($conn); my $server_type = server_type($conn); @@ -68,6 +57,12 @@ my $coll = $testdb->get_collection('test_collection'); plan skip_all => "Requires MongoDB 3.6" if $server_version < v3.6.0; +plan skip_all => "Sessions unsupported on standalone server" + if $server_type eq 'Standalone'; + +plan skip_all => "deployment does not support sessions" + unless $conn->_topology->_supports_sessions; + subtest 'endSession closes sessions on server' => sub { my $session_count = 10; my @sessions; @@ -109,9 +104,9 @@ subtest 'endSession closes sessions on server' => sub { # called in destruction of client normally $conn->_server_session_pool->end_all_sessions; - my $response = Test::Role::BSONDebug::GET_LAST_DECODE_ONE; + my $response = $events[-1]; - is $response->{ok}, 1, 'Got ok 1 from ending all sessions'; + is $response->{reply}->{ok}, 1, 'Got ok 1 from ending all sessions'; }; diff --git a/devel/t-dynamic/PERL-790-unacknowledged-write-sessions.t b/t/sessions-unacknowledged-write.t similarity index 64% rename from devel/t-dynamic/PERL-790-unacknowledged-write-sessions.t rename to t/sessions-unacknowledged-write.t index da8e2d02..adad9003 100644 --- a/devel/t-dynamic/PERL-790-unacknowledged-write-sessions.t +++ b/t/sessions-unacknowledged-write.t @@ -29,11 +29,6 @@ use MongoDB::Error; use MongoDB::_Types qw/ to_IxHash /; use lib "t/lib"; -use lib "devel/lib"; - -use if $ENV{MONGOVERBOSE}, qw/Log::Any::Adapter Stderr/; - -use MongoDBTest::Orchestrator; use MongoDBTest qw/ build_client @@ -45,21 +40,15 @@ use MongoDBTest qw/ uuid_to_string /; -use Test::Role::BSONDebug; -Role::Tiny->apply_roles_to_package( - 'BSON', 'Test::Role::BSONDebug', -); - -my $orc = -MongoDBTest::Orchestrator->new( - config_file => "devel/config/replicaset-single-3.6.yml" ); -$orc->start; - -$ENV{MONGOD} = $orc->as_uri; +my @events; -print $ENV{MONGOD}; +sub clear_events { @events = () } +sub event_count { scalar @events } +sub event_cb { push @events, $_[0] } -my $conn = build_client(); +my $conn = build_client( + monitoring_callback => \&event_cb, +); my $testdb = get_test_db($conn); my $server_version = server_version($conn); my $server_type = server_type($conn); @@ -67,6 +56,12 @@ my $server_type = server_type($conn); plan skip_all => "Requires MongoDB 3.6" if $server_version < v3.6.0; +plan skip_all => "Sessions unsupported on standalone server" + if $server_type eq 'Standalone'; + +plan skip_all => "deployment does not support sessions" + unless $conn->_topology->_supports_sessions; + subtest 'Session for ack writes' => sub { my $coll = $testdb->get_collection( 'test_collection', { write_concern => { w => 1 } } ); @@ -75,19 +70,19 @@ subtest 'Session for ack writes' => sub { my $result = $coll->insert_one( { _id => 1 }, { session => $session } ); - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $command = $events[-2]->{ command }; - ok $command->EXISTS('lsid'), 'Session found'; + ok exists $command->{'lsid'}, 'Session found'; - is uuid_to_string( $command->FETCH('lsid')->{id}->data ), + is uuid_to_string( $command->{'lsid'}->{id}->data ), uuid_to_string( $session->_server_session->session_id->{id}->data ), "Session matches"; my $result2 = $coll->insert_one( { _id => 2 } ); - my $command2 = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $command2 = $events[-2]->{ command }; - ok $command2->EXISTS('lsid'), 'Implicit session found'; + ok $command2->{'lsid'}, 'Implicit session found'; }; subtest 'No session for unac writes' => sub { @@ -98,20 +93,15 @@ subtest 'No session for unac writes' => sub { my $result = $coll->insert_one( { _id => 1 }, { session => $session } ); - my $command = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; + my $command = $events[-2]->{ command }; - # cannot guarantee ixhash! - $command = to_IxHash( $command ); - - ok ! $command->EXISTS('lsid'), 'No session found'; + ok ! exists $command->{'lsid'}, 'No session found'; my $result2 = $coll->insert_one( { _id => 2 } ); - my $command2 = Test::Role::BSONDebug::GET_LAST_ENCODE_ONE; - - $command2 = to_IxHash( $command2 ); + my $command2 = $events[-2]->{ command }; - ok ! $command2->EXISTS('lsid'), 'No implicit session found'; + ok ! exists $command2->{'lsid'}, 'No implicit session found'; }; clear_testdbs;