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.
+