Test-Taint-1.08/0000755000175000017500000000000013500255533012107 5ustar andyandyTest-Taint-1.08/Taint.xs0000644000175000017500000000036713500254357013553 0ustar andyandy#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" MODULE = Test::Taint PACKAGE = Test::Taint void _taint(...) CODE: IV i; for (i = 0; i < items; i++) SvTAINTED_on(ST(i)); Test-Taint-1.08/MANIFEST0000644000175000017500000000053713500255534013246 0ustar andyandyChanges Makefile.PL MANIFEST ppport.h t/00.load.t t/no-dash-T.t t/pod-coverage.t t/pod.t t/taint.t t/taint_deeply.t t/tainted.t t/tainted_ok.t t/tainted_ok_deeply.t Taint.pm Taint.xs META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Test-Taint-1.08/Makefile.PL0000644000175000017500000000166413500254357014073 0ustar andyandyuse 5.6.1; use strict; use warnings FATAL => 'all'; use ExtUtils::MakeMaker; my %parms = ( NAME => 'Test::Taint', VERSION_FROM => 'Taint.pm', ABSTRACT => "Checks for taintedness of variables", PREREQ_PM => { 'overload' => 0, 'Scalar::Util' => 0, 'Test::Builder' => 0, 'Test::More' => 0, 'Tie::Array' => 0, 'Tie::Hash' => 0, 'Tie::Scalar' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Test-Taint-*' }, ); if ( $ExtUtils::MakeMaker::VERSION ge '6.46' ) { $parms{META_MERGE} = { resources => { repository => 'https://github.com/petdance/test-taint', } }; } WriteMakefile( %parms ); sub MY::postamble { return <<'MAKE'; .PHONY: critic critic: perlcritic -1 -q -profile perlcriticrc Taint.pm t/*.t MAKE } Test-Taint-1.08/META.json0000664000175000017500000000221613500255533013533 0ustar andyandy{ "abstract" : "Checks for taintedness of variables", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.143240", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-Taint", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Scalar::Util" : "0", "Test::Builder" : "0", "Test::More" : "0", "Tie::Array" : "0", "Tie::Hash" : "0", "Tie::Scalar" : "0", "overload" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "https://github.com/petdance/test-taint" } }, "version" : "1.08" } Test-Taint-1.08/t/0000755000175000017500000000000013500255533012352 5ustar andyandyTest-Taint-1.08/t/00.load.t0000644000175000017500000000026413500254357013701 0ustar andyandy#!perl -T use strict; use warnings; use Test::More tests => 1; use Test::Taint; diag( "Testing Test::Taint $Test::Taint::VERSION, Perl $], $^X" ); pass( 'Module loaded OK' ); Test-Taint-1.08/t/taint.t0000644000175000017500000000136213500254357013663 0ustar andyandy#!perl -T use warnings; use strict; BEGIN { for($0, $^X) { ## no critic (Variables::ProhibitPunctuationVars) ($_) = /(.*)/; } } use Test::More; use Test::Taint tests => 10; use constant VAR => 'VAR'; ## no critic (ValuesAndExpressions::ProhibitConstantPragma) taint_checking_ok(); my $foo = 43; untainted_ok( $foo, 'Starts clean' ); taint($foo); tainted_ok( $foo, 'Gets dirty' ); $foo =~ /(\d+)/ or die; $foo = $1; untainted_ok( $foo, 'Reclean' ); my $bar = 'bar'; untainted_ok( $bar, 'Starts clean' ); taint($bar); tainted_ok( $bar, 'Gets dirty' ); is($bar, 'bar', 'String value stays the same'); untainted_ok( VAR, 'Starts clean' ); taint(VAR); untainted_ok( VAR, 'Stays clean' ); is(VAR, 'VAR', 'String value stays the same'); Test-Taint-1.08/t/tainted.t0000644000175000017500000000077513500255474014204 0ustar andyandy#!perl -T use warnings; use strict; use Test::More tests => 6; use Test::Taint; taint_checking_ok(); ok( tainted($^X), '$^X is tainted' ); my $foo = 43; ok( !tainted($foo), '43 is not tainted' ); RESET_SIG_DIE: { my $counter = 0; local $SIG{__DIE__} = sub { $counter++ }; ok( tainted($^X), '$^X is tainted' ); is($counter, 0, 'counter was not incremented (our die did not fire)'); eval { die 'validly' }; is($counter, 1, 'counter was incremented (our die fired properly)'); } Test-Taint-1.08/t/no-dash-T.t0000644000175000017500000000046413500254357014300 0ustar andyandy#!perl -w # Note the lack of -T in the shebang use warnings; use strict; use Test::Taint tests=>4; use Test::More; ok( !taint_checking(), 'Taint checking is off' ); my $foo = 43; untainted_ok( $foo, 'Starts clean' ); taint($foo); untainted_ok( $foo, 'Stays clean' ); untainted_ok( $Test::Taint::TAINT ); Test-Taint-1.08/t/pod-coverage.t0000644000175000017500000000040313500254357015112 0ustar andyandy#!perl -T use strict; use warnings; use Test::More; my $module = 'Test::Pod::Coverage 1.04'; if ( eval "use $module; 1;" ) { ## no critic (ProhibitStringyEval) all_pod_coverage_ok(); } else { plan skip_all => "$module required for testing POD"; } Test-Taint-1.08/t/tainted_ok.t0000644000175000017500000000024013500255474014660 0ustar andyandy#!perl -T use warnings; use strict; use Test::Taint tests=>3; taint_checking_ok(); tainted_ok( $^X, '$^X is tainted' ); my $foo = 43; untainted_ok( $foo ); Test-Taint-1.08/t/taint_deeply.t0000644000175000017500000002116313500254772015227 0ustar andyandy#!perl -T ## Two techniques that are bad in general but necessary in this test. ## no critic (Miscellanea::ProhibitTies) ## no critic (Modules::ProhibitMultiplePackages) use strict; use warnings FATAL => 'all'; use Test::More; use Test::Taint tests => 111; taint_checking_ok('Taint checking is on'); TAINT_A_HASH: { my %hash = ( value => 7, unknown => undef, ); $hash{circular} = \%hash; untainted_ok( $hash{value}, 'Starts clean' ); taint_deeply( \%hash ); tainted_ok( $hash{value}, 'Gets dirty' ); is( $hash{value}, 7, 'value stays the same' ); $hash{value} =~ /\A(\d+)\z/ or die; $hash{value} = $1; untainted_ok( $hash{value}, 'Reclean' ); is( $hash{value}, 7, 'value stays the same' ); } TAINT_AN_ARRAY: { my @array = ( 7, ); untainted_ok( $array[0], 'Starts clean' ); taint_deeply( \@array ); tainted_ok( $array[0], 'Gets dirty' ); is( $array[0], 7, 'value stays the same' ); $array[0] =~ /\A(\d+)\z/ or die; $array[0] = $1; untainted_ok( $array[0], 'Reclean' ); is( $array[0], 7, 'value stays the same' ); } TAINT_A_SCALAR: { my $scalar = 14; untainted_ok( $scalar, 'Starts clean' ); taint_deeply( \$scalar ); tainted_ok( $scalar, 'Gets dirty' ); is( $scalar, 14, 'value stays the same' ); $scalar =~ /\A(\d+)\z/ or die; $scalar = $1; untainted_ok( $scalar, 'Reclean' ); is( $scalar, 14, 'value stays the same' ); } TAINT_A_TYPEGLOB: { no strict 'vars'; $x = 21; %x = (k1 => 28, k2 => 35, k3 => 42, k4 => 49); @x = (56, 63, 70, 77); untainted_ok( $x, 'Starts clean' ); untainted_ok( $x{$_}, 'Starts clean' ) foreach keys %x; untainted_ok( $_, 'Starts clean' ) foreach @x; taint_deeply( \*x ); tainted_ok( $x, 'Gets dirty' ); tainted_ok( $x{$_}, 'Gets dirty' ) foreach keys %x; tainted_ok( $_, 'Gets dirty' ) foreach @x; is( $x, 21, 'value stays the same' ); is( $x{k1}, 28, 'value stays the same' ); is( $x{k2}, 35, 'value stays the same' ); is( $x{k3}, 42, 'value stays the same' ); is( $x{k4}, 49, 'value stays the same' ); is( $x[0], 56, 'value stays the same' ); is( $x[1], 63, 'value stays the same' ); is( $x[2], 70, 'value stays the same' ); is( $x[3], 77, 'value stays the same' ); $x =~ /\A(\d+)\z/ or die; $x = $1; untainted_ok( $x, 'Reclean' ); foreach my $value (values %x) { $value =~ /\A(\d+)\z/ or die; $value = $1; } untainted_ok( $x{$_}, 'Reclean' ) foreach keys %x; foreach my $element (@x) { $element =~ /\A(\d+)\z/ or die; $element = $1; } untainted_ok( $_, 'Reclean' ) foreach keys %x; is( $x, 21, 'value stays the same' ); is( $x{k1}, 28, 'value stays the same' ); is( $x{k2}, 35, 'value stays the same' ); is( $x{k3}, 42, 'value stays the same' ); is( $x{k4}, 49, 'value stays the same' ); is( $x[0], 56, 'value stays the same' ); is( $x[1], 63, 'value stays the same' ); is( $x[2], 70, 'value stays the same' ); is( $x[3], 77, 'value stays the same' ); } TAINT_A_HASH_OBJECT: { { package My::ObjectHash; sub new { return bless {} => shift }; } my $hash_object = My::ObjectHash->new; isa_ok( $hash_object, 'My::ObjectHash' ); $hash_object->{value} = 84; untainted_ok( $hash_object->{value}, 'Starts clean' ); taint_deeply( $hash_object ); tainted_ok( $hash_object->{value}, 'Gets dirty' ); is( $hash_object->{value}, 84, 'value stays the same' ); $hash_object->{value} =~ /\A(\d+)\z/ or die; $hash_object->{value} = $1; untainted_ok( $hash_object->{value}, 'Reclean' ); is( $hash_object->{value}, 84, 'value stays the same' ); isa_ok( $hash_object, 'My::ObjectHash' ); } TAINT_AN_ARRAY_OBJECT: { { package My::ObjectArray; sub new { return bless [] => shift }; } my $array_object = My::ObjectArray->new; isa_ok( $array_object, 'My::ObjectArray' ); $array_object->[0] = 84; untainted_ok( $array_object->[0], 'Starts clean' ); taint_deeply( $array_object ); tainted_ok( $array_object->[0], 'Gets dirty' ); is( $array_object->[0], 84, 'value stays the same' ); $array_object->[0] =~ /\A(\d+)\z/ or die; $array_object->[0] = $1; untainted_ok( $array_object->[0], 'Reclean' ); is( $array_object->[0], 84, 'value stays the same' ); isa_ok( $array_object, 'My::ObjectArray' ); } TAINT_A_SCALAR_OBJECT: { { package My::ObjectScalar; sub new { my $scalar; return bless \$scalar => shift }; } my $scalar_object = My::ObjectScalar->new; isa_ok( $scalar_object, 'My::ObjectScalar' ); ${$scalar_object} = 84; untainted_ok( ${$scalar_object}, 'Starts clean' ); taint_deeply( $scalar_object ); tainted_ok( ${$scalar_object}, 'Gets dirty' ); is( ${$scalar_object}, 84, 'value stays the same' ); ${$scalar_object} =~ /\A(\d+)\z/ or die; ${$scalar_object} = $1; untainted_ok( ${$scalar_object}, 'Reclean' ); is( ${$scalar_object}, 84, 'value stays the same' ); isa_ok( $scalar_object, 'My::ObjectScalar' ); } TAINT_A_REF: { { package My::ObjectRef; sub new { my $ref = \my %hash;; return bless \$ref, => shift; }; } my $ref_object = My::ObjectRef->new; isa_ok( $ref_object, 'My::ObjectRef' ); ${$ref_object}->{key} = 1; untainted_ok( ${$ref_object}->{key}, 'Starts clean' ); taint_deeply( $ref_object ); tainted_ok( ${$ref_object}->{key}, 'Gets dirty' ); is( ${$ref_object}->{key}, 1, 'value stays the same' ); ${$ref_object}->{key} =~ /\A(\d+)\z/ or die; ${$ref_object}->{key} = $1; untainted_ok( ${$ref_object}->{key}, 'Reclean' ); is( ${$ref_object}->{key}, 1, 'value stays the same' ); isa_ok( $ref_object, 'My::ObjectRef' ); } TAINT_A_TIED_HASH: { { package My::TiedHash; use Tie::Hash; use base 'Tie::StdHash'; } my $tied_hash_object = tie my %tied_hash, 'My::TiedHash'; $tied_hash_object->{value} = 84; untainted_ok( $tied_hash_object->{value}, 'Starts clean' ); taint_deeply( \%tied_hash ); tainted_ok( $tied_hash_object->{value}, 'Gets dirty' ); is( $tied_hash_object->{value}, 84, 'value stays the same' ); $tied_hash_object->{value} =~ /\A(\d+)\z/ or die; $tied_hash_object->{value} = $1; untainted_ok( $tied_hash_object->{value}, 'Reclean' ); is( $tied_hash_object->{value}, 84, 'value stays the same' ); } TAINT_A_TIED_ARRAY: { { package My::TiedArray; use Tie::Array; use base 'Tie::StdArray'; } my $tied_array_object = tie my @tied_array, 'My::TiedArray'; $tied_array_object->[0] = 56; untainted_ok( $tied_array_object->[0], 'Starts clean' ); taint_deeply( \@tied_array ); tainted_ok( $tied_array_object->[0], 'Gets dirty' ); is( $tied_array_object->[0], 56, 'value stays the same' ); $tied_array_object->[0] =~ /\A(\d+)\z/ or die; $tied_array_object->[0] = $1; untainted_ok( $tied_array_object->[0], 'Reclean' ); is( $tied_array_object->[0], 56, 'value stays the same' ); } TAINT_A_TIED_SCALAR: { { package My::TiedScalar; use Tie::Scalar; use base 'Tie::StdScalar'; } my $tied_scalar_object = tie my $tied_scalar, 'My::TiedScalar'; ${$tied_scalar_object} = 63; untainted_ok( ${$tied_scalar_object}, 'Starts clean' ); taint_deeply( \$tied_scalar ); tainted_ok( ${$tied_scalar_object}, 'Gets dirty' ); is( ${$tied_scalar_object}, 63, 'value stays the same' ); ${$tied_scalar_object} =~ /\A(\d+)\z/ or die; ${$tied_scalar_object} = $1; untainted_ok( ${$tied_scalar_object}, 'Reclean' ); is( ${$tied_scalar_object}, 63, 'value stays the same' ); } TAINT_AN_OVERLOADED_OBJECT: { { package My::Overloaded; use base 'My::ObjectHash'; use overload '""' => \&as_string; sub as_string { my $self = shift; return "%{$self}"; } } my $overloaded_object = My::Overloaded->new; isa_ok( $overloaded_object, 'My::Overloaded' ); $overloaded_object->{value} = 99; untainted_ok( $overloaded_object->{value}, 'Starts clean' ); taint_deeply( $overloaded_object ); tainted_ok( $overloaded_object->{value}, 'Gets dirty' ); is( $overloaded_object->{value}, 99, 'value stays the same' ); $overloaded_object->{value} =~ /\A(\d+)\z/ or die; $overloaded_object->{value} = $1; untainted_ok( $overloaded_object->{value}, 'Reclean' ); is( $overloaded_object->{value}, 99, 'value stays the same' ); isa_ok( $overloaded_object, 'My::Overloaded' ); } Test-Taint-1.08/t/pod.t0000644000175000017500000000034513500254357013326 0ustar andyandy#!perl -Tw use warnings; use strict; use Test::More; if ( eval 'use Test::Pod 1.14; 1;' ) { ## no critic (ProhibitStringyEval) all_pod_files_ok(); } else { plan skip_all => 'Test::Pod 1.14 required for testing POD'; } Test-Taint-1.08/t/tainted_ok_deeply.t0000644000175000017500000000113513500254357016225 0ustar andyandy#!perl -T use strict; use warnings FATAL => 'all'; use Test::More; use Test::Taint tests => 8; taint_checking_ok('Taint checking is on'); my %vars = ( HASH => { key => 'value' }, ARRAY => [ 1..2 ], GLOB => \*DATA, SCALAR => \q{u can't taint this}, REF => \{ another_key => 1 }, ); while(my($key, $value) = each %vars) { is( ref $value, $key, 'Make sure the datatype is correct', ); } untainted_ok_deeply( \%vars, 'Everything should be untainted' ); taint_deeply( \%vars ); tainted_ok_deeply( \%vars, 'Everything should be tainted' ); __DATA__ i am glob Test-Taint-1.08/META.yml0000664000175000017500000000121613500255533013362 0ustar andyandy--- abstract: 'Checks for taintedness of variables' author: - unknown build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.143240' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test-Taint no_index: directory: - t - inc requires: Scalar::Util: '0' Test::Builder: '0' Test::More: '0' Tie::Array: '0' Tie::Hash: '0' Tie::Scalar: '0' overload: '0' resources: repository: https://github.com/petdance/test-taint version: '1.08' Test-Taint-1.08/Taint.pm0000644000175000017500000002113713500255474013534 0ustar andyandypackage Test::Taint; ## no critic (Bangs::ProhibitVagueNames) ## We're dealing with abstract vars like "$var" in this code. =head1 NAME Test::Taint - Tools to test taintedness =head1 VERSION Version 1.08 =cut use vars qw( $VERSION ); $VERSION = '1.08'; =head1 SYNOPSIS taint_checking_ok(); # We have to have taint checking on my $id = "deadbeef"; # Dummy session ID taint( $id ); # Simulate it coming in from the web tainted_ok( $id ); $id = validate_id( $id ); # Your routine to check the $id untainted_ok( $id ); # Did it come back clean? ok( defined $id ); =head1 DESCRIPTION Tainted data is data that comes from an unsafe source, such as the command line, or, in the case of web apps, any GET or POST transactions. Read the L man page for details on why tainted data is bad, and how to untaint the data. When you're writing unit tests for code that deals with tainted data, you'll want to have a way to provide tainted data for your routines to handle, and easy ways to check and report on the taintedness of your data, in standard L style. =cut use strict; use warnings; use base 'DynaLoader'; use Test::Builder; use overload; use Scalar::Util; use vars qw( $TAINT ); my $Test = Test::Builder->new; use vars qw( @EXPORT ); @EXPORT = qw( taint taint_deeply tainted tainted_deeply tainted_ok tainted_ok_deeply untainted_ok untainted_ok_deeply taint_checking taint_checking_ok ); bootstrap Test::Taint $VERSION; sub import { my $self = shift; my $caller = caller; no strict 'refs'; for my $sub ( @EXPORT ) { *{$caller.'::'.$sub} = \&{$sub}; } $Test->exported_to($caller); $Test->plan(@_); } # import sub _deeply_traverse { my $callback = shift; my @stack = \@_; my %seen; while(@stack) { my $node = pop @stack; # skip the node if its not a reference next unless defined $node; my($realpack, $realtype, $id) = overload::StrVal($node) =~ /\A(?:(.+)\=)?(HASH|ARRAY|GLOB|SCALAR|REF)\((0x[[:xdigit:]]+)\)\z/ or next; # taint the contents of tied objects if(my $tied = $realtype eq 'HASH' ? tied %{$node} : $realtype eq 'ARRAY' ? tied @{$node} : $realtype eq 'SCALAR' ? tied ${$node} : $realtype eq 'REF' ? tied ${$node} : undef) { push @stack, $tied; next; } # prevent circular references from being traversed no warnings 'uninitialized'; next if $seen{$realpack, $realtype, $id}++; # perform an action on the node, then push them on the stack for traversal push @stack, $realtype eq 'HASH' ? $callback->(values %{$node}) : $realtype eq 'ARRAY' ? $callback->(@{$node}) : $realtype eq 'SCALAR' ? $callback->(${$node}) : $realtype eq 'REF' ? $callback->(${$node}) : map $callback->(*$node{$_}), qw(SCALAR ARRAY HASH); #must be a GLOB } return; } # _deeply_traverse =head1 C-style Functions All the C functions work like standard C-style functions, where the last parm is an optional message, it outputs ok or not ok, and returns a boolean telling if the test passed. =head2 taint_checking_ok( [$message] ) L-style test that taint checking is on. This should probably be the first thing in any F<*.t> file that deals with taintedness. =cut sub taint_checking_ok { my $msg = @_ ? shift : "Taint checking is on"; my $ok = taint_checking(); $Test->ok( $ok, $msg ); return $ok; } # taint_checking_ok =head2 tainted_ok( $var [, $message ] ) Checks that I<$var> is tainted. tainted_ok( $ENV{FOO} ); =cut sub tainted_ok { my $var = shift; my $msg = shift; my $ok = tainted( $var ); $Test->ok( $ok, $msg ); return $ok; } # tainted_ok =head2 untainted_ok( $var [, $message ] ) Checks that I<$var> is not tainted. my $foo = my_validate( $ENV{FOO} ); untainted_ok( $foo ); =cut sub untainted_ok { my $var = shift; my $msg = shift; my $ok = !tainted( $var ); $Test->ok( $ok, $msg ); return $ok; } # untainted_ok =head2 tainted_ok_deeply( $var [, $message ] ) Checks that I<$var> is tainted. If I<$var> is a reference, it recursively checks every variable to make sure they are all tainted. tainted_ok_deeply( \%ENV ); =cut sub tainted_ok_deeply { my $var = shift; my $msg = shift; my $ok = tainted_deeply( $var ); $Test->ok( $ok, $msg ); return $ok; } # tainted_ok_deeply =head2 untainted_ok_deeply( $var [, $message ] ) Checks that I<$var> is not tainted. If I<$var> is a reference, it recursively checks every variable to make sure they are all not tainted. my %env = my_validate( \%ENV ); untainted_ok_deeply( \%env ); =cut sub untainted_ok_deeply { my $var = shift; my $msg = shift; my $ok = !tainted_deeply( $var ); $Test->ok( $ok, $msg ); return $ok; } # untainted_ok_deeply =head1 Helper Functions These are all helper functions. Most are wrapped by an C counterpart, except for C which actually does something, instead of just reporting it. =head2 taint_checking() Returns true if taint checking is enabled via the -T flag. =cut sub taint_checking() { return tainted( $Test::Taint::TAINT ); } # taint_checking =head2 tainted( I<$var> ) Returns boolean saying if C<$var> is tainted. =cut sub tainted { no warnings qw(void uninitialized); return !eval { local $SIG{__DIE__} = 'DEFAULT'; join('', shift), kill 0; 1 }; } # tainted =head2 tainted_deeply( I<$var> ) Returns boolean saying if C<$var> is tainted. If C<$var> is a reference it recursively checks every variable to make sure they are all tainted. =cut sub tainted_deeply { my $is_tainted = 1; _deeply_traverse( sub { foreach (@_) { next if not defined or ref or Scalar::Util::readonly $_ or tainted $_; $is_tainted = 0; last; } return @_; }, shift, ); return $is_tainted; } # tainted_deeply =head2 taint( @list ) Marks each (apparently) taintable argument in I<@list> as being tainted. References can be tainted like any other scalar, but it doesn't make sense to, so they will B be tainted by this function. Some Cd and magical variables may fail to be tainted by this routine, try as it may. =cut sub taint { local $_; for ( @_ ) { _taint($_) unless ref or Scalar::Util::readonly $_; } } # taint # _taint() is an external function in Taint.xs =head2 taint_deeply( @list ) Similar to C, except that if any elements in I<@list> are references, it walks deeply into the data structure and marks each taintable argument as being tainted. If any variables are Cd this will taint all the scalars within the tied object. =cut sub taint_deeply { _deeply_traverse( sub { taint @_; @_ }, @_, ); return; } # taint_deeply BEGIN { MAKE_SOME_TAINT: { # Somehow we need to get some taintedness into $Test::Taint::TAINT # Let's try the easy way first. Either of these should be # tainted, unless somebody has untainted them, so this # will almost always work on the first try. # (Unless, of course, taint checking has been turned off!) $TAINT = substr("$0$^X", 0, 0); last if tainted $TAINT; # Let's try again. Maybe somebody cleaned those. $TAINT = substr(join('', @ARGV, %ENV), 0, 0); last if tainted $TAINT; # If those don't work, go try to open some file from some unsafe # source and get data from them. That data is tainted. # (Yes, even reading from /dev/null works!) local(*FOO); for ( qw(/dev/null / . ..), values %INC, $0, $^X ) { next unless defined $_; if ( open FOO, $_ ) { my $potentially_tainted_data; if ( defined sysread FOO, $potentially_tainted_data, 1 ) { $TAINT = substr( $potentially_tainted_data, 0, 0 ); last if tainted $TAINT; } } } close FOO; } # Sanity check die 'Our taintbrush should have zero length!' if length $TAINT; } =head1 AUTHOR Written by Andy Lester, C<< >>. =head1 COPYRIGHT Copyright 2004-2019, Andy Lester. You may use, modify, and distribute this package under the same terms as Perl itself. =cut 1; Test-Taint-1.08/Changes0000644000175000017500000000343313500255474013411 0ustar andyandyRevision history for Perl extension Test::Taint 1.08 Wed Jun 12 15:01:48 CDT 2019 [FIXES] Fixed intermittent failures in the test suite. Thanks, Petr Pisar. (RT #119897) 1.06 Fri Oct 19 11:30:31 CDT 2012 [ENHANCEMENTS] tainted() now localizes $SIG{__DIE__} before performing the taint check. If the calling program has its own $SIG{__DIE__}, we don't want to use it. Thanks, Pete Krawczyk. https://rt.cpan.org/Ticket/Display.html?id=23507 [FIXES] Checks for undef before opening files when trying to create some taint. Thanks Frédéric Buclin. https://rt.cpan.org/Ticket/Display.html?id=51246 1.04 Mon Aug 9 22:06:10 CDT 2004 No differences from 1.03_01. More goodness from Dan Kubb. [ENHANCEMENTS] New functions: * tainted_ok_deeply() * untainted_ok_deeply() [INTERNALS] * Added Build.PL for those who prefer Module::Build. * Added tests to improve coverage. It's at 99% coverage now, up from around 80%. * Refactored the traversal code so that tainted_deeply and taint_deeply share almost the exact same code to walk the data structure. 1.02 April 22nd, 2004 This is the "Thanks, Dan Kubb" release. [ENHANCEMENTS] * Added taint_deeply() to taint all elements in a structure. 1.00 March 14th, 2004 This is the "Thanks, Dave Rolsky" release. [FIXES] * taint() could corrupt a string and set it to 0. * Removed requirement on Test::Builder::Tester. [ENHANCEMENTS] * The taint() function now goes thru XS, instead of Perl magic. 0.01 Tue Feb 3 23:56:25 CST 2004 Brand new, and ready to go. Test-Taint-1.08/ppport.h0000644000175000017500000003574313500254357013623 0ustar andyandy /* ppport.h -- Perl/Pollution/Portability Version 2.0002 * * Automatically Created by Devel::PPPort on Sat Feb 22 13:35:44 2003 * * Do NOT edit this file directly! -- Edit PPPort.pm instead. * * Version 2.x, Copyright (C) 2001, Paul Marquess. * Version 1.x, Copyright (C) 1999, Kenneth Albanowski. * This code may be used and distributed under the same license as any * version of Perl. * * This version of ppport.h is designed to support operation with Perl * installations back to 5.004, and has been tested up to 5.8.0. * * If this version of ppport.h is failing during the compilation of this * module, please check if a newer version of Devel::PPPort is available * on CPAN before sending a bug report. * * If you are using the latest version of Devel::PPPort and it is failing * during compilation of this module, please send a report to perlbug@perl.com * * Include all following information: * * 1. The complete output from running "perl -V" * * 2. This file. * * 3. The name & version of the module you were trying to build. * * 4. A full log of the build that failed. * * 5. Any other information that you think could be relevant. * * * For the latest version of this code, please retreive the Devel::PPPort * module from CPAN. * */ /* * In order for a Perl extension module to be as portable as possible * across differing versions of Perl itself, certain steps need to be taken. * Including this header is the first major one, then using dTHR is all the * appropriate places and using a PL_ prefix to refer to global Perl * variables is the second. * */ /* If you use one of a few functions that were not present in earlier * versions of Perl, please add a define before the inclusion of ppport.h * for a static include, or use the GLOBAL request in a single module to * produce a global definition that can be referenced from the other * modules. * * Function: Static define: Extern define: * newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL * */ /* To verify whether ppport.h is needed for your module, and whether any * special defines should be used, ppport.h can be run through Perl to check * your source code. Simply say: * * perl -x ppport.h *.c *.h *.xs foo/bar*.c [etc] * * The result will be a list of patches suggesting changes that should at * least be acceptable, if not necessarily the most efficient solution, or a * fix for all possible problems. It won't catch where dTHR is needed, and * doesn't attempt to account for global macro or function definitions, * nested includes, typemaps, etc. * * In order to test for the need of dTHR, please try your module under a * recent version of Perl that has threading compiled-in. * */ /* #!/usr/bin/perl @ARGV = ("*.xs") if !@ARGV; %badmacros = %funcs = %macros = (); $replace = 0; foreach () { $funcs{$1} = 1 if /Provide:\s+(\S+)/; $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/; $replace = $1 if /Replace:\s+(\d+)/; $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/; $badmacros{$1}=$2 if /Replace (\S+) with (\S+)/; } foreach $filename (map(glob($_),@ARGV)) { unless (open(IN, "<$filename")) { warn "Unable to read from $file: $!\n"; next; } print "Scanning $filename...\n"; $c = ""; while () { $c .= $_; } close(IN); $need_include = 0; %add_func = (); $changes = 0; $has_include = ($c =~ /#.*include.*ppport/m); foreach $func (keys %funcs) { if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) { if ($c !~ /\b$func\b/m) { print "If $func isn't needed, you don't need to request it.\n" if $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m); } else { print "Uses $func\n"; $need_include = 1; } } else { if ($c =~ /\b$func\b/m) { $add_func{$func} =1 ; print "Uses $func\n"; $need_include = 1; } } } if (not $need_include) { foreach $macro (keys %macros) { if ($c =~ /\b$macro\b/m) { print "Uses $macro\n"; $need_include = 1; } } } foreach $badmacro (keys %badmacros) { if ($c =~ /\b$badmacro\b/m) { $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm); print "Uses $badmacros{$badmacro} (instead of $badmacro)\n"; $need_include = 1; } } if (scalar(keys %add_func) or $need_include != $has_include) { if (!$has_include) { $inc = join('',map("#define NEED_$_\n", sort keys %add_func)). "#include \"ppport.h\"\n"; $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m; } elsif (keys %add_func) { $inc = join('',map("#define NEED_$_\n", sort keys %add_func)); $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m; } if (!$need_include) { print "Doesn't seem to need ppport.h.\n"; $c =~ s/^.*#.*include.*ppport.*\n//m; } $changes++; } if ($changes) { open(OUT,">/tmp/ppport.h.$$"); print OUT $c; close(OUT); open(DIFF, "diff -u $filename /tmp/ppport.h.$$|"); while () { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; } close(DIFF); unlink("/tmp/ppport.h.$$"); } else { print "Looks OK\n"; } } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef PERL_REVISION # ifndef __PATCHLEVEL_H_INCLUDED__ # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifndef ERRSV # define ERRSV perl_get_sv("@",FALSE) #endif #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) /* Replace: 1 */ # define PL_Sv Sv # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_defgv defgv # define PL_dirty dirty # define PL_dowarn dowarn # define PL_hints hints # define PL_na na # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfpv rsfp # define PL_stdingv stdingv # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes /* Replace: 0 */ #endif #ifdef HASATTRIBUTE # if defined(__GNUC__) && defined(__cplusplus) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif #else # define PERL_UNUSED_DECL #endif #ifndef dNOOP # define NOOP (void)0 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL #endif #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP # define dTHXa(x) dNOOP # define dTHXoa(x) dNOOP #endif #ifndef pTHX # define pTHX void # define pTHX_ # define aTHX # define aTHX_ #endif /* IV could also be a quad (say, a long long), but Perls * capable of those should have IVSIZE already. */ #if !defined(IVSIZE) && defined(LONGSIZE) # define IVSIZE LONGSIZE #endif #ifndef IVSIZE # define IVSIZE 4 /* A bold guess, but the best we can make. */ #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR #if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) #else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) #endif #define NUM2PTR(any,d) (any)(PTRV)(d) #define PTR2IV(p) INT2PTR(IV,p) #define PTR2UV(p) INT2PTR(UV,p) #define PTR2NV(p) NUM2PTR(NV,p) #if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) #else # define PTR2ul(p) INT2PTR(unsigned long,p) #endif #endif /* !INT2PTR */ #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif #ifndef gv_stashpvn # define gv_stashpvn(str,len,flags) gv_stashpv(str,flags) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0)) #endif #ifndef newRV_inc /* Replace: 1 */ # define newRV_inc(sv) newRV(sv) /* Replace: 0 */ #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif #ifndef newRV_noinc # ifdef __GNUC__ # define newRV_noinc(sv) \ ({ \ SV *nsv = (SV*)newRV(sv); \ SvREFCNT_dec(sv); \ nsv; \ }) # else # if defined(USE_THREADS) static SV * newRV_noinc (SV * sv) { SV *nsv = (SV*)newRV(sv); SvREFCNT_dec(sv); return nsv; } # else # define newRV_noinc(sv) \ (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv) # endif # endif #endif /* Provide: newCONSTSUB */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63)) #if defined(NEED_newCONSTSUB) static #else extern void newCONSTSUB(HV * stash, char * name, SV *sv); #endif #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) void newCONSTSUB(stash,name,sv) HV *stash; char *name; SV *sv; { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)) /* before 5.003_22 */ start_subparse(), #else # if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22) /* 5.003_22 */ start_subparse(0), # else /* 5.003_23 onwards */ start_subparse(FALSE, 0), # endif #endif newSVOP(OP_CONST, 0, newSVpv(name,0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* newCONSTSUB */ #ifndef START_MY_CXT /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #else /* single interpreter */ #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif #endif /* START_MY_CXT */ #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # else # if IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # endif # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */ # define AvFILLp AvFILL #endif #ifdef SvPVbyte # if PERL_REVISION == 5 && PERL_VERSION < 7 /* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */ # undef SvPVbyte # define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp)) static char * my_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } # endif #else # define SvPVbyte SvPV #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_nolen(sv)) static char * sv_2pv_nolen(pTHX_ register SV *sv) { STRLEN n_a; return sv_2pv(sv, &n_a); } #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */