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