From dfe23c71bd6409b877ddd504e40498d232323de6 Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 16:09:26 +0000 Subject: perl-Taint-Runtime-0.03 base --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..e35f2e2 --- /dev/null +++ b/Changes @@ -0,0 +1,9 @@ +Revision history for Perl extension Taint::Runtime. + +0.03 Thu Jun 14 11:54:00 2007 + - Fix untaint failure on multiline strings found by Alexey A. Kiritchun. + +0.01 Fri Feb 25 09:38:30 2005 + - original version; created by h2xs 1.23 with options + -A -n Taint::Runtime + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..629b527 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,16 @@ +Changes +is_taint_bench.pl +lib/Taint/Runtime.pm +Makefile.PL +MANIFEST +MANIFEST.SKIP +META.yml Module meta-data (added by MakeMaker) +ppport.h +README +Runtime.xs +t/00_Base.t +t/01_non_xs.t +t/02_xs.t +t/03_var.t +t/04_enable.t +t/Taint-Runtime.t diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..f682cba --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,18 @@ +CVS/ +blib +pm_to_blib +.cvsignore +Runtime.bs +Runtime.c +Runtime.o +^tgz/ +\.~$ +\.# +\w#$ +\.bak$ +Makefile$ +Makefile\.old$ +\.gz$ +tmon\.out + + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..b5b369e --- /dev/null +++ b/META.yml @@ -0,0 +1,10 @@ +# http://module-build.sourceforge.net/META-spec.html +#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# +name: Taint-Runtime +version: 0.03 +version_from: lib/Taint/Runtime.pm +installdirs: site +requires: + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.30_01 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..995a613 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,20 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Taint::Runtime', + VERSION_FROM => 'lib/Taint/Runtime.pm', + ABSTRACT_FROM => 'lib/Taint/Runtime.pm', + AUTHOR => 'Paul Seamons', +); + +package MY; + +sub postamble { + return qq^ + +pm_to_blib: README + +README: \$(VERSION_FROM) + pod2text \$(VERSION_FROM) > README +^; +} diff --git a/README b/README new file mode 100644 index 0000000..3017296 --- /dev/null +++ b/README @@ -0,0 +1,263 @@ +NAME + Taint::Runtime - Runtime enable taint checking + +SYNOPSIS + ### sample "enable" usage + + #!/usr/bin/perl -w + use Taint::Runtime qw(enable taint_env); + taint_env(); + # having the keyword enable in the import list starts taint + + ### sample $TAINT usage + + #!/usr/bin/perl -w + use Taint::Runtime qw($TAINT taint_env); + $TAINT = 1; + taint_env(); + + # taint is now enabled + + if (1) { + local $TAINT = 0; + + # do something we trust + } + + # back to an untrustwory area + + ### sample functional usage + + #!/usr/bin/perl -w + use strict; + use Taint::Runtime qw(taint_start is_tainted taint_env + taint untaint + taint_enabled); + + ### other operations here + + taint_start(); # taint should become active + taint_env(); # %ENV was previously untainted + + print taint_enabled() ? "enabled\n" : "not enabled\n"; + + my $var = taint("some string"); + + print is_tainted($var) ? "tainted\n" : "not tainted\n"; + + $var = untaint($var); + # OR + untaint \$var; + + print is_tainted($var) ? "tainted\n" : "not tainted\n"; + +DESCRIPTION + First - you probably shouldn't use this module to control taint. You + should probably use the -T switch on the commandline instead. There are + a somewhat limited number of legitimate use cases where you should use + this module instead of the -T switch. Unless you have a specific and + good reason for not using the -T option, you should use the -T option. + + Taint is a good thing. However, few people (that I work with or talk to + or discuss items with) use taint even though they should. The goal of + this module isn't to use taint less, but to actually encourage its use + more. This module aims to make using taint as painless as possible (This + can be an argument against it - often implementation of security implies + pain - so taking away pain might lessen security - sort of). + + In general - the more secure your script needs to be - the earlier on in + your program that tainting should be enabled. For most setuid scripts, + you should enable taint by using the -T switch. Without doing so you + allow for a non-root user to override @INC which allows for them to put + their own module in the place of trusted modules. This is bad. This is + very bad. Use the -T switch. + + There are some common places where this module may be useful, and where + most people don't use it. One such place is in a web server. The -T + switch removes PERL5LIB and PERLLIB and '.' from @INC (or remove them + before they can be added). This makes sense under setuid. The use of the + -T switch in a CGI environment may cause a bit of a headache. For new + development, CGI scripts it may be possible to use the -T switch and for + mod_perl environments there is the PerlTaint variable. Both of these + methods will enable taint and from that point on development should be + done with taint. + + However, many (possibly most) perl web server implentations add their + own paths to the PERL5LIB. All CGI's and mod_perl scripts can then have + access. Using the -T switch throws a wrench into the works as suddenly + PERL5LIB disappears (mod_perl can easily have the extra directories + added again using push @INC, '/our/lib/dir';). The company + I work for has 200 plus user visible scripts mixed with some mod_perl. + Currently none of the scripts use taint. We would like for them all to, + but it is not feasible to make the change all at once. Taint::Runtime + allows for moving legacy scripts over one at a time. + + Again, if you are using setuid - don't use this script. + + If you are not using setuid and have reasons not to use the -T and are + using this module, make sure that taint is enabled before processing any + user data. Also remember that BECAUSE THE -T SWITCH WAS NOT USED %ENV IS + INITIALLY NOT MARKED AS TAINTED. Call taint_env() to mark it as tainted + (especially important in CGI scripts which all read from + $ENV{'QUERY_STRING'}). + + If you are not using the -T switch, you most likely should use the + following at the very top of your script: + + #!/usr/bin/perl -w + + use strict; + use Taint::Runtime qw(enable taint_env); + taint_env(); + + Though this module allows for you to turn taint off - you probably + shouldn't. This module is more for you to turn taint on - and once it is + on it probably ought to stay on. + +NON-EXPORTABLE XS FUNCTIONS + The following very basic functions provide the base functionality. + + _taint_start() + Sets PL_tainting + + _taint_stop() + Sets PL_tainting + + _taint_enabled() + View of PL_tainting + + _tainted() + Returns a zero length tainted string. + +$TAINT VARIABLE + The variable $TAINT is tied to the current state of taint. If $TAINT is + set to 0 taint mode is off. When it is set to 1 taint mode is enabled. + + if (1) { + local $TAINT = 1; + + # taint is enabled + } + +EXPORT FUNCTIONS + enable/disable + Not really functions. If these keywords are in the import list, + taint will be either enabled or disabled. + + taint_start + Start taint mode. $TAINT will equal 1. + + taint_stop + Stop taint mode. $TAINT will equal 0. + + taint_env + Convenience function that taints the keys and values of %ENV. If the + -T switch was not used - you most likely should call this as soon as + taint mode is enabled. + + taint + Taints the passed in variable. Only works on writeable scalar + values. If a scalar ref is passed in - it is modified. If a scalar + is passed in (non ref) it is copied, modified and returned. If a + value was undefined, it becomes a zero length defined and tainted + string. + + taint(\$var_to_be_tainted); + + my $tainted_copy = taint($some_var); + + For a stronger taint, see the Taint module by Dan Sulgalski which is + capable of tainting most types of data. + + untaint + Untaints the passed in variable. Only works on writeable scalar + values. If a scalar ref is passed in - it is modified. If a scalar + is passed in (non ref) it is copied, modified and returned. If a + value was undefined it becomes an untainted undefined value. + + Note: Just because the variable is untainted, doesn't mean that it + is safe. You really should use CGI::Ex::Validate, or + Data::FormValidator or any of the Untaint:: modules. If you are + doing your own validation, and once you have put the user data + through very strict checks, then you can use untaint. + + if ($var_to_be_untainted =~ /^[\w\.\-]{0,100}$/) { + untaint(\$var_to_be_untainted); + } + + my $untainted_copy = untaint($some_var); + + taint_enabled + Boolean - Is taint on. + + tainted + Returns a zero length tainted string. + + is_tainted + Boolean - True if the passed value is tainted. + + taint_deeply + Convenience function that attempts to deply recurse a structure and + mark it as tainted. Takes a hashref, arrayref, scalar ref, or scalar + and recursively untaints the structure. + + For a stronger taint, see the Taint module by Dan Sulgalski which is + capable of tainting most types of data. + +TURNING TAINT ON + (Be sure to call taint_env() after turning taint on the first time) + + #!/usr/bin/perl -T + + use Taint::Runtime qw(enable); + # this does not create a function called enable - just starts taint + + use Taint::Runtime qw($TAINT); + $TAINT = 1; + + use Taint::Runtime qw(taint_start); + taint_start; + +TURNING TAINT OFF + use Taint::Runtime qw(disable); + # this does not create a function called disable - just stops taint + + use Taint::Runtime qw($TAINT); + $TAINT = 0; + + use Taint::Runtime qw(taint_stop); + taint_stop; + +CREDITS + C code was provided by "hv" on perlmonks. This module wouldn't really be + possible without insight into the internals that "hv" provided. His post + with the code was shown in this node on perlmonks: + + http://perlmonks.org/?node_id=434086 + + The basic premise in that node was the following code: + + use Inline C => 'void _start_taint() { PL_tainting = 1; }'; + use Inline C => 'SV* _tainted() { PL_tainted = 1; return newSVpvn("", 0); }'; + + In this module, these two lines have instead been turned into XS for + runtime speed (and so you won't need Inline and Parse::RecDescent). + + Note: even though "hv" provided the base code example, that doesn't mean + that he necessarily endorses the idea. If there are disagreements, + quirks, annoyances or any other negative side effects with this module - + blame me - not "hv." + +THANKS + Thanks to Alexey A. Kiritchun for pointing out untaint failure on + multiline strings. + +AUTHOR + Paul Seamons (2005) + + C stub functions by "hv" on perlmonks.org + +LICENSE + This module may be used and distributed under the same terms as Perl + itself. + diff --git a/Runtime.xs b/Runtime.xs new file mode 100644 index 0000000..a8a2dd4 --- /dev/null +++ b/Runtime.xs @@ -0,0 +1,37 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "ppport.h" + +MODULE = Taint::Runtime PACKAGE = Taint::Runtime + +int +_taint_start() + CODE: + PL_tainting = 1; + RETVAL = 1; + OUTPUT: + RETVAL + +int +_taint_stop() + CODE: + PL_tainting = 0; + RETVAL = 1; + OUTPUT: + RETVAL + +int +_taint_enabled() + CODE: + RETVAL = PL_tainting; + OUTPUT: + RETVAL + +SV* +_tainted() + CODE: + PL_tainted = 1; + RETVAL = newSVpvn("", 0); + OUTPUT: + RETVAL diff --git a/is_taint_bench.pl b/is_taint_bench.pl new file mode 100644 index 0000000..f4c81bc --- /dev/null +++ b/is_taint_bench.pl @@ -0,0 +1,67 @@ +#!/usr/bin/perl -w + +use strict; +use Benchmark qw(timethese cmpthese countit timestr); +use Taint::Runtime qw($TAINT taint); +$TAINT = 1; + +sub is1 { return if ! defined $_[0]; ! eval { eval '#'.substr($_[0], 0, 0); 1 } } +sub is2 { local $^W = 0; local $@; eval { kill 0 * $_[0] }; $@ =~ /^Insecure/ } +sub is3 { local $^W = 0; ! eval { my $t = 0 * $_[0]; eval("1 + $t") } } + +my $var_bad = taint("foo"); +my $var_ok = "bar"; +my $var_und = undef; + + +print is1($var_bad) ? "Correct\n" : "Wrong\n"; +print is2($var_bad) ? "Correct\n" : "Wrong\n"; +print is3($var_bad) ? "Correct\n" : "Wrong\n"; + +print is1($var_ok) ? "Wrong\n" : "Correct\n"; +print is2($var_ok) ? "Wrong\n" : "Correct\n"; +print is3($var_ok) ? "Wrong\n" : "Correct\n"; + +print is1($var_und) ? "Wrong\n" : "Correct\n"; +print is2($var_und) ? "Wrong\n" : "Correct\n"; +print is3($var_und) ? "Wrong\n" : "Correct\n"; + +foreach my $var ($var_ok, $var_bad, $var_und) { + print "Run: ".(! $var ? "Undefined" : $var eq 'foo' ? 'Tainted' : 'Untainted')."\n"; + cmpthese (-2,{ + is1 => sub { is1($var) }, + is2 => sub { is2($var) }, + is3 => sub { is3($var) }, + },'auto'); +} + +__END__ + +### Perl 5.8.5 Mandrake 10.1 1.4 Mobile +# Run: Untainted +# Benchmark: running is1, is2, is3 for at least 2 CPU seconds... +# is1: 3 wallclock secs ( 2.04 usr + 0.00 sys = 2.04 CPU) @ 40906.86/s (n=83450) +# is2: 1 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 147537.74/s (n=312780) +# is3: 2 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 29252.38/s (n=61430) +# Rate is3 is1 is2 +# is3 29252/s -- -28% -80% +# is1 40907/s 40% -- -72% +# is2 147538/s 404% 261% -- +# Run: Tainted +# Benchmark: running is1, is2, is3 for at least 2 CPU seconds... +# is1: 2 wallclock secs ( 2.13 usr + 0.00 sys = 2.13 CPU) @ 67086.85/s (n=142895) +# is2: 2 wallclock secs ( 2.02 usr + 0.00 sys = 2.02 CPU) @ 52951.49/s (n=106962) +# is3: 3 wallclock secs ( 2.07 usr + 0.00 sys = 2.07 CPU) @ 48884.06/s (n=101190) +# Rate is3 is2 is1 +# is3 48884/s -- -8% -27% +# is2 52951/s 8% -- -21% +# is1 67087/s 37% 27% -- +# Run: Undefined +# Benchmark: running is1, is2, is3 for at least 2 CPU seconds... +# is1: 1 wallclock secs ( 2.02 usr + 0.00 sys = 2.02 CPU) @ 40643.56/s (n=82100) +# is2: 2 wallclock secs ( 2.16 usr + 0.00 sys = 2.16 CPU) @ 111499.07/s (n=240838) +# is3: 2 wallclock secs ( 2.04 usr + 0.00 sys = 2.04 CPU) @ 26348.04/s (n=53750) +# Rate is3 is1 is2 +# is3 26348/s -- -35% -76% +# is1 40644/s 54% -- -64% +# is2 111499/s 323% 174% - diff --git a/lib/Taint/Runtime.pm b/lib/Taint/Runtime.pm new file mode 100644 index 0000000..2506cc7 --- /dev/null +++ b/lib/Taint/Runtime.pm @@ -0,0 +1,452 @@ +package Taint::Runtime; + +=head1 NAME + +Taint::Runtime - Runtime enable taint checking + +=cut + +use strict; +use Exporter; +use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK @EXPORT $VERSION $TAINT); +use XSLoader; + +@ISA = qw(Exporter); +%EXPORT_TAGS = ( + 'all' => [qw( + taint_start + taint_stop + taint_enabled + tainted + is_tainted + taint + untaint + taint_env + taint_deeply + $TAINT + ) ], + ); +@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); +@EXPORT = qw(taint_start taint_stop); + +$VERSION = '0.03'; +XSLoader::load('Taint::Runtime', $VERSION); + +###----------------------------------------------------------------### + +tie $TAINT, __PACKAGE__; + +sub TIESCALAR { + return bless [], __PACKAGE__; +} + +sub FETCH { + _taint_enabled() ? 1 : 0; +} + +sub STORE { + my ($self, $val) = @_; + $val = 0 if ! $val || $val eq 'disable'; + $val ? _taint_start() : _taint_stop(); +} + +###----------------------------------------------------------------### + +### allow for special enable/disable keywords +sub import { + my $change; + for my $i (reverse 1 .. $#_) { + next if $_[$i] !~ /^(dis|en)able$/; + my $val = $1 eq 'dis' ? 0 : 1; + splice @_, $i, 1, (); + die 'Cannot both enable and disable $TAINT during import' if defined $change && $change != $val; + $TAINT = $val; + } + __PACKAGE__->export_to_level(1, @_); +} + +###----------------------------------------------------------------### + +sub taint_start { _taint_start(); } + +sub taint_stop { _taint_stop() } + +sub taint_enabled { _taint_enabled() } + +sub tainted { _tainted() } + +sub is_tainted { return if ! defined $_[0]; ! eval { eval '#'.substr($_[0], 0, 0); 1 } } + +# slower on tainted and undef +# modified version from standard lib/perl/5.8.5/tainted.pl +sub is_tainted2 { local $^W = 0; local $@; eval { kill 0 * $_[0] }; $@ =~ /^Insecure/ } + +sub taint { + my $str = shift; + my $ref = ref($str) ? $str : \$str; + $$ref = '' if ! defined $$ref; + $$ref .= tainted(); + return ref($str) ? 1 : $str; +} + +sub untaint { + my $str = shift; + my $ref = ref($str) ? $str : \$str; + if (! defined $$ref) { + $$ref = undef; + } else { + $$ref = ($$ref =~ /(.*)/s) ? $1 : do { require Carp; Carp::confess("Couldn't find data to untaint") }; + } + return ref($str) ? 1 : $str; +} + +###----------------------------------------------------------------### + +sub taint_env { + taint_deeply(\%ENV); +} + +sub taint_deeply { + my ($ref, $seen) = @_; + + return if ! defined $ref; # can undefined be tainted ? + + if (! ref $ref) { + taint \$_[0]; # better be modifyable + return; + + } elsif (UNIVERSAL::isa($ref, 'SCALAR')) { + taint $ref; + return; + } + + ### avoid circular descent + $seen ||= {}; + return if $seen->{$ref}; + $seen->{$ref} = 1; + + if (UNIVERSAL::isa($ref, 'ARRAY')) { + taint_deeply($_, $seen) foreach @$ref; + + } elsif (UNIVERSAL::isa($ref, 'HASH')) { + while (my ($key, $val) = each %$ref) { + taint_deeply($key); + taint_deeply($val, $seen); + $ref->{$key} = $val; + } + } else { + # not really sure if or what to do for GLOBS or CODE refs + } +} + +###----------------------------------------------------------------### + +1; + +__END__ + +=head1 SYNOPSIS + + ### sample "enable" usage + + #!/usr/bin/perl -w + use Taint::Runtime qw(enable taint_env); + taint_env(); + # having the keyword enable in the import list starts taint + + + ### sample $TAINT usage + + #!/usr/bin/perl -w + use Taint::Runtime qw($TAINT taint_env); + $TAINT = 1; + taint_env(); + + # taint is now enabled + + if (1) { + local $TAINT = 0; + + # do something we trust + } + + # back to an untrustwory area + + + + ### sample functional usage + + #!/usr/bin/perl -w + use strict; + use Taint::Runtime qw(taint_start is_tainted taint_env + taint untaint + taint_enabled); + + ### other operations here + + taint_start(); # taint should become active + taint_env(); # %ENV was previously untainted + + print taint_enabled() ? "enabled\n" : "not enabled\n"; + + my $var = taint("some string"); + + print is_tainted($var) ? "tainted\n" : "not tainted\n"; + + $var = untaint($var); + # OR + untaint \$var; + + print is_tainted($var) ? "tainted\n" : "not tainted\n"; + + + +=head1 DESCRIPTION + +First - you probably shouldn't use this module to control taint. +You should probably use the -T switch on the commandline instead. +There are a somewhat limited number of legitimate use cases where +you should use this module instead of the -T switch. Unless you +have a specific and good reason for not using the -T option, you +should use the -T option. + +Taint is a good thing. However, few people (that I work with or talk +to or discuss items with) use taint even though they should. The goal of +this module isn't to use taint less, but to actually encourage its use +more. This module aims to make using taint as painless as possible (This +can be an argument against it - often implementation of security implies +pain - so taking away pain might lessen security - sort of). + +In general - the more secure your script needs to be - the earlier +on in your program that tainting should be enabled. For most setuid scripts, +you should enable taint by using the -T switch. Without doing so you allow +for a non-root user to override @INC which allows for them to put their +own module in the place of trusted modules. This is bad. This is very bad. +Use the -T switch. + +There are some common places where this module may be useful, and where +most people don't use it. One such place is in a web server. The -T switch +removes PERL5LIB and PERLLIB and '.' from @INC (or remove them before +they can be added). This makes sense under setuid. The use of the -T switch +in a CGI environment may cause a bit of a headache. For new development, +CGI scripts it may be possible to use the -T switch and for mod_perl environments +there is the PerlTaint variable. Both of these methods will enable taint +and from that point on development should be done with taint. + +However, many (possibly most) perl web server implentations add their +own paths to the PERL5LIB. All CGI's and mod_perl scripts can then have access. +Using the -T switch throws a wrench into the works as suddenly PERL5LIB +disappears (mod_perl can easily have the extra directories added again +using push @INC, '/our/lib/dir';). The company I work for +has 200 plus user visible scripts mixed with some mod_perl. Currently +none of the scripts use taint. We would like for them all to, but it +is not feasible to make the change all at once. Taint::Runtime allows for moving legacy +scripts over one at a time. + +Again, if you are using setuid - don't use this script. + +If you are not using setuid and have reasons not to use the -T and are +using this module, make sure that taint is enabled before processing +any user data. Also remember that BECAUSE THE -T SWITCH WAS NOT USED +%ENV IS INITIALLY NOT MARKED AS TAINTED. Call taint_env() to mark +it as tainted (especially important in CGI scripts which all read from +$ENV{'QUERY_STRING'}). + +If you are not using the -T switch, you most likely should use the +following at the very top of your script: + + #!/usr/bin/perl -w + + use strict; + use Taint::Runtime qw(enable taint_env); + taint_env(); + +Though this module allows for you to turn taint off - you probably shouldn't. +This module is more for you to turn taint on - and once it is on it probably +ought to stay on. + +=head1 NON-EXPORTABLE XS FUNCTIONS + +The following very basic functions provide the base functionality. + +=over 4 + +=item _taint_start() + +Sets PL_tainting + +=item _taint_stop() + +Sets PL_tainting + +=item _taint_enabled() + +View of PL_tainting + +=item _tainted() + +Returns a zero length tainted string. + +=back + +=head1 $TAINT VARIABLE + +The variable $TAINT is tied to the current state of taint. +If $TAINT is set to 0 taint mode is off. When it is set to +1 taint mode is enabled. + + if (1) { + local $TAINT = 1; + + # taint is enabled + } + +=head1 EXPORT FUNCTIONS + +=over 4 + +=item enable/disable + +Not really functions. If these keywords are in +the import list, taint will be either enabled +or disabled. + +=item taint_start + +Start taint mode. $TAINT will equal 1. + +=item taint_stop + +Stop taint mode. $TAINT will equal 0. + +=item taint_env + +Convenience function that taints the keys and values of %ENV. If +the -T switch was not used - you most likely should call +this as soon as taint mode is enabled. + +=item taint + +Taints the passed in variable. Only works on writeable scalar values. +If a scalar ref is passed in - it is modified. If a scalar is passed in +(non ref) it is copied, modified and returned. If a value was undefined, +it becomes a zero length defined and tainted string. + + taint(\$var_to_be_tainted); + + my $tainted_copy = taint($some_var); + +For a stronger taint, see the Taint module by Dan Sulgalski which is +capable of tainting most types of data. + +=item untaint + +Untaints the passed in variable. Only works on writeable scalar values. +If a scalar ref is passed in - it is modified. If a scalar is passed in +(non ref) it is copied, modified and returned. If a value was undefined +it becomes an untainted undefined value. + +Note: Just because the variable is untainted, doesn't mean that it +is safe. You really should use CGI::Ex::Validate, or Data::FormValidator +or any of the Untaint:: modules. If you are doing your own validation, and +once you have put the user data through very strict checks, then you +can use untaint. + + if ($var_to_be_untainted =~ /^[\w\.\-]{0,100}$/) { + untaint(\$var_to_be_untainted); + } + + my $untainted_copy = untaint($some_var); + +=item taint_enabled + +Boolean - Is taint on. + +=item tainted + +Returns a zero length tainted string. + +=item is_tainted + +Boolean - True if the passed value is tainted. + +=item taint_deeply + +Convenience function that attempts to deply recurse a +structure and mark it as tainted. Takes a hashref, arrayref, +scalar ref, or scalar and recursively untaints the structure. + +For a stronger taint, see the Taint module by Dan Sulgalski which is +capable of tainting most types of data. + +=back + +=head1 TURNING TAINT ON + +(Be sure to call taint_env() after turning taint on the first time) + + #!/usr/bin/perl -T + + + use Taint::Runtime qw(enable); + # this does not create a function called enable - just starts taint + + use Taint::Runtime qw($TAINT); + $TAINT = 1; + + + use Taint::Runtime qw(taint_start); + taint_start; + + +=head1 TURNING TAINT OFF + + use Taint::Runtime qw(disable); + # this does not create a function called disable - just stops taint + + + use Taint::Runtime qw($TAINT); + $TAINT = 0; + + + use Taint::Runtime qw(taint_stop); + taint_stop; + + +=head1 CREDITS + +C code was provided by "hv" on perlmonks. This module wouldn't +really be possible without insight into the internals that "hv" +provided. His post with the code was shown in this node on +perlmonks: + + http://perlmonks.org/?node_id=434086 + +The basic premise in that node was the following code: + + use Inline C => 'void _start_taint() { PL_tainting = 1; }'; + use Inline C => 'SV* _tainted() { PL_tainted = 1; return newSVpvn("", 0); }'; + +In this module, these two lines have instead been turned into +XS for runtime speed (and so you won't need Inline and Parse::RecDescent). + +Note: even though "hv" provided the base code example, that doesn't mean that he +necessarily endorses the idea. If there are disagreements, quirks, annoyances +or any other negative side effects with this module - blame me - not "hv." + +=head1 THANKS + +Thanks to Alexey A. Kiritchun for pointing out untaint failure on multiline strings. + +=head1 AUTHOR + +Paul Seamons (2005) + +C stub functions by "hv" on perlmonks.org + +=head1 LICENSE + +This module may be used and distributed under the same +terms as Perl itself. + +=cut diff --git a/ppport.h b/ppport.h new file mode 100644 index 0000000..d6fb163 --- /dev/null +++ b/ppport.h @@ -0,0 +1,1096 @@ + +/* ppport.h -- Perl/Pollution/Portability Version 2.011 + * + * Automatically Created by Devel::PPPort on Fri Feb 25 09:38:30 2005 + * + * 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.1. + * + * 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__ +# define PERL_PATCHLEVEL_H_IMPLICIT +# include +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# 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)) || defined(__INTEL_COMPILER) +# 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 + +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#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 + +#ifndef get_cv +# define get_cv(name,create) perl_get_cv(name,create) +#endif + +#ifndef get_sv +# define get_sv(name,create) perl_get_sv(name,create) +#endif + +#ifndef get_av +# define get_av(name,create) perl_get_av(name,create) +#endif + +#ifndef get_hv +# define get_hv(name,create) perl_get_hv(name,create) +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef eval_pv +# define eval_pv perl_eval_pv +#endif + +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1)) +#define I32_CAST +#else +#define I32_CAST (I32*) +#endif + +#ifndef grok_hex +static UV _grok_hex (char *string, STRLEN *len, I32 *flags, NV *result) { + NV r = scan_hex(string, *len, I32_CAST len); + if (r > UV_MAX) { + *flags |= PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) *result = r; + return UV_MAX; + } + return (UV)r; +} + +# define grok_hex(string, len, flags, result) \ + _grok_hex((string), (len), (flags), (result)) +#endif + +#ifndef grok_oct +static UV _grok_oct (char *string, STRLEN *len, I32 *flags, NV *result) { + NV r = scan_oct(string, *len, I32_CAST len); + if (r > UV_MAX) { + *flags |= PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) *result = r; + return UV_MAX; + } + return (UV)r; +} + +# define grok_oct(string, len, flags, result) \ + _grok_oct((string), (len), (flags), (result)) +#endif + +#if !defined(grok_bin) && defined(scan_bin) +static UV _grok_bin (char *string, STRLEN *len, I32 *flags, NV *result) { + NV r = scan_bin(string, *len, I32_CAST len); + if (r > UV_MAX) { + *flags |= PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) *result = r; + return UV_MAX; + } + return (UV)r; +} + +# define grok_bin(string, len, flags, result) \ + _grok_bin((string), (len), (flags), (result)) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE \ + (PL_curcop == &PL_compiling ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + + +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +# define IS_NUMBER_NOT_INT 0x04 +# define IS_NUMBER_NEG 0x08 +# define IS_NUMBER_INFINITY 0x10 +# define IS_NUMBER_NAN 0x20 +#endif + +#ifndef grok_numeric_radix +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(aTHX_ sp, send) + +#define grok_numeric_radix Perl_grok_numeric_radix + +bool +Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1)) + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* pre5.6.0 perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h */ +#include + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif /* PERL_VERSION */ +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif /* grok_numeric_radix */ + +#ifndef grok_number + +#define grok_number Perl_grok_number + +int +Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif /* grok_number */ + +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/t/00_Base.t b/t/00_Base.t new file mode 100644 index 0000000..35d310a --- /dev/null +++ b/t/00_Base.t @@ -0,0 +1,15 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl Taint-Runtime.t' + +######################### + +# change 'tests => 1' to 'tests => last_test_to_print'; + +use Test::More tests => 1; +BEGIN { use_ok('Taint::Runtime') }; + +######################### + +# Insert your test code below, the Test::More module is use()ed here so read +# its man page ( perldoc Test::More ) for help writing this test script. + diff --git a/t/01_non_xs.t b/t/01_non_xs.t new file mode 100644 index 0000000..efe011f --- /dev/null +++ b/t/01_non_xs.t @@ -0,0 +1,30 @@ +#!perl -T + +use Test::More tests => 9; +BEGIN { use_ok('Taint::Runtime') }; + +Taint::Runtime->import(qw(taint_enabled + taint + untaint + is_tainted + )); + +ok(taint_enabled(), "Taint is On"); + +my $data = "foo\nbar"; +ok(! is_tainted($data), "No false positive on is_tainted"); + +my $copy = taint($data); +ok(is_tainted($copy), "Made a tainted copy"); + +taint(\$data); +ok(is_tainted($data), "Tainted it directly"); + +$copy = untaint($data); +ok(! is_tainted($copy), "Made a clean copy"); +ok($copy eq $data, "And i got all of the data back"); + +ok(is_tainted($data), "Data is still tainted"); + +untaint(\$data); +ok(! is_tainted($data), "Clean it directly"); diff --git a/t/02_xs.t b/t/02_xs.t new file mode 100644 index 0000000..fdada44 --- /dev/null +++ b/t/02_xs.t @@ -0,0 +1,31 @@ + +use Test::More tests => 8; +BEGIN { use_ok('Taint::Runtime') }; + +Taint::Runtime->import(qw(taint_start + taint_enabled + taint + untaint + is_tainted + )); + +ok(! taint_enabled(), "Taint is Not on yet"); + +taint_start(); + +ok(taint_enabled(), "Taint is On"); + +my $data = "foo"; +ok(! is_tainted($data), "No false positive on is_tainted"); + +my $copy = taint($data); +ok(is_tainted($copy), "Made a tainted copy"); + +taint(\$data); +ok(is_tainted($data), "Tainted it directly"); + +$copy = untaint($data); +ok(! is_tainted($copy), "Made a clean copy"); + +untaint(\$data); +ok(! is_tainted($data), "Clean it directly"); diff --git a/t/03_var.t b/t/03_var.t new file mode 100644 index 0000000..c4240fe --- /dev/null +++ b/t/03_var.t @@ -0,0 +1,31 @@ + +use Test::More tests => 7; +BEGIN { use_ok('Taint::Runtime') }; + +Taint::Runtime->import(qw($TAINT + taint_enabled + taint + untaint + is_tainted + )); + +ok(! $TAINT, "Not on"); + +ok(! taint_enabled(), "Taint is Not on yet"); + +$TAINT = 1; + +ok(taint_enabled(), "Taint is On"); + +$TAINT = 0; + +ok(! taint_enabled(), "Taint disabled"); + +{ + local $TAINT = 1; + + ok(taint_enabled(), "Taint is On"); + +} + +ok(! taint_enabled(), "Taint disabled"); diff --git a/t/04_enable.t b/t/04_enable.t new file mode 100644 index 0000000..ff81980 --- /dev/null +++ b/t/04_enable.t @@ -0,0 +1,15 @@ + +use Test::More tests => 4; +BEGIN { use_ok('Taint::Runtime') }; + +Taint::Runtime->import(qw($TAINT)); + +ok(! $TAINT, "Not on"); + +Taint::Runtime->import('enable'); + +ok($TAINT, "Taint is On"); + +Taint::Runtime->import('disable'); + +ok(! $TAINT, "Not on"); diff --git a/t/Taint-Runtime.t b/t/Taint-Runtime.t new file mode 100644 index 0000000..35d310a --- /dev/null +++ b/t/Taint-Runtime.t @@ -0,0 +1,15 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl Taint-Runtime.t' + +######################### + +# change 'tests => 1' to 'tests => last_test_to_print'; + +use Test::More tests => 1; +BEGIN { use_ok('Taint::Runtime') }; + +######################### + +# Insert your test code below, the Test::More module is use()ed here so read +# its man page ( perldoc Test::More ) for help writing this test script. +