Commit | Line | Data |
c0329273 |
1 | BEGIN { $ENV{DBICTEST_ANFANG_DEFANG} = 1 } |
2 | |
83542a7d |
3 | use strict; |
4 | use warnings; |
ade96c1f |
5 | use Config; |
6 | |
7 | # there is talk of possible perl compilations where -T is fatal or just |
8 | # doesn't work. We don't want to have the user deal with that. |
9 | BEGIN { unless ($INC{'t/lib/DBICTest/WithTaint.pm'}) { |
10 | |
a5741f5c |
11 | if ( $^O eq 'MSWin32' and $^X =~ /\x20/ ) { |
12 | print "1..0 # SKIP Running this test on Windows with spaces within the perl executable path (\$^X) is not possible due to https://rt.perl.org/Ticket/Display.html?id=123907\n"; |
13 | exit 0; |
14 | } |
15 | |
ade96c1f |
16 | # it is possible the test itself is initially invoked in taint mode |
17 | # and with relative paths *and* with a relative $^X and some other |
18 | # craziness... in short: just be proactive |
19 | require File::Spec; |
66a65d81 |
20 | |
21 | if (length $ENV{PATH}) { |
22 | ( $ENV{PATH} ) = join ( $Config{path_sep}, |
23 | map { length($_) ? File::Spec->rel2abs($_) : () } |
24 | split /\Q$Config{path_sep}/, $ENV{PATH} |
25 | ) =~ /\A(.+)\z/; |
26 | } |
27 | |
28 | my ($perl) = $^X =~ /\A(.+)\z/; |
ade96c1f |
29 | |
30 | { |
31 | local $ENV{PATH} = "/nosuchrootbindir"; |
32 | system( $perl => -T => -e => ' |
33 | use warnings; |
34 | use strict; |
35 | eval { my $x = $ENV{PATH} . (kill (0)); 1 } or exit 42; |
36 | exit 0; |
37 | '); |
38 | } |
39 | |
40 | if ( ($? >> 8) != 42 ) { |
41 | print "1..0 # SKIP Your perl does not seem to like/support -T...\n"; |
42 | exit 0; |
43 | } |
44 | |
45 | exec( $perl, qw( -I. -Mt::lib::DBICTest::WithTaint -T ), __FILE__ ); |
46 | }} |
83542a7d |
47 | |
9f72d93a |
48 | # When in taint mode, PERL5LIB is ignored (but *not* unset) |
49 | # Put it back in INC so that local-lib users can actually |
a8de639b |
50 | # run this test. Use lib.pm instead of an @INC unshift as |
51 | # it will correctly add any arch subdirs encountered |
a8de639b |
52 | |
53 | use lib ( |
54 | grep { length } |
55 | map { split /\Q$Config{path_sep}\E/, (/^(.*)$/)[0] } # untainting regex |
56 | grep { defined } |
57 | @ENV{qw(PERL5LIB PERLLIB)} # precedence preserved by lib |
58 | ); |
9f72d93a |
59 | |
6fc6d60c |
60 | # We need to specify 'lib' here as well because even if it was already in |
61 | # @INC, the above will have put our local::lib in front of it, so now an |
62 | # installed DBIx::Class will take precedence over the one we're trying to test. |
63 | # In some cases, prove will have supplied ./lib as an absolute path so it |
64 | # doesn't seem worth trying to remove the second copy since it won't hurt |
65 | # anything. |
66 | use lib qw(t/lib lib); |
67 | |
91b0ad0b |
68 | use Test::More; |
f54428ab |
69 | use Test::Exception; |
8d6b1478 |
70 | use DBICTest; |
83542a7d |
71 | |
f54428ab |
72 | throws_ok ( |
73 | sub { $ENV{PATH} . (kill (0)) }, |
74 | qr/Insecure dependency in kill/, |
75 | 'taint mode active' |
66a65d81 |
76 | ) if length $ENV{PATH}; |
83542a7d |
77 | |
f54428ab |
78 | { |
79 | package DBICTest::Taint::Classes; |
83542a7d |
80 | |
f54428ab |
81 | use Test::More; |
82 | use Test::Exception; |
91b0ad0b |
83 | |
f54428ab |
84 | use base qw/DBIx::Class::Schema/; |
91b0ad0b |
85 | |
f54428ab |
86 | lives_ok (sub { |
87 | __PACKAGE__->load_classes(qw/Manual/); |
88 | ok( __PACKAGE__->source('Manual'), 'The Classes::Manual source has been registered' ); |
89 | __PACKAGE__->_unregister_source (qw/Manual/); |
90 | }, 'Loading classes with explicit load_classes worked in taint mode' ); |
91b0ad0b |
91 | |
f54428ab |
92 | lives_ok (sub { |
93 | __PACKAGE__->load_classes(); |
94 | ok( __PACKAGE__->source('Auto'), 'The Classes::Auto source has been registered' ); |
95 | ok( __PACKAGE__->source('Auto'), 'The Classes::Manual source has been re-registered' ); |
96 | }, 'Loading classes with Module::Find/load_classes worked in taint mode' ); |
97 | } |
83542a7d |
98 | |
f54428ab |
99 | { |
100 | package DBICTest::Taint::Namespaces; |
83542a7d |
101 | |
f54428ab |
102 | use Test::More; |
103 | use Test::Exception; |
91b0ad0b |
104 | |
f54428ab |
105 | use base qw/DBIx::Class::Schema/; |
83542a7d |
106 | |
f54428ab |
107 | lives_ok (sub { |
108 | __PACKAGE__->load_namespaces(); |
109 | ok( __PACKAGE__->source('Test'), 'The Namespaces::Test source has been registered' ); |
110 | }, 'Loading classes with Module::Find/load_namespaces worked in taint mode' ); |
111 | } |
91b0ad0b |
112 | |
f2d11f4a |
113 | # check that we can create a database and all |
114 | { |
115 | my $s = DBICTest->init_schema( sqlite_use_file => 1 ); |
116 | my $art = $s->resultset('Artist')->search({}, { |
117 | prefetch => 'cds', order_by => 'artistid', |
118 | })->next; |
119 | is ($art->artistid, 1, 'got artist'); |
120 | } |
121 | |
f54428ab |
122 | done_testing; |