use
MongoDBTest
qw/skip_unless_mongod build_client get_test_db server_version server_type/
;
skip_unless_mongod();
my
$conn
= build_client();
my
$testdb
= get_test_db(
$conn
);
my
$db_name
=
$testdb
->name;
my
$server_version
= server_version(
$conn
);
my
$server_type
= server_type(
$conn
);;
subtest
'get_database'
=>
sub
{
isa_ok(
$conn
,
'MongoDB::MongoClient'
);
my
$db
;
ok(
$db
=
$conn
->get_database(
$db_name
),
"get_database(NAME)"
);
isa_ok(
$db
,
'MongoDB::Database'
);
my
$wc
= MongoDB::WriteConcern->new(
w
=> 2 );
ok(
$db
=
$conn
->get_database(
$db_name
, {
write_concern
=>
$wc
} ),
"get_database(NAME, OPTIONS)"
);
is(
$db
->write_concern->w, 2,
"DB-level write concern as expected"
);
ok(
$db
=
$conn
->get_database(
$db_name
, {
write_concern
=> {
w
=> 3 } } ),
"get_database(NAME, OPTIONS)"
);
is(
$db
->write_concern->w, 3,
"DB-level write concern coerces"
);
ok(
$db
=
$conn
->get_database(
$db_name
, {
bson_codec
=> {
op_char
=>
'-'
} } ),
"get_database(NAME, OPTIONS)"
);
is(
$db
->bson_codec->op_char,
'-'
,
"DB-level bson_codec coerces"
);
is(
$db
->client,
$conn
,
"client method"
);
};
subtest
'run_command'
=>
sub
{
is(
ref
$testdb
->run_command( [
ismaster
=> 1 ] ),
'HASH'
,
"run_command(ARRAYREF) gives HASH"
);
is(
ref
$testdb
->run_command( {
ismaster
=> 1 } ),
'HASH'
,
"run_command(HASHREF) gives HASH"
);
is(
ref
$testdb
->run_command( Tie::IxHash->new(
ismaster
=> 1 ) ),
'HASH'
,
"run_command(IxHash) gives HASH"
);
is(
ref
$testdb
->run_command( bson_doc(
ismaster
=> 1 ) ),
'HASH'
,
"run_command(BSON::Doc) gives HASH"
);
if
(
$server_type
eq
'RSPrimary'
&&
$conn
->_topology->all_servers > 1 ) {
my
$primary
=
$testdb
->run_command( [
ismaster
=> 1 ] );
my
$secondary
=
$testdb
->run_command( [
ismaster
=> 1 ], {
mode
=>
'secondary'
} );
isnt(
$primary
->{me},
$secondary
->{me},
"run_command respects explicit read preference"
)
or
do
{ diag explain
$primary
; diag explain
$secondary
};
}
my
$err
= exception {
$testdb
->run_command( {
foo
=>
'bar'
} ) };
if
(
$err
->code == COMMAND_NOT_FOUND ) {
pass(
"error from non-existent command"
);
}
else
{
like(
$err
->message,
qr/no such cmd|unrecognized command|CMD_UNKNOWN/
,
"error from non-existent command"
);
}
$err
= exception {
$testdb
->run_command( [
x
=>
"a"
x MAX_BSON_WIRE_SIZE ] ) };
like(
$err
,
qr/command too large/
,
"error on too large command"
);
$err
= exception {
$testdb
->run_command( {
ismaster
=> 1,
other_param
=> 1 } ) };
like(
$err
,
qr/not an ordered document/
,
"error on multi-key regular hashref"
);
};
subtest
"collection names"
=>
sub
{
is(
scalar
$testdb
->collection_names, 0,
'no collections'
);
my
$res
=
$testdb
->list_collections;
cmp_deeply( [
$res
->all ], [],
"list_collections has empty cursor"
);
my
$coll
=
$testdb
->get_collection(
'test'
);
my
$cmd
= [
create
=>
"test_capped"
,
capped
=> true,
size
=> 10000 ];
$testdb
->run_command(
$cmd
);
my
$cap
=
$testdb
->get_collection(
"test_capped"
);
$coll
->indexes->create_one([
name
=> 1]);
$cap
->indexes->create_one([
name
=> 1]);
ok(
$coll
->insert_one({
name
=>
'Alice'
}),
"create test collection"
);
ok(
$cap
->insert_one({
name
=>
'Bob'
}),
"create capped collection"
);
my
%names
=
map
{;
$_
=> 1 }
$testdb
->collection_names;
my
%got
=
map
{
$_
->{name} =>
$_
}
$testdb
->list_collections( {
name
=>
qr/^test/
} )->all;
for
my
$k
(
qw/test test_capped/
) {
ok(
exists
$names
{
$k
},
"collection_names included $k"
);
ok(
exists
$got
{
$k
},
"list_collections included $k"
);
}
my
@names_of_capped
=
$testdb
->collection_names( {
'options.capped'
=> true } );
cmp_deeply( \
@names_of_capped
, [str(
'test_capped'
)],
"collection_names with filter"
);
};
{
my
$admin
=
$conn
->get_database(
'admin'
);
my
%cmd
;
tie
(
%cmd
,
'Tie::IxHash'
,
buildinfo
=> 1);
my
$result
=
$admin
->run_command(\
%cmd
);
is(
$result
->{ok}, 1);
}
done_testing;