Add builtin::is_tainted

builtin.c

@@ -125,6 +125,10 @@ XS(XS_builtin_func1_scalar)
             Perl_pp_floor(aTHX);
             break;
 
+        case OP_IS_TAINTED:
+            Perl_pp_is_tainted(aTHX);
+            break;
+
         default:
             Perl_die(aTHX_ "panic: unhandled opcode %" IVdf
                            " for xs_builtin_func1_scalar()", (IV) ix);
@@ -380,16 +384,17 @@ static const struct BuiltinFuncDescriptor builtins[] = {
     { "builtin::false",  &XS_builtin_false,  &ck_builtin_const, BUILTIN_CONST_FALSE },
 
     /* unary functions */
-    { "builtin::is_bool",  &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL  },
-    { "builtin::weaken",   &XS_builtin_func1_void,   &ck_builtin_func1, OP_WEAKEN   },
-    { "builtin::unweaken", &XS_builtin_func1_void,   &ck_builtin_func1, OP_UNWEAKEN },
-    { "builtin::is_weak",  &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK  },
-    { "builtin::blessed",  &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED  },
-    { "builtin::refaddr",  &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR  },
-    { "builtin::reftype",  &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE  },
-    { "builtin::ceil",     &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL     },
-    { "builtin::floor",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR    },
-    { "builtin::trim",     &XS_builtin_trim, NULL, 0 },
+    { "builtin::is_bool",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL    },
+    { "builtin::weaken",     &XS_builtin_func1_void,   &ck_builtin_func1, OP_WEAKEN     },
+    { "builtin::unweaken",   &XS_builtin_func1_void,   &ck_builtin_func1, OP_UNWEAKEN   },
+    { "builtin::is_weak",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK    },
+    { "builtin::blessed",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED    },
+    { "builtin::refaddr",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR    },
+    { "builtin::reftype",    &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE    },
+    { "builtin::ceil",       &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL       },
+    { "builtin::floor",      &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR      },
+    { "builtin::is_tainted", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_TAINTED },
+    { "builtin::trim",       &XS_builtin_trim, NULL, 0 },
 
     { "builtin::created_as_string", &XS_builtin_created_as_string, &ck_builtin_func1, 0 },
     { "builtin::created_as_number", &XS_builtin_created_as_number, &ck_builtin_func1, 0 },

ext/Opcode/Opcode.pm

@@ -1,31 +1,21 @@
-package Opcode;
-
-use 5.006_001;
+package Opcode 1.59;
 
 use strict;
 
-our($VERSION, @ISA, @EXPORT_OK);
-
-$VERSION = "1.58";
-
 use Carp;
 use Exporter 'import';
 use XSLoader;
 
-BEGIN {
-    @EXPORT_OK = qw(
+sub opset (;@);
+sub opset_to_hex ($);
+sub opdump (;$);
+use subs our @EXPORT_OK = qw(
 	opset ops_to_opset
 	opset_to_ops opset_to_hex invert_opset
 	empty_opset full_opset
 	opdesc opcodes opmask define_optag
 	opmask_add verify_opset opdump
-    );
-}
-
-sub opset (;@);
-sub opset_to_hex ($);
-sub opdump (;$);
-use subs @EXPORT_OK;
+);
 
 XSLoader::load();
 
@@ -451,6 +441,8 @@ These are a hotchpotch of opcodes still waiting to be considered
 
     ceil floor
 
+    is_tainted
+
 =item :base_math
 
 These ops are not included in :base_core because of the risk of them being

lib/B/Deparse.pm

@@ -7,7 +7,7 @@
 # This is based on the module of the same name by Malcolm Beattie,
 # but essentially none of his code remains.
 
-package B::Deparse;
+package B::Deparse 1.65;
 use strict;
 use Carp;
 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
@@ -53,7 +53,6 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         MDEREF_SHIFT
     );
 
-our $VERSION = '1.64';
 our $AUTOLOAD;
 use warnings ();
 require feature;
@@ -6660,15 +6659,16 @@ sub builtin1 {
     return "builtin::$name($arg)";
 }
 
