use
5.010;
our
$VERSION
=
'0.35'
;
our
@ISA
=
qw(Exporter)
;
our
@EXPORT_OK
=
qw(test_tx_action)
;
sub
test_tx_action {
my
%targs
=
@_
;
my
$tmpdir
=
$targs
{tmpdir} or
die
"BUG: please supply tmpdir"
;
my
$reset_state
=
$targs
{reset_state} or
die
"BUG: please supply reset_state"
;
my
$tm
;
if
(
$targs
{reset_db_dir}) {
remove
"$tmpdir/.tx"
;
}
$reset_state
->();
my
$pa
= Perinci::Access::InProcess->new(
use_tx
=>1,
custom_tx_manager
=>
sub
{
my
$self
=
shift
;
$tm
//= Perinci::Tx::Manager->new(
data_dir
=>
"$tmpdir/.tx"
,
pa
=>
$self
);
die
$tm
unless
blessed(
$tm
);
$tm
;
});
my
$f
=
$targs
{f};
my
$fargs
=
$targs
{args} // {};
my
$tname
=
$targs
{name} //
"call $f => {"
.
join
(
","
,
map
{
"$_=>$fargs->{$_}"
}
sort
keys
%$fargs
).
"}"
;
subtest
$tname
=>
sub
{
my
$res
;
my
$estatus
;
my
$tx_id
;
my
(
$tx_id1
);
my
$done_testing
;
my
$uri
=
"/$f"
;
$uri
=~ s!::!/!g;
my
$num_actions
= 0;
my
$num_undo_actions
= 0;
no
strict
'refs'
;
$res
= *{
$f
}{CODE}->(
%$fargs
,
-tx_action
=>
'check_state'
);
my
$has_do_actions
;
if
(
$res
->[0] == 200) {
if
(
$res
->[3]{do_actions}) {
$num_actions
= @{
$res
->[3]{do_actions} };
$has_do_actions
++;
}
else
{
$num_actions
= 1;
}
note
"number of actions: $num_actions"
;
$num_undo_actions
= @{
$res
->[3]{undo_actions} };
note
"number of undo actions: $num_undo_actions"
;
}
subtest
"normal action + commit"
=>
sub
{
$tx_id
= UUID::Random::generate();
$res
=
$pa
->request(
begin_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
unless
(is(
$res
->[0], 200,
"begin_tx succeeds"
)) {
note
"res = "
, explain(
$res
);
goto
DONE_TESTING;
}
$res
=
$pa
->request(
call
=>
$uri
, {
args
=>
$fargs
,
tx_id
=>
$tx_id
,
confirm
=>
$targs
{confirm}});
$estatus
=
$targs
{status} // 200;
unless
(is(
$res
->[0],
$estatus
,
"status is $estatus"
)) {
note
"res = "
, explain(
$res
);
goto
DONE_TESTING;
}
do
{
$done_testing
++;
return
}
unless
$estatus
== 200;
$res
=
$pa
->request(
commit_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
unless
(is(
$res
->[0], 200,
"commit_tx succeeds"
)) {
note
"res = "
, explain(
$res
);
goto
DONE_TESTING;
}
$tx_id1
=
$tx_id
;
};
goto
DONE_TESTING
if
$done_testing
|| !Test::More->builder->is_passing;
$targs
{after_do}->()
if
$targs
{after_do};
subtest
"repeat action -> noop (idempotent), rollback"
=>
sub
{
$tx_id
= UUID::Random::generate();
$res
=
$pa
->request(
begin_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$res
=
$pa
->request(
call
=>
$uri
, {
args
=>
$fargs
,
tx_id
=>
$tx_id
,
confirm
=>
$targs
{confirm}});
unless
(is(
$res
->[0], 304,
"status is 304"
)) {
note
"res = "
, explain(
$res
);
goto
DONE_TESTING;
}
$res
=
$pa
->request(
rollback_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
unless
(is(
$res
->[0], 200,
"rollback_tx succeeds"
)) {
note
"res = "
, explain(
$res
);
goto
DONE_TESTING;
}
};
goto
DONE_TESTING
if
$done_testing
|| !Test::More->builder->is_passing;
$targs
{before_undo}->()
if
$targs
{before_undo};
subtest
"undo"
=>
sub
{
$res
=
$pa
->request(
undo
=>
"/"
, {
tx_id
=>
$tx_id1
,
confirm
=>
$targs
{confirm}});
$estatus
=
$targs
{undo_status} // 200;
unless
(is(
$res
->[0],
$estatus
,
"status is $estatus"
)) {
note
"res = "
, explain(
$res
);
goto
DONE_TESTING;
}
do
{
$done_testing
++;
return
}
unless
$estatus
== 200;
$res
=
$tm
->list(
tx_id
=>
$tx_id1
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'U'
,
"transaction status is U"
)
or note
"res = "
, explain(
$res
);
};
goto
DONE_TESTING
if
$done_testing
|| !Test::More->builder->is_passing;
subtest
"crash during action -> rollback"
=>
sub
{
$tx_id
= UUID::Random::generate();
for
my
$i
(1..
$num_actions
) {
$res
=
$pa
->request(
begin_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
subtest
"crash at action #$i"
=>
sub
{
my
$ja
= 0;
local
$Perinci::Tx::Manager::_hooks
{after_fix_state} =
sub
{
my
(
$self
,
%args
) =
@_
;
my
$nl
=
$self
->{_action_nest_level} // 0;
return
unless
$nl
<= (
$has_do_actions
? 2:1);
return
if
$args
{which} eq
'rollback'
;
$ja
++
if
$args
{which} eq
'action'
;
if
(
$ja
==
$i
&&
$nl
== (
$has_do_actions
? 2:1)) {
for
(
"CRASH DURING ACTION"
) {
$log
->trace(
$_
);
die
$_
}
}
};
eval
{
$res
=
$pa
->request(
call
=>
$uri
,
{
args
=>
$fargs
,
tx_id
=>
$tx_id
});
};
$tm
= Perinci::Tx::Manager->new(
data_dir
=>
"$tmpdir/.tx"
,
pa
=>
$pa
);
$res
=
$tm
->list(
tx_id
=>
$tx_id
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'R'
,
"transaction status is R"
)
or note
"res = "
, explain(
$res
);
};
}
ok 1
if
!
$num_actions
;
};
goto
DONE_TESTING
if
$done_testing
|| !Test::More->builder->is_passing;
subtest
"crash during rollback -> tx status X"
=>
sub
{
$tx_id
= UUID::Random::generate();
my
$i
= 0;
my
$last
;
while
(1) {
$i
++;
last
if
$last
;
$res
=
$pa
->request(
begin_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
subtest
"crash at rollback #$i"
=>
sub
{
my
$ja
= 0;
my
$jrb
= 0;
my
$crashed
;
local
$Perinci::Tx::Manager::_hooks
{after_fix_state} =
sub
{
my
(
$self
,
%args
) =
@_
;
my
$nl
=
$self
->{_action_nest_level} // 0;
return
unless
$nl
<= (
$has_do_actions
? 2:1);
if
(
$args
{which} eq
'action'
) {
return
unless
++
$ja
>=
$num_actions
;
for
(
"CRASH DURING ACTION"
) {
$log
->trace(
$_
);
die
$_
}
}
$jrb
++
if
$args
{which} eq
'rollback'
;
if
(
$jrb
==
$i
) {
for
(
"CRASH DURING ROLLBACK"
){
$crashed
++;
$log
->trace(
$_
);
die
$_
;
}
}
};
eval
{
$res
=
$pa
->request(
call
=>
$uri
,
{
args
=>
$fargs
,
tx_id
=>
$tx_id
});
};
do
{ ok 1;
$last
++;
return
}
unless
$crashed
;
$tm
= Perinci::Tx::Manager->new(
data_dir
=>
"$tmpdir/.tx"
,
pa
=>
$pa
);
$res
=
$tm
->list(
tx_id
=>
$tx_id
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'X'
,
"transaction status is X"
)
or note
"res = "
, explain(
$res
);
};
$reset_state
->();
}
};
goto
DONE_TESTING
if
$done_testing
|| !Test::More->builder->is_passing;
subtest
"redo"
=>
sub
{
$res
=
$pa
->request(
redo
=>
"/"
, {
tx_id
=>
$tx_id1
,
confirm
=>
$targs
{confirm}});
unless
(is(
$res
->[0], 200,
"redo succeeds"
)) {
note
"res = "
, explain(
$res
);
goto
DONE_TESTING;
}
$res
=
$tm
->list(
tx_id
=>
$tx_id1
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'C'
,
"transaction status is C"
)
or note
"res = "
, explain(
$res
);
};
goto
DONE_TESTING
if
$done_testing
|| !Test::More->builder->is_passing;
$targs
{before_undo}->()
if
$targs
{before_undo};
subtest
"undo #2"
=>
sub
{
$res
=
$pa
->request(
undo
=>
"/"
, {
tx_id
=>
$tx_id1
,
confirm
=>
$targs
{confirm}});
unless
(is(
$res
->[0], 200,
"undo succeeds"
)) {
note
"res = "
, explain(
$res
);
goto
DONE_TESTING;
}
$res
=
$tm
->list(
tx_id
=>
$tx_id1
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'U'
,
"transaction status is U"
)
or note
"res = "
, explain(
$res
);
};
goto
DONE_TESTING
if
$done_testing
|| !Test::More->builder->is_passing;
subtest
"crash while undo -> roll forward"
=>
sub
{
$tx_id
= UUID::Random::generate();
for
my
$i
(1..
$num_undo_actions
) {
$pa
->request(
discard_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$pa
->request(
begin_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$pa
->request(
call
=>
$uri
, {
args
=>
$fargs
,
tx_id
=>
$tx_id
,
confirm
=>
$targs
{confirm}});
$pa
->request(
commit_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$res
=
$tm
->list(
tx_id
=>
$tx_id
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'C'
,
"transaction status is C"
)
or note
"res = "
, explain(
$res
);
subtest
"crash at undo action #$i"
=>
sub
{
my
$ju
= 0;
local
$Perinci::Tx::Manager::_settings
{default_rollback_on_action_failure} = 0;
local
$Perinci::Tx::Manager::_hooks
{after_fix_state} =
sub
{
my
(
$self
,
%args
) =
@_
;
my
$nl
=
$self
->{_action_nest_level} // 0;
return
unless
$args
{which} eq
'undo'
;
if
(++
$ju
==
$i
) {
for
(
"CRASH DURING UNDO ACTION"
) {
$log
->trace(
$_
);
die
$_
;
}
}
};
eval
{
$res
=
$pa
->request(
undo
=>
"/"
, {
tx_id
=>
$tx_id
});
};
$tm
= Perinci::Tx::Manager->new(
data_dir
=>
"$tmpdir/.tx"
,
pa
=>
$pa
);
$res
=
$tm
->list(
tx_id
=>
$tx_id
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'U'
,
"transaction status is U"
)
or note
"res = "
, explain(
$res
);
};
}
ok 1
if
!
$num_undo_actions
;
};
goto
DONE_TESTING
if
$done_testing
|| !Test::More->builder->is_passing;
subtest
"crash while roll forward failed undo -> tx status X"
=>
sub
{
$tx_id
= UUID::Random::generate();
my
$i
= 0;
my
$last
;
while
(1) {
$i
++;
last
if
$last
;
$reset_state
->();
$pa
->request(
discard_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$pa
->request(
begin_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$pa
->request(
call
=>
$uri
, {
args
=>
$fargs
,
tx_id
=>
$tx_id
,
confirm
=>
$targs
{confirm}});
$pa
->request(
commit_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$res
=
$tm
->list(
tx_id
=>
$tx_id
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'C'
,
"transaction status is C"
)
or note
"res = "
, explain(
$res
);
subtest
"crash at rollback action #$i"
=>
sub
{
my
$ju
= 0;
my
$jrb
= 0;
my
$crashed
;
local
$Perinci::Tx::Manager::_hooks
{after_fix_state} =
sub
{
my
(
$self
,
%args
) =
@_
;
if
(
$args
{which} eq
'undo'
) {
if
(++
$ju
==
$num_undo_actions
) {
for
(
"CRASH DURING UNDO ACTION"
) {
$log
->trace(
$_
);
die
$_
;
}
}
}
elsif
(
$args
{which} eq
'rollback'
) {
if
(++
$jrb
==
$i
) {
for
(
"CRASH DURING ROLLBACK"
) {
$crashed
++;
$log
->trace(
$_
);
die
$_
;
}
}
}
};
eval
{
$res
=
$pa
->request(
undo
=>
"/"
, {
tx_id
=>
$tx_id
});
};
do
{ ok 1;
$last
++;
return
}
unless
$crashed
;
$tm
= Perinci::Tx::Manager->new(
data_dir
=>
"$tmpdir/.tx"
,
pa
=>
$pa
);
$res
=
$tm
->list(
tx_id
=>
$tx_id
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'X'
,
"transaction status is X"
)
or note
"res = "
, explain(
$res
);
};
}
ok 1
if
!
$num_undo_actions
;
};
goto
DONE_TESTING
if
$done_testing
|| !Test::More->builder->is_passing;
subtest
"crash while redo -> roll forward"
=>
sub
{
$tx_id
= UUID::Random::generate();
my
$i
= 0;
my
$last
;
while
(1) {
$i
++;
last
if
$last
;
$reset_state
->();
$pa
->request(
discard_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$pa
->request(
begin_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$pa
->request(
call
=>
$uri
, {
args
=>
$fargs
,
tx_id
=>
$tx_id
,
confirm
=>
$targs
{confirm}});
$pa
->request(
commit_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$pa
->request(
undo
=>
"/"
, {
tx_id
=>
$tx_id
});
$res
=
$tm
->list(
tx_id
=>
$tx_id
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'U'
,
"transaction status is U"
)
or note
"res = "
, explain(
$res
);
subtest
"crash at redo action #$i"
=>
sub
{
my
$jrd
= 0;
my
$crashed
;
local
$Perinci::Tx::Manager::_settings
{default_rollback_on_action_failure} = 0;
local
$Perinci::Tx::Manager::_hooks
{after_fix_state} =
sub
{
my
(
$self
,
%args
) =
@_
;
my
$nl
=
$self
->{_action_nest_level} // 0;
return
unless
$args
{which} eq
'redo'
;
if
(++
$jrd
==
$i
) {
for
(
"CRASH DURING REDO ACTION"
) {
$crashed
++;
$log
->trace(
$_
);
die
$_
;
}
}
};
eval
{
$res
=
$pa
->request(
redo
=>
"/"
, {
tx_id
=>
$tx_id
});
};
do
{ ok 1;
$last
++;
return
}
unless
$crashed
;
$tm
= Perinci::Tx::Manager->new(
data_dir
=>
"$tmpdir/.tx"
,
pa
=>
$pa
);
$res
=
$tm
->list(
tx_id
=>
$tx_id
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'C'
,
"transaction status is C"
)
or note
"res = "
, explain(
$res
);
};
}
ok 1
if
!
$num_actions
;
};
goto
DONE_TESTING
if
$done_testing
|| !Test::More->builder->is_passing;
subtest
"crash while roll forward failed redo -> tx status X"
=>
sub
{
$tx_id
= UUID::Random::generate();
my
$i
= 0;
my
$last
;
while
(1) {
$i
++;
last
if
$last
;
$reset_state
->();
$pa
->request(
discard_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$pa
->request(
begin_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$pa
->request(
call
=>
$uri
, {
args
=>
$fargs
,
tx_id
=>
$tx_id
,
confirm
=>
$targs
{confirm}});
$pa
->request(
commit_tx
=>
"/"
, {
tx_id
=>
$tx_id
});
$pa
->request(
undo
=>
"/"
, {
tx_id
=>
$tx_id
});
$res
=
$tm
->list(
tx_id
=>
$tx_id
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'U'
,
"transaction status is U"
)
or note
"res = "
, explain(
$res
);
subtest
"crash at rollback action #$i"
=>
sub
{
my
$jrd
= 0;
my
$jrb
= 0;
my
$crashed
;
local
$Perinci::Tx::Manager::_hooks
{after_fix_state} =
sub
{
my
(
$self
,
%args
) =
@_
;
if
(
$args
{which} eq
'redo'
) {
if
(++
$jrd
==
$num_actions
) {
for
(
"CRASH DURING REDO ACTION"
) {
$log
->trace(
$_
);
die
$_
;
}
}
}
elsif
(
$args
{which} eq
'rollback'
) {
if
(++
$jrb
==
$i
) {
for
(
"CRASH DURING ROLLBACK"
) {
$crashed
++;
$log
->trace(
$_
);
die
$_
;
}
}
}
};
eval
{
$res
=
$pa
->request(
redo
=>
"/"
, {
tx_id
=>
$tx_id
});
};
do
{ ok 1;
$last
++;
return
}
unless
$crashed
;
$tm
= Perinci::Tx::Manager->new(
data_dir
=>
"$tmpdir/.tx"
,
pa
=>
$pa
);
$res
=
$tm
->list(
tx_id
=>
$tx_id
,
detail
=>1);
is(
$res
->[2][0]{tx_status},
'X'
,
"transaction status is X"
)
or note
"res = "
, explain(
$res
);
};
}
ok 1
if
!
$num_actions
;
};
goto
DONE_TESTING
if
$done_testing
|| !Test::More->builder->is_passing;
DONE_TESTING:
done_testing;
};
}
1;