diff --git a/lib/Overload/FileCheck.pm b/lib/Overload/FileCheck.pm index 5034976..2574687 100644 --- a/lib/Overload/FileCheck.pm +++ b/lib/Overload/FileCheck.pm @@ -60,6 +60,8 @@ my @CHECK_STATUS = qw{CHECK_IS_FALSE CHECK_IS_TRUE CHECK_IS_NULL FALLBACK_TO_REA my @STAT_HELPERS = qw{ stat_as_directory stat_as_file stat_as_symlink stat_as_socket stat_as_chr stat_as_block stat_as_fifo}; +my @INTROSPECTION = qw{ is_mocked get_mocked_checks }; + our @EXPORT_OK = ( qw{ mock_all_from_stat @@ -69,6 +71,7 @@ our @EXPORT_OK = ( @CHECK_STATUS, @STAT_T_IX, @STAT_HELPERS, + @INTROSPECTION, ); our %EXPORT_TAGS = ( @@ -454,6 +457,21 @@ sub unmock_all_file_checks { return unmock_file_check(@mocks); } +sub is_mocked { + my ($check) = @_; + + my ( undef, $optype ) = _resolve_check($check); + + return exists $_current_mocks->{$optype} ? 1 : 0; +} + +sub get_mocked_checks { + return sort + grep { $_ !~ qr{^l?stat$} } + map { $REVERSE_MAP{$_} } + keys %$_current_mocks; +} + # should not be called directly # this is called from XS to check if one OP is mocked # and trigger the callback function when mocked @@ -1053,6 +1071,28 @@ By a simple call to unmock_all_file_checks, you would disable the effect of over filecheck OPs. (not that the XS code is still plugged in, but fallback as soon as possible to the original OP) +=head2 is_mocked( $check ) + +Returns true if the given file check operator is currently mocked, false otherwise. +The leading dash is optional. + + if ( is_mocked('-e') ) { + # -e is currently mocked + } + +This also works for C and C: + + if ( is_mocked('stat') ) { ... } + +=head2 get_mocked_checks() + +Returns a sorted list of file check operator names (without dash) that are currently +mocked. C and C are excluded from the list — use C +to check those. + + my @checks = get_mocked_checks(); + # e.g. ('B', 'T', 'e', 'f') + =head2 mock_stat( CODE ) mock_stat provides one interface to setup a hook for all C and C calls. diff --git a/t/introspection.t b/t/introspection.t new file mode 100644 index 0000000..16d7804 --- /dev/null +++ b/t/introspection.t @@ -0,0 +1,81 @@ +#!perl + +use strict; +use warnings; + +use Test2::Bundle::Extended; +use Test2::Tools::Explain; + +use Overload::FileCheck qw(:all); + +# ---- is_mocked ---- + +ok( !is_mocked('-e'), '-e is not mocked initially' ); +ok( !is_mocked('e'), 'also works without leading dash' ); +ok( !is_mocked('stat'), 'stat is not mocked initially' ); + +mock_file_check( '-e' => sub { CHECK_IS_TRUE } ); +ok( is_mocked('-e'), '-e is mocked after mock_file_check' ); +ok( is_mocked('e'), 'is_mocked works without dash too' ); +ok( !is_mocked('-f'), '-f is still not mocked' ); + +unmock_file_check('-e'); +ok( !is_mocked('-e'), '-e is no longer mocked after unmock' ); + +# ---- get_mocked_checks ---- + +is( [ get_mocked_checks() ], [], 'no checks mocked initially' ); + +mock_file_check( '-f' => sub { CHECK_IS_TRUE } ); +mock_file_check( '-e' => sub { CHECK_IS_TRUE } ); + +is( [ get_mocked_checks() ], [ 'e', 'f' ], 'returns sorted list of mocked checks' ); + +unmock_file_check('-e'); +is( [ get_mocked_checks() ], [ 'f' ], 'list updates after unmock' ); + +unmock_file_check('-f'); +is( [ get_mocked_checks() ], [], 'empty after all unmocked' ); + +# ---- stat/lstat exclusion from get_mocked_checks ---- + +mock_stat( sub { FALLBACK_TO_REAL_OP } ); +ok( is_mocked('stat'), 'stat is mocked after mock_stat' ); +ok( is_mocked('lstat'), 'lstat is mocked after mock_stat' ); +is( [ get_mocked_checks() ], [], 'stat/lstat excluded from get_mocked_checks' ); + +unmock_stat(); +ok( !is_mocked('stat'), 'stat unmocked' ); +ok( !is_mocked('lstat'), 'lstat unmocked' ); + +# ---- mock_all_from_stat ---- + +mock_all_from_stat( sub { FALLBACK_TO_REAL_OP } ); +ok( is_mocked('-e'), '-e is mocked via mock_all_from_stat' ); +ok( is_mocked('-f'), '-f is mocked via mock_all_from_stat' ); +ok( is_mocked('-d'), '-d is mocked via mock_all_from_stat' ); +ok( is_mocked('stat'), 'stat is mocked via mock_all_from_stat' ); + +my @checks = get_mocked_checks(); +ok( scalar @checks > 20, 'mock_all_from_stat mocks many checks (got ' . scalar(@checks) . ')' ); + +unmock_all_file_checks(); +is( [ get_mocked_checks() ], [], 'all cleared after unmock_all_file_checks' ); + +# ---- guard interaction ---- + +{ + my $guard = mock_file_check_guard( '-d' => sub { CHECK_IS_TRUE } ); + ok( is_mocked('-d'), '-d is mocked inside guard scope' ); +} +ok( !is_mocked('-d'), '-d is unmocked after guard goes out of scope' ); + +# ---- invalid check ---- + +like( + dies { is_mocked('-Q') }, + qr/Unknown check/, + 'is_mocked croaks on unknown check' +); + +done_testing;