File Coverage

blib/lib/Test/Taint.pm
Criterion Covered Total %
statement 124 124 100.0
branch 40 44 90.9
condition 12 12 100.0
subroutine 27 27 100.0
pod 10 10 100.0
total 213 217 98.1


line stmt bran cond sub pod time code
1             package Test::Taint;
2              
3             ## no critic (Bangs::ProhibitVagueNames)
4             ## We're dealing with abstract vars like "$var" in this code.
5              
6             =head1 NAME
7              
8             Test::Taint - Tools to test taintedness
9              
10             =head1 VERSION
11              
12             Version 1.08
13              
14             =cut
15              
16 7     7   270467 use vars qw( $VERSION );
  7         49  
  7         375  
17             $VERSION = '1.08';
18              
19             =head1 SYNOPSIS
20              
21             taint_checking_ok(); # We have to have taint checking on
22             my $id = "deadbeef"; # Dummy session ID
23             taint( $id ); # Simulate it coming in from the web
24             tainted_ok( $id );
25             $id = validate_id( $id ); # Your routine to check the $id
26             untainted_ok( $id ); # Did it come back clean?
27             ok( defined $id );
28              
29             =head1 DESCRIPTION
30              
31             Tainted data is data that comes from an unsafe source, such as the
32             command line, or, in the case of web apps, any GET or POST transactions.
33             Read the L man page for details on why tainted data is bad,
34             and how to untaint the data.
35              
36             When you're writing unit tests for code that deals with tainted data,
37             you'll want to have a way to provide tainted data for your routines to
38             handle, and easy ways to check and report on the taintedness of your data,
39             in standard L style.
40              
41             =cut
42              
43 7     7   34 use strict;
  7         13  
  7         112  
44 7     7   26 use warnings;
  7         9  
  7         144  
45              
46 7     7   34 use base 'DynaLoader';
  7         11  
  7         571  
47 7     7   1045 use Test::Builder;
  7         93374  
  7         146  
48 7     7   6632 use overload;
  7         5601  
  7         32  
49 7     7   311 use Scalar::Util;
  7         13  
  7         231  
50 7     7   32 use vars qw( $TAINT );
  7         10  
  7         360  
51              
52             my $Test = Test::Builder->new;
53              
54 7     7   41 use vars qw( @EXPORT );
  7         8  
  7         434  