-sub pp_is_bool  { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "is_bool"); }
-sub pp_is_weak  { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "is_weak"); }
-sub pp_weaken   { builtin1(@_, "weaken"); }
-sub pp_unweaken { builtin1(@_, "unweaken"); }
-sub pp_blessed  { builtin1(@_, "blessed"); }
-sub pp_refaddr  { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "refaddr"); }
-sub pp_reftype  { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "reftype"); }
-sub pp_ceil     { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "ceil"); }
-sub pp_floor    { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "floor"); }
+sub pp_is_bool    { builtin1(@_, "is_bool"); }
+sub pp_is_weak    { builtin1(@_, "is_weak"); }
+sub pp_weaken     { builtin1(@_, "weaken"); }
+sub pp_unweaken   { builtin1(@_, "unweaken"); }
+sub pp_blessed    { builtin1(@_, "blessed"); }
+sub pp_refaddr    { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "refaddr"); }
+sub pp_reftype    { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "reftype"); }
+sub pp_ceil       { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "ceil"); }
+sub pp_floor      { $_[0]->maybe_targmy(@_[1,2], \&builtin1, "floor"); }
+sub pp_is_tainted { builtin1(@_, "is_tainted"); }
 
 1;
 __END__

lib/B/Deparse.t

@@ -3221,6 +3221,7 @@ $x = builtin::refaddr(undef);
 $x = builtin::reftype(undef);
 $x = builtin::ceil($x);
 $x = builtin::floor($x);
+$x = builtin::is_tainted($x);
 ####
 # boolean true preserved
 my $x = !0;

lib/builtin.pm

@@ -1,4 +1,4 @@
-package builtin 0.007;
+package builtin 0.008;
 
 use strict;
 use warnings;
@@ -24,6 +24,7 @@ builtin - Perl pragma to import built-in utility functions
         ceil floor
         indexed
         trim
+        is_tainted
     );
 
 =head1 DESCRIPTION
@@ -281,8 +282,12 @@ C<trim> is equivalent to:
 For Perl versions where this feature is not available look at the
 L<String::Util> module for a comparable implementation.
 
+=head2 is_tainted
+
+    $bool = is_tainted($var);
+
+Returns true when given a tainted variable.
+
 =head1 SEE ALSO
 
 L<perlop>, L<perlfunc>, L<Scalar::Util>
-
-=cut

lib/builtin.t

@@ -1,20 +1,19 @@
-#!./perl
+#!./perl -T
 
 BEGIN {
     chdir 't' if -d 't';
     require './test.pl';
     set_up_inc('../lib');
 }
 
-use strict;
-use warnings;
+use v5.36;
 no warnings 'experimental::builtin';
 
 package FetchStoreCounter {
-    sub new { my $class = shift; return bless [@_], $class }
-    sub TIESCALAR { return shift->new(@_) }
-    sub FETCH { ${shift->[0]}++ }
-    sub STORE { ${shift->[1]}++ }
+    sub TIESCALAR($class, @args) { bless \@args, $class }
+
+    sub FETCH($self)    { $self->[0]->$*++ }
+    sub STORE($self, $) { $self->[1]->$*++ }
 }
 
 # booleans
@@ -47,7 +46,7 @@ package FetchStoreCounter {
     is($fetchcount, 1, 'is_bool() invokes FETCH magic');
 
     $tied = is_bool(false);
-    is($storecount, 1, 'is_bool() TARG invokes STORE magic');
+    is($storecount, 1, 'is_bool() invokes STORE magic');
 }
 
 # weakrefs
@@ -342,6 +341,23 @@ TODO: {
     is(trim($str2), "Hello world!", "Trim on an our \$var");
 }
 
+# is_tainted
+{
+    use builtin qw( is_tainted );
+
+    is(is_tainted($0), !!${^TAINT}, "\$0 is tainted (if tainting is supported)");
+    ok(!is_tainted($1), "\$1 isn't tainted");
+
+    # Invokes magic
+    tie my $tied, FetchStoreCounter => (\my $fetchcount, \my $storecount);
+
+    my $_dummy = is_tainted($tied);
+    is($fetchcount, 1, 'is_tainted() invokes FETCH magic');
+
+    $tied = is_tainted($0);
+    is($storecount, 1, 'is_tainted() invokes STORE magic');
+}
+
 # vim: tabstop=4 shiftwidth=4 expandtab autoindent softtabstop=4
 
 done_testing();