%PDF-
%PDF-
Mini Shell
Mini Shell
# Copyright 2018 - present MongoDB, Inc.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
use strict;
use warnings;
use JSON::MaybeXS;
use Path::Tiny 0.054; # basename with suffix
use Test::More 0.88;
use Test::Deep ':v1';
use Safe::Isa;
use lib "t/lib";
use MongoDBTest qw/
build_client
get_test_db
clear_testdbs
get_unique_collection
server_version
server_type
check_min_server_version
skip_unless_mongod
skip_unless_sessions
skip_unless_failpoints_available
to_snake_case
remap_hashref_to_snake_case
get_features
/;
skip_unless_mongod();
skip_unless_sessions();
skip_unless_failpoints_available();
my $conn = build_client(retry_writes => 1);
my $testdb = get_test_db($conn);
my $server_version = server_version($conn);
my $server_type = server_type($conn);
sub run_test {
my ( $coll, $test ) = @_;
enable_failpoint( $test->{failPoint} );
my $op = $test->{operation};
my $method = $op->{name};
$method =~ s{([A-Z])}{_\L$1}g;
my $func_name = 'do_' . $method;
my $ret = eval { main->$func_name( $coll, $op->{arguments} ) };
my $err = $@;
if ( exists $test->{outcome}->{error} && $test->{outcome}->{error} ) {
ok $err, 'Exception occured';
}
if ( !exists $test->{outcome}{error} && exists $test->{outcome}->{result} ) {
my $expected = remap_hashref_to_snake_case( $test->{outcome}->{result} );
# not all commands return an upserted count
delete $expected->{upserted_count} unless $ret->$_can('upserted_count');
for my $key ( keys %$expected ) {
my $got = ref $ret eq 'HASH' ? $ret->{$key} : $ret->$key;
cmp_deeply $got, $expected->{$key}, "$key result as expected";
}
}
my @coll_outcome = $coll->find()->all;
my $coll_expected = $test->{outcome}->{collection}->{data};
is_deeply \@coll_outcome, $coll_expected, 'Collection has correct outcome';
disable_failpoint( $test->{failPoint} );
}
sub do_delete_one {
my ( $self, $coll, $args ) = @_;
$args //= {};
my $filter = defined $args->{filter} ? $args->{filter} : {};
return $coll->delete_one( $filter );
}
sub do_replace_one {
my ( $self, $coll, $args ) = @_;
$args //= {};
my $filter = defined $args->{filter} ? $args->{filter} : {};
my $replacement = defined $args->{replacement} ? $args->{replacement} : {};
return $coll->replace_one( $filter, $replacement );
}
sub do_find_one_and_update {
my ( $self, $coll, $args ) = @_;
$args //= {};
my $filter = defined $args->{filter} ? $args->{filter} : {};
my $update = defined $args->{update} ? $args->{update} : {};
my $options = {
( defined $args->{returnDocument} ? ( returnDocument => lc $args->{returnDocument} ) : () )
};
return $coll->find_one_and_update( $filter, $update, $options );
}
sub do_find_one_and_replace {
my ( $self, $coll, $args ) = @_;
$args //= {};
my $filter = defined $args->{filter} ? $args->{filter} : {};
my $replace = defined $args->{replacement} ? $args->{replacement} : {};
my $options = {
( defined $args->{returnDocument} ? ( returnDocument => lc $args->{returnDocument} ) : () )
};
return $coll->find_one_and_replace( $filter, $replace, $options );
}
sub do_insert_one {
my ( $self, $coll, $args ) = @_;
return $coll->insert_one( $args->{document} );
}
sub do_find_one_and_delete {
my ( $self, $coll, $args ) = @_;
$args //= {};
my $filter = defined $args->{filter} ? $args->{filter} : {};
my $options = {
( defined $args->{sort} ? ( sort => $args->{sort} ) : () )
};
return $coll->find_one_and_delete( $filter, $options );
}
my %bulk_remap = (
insert_one => [qw( document )],
update_one => [qw( filter update )],
update_many => [qw( filter update )],
replace_one => [qw( filter replacement )],
delete_one => [qw( filter )],
delete_many => [qw( filter )],
);
sub do_bulk_write {
my ( $self, $coll, $args ) = @_;
my $options = {
( defined $args->{options}
&& defined $args->{options}->{ordered}
&& $args->{options}->{ordered}
? ( ordered => 1 )
: ( ordered => 0 ) )
};
my @arguments;
for my $request ( @{ $args->{requests} } ) {
my $req_name = to_snake_case( $request->{name} );
my @req_fields = @{ $bulk_remap{ $req_name } };
my @arg = map {
delete $request->{arguments}->{ $_ }
} @req_fields;
push @arg, $request->{arguments} if keys %{ $request->{arguments} };
push @arguments, { $req_name => \@arg };
}
return $coll->bulk_write( \@arguments, $options );
}
sub do_update_one {
my ( $self, $coll, $args ) = @_;
$args //= {};
my $filter = defined $args->{filter} ? $args->{filter} : {};
my $update = defined $args->{update} ? $args->{update} : {};
my $options = {
( defined $args->{upsert} ? $args->{upsert} ? ( upsert => 1 ) : ( upsert => 0 ) : () )
};
return $coll->update_one( $filter, $update, $options );
}
sub do_insert_many {
my ( $self, $coll, $args ) = @_;
$args //= {};
my $options = {
( defined $args->{options}
&& defined $args->{options}->{ordered}
&& $args->{options}->{ordered}
? ( ordered => 1 )
: ( ordered => 0 ) )
};
return $coll->insert_many( $args->{documents}, $options );
}
my $dir = path("t/data/retryable-writes");
my $iterator = $dir->iterator;
while ( my $path = $iterator->() ) {
next unless $path =~ /\.json$/;
my $plan = eval { decode_json( $path->slurp_utf8 ) };
if ($@) {
die "Error decoding $path: $@";
}
subtest $path => sub {
if ( exists $plan->{minServerVersion} ) {
my $min_version = $plan->{minServerVersion};
plan skip_all => "Requires MongoDB $min_version"
if check_min_server_version( $conn, $min_version );
}
for my $test ( @{ $plan->{tests} } ) {
my $client_options = $test->{clientOptions};
$client_options = remap_hashref_to_snake_case( $client_options );
my $test_conn = build_client( %$client_options );
my $test_db = get_test_db( $test_conn );
my $coll = get_unique_collection( $test_db, 'retry_write' );
my $ret = $coll->insert_many( $plan->{data} );
my $description = $test->{description};
subtest $description => sub {
run_test( $coll, $test );
}
}
};
}
sub enable_failpoint {
my $failpoint = shift;
return unless defined $failpoint;
$conn->send_admin_command([
configureFailPoint => $failpoint->{configureFailPoint},
mode => $failpoint->{mode},
defined $failpoint->{data}
? ( data => $failpoint->{data} )
: (),
]);
}
sub disable_failpoint {
my $failpoint = shift;
return unless defined $failpoint;
$conn->send_admin_command([
configureFailPoint => $failpoint->{configureFailPoint},
mode => 'off',
]);
}
clear_testdbs;
done_testing;
Zerion Mini Shell 1.0