55             @EXPORT = qw(
56             taint taint_deeply
57             tainted tainted_deeply
58             tainted_ok tainted_ok_deeply
59             untainted_ok untainted_ok_deeply
60             taint_checking
61             taint_checking_ok
62             );
63              
64             bootstrap Test::Taint $VERSION;
65              
66             sub import {
67 7     7   42 my $self = shift;
68 7         13 my $caller = caller;
69 7     7   39 no strict 'refs';
  7         10  
  7         1684  
70 7         15 for my $sub ( @EXPORT ) {
71 70         78 *{$caller.'::'.$sub} = \&{$sub};
  70         206  
  70         101  
72             }
73 7         28 $Test->exported_to($caller);
74 7         62 $Test->plan(@_);
75             } # import
76              
77             sub _deeply_traverse {
78 15     15   19 my $callback = shift;
79 15         28 my @stack = \@_;
80              
81 15         17 my %seen;
82              
83 15         32 while(@stack) {
84 104         244 my $node = pop @stack;
85              
86             # skip the node if its not a reference
87 104 100       191 next unless defined $node;
88              
89 94 100       164 my($realpack, $realtype, $id) = overload::StrVal($node) =~ /\A(?:(.+)\=)?(HASH|ARRAY|GLOB|SCALAR|REF)\((0x[[:xdigit:]]+)\)\z/
90             or next;
91              
92             # taint the contents of tied objects
93 59 100       532 if(my $tied = $realtype eq 'HASH' ? tied %{$node} :
  17 100       31  
    100          
    100          
    100          
94 23         46 $realtype eq 'ARRAY' ? tied @{$node} :
95 11         21 $realtype eq 'SCALAR' ? tied ${$node} :
96 4         9 $realtype eq 'REF' ? tied ${$node} : undef) {
97 3         4 push @stack, $tied;
98 3         7 next;
99             }
100              
101             # prevent circular references from being traversed
102 7     7   44 no warnings 'uninitialized';
  7         11  
  7         2465  
103 56 100       173 next if $seen{$realpack, $realtype, $id}++;
104              
105             # perform an action on the node, then push them on the stack for traversal
106             push @stack,
107 15         32 $realtype eq 'HASH' ? $callback->(values %{$node}) :
108 22         35 $realtype eq 'ARRAY' ? $callback->(@{$node}) :
109 10         16 $realtype eq 'SCALAR' ? $callback->(${$node}) :
110 4         6 $realtype eq 'REF' ? $callback->(${$node}) :
111 55 100       114 map $callback->(*$node{$_}), qw(SCALAR ARRAY HASH); #must be a GLOB
    100          
    100          
    100          
112             }
113              
114 15         84 return;
115             } # _deeply_traverse
116              
117             =head1 C-style Functions
118              
119             All the C functions work like standard C-style
120             functions, where the last parm is an optional message, it outputs ok or
121             not ok, and returns a boolean telling if the test passed.
122              
123             =head2 taint_checking_ok( [$message] )
124              
125             L-style test that taint checking is on. This should probably
126             be the first thing in any F<*.t> file that deals with taintedness.
127              
128             =cut
129              
130             sub taint_checking_ok {
131 5 100   5 1 354 my $msg = @_ ? shift : "Taint checking is on";
132              
133 5         14 my $ok = taint_checking();
134 5         29 $Test->ok( $ok, $msg );
135              
136 5         1857 return $ok;
137             } # taint_checking_ok
138              
139             =head2 tainted_ok( $var [, $message ] )
140              
141             Checks that I<$var> is tainted.
142              
143             tainted_ok( $ENV{FOO} );
144              
145             =cut
146              
147             sub tainted_ok {
148 23     23 1 86 my $var = shift;
149 23         32 my $msg = shift;
150 23         44 my $ok = tainted( $var );
151 23         93 $Test->ok( $ok, $msg );
152              
153 23         5266 return $ok;
154             } # tainted_ok
155              
156             =head2 untainted_ok( $var [, $message ] )
157              
158             Checks that I<$var> is not tainted.
159              
160             my $foo = my_validate( $ENV{FOO} );
161             untainted_ok( $foo );
162              
163             =cut
164              
165             sub untainted_ok {
166 49     49 1 20158 my $var = shift;
167 49         71 my $msg = shift;
168              
169 49         98 my $ok = !tainted( $var );
170 49         127 $Test->ok( $ok, $msg );
171              
172 49         10959 return $ok;
173             } # untainted_ok
174              
175             =head2 tainted_ok_deeply( $var [, $message ] )
176              
177             Checks that I<$var> is tainted. If I<$var>
178             is a reference, it recursively checks every
179             variable to make sure they are all tainted.
180              
181             tainted_ok_deeply( \%ENV );
182              
183             =cut
184              
185             sub tainted_ok_deeply {
186 1     1 1 5 my $var = shift;
187 1         2 my $msg = shift;
188              
189 1         2 my $ok = tainted_deeply( $var );
190 1         5 $Test->ok( $ok, $msg );
191              
192 1         343 return $ok;
193             } # tainted_ok_deeply
194              
195             =head2 untainted_ok_deeply( $var [, $message ] )
196              
197             Checks that I<$var> is not tainted. If I<$var>
198             is a reference, it recursively checks every
199             variable to make sure they are all not tainted.
200              
201             my %env = my_validate( \%ENV );
202             untainted_ok_deeply( \%env );
203              
204             =cut
205              
206             sub untainted_ok_deeply {
207 1     1 1 2226 my $var = shift;
208 1         2 my $msg = shift;
209              
210 1         3 my $ok = !tainted_deeply( $var );
211 1         4 $Test->ok( $ok, $msg );
212              
213 1         276 return $ok;
214             } # untainted_ok_deeply
215              
216             =head1 Helper Functions
217              
218             These are all helper functions. Most are wrapped by an C
219             counterpart, except for C which actually does something, instead
220             of just reporting it.
221              
222             =head2 taint_checking()
223              
224             Returns true if taint checking is enabled via the -T flag.
225              
226             =cut
227              
228             sub taint_checking() {
229 6     6 1 79 return tainted( $Test::Taint::TAINT );
230             } # taint_checking
231              
232             =head2 tainted( I<$var> )
233              
234             Returns boolean saying if C<$var> is tainted.
235              
236             =cut
237              
238             sub tainted {
239 7     7   86 no warnings qw(void uninitialized);
  7         10  
  7         3002  
240              
241 197     197 1 250 return !eval { local $SIG{__DIE__} = 'DEFAULT'; join('', shift), kill 0; 1 };
  197         647  
  197         1055  
  157         528  
242             } # tainted
243              
244             =head2 tainted_deeply( I<$var> )
245              
246             Returns boolean saying if C<$var> is tainted. If
247             C<$var> is a reference it recursively checks every
248             variable to make sure they are all tainted.
249              
250             =cut
251              
252             sub tainted_deeply {
253 2     2 1 3 my $is_tainted = 1;
254              
255             _deeply_traverse(
256             sub {
257 22     22   28 foreach (@_) {
258             next
259             if not defined
260             or ref
261 31 100 100     120 or Scalar::Util::readonly $_
      100        
      100        
262             or tainted $_;
263              
264 3         4 $is_tainted = 0;
265 3         5 last;
266             }
267              
268 22         59 return @_;
269             },
270             shift,
271 2         11 );
272              
273 2         9 return $is_tainted;
274             } # tainted_deeply
275              
276             =head2 taint( @list )
277              
278             Marks each (apparently) taintable argument in I<@list> as being tainted.
279              
280             References can be tainted like any other scalar, but it doesn't make
281             sense to, so they will B be tainted by this function.
282              
283             Some Cd and magical variables may fail to be tainted by this routine,
284             try as it may.
285              
286             =cut
287              
288             sub taint {
289 45     45 1 54 local $_;
290              
291 45         63 for ( @_ ) {
292 58 100 100     202 _taint($_) unless ref or Scalar::Util::readonly $_;
293             }
294             } # taint
295              
296             # _taint() is an external function in Taint.xs
297              
298             =head2 taint_deeply( @list )
299              
300             Similar to C, except that if any elements in I<@list> are
301             references, it walks deeply into the data structure and marks each
302             taintable argument as being tainted.
303              
304             If any variables are Cd this will taint all the scalars within
305             the tied object.
306              
307             =cut
308              
309             sub taint_deeply {
310             _deeply_traverse(
311 41     41   72 sub { taint @_; @_ },
  41         121  
312 13     13 1 88 @_,
313             );
314              
315 13         40 return;
316             } # taint_deeply
317              
318             BEGIN {
319             MAKE_SOME_TAINT: {
320             # Somehow we need to get some taintedness into $Test::Taint::TAINT
321             # Let's try the easy way first. Either of these should be
322             # tainted, unless somebody has untainted them, so this
323             # will almost always work on the first try.
324             # (Unless, of course, taint checking has been turned off!)
325 7     7   22 $TAINT = substr("$0$^X", 0, 0);
  7         38  
326 7 100       20 last if tainted $TAINT;
327              
328             # Let's try again. Maybe somebody cleaned those.
329 2         42 $TAINT = substr(join('', @ARGV, %ENV), 0, 0);
330 2 100       7 last if tainted $TAINT;
331              
332             # If those don't work, go try to open some file from some unsafe
333             # source and get data from them. That data is tainted.
334             # (Yes, even reading from /dev/null works!)
335 1         3 local(*FOO);
336 1         10 for ( qw(/dev/null / . ..), values %INC, $0, $^X ) {
337 103 50       207 next unless defined $_;
338 103 50       2390 if ( open FOO, $_ ) {
339 103         178 my $potentially_tainted_data;
340 103 100       589 if ( defined sysread FOO, $potentially_tainted_data, 1 ) {
341 100         204 $TAINT = substr( $potentially_tainted_data, 0, 0 );
342 100 50       167 last if tainted $TAINT;
343             }
344             }
345             }
346 1         8 close FOO;
347             }
348              
349             # Sanity check
350 7 50       273 die 'Our taintbrush should have zero length!' if length $TAINT;
351             }
352              
353              
354             =head1 AUTHOR
355              
356             Written by Andy Lester, C<< >>.
357              
358             =head1 COPYRIGHT
359              
360             Copyright 2004-2019, Andy Lester.
361              
362             You may use, modify, and distribute this package under the
363             same terms as Perl itself.
364              
365             =cut
366              
367             1;