diff --git a/lib/Overload/FileCheck.pm b/lib/Overload/FileCheck.pm index 34acb3c..7952c8f 100644 --- a/lib/Overload/FileCheck.pm +++ b/lib/Overload/FileCheck.pm @@ -287,10 +287,11 @@ sub _check_from_stat { # or if we let it fallback to the Perl OP # 2/ doing a second stat call in order to cache _ - my $can_use_stat; - $can_use_stat = 1 if $check =~ qr{^[sfdMXxzACORWeorwugk]$}; + # In Perl, only -l uses lstat (does not follow symlinks). + # All other file test ops use stat (follows symlinks). + my $use_lstat = ( $check eq 'l' ); - my $stat_or_lstat = $can_use_stat ? 'stat' : 'lstat'; + my $stat_or_lstat = $use_lstat ? 'lstat' : 'stat'; my (@mocked_lstat_result) = $sub_for_stat->( $stat_or_lstat, $f_or_fh ); if ( scalar @mocked_lstat_result == 1 @@ -307,14 +308,14 @@ sub _check_from_stat { # now performing a real stat call [ using the mocked stat function ] my ( @stat, @lstat ); - if ($can_use_stat) { - no warnings; # throw warnings with Perl <= 5.14 - @stat = stat($f_or_fh) if defined $f_or_fh; - } - else { + if ($use_lstat) { no warnings; @lstat = lstat($f_or_fh) if defined $f_or_fh; } + else { + no warnings; # throw warnings with Perl <= 5.14 + @stat = stat($f_or_fh) if defined $f_or_fh; + } # Dispatch table mapping each check letter to its handler. # Closures capture @stat, @lstat, $optype, and $f_or_fh from the enclosing scope. @@ -355,12 +356,14 @@ sub _check_from_stat { f => sub { _check_mode_type( $stat[ST_MODE], S_IFREG ) }, # plain file d => sub { _check_mode_type( $stat[ST_MODE], S_IFDIR ) }, # directory - # File type checks via mode bits (using @lstat — does not follow symlinks) + # Symlink check — only op that uses lstat (does not follow symlinks) l => sub { _check_mode_type( $lstat[ST_MODE], S_IFLNK ) }, # symbolic link - p => sub { _check_mode_type( $lstat[ST_MODE], S_IFIFO ) }, # named pipe (FIFO) - S => sub { _check_mode_type( $lstat[ST_MODE], S_IFSOCK ) }, # socket - b => sub { _check_mode_type( $lstat[ST_MODE], S_IFBLK ) }, # block special file - c => sub { _check_mode_type( $lstat[ST_MODE], S_IFCHR ) }, # character special file + + # File type checks via mode bits (using @stat — follows symlinks like Perl) + p => sub { _check_mode_type( $stat[ST_MODE], S_IFIFO ) }, # named pipe (FIFO) + S => sub { _check_mode_type( $stat[ST_MODE], S_IFSOCK ) }, # socket + b => sub { _check_mode_type( $stat[ST_MODE], S_IFBLK ) }, # block special file + c => sub { _check_mode_type( $stat[ST_MODE], S_IFCHR ) }, # character special file # Age calculations: (basetime - timestamp) / seconds_per_day M => sub { @@ -378,7 +381,7 @@ sub _check_from_stat { ); my $handler = $dispatch{$check} - or die "Unknown check $check.\n"; + or Carp::croak(qq[Unknown check '$check']); return $handler->(); } @@ -403,7 +406,7 @@ sub mock_stat { foreach my $opname (qw{stat lstat}) { my $optype = $MAP_FC_OP{$opname}; - die qq[No optype found for $opname] unless $optype; + Carp::croak(qq[No optype found for $opname]) unless $optype; # plug the sub $_current_mocks->{$optype} = sub { diff --git a/t/stat-dispatch-special-types.t b/t/stat-dispatch-special-types.t new file mode 100644 index 0000000..b6bf91b --- /dev/null +++ b/t/stat-dispatch-special-types.t @@ -0,0 +1,144 @@ +#!/usr/bin/perl -w + +# Test that _check_from_stat uses stat (not lstat) for -p, -S, -b, -c checks, +# matching real Perl semantics where these operators follow symlinks. +# +# Before this fix, -p/-S/-b/-c used lstat, so mocking a symlink that points +# to a socket (for example) would incorrectly fail -S because lstat sees +# symlink mode bits, not socket mode bits. + +use strict; +use warnings; + +use Test2::Bundle::Extended; +use Test2::Tools::Explain; +use Test2::Plugin::NoWarnings; + +use Fcntl qw(S_IFIFO); +use Overload::FileCheck q{:all}; + +my $mock_path = '/test/special-file'; + +subtest '-p/-S/-b/-c dispatch stat, not lstat' => sub { + my @types_seen; + + mock_all_from_stat( + sub { + my ( $type, $file ) = @_; + if ( defined $file && $file eq $mock_path ) { + push @types_seen, $type; + return stat_as_socket(); + } + return FALLBACK_TO_REAL_OP; + } + ); + + for my $check (qw( p S b c )) { + @types_seen = (); + # Just trigger the check to verify the stat_or_lstat argument + eval "no warnings; -$check '$mock_path'"; + is( \@types_seen, ['stat'], "-$check dispatches stat, not lstat" ); + } + + unmock_all_file_checks(); +}; + +subtest '-S detects socket through symlink mock' => sub { + mock_all_from_stat( + sub { + my ( $type, $file ) = @_; + return FALLBACK_TO_REAL_OP unless defined $file && $file eq $mock_path; + + if ( $type eq 'lstat' ) { + # lstat sees the symlink itself + return stat_as_symlink(); + } + # stat follows the symlink and sees the socket + return stat_as_socket(); + } + ); + + ok( -S $mock_path, '-S returns true for symlink-to-socket (follows symlink via stat)' ); + ok( !-f $mock_path, '-f returns false for socket' ); + + unmock_all_file_checks(); +}; + +subtest '-p detects pipe through symlink mock' => sub { + mock_all_from_stat( + sub { + my ( $type, $file ) = @_; + return FALLBACK_TO_REAL_OP unless defined $file && $file eq $mock_path; + + if ( $type eq 'lstat' ) { + return stat_as_symlink(); + } + return [ 0, 0, S_IFIFO | 0644, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0 ]; + } + ); + + ok( -p $mock_path, '-p returns true for symlink-to-pipe (follows symlink via stat)' ); + + unmock_all_file_checks(); +}; + +subtest '-b detects block device through symlink mock' => sub { + mock_all_from_stat( + sub { + my ( $type, $file ) = @_; + return FALLBACK_TO_REAL_OP unless defined $file && $file eq $mock_path; + + if ( $type eq 'lstat' ) { + return stat_as_symlink(); + } + return stat_as_block(); + } + ); + + ok( -b $mock_path, '-b returns true for symlink-to-block-device (follows symlink via stat)' ); + + unmock_all_file_checks(); +}; + +subtest '-c detects char device through symlink mock' => sub { + mock_all_from_stat( + sub { + my ( $type, $file ) = @_; + return FALLBACK_TO_REAL_OP unless defined $file && $file eq $mock_path; + + if ( $type eq 'lstat' ) { + return stat_as_symlink(); + } + return stat_as_chr(); + } + ); + + ok( -c $mock_path, '-c returns true for symlink-to-char-device (follows symlink via stat)' ); + + unmock_all_file_checks(); +}; + +subtest '-l still uses lstat correctly' => sub { + my @types_seen; + + mock_all_from_stat( + sub { + my ( $type, $file ) = @_; + return FALLBACK_TO_REAL_OP unless defined $file && $file eq $mock_path; + push @types_seen, $type; + + if ( $type eq 'lstat' ) { + return stat_as_symlink(); + } + return stat_as_file(); + } + ); + + @types_seen = (); + ok( -l $mock_path, '-l returns true for symlink' ); + is( \@types_seen, ['lstat'], '-l dispatches lstat, not stat' ); + + unmock_all_file_checks(); +}; + +done_testing;