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