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