1use 5.008001; 2use strict; 3use warnings; 4 5package TestUtils; 6 7use Carp; 8use Cwd qw/getcwd/; 9use Config; 10use File::Temp 0.19 (); 11 12use Exporter; 13our @ISA = qw/Exporter/; 14our @EXPORT = qw( 15 exception 16 pushd 17 tempd 18 has_symlinks 19); 20 21# If we have Test::FailWarnings, use it 22BEGIN { 23 eval { require Test::FailWarnings; 1 } and do { Test::FailWarnings->import }; 24} 25 26sub has_symlinks { 27 return $Config{d_symlink} 28 unless $^O eq 'msys' || $^O eq 'MSWin32'; 29 30 if ($^O eq 'msys') { 31 # msys needs both `d_symlink` and a special environment variable 32 return unless $Config{d_symlink}; 33 return $ENV{MSYS} =~ /winsymlinks:nativestrict/; 34 } elsif ($^O eq 'MSWin32') { 35 # Perl 5.33.5 adds symlink support for MSWin32 but needs elevated 36 # privileges so verify if we can use it for testing. 37 my $wd=tempd(); 38 open my $fh, ">", "foo"; 39 return eval { symlink "foo", "bar" }; 40 } 41} 42 43sub exception(&) { 44 my $code = shift; 45 my $success = eval { $code->(); 1 }; 46 my $err = $@; 47 return '' if $success; 48 croak "Execution died, but the error was lost" unless $@; 49 return $@; 50} 51 52sub tempd { 53 return pushd( File::Temp->newdir ); 54} 55 56sub pushd { 57 my $temp = shift; 58 my $guard = TestUtils::_Guard->new( 59 { 60 temp => $temp, 61 origin => getcwd(), 62 code => sub { chdir $_[0]{origin} }, 63 } 64 ); 65 chdir $guard->{temp} 66 or croak("Couldn't chdir: $!"); 67 return $guard; 68} 69 70package TestUtils::_Guard; 71 72sub new { bless $_[1], $_[0] } 73 74sub DESTROY { $_[0]{code}->( $_[0] ) } 75 761; 77