diff --git a/.github/workflows/testsuite.yml b/.github/workflows/testsuite.yml index 8af84cc..b3673de 100644 --- a/.github/workflows/testsuite.yml +++ b/.github/workflows/testsuite.yml @@ -69,7 +69,7 @@ jobs: - uses: actions/checkout@v6 - run: perl -V - name: Install Dependencies - run: cpm install -g --show-build-log-on-failure + run: cpm install -g --show-build-log-on-failure || cpanm --installdeps --notest . - run: perl Makefile.PL - run: make - run: make test diff --git a/FileCheck.xs b/FileCheck.xs index 8d893fc..ce88147 100644 --- a/FileCheck.xs +++ b/FileCheck.xs @@ -532,6 +532,27 @@ mock_op(optype) RETVAL +int +_xs_is_mocked(optype) + SV* optype; +CODE: +{ + dMY_CXT; + int opid; + + if ( ! SvIOK(optype) ) + croak("first argument to _xs_is_mocked must be one integer"); + + opid = SvIV( optype ); + if ( !opid || opid < 0 || opid >= OP_MAX ) + croak( "Invalid opid value %d", opid ); + + RETVAL = gl_overload_ft->op[opid].is_mocked; +} +OUTPUT: + RETVAL + + SV* get_basetime() CODE: @@ -650,6 +671,10 @@ CODE: /* is_mocked stays 0 from Newxz */ } } + /* Perl-level state ($_current_mocks) is reset lazily in + * mock_file_check() via _xs_is_mocked() check, rather than + * here, because call_pv() during CLONE is unreliable on + * some Perl builds. */ } #endif diff --git a/lib/Overload/FileCheck.pm b/lib/Overload/FileCheck.pm index 5034976..a745965 100644 --- a/lib/Overload/FileCheck.pm +++ b/lib/Overload/FileCheck.pm @@ -235,7 +235,16 @@ sub mock_file_check { Carp::croak(q[Second arg must be a CODE ref]) unless ref $sub eq 'CODE'; my ( $name, $optype ) = _resolve_check($check); - Carp::croak(qq[-$name is already mocked by Overload::FileCheck]) if exists $_current_mocks->{$optype}; + + if ( exists $_current_mocks->{$optype} ) { + # In ithreads, the Perl hash may carry stale entries from the + # parent thread while the XS layer has already reset is_mocked. + # Check the actual XS state before croaking. + if ( _xs_is_mocked($optype) ) { + Carp::croak(qq[-$name is already mocked by Overload::FileCheck]); + } + delete $_current_mocks->{$optype}; + } $_current_mocks->{$optype} = $sub; diff --git a/t/ithreads-clone.t b/t/ithreads-clone.t new file mode 100644 index 0000000..12391f2 --- /dev/null +++ b/t/ithreads-clone.t @@ -0,0 +1,71 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Config; +use Test2::V0; + +BEGIN { + plan skip_all => 'This perl is not built with ithreads support' + unless $Config{useithreads}; +} + +use threads; +use Overload::FileCheck qw(:check mock_file_check unmock_file_check); + +# -- Parent thread mocks -e -------------------------------------------------- + +mock_file_check( + '-e' => sub { + my ($file) = @_; + return CHECK_IS_TRUE if $file eq '/parent/file'; + return FALLBACK_TO_REAL_OP; + } +); + +ok( -e '/parent/file', '-e mock works in parent thread' ); + +# -- Child thread can re-mock independently ----------------------------------- + +my $thr = threads->create(sub { + # The XS CLONE resets is_mocked=0, and _clone_init clears + # $_current_mocks. So the child should be able to mock -e + # without getting "already mocked" error. + + my $can_mock = eval { + mock_file_check( + '-e' => sub { + my ($file) = @_; + return CHECK_IS_TRUE if $file eq '/child/file'; + return FALLBACK_TO_REAL_OP; + } + ); + 1; + }; + + my $mock_error = $@; + my $child_works = $can_mock ? ( -e '/child/file' ? 1 : 0 ) : 0; + + # Parent's mock should not be active in child + my $parent_leaked = -e '/parent/file' ? 1 : 0; + + unmock_file_check('-e') if $can_mock; + + return ( $can_mock, $mock_error, $child_works, $parent_leaked ); +}); + +my ( $can_mock, $mock_error, $child_works, $parent_leaked ) = $thr->join; + +ok( $can_mock, 'child thread can mock_file_check without "already mocked" error' ) + or diag("mock error: $mock_error"); +ok( $child_works, 'child thread mock returns correct value' ); +ok( !$parent_leaked, 'parent mock state does not leak into child thread' ); + +# -- Parent mock still works after child exits -------------------------------- + +ok( -e '/parent/file', 'parent mock unaffected by child thread' ); + +unmock_file_check('-e'); + +done_testing;