summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doio.c25
-rw-r--r--embed.fnc6
-rw-r--r--embed.h1
-rw-r--r--ext/File-Glob/Glob.pm2
-rw-r--r--ext/File-Glob/Glob.xs4
-rw-r--r--inline.h50
-rw-r--r--lib/warnings.pm240
-rw-r--r--perl.h6
-rw-r--r--perlio.c9
-rw-r--r--pod/perldiag.pod6
-rw-r--r--pod/perllexwarn.pod2
-rw-r--r--pp_ctl.c26
-rw-r--r--proto.h8
-rw-r--r--regen/warnings.pl7
-rw-r--r--t/io/open.t61
-rw-r--r--t/lib/warnings/doio32
-rw-r--r--t/op/caller.t4
-rw-r--r--t/op/require_errors.t24
-rw-r--r--t/porting/diag.t1
-rw-r--r--warnings.h10
20 files changed, 388 insertions, 136 deletions
diff --git a/doio.c b/doio.c
index b24a5b4d67..d79bf44da7 100644
--- a/doio.c
+++ b/doio.c
@@ -216,6 +216,9 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw,
goto say_false;
}
#endif /* USE_STDIO */
+ if (!IS_SAFE_PATHNAME(*svp, "open"))
+ goto say_false;
+
name = (SvOK(*svp) || SvGMAGICAL(*svp)) ?
savesvpv (*svp) : savepvs ("");
SAVEFREEPV(name);
@@ -1660,8 +1663,10 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
else {
const char *name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
- if (PerlLIO_chmod(name, val))
- tot--;
+ if (!IS_SAFE_PATHNAME(*mark, "chmod") ||
+ PerlLIO_chmod(name, val)) {
+ tot--;
+ }
}
}
}
@@ -1694,8 +1699,10 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
else {
const char *name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
- if (PerlLIO_chown(name, val, val2))
+ if (!IS_SAFE_PATHNAME(*mark, "chown") ||
+ PerlLIO_chown(name, val, val2)) {
tot--;
+ }
}
}
}
@@ -1795,7 +1802,10 @@ nothing in the core.
while (++mark <= sp) {
s = SvPV_nolen_const(*mark);
APPLY_TAINT_PROPER();
- if (PerlProc_geteuid() || PL_unsafe) {
+ if (!IS_SAFE_PATHNAME(*mark, "unlink")) {
+ tot--;
+ }
+ else if (PerlProc_geteuid() || PL_unsafe) {
if (UNLINK(s))
tot--;
}
@@ -1873,6 +1883,10 @@ nothing in the core.
else {
const char * const name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
+ if (!IS_SAFE_PATHNAME(*mark, "utime")) {
+ tot--;
+ }
+ else
#ifdef HAS_FUTIMES
if (utimes(name, (struct timeval *)utbufp))
#else
@@ -2365,6 +2379,9 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
PERL_ARGS_ASSERT_START_GLOB;
+ if (!IS_SAFE_SYSCALL(tmpglob, "pattern", "glob"))
+ return NULL;
+
ENTER;
SAVEFREESV(tmpcmd);
#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
diff --git a/embed.fnc b/embed.fnc
index d223f0d91e..559be3e237 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1601,6 +1601,8 @@ Am |I32 |whichsig |NN const char* sig
Ap |I32 |whichsig_sv |NN SV* sigsv
Ap |I32 |whichsig_pv |NN const char* sig
Ap |I32 |whichsig_pvn |NN const char* sig|STRLEN len
+: used to check for NULs in pathnames and other names
+AiR |bool |is_safe_syscall|NN SV *pv|NN const char *what|NN const char *op_name
: Used in pp_ctl.c
p |void |write_to_stderr|NN SV* msv
: Used in op.c
@@ -2280,7 +2282,7 @@ s |void |printbuf |NN const char *const fmt|NN const char *const s
EXMp |bool |validate_proto |NN SV *name|NULLOK SV *proto|bool warn
#if defined(PERL_IN_UNIVERSAL_C)
-s |bool|isa_lookup |NN HV *stash|NN const char * const name \
+s |bool |isa_lookup |NN HV *stash|NN const char * const name \
|STRLEN len|U32 flags
#endif
@@ -2292,7 +2294,7 @@ s |bool |is_cur_LC_category_utf8|int category
#if defined(PERL_IN_UTIL_C)
s |const COP*|closest_cop |NN const COP *cop|NULLOK const OP *o
s |SV* |mess_alloc
-s |SV *|with_queued_errors|NN SV *ex
+s |SV * |with_queued_errors|NN SV *ex
s |bool |invoke_exception_hook|NULLOK SV *ex|bool warn
#if defined(PERL_MEM_LOG) && !defined(PERL_MEM_LOG_NOIMPL)
sn |void |mem_log_common |enum mem_log_type mlt|const UV n|const UV typesize \
diff --git a/embed.h b/embed.h
index 49700ca352..8874b68e1e 100644
--- a/embed.h
+++ b/embed.h
@@ -230,6 +230,7 @@
#define instr Perl_instr
#define is_ascii_string Perl_is_ascii_string
#define is_lvalue_sub() Perl_is_lvalue_sub(aTHX)
+#define is_safe_syscall(a,b,c) S_is_safe_syscall(aTHX_ a,b,c)
#define is_uni_alnum(a) Perl_is_uni_alnum(aTHX_ a)
#define is_uni_alnum_lc(a) Perl_is_uni_alnum_lc(aTHX_ a)
#define is_uni_alnumc(a) Perl_is_uni_alnumc(aTHX_ a)
diff --git a/ext/File-Glob/Glob.pm b/ext/File-Glob/Glob.pm
index 379d7f0ee1..30016794f7 100644
--- a/ext/File-Glob/Glob.pm
+++ b/ext/File-Glob/Glob.pm
@@ -37,7 +37,7 @@ pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob"
@EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob');
-$VERSION = '1.20';
+$VERSION = '1.21';
sub import {
require Exporter;
diff --git a/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs
index df5530a088..43904df434 100644
--- a/ext/File-Glob/Glob.xs
+++ b/ext/File-Glob/Glob.xs
@@ -227,7 +227,9 @@ csh_glob(pTHX_ AV *entries, SV *patsv)
assert(SvTYPE(entries) != SVt_PVAV);
sv_upgrade((SV *)entries, SVt_PVAV);
-
+ if (!IS_SAFE_SYSCALL(patsv, "pattern", "glob"))
+ return FALSE;
+
if (patav) {
I32 items = AvFILLp(patav) + 1;
SV **svp = AvARRAY(patav);
diff --git a/inline.h b/inline.h
index b33cd3fd6f..86deaf5175 100644
--- a/inline.h
+++ b/inline.h
@@ -221,3 +221,53 @@ S_isALNUM_lazy(pTHX_ const char* p)
return isALNUM_lazy_if(p,1);
}
+
+/* ------------------------------- perl.h ----------------------------- */
+
+/*
+=for apidoc AiR|bool|is_safe_syscall|SV *pv|const char *what|const char *op_name
+
+Test that the given C<pv> doesn't contain any internal NUL characters.
+If it does, set C<errno> to ENOENT, optionally warn, and return FALSE.
+
+Return TRUE if the name is safe.
+
+Used by the IS_SAFE_SYSCALL() macro.
+
+=cut
+*/
+
+PERL_STATIC_INLINE bool
+S_is_safe_syscall(pTHX_ SV *pv, const char *what, const char *op_name) {
+ /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
+ * perl itself uses xce*() functions which accept 8-bit strings.
+ */
+
+ PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
+
+ if (SvPOK(pv) && SvCUR(pv) >= 1) {
+ char *p = SvPVX(pv);
+ char *null_at;
+ if (UNLIKELY((null_at = (char *)memchr(p, 0, SvCUR(pv)-1)) != NULL)) {
+ SETERRNO(ENOENT, LIB_INVARG);
+ if (ckWARN(WARN_SYSCALLS)) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
+ "Invalid \\0 character in %s for %s: %s\\0%s",
+ what, op_name, p, null_at+1);
+ }
+ return FALSE;
+ }
+ }
+
+ return TRUE;
+}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: nil
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 et:
+ */
diff --git a/lib/warnings.pm b/lib/warnings.pm
index 7d988cbd99..3a08b67041 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -5,7 +5,7 @@
package warnings;
-our $VERSION = '1.18';
+our $VERSION = '1.19';
# Verify that we're called correctly so that warnings will work.
# see also strict.pm.
@@ -233,130 +233,136 @@ our %Offsets = (
'experimental::lexical_topic'=> 106,
'experimental::regex_sets'=> 108,
'experimental::smartmatch'=> 110,
+
+ # Warnings Categories added in Perl 5.019
+
+ 'syscalls' => 112,
);
our %Bits = (
- 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..55]
- 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [29]
- 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [30]
- 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
- 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
- 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
- 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
- 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [31]
- 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
- 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
- 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55", # [51..55]
- 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [52]
- 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [53]
- 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [54]
- 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [55]
- 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
- 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [47]
- 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [46]
- 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
- 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [24]
- 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
- 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
- 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [25]
- 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
- 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
- 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [48]
- 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [49]
- 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
- 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
- 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
- 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
- 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [32]
- 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
- 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
- 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [33]
- 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [34]
- 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [35]
- 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [36]
- 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
- 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
- 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
- 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [37]
- 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [38]
- 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00", # [21..25]
- 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [26]
- 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [27]
- 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [50]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00", # [28..38,47]
- 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [39]
- 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [40]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [41]
- 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [42]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [43]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00", # [44,48..50]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [45]
+ 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..56]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [29]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [30]
+ 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
+ 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x00", # [51..55]
+ 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [52]
+ 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [53]
+ 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [54]
+ 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [55]
+ 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [47]
+ 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [46]
+ 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
+ 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
+ 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [5..11,56]
+ 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
+ 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [48]
+ 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [49]
+ 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
+ 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [50]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00\x00", # [28..38,47]
+ 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [56]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [39]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [41]
+ 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00\x00", # [44,48..50]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [45]
);
our %DeadBits = (
- 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..55]
- 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [29]
- 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [30]
- 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
- 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
- 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
- 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
- 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [31]
- 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
- 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
- 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa", # [51..55]
- 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [52]
- 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [53]
- 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [54]
- 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [55]
- 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
- 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [47]
- 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [46]
- 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
- 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [24]
- 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
- 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
- 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [25]
- 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
- 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
- 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [48]
- 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [49]
- 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
- 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
- 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
- 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
- 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [32]
- 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
- 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
- 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [33]
- 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [34]
- 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [35]
- 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [36]
- 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
- 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
- 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
- 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [37]
- 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [38]
- 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00", # [21..25]
- 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [26]
- 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [27]
- 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [50]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00", # [28..38,47]
- 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [39]
- 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [40]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [41]
- 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [42]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [43]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00", # [44,48..50]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [45]
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..56]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [29]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [30]
+ 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
+ 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\x00", # [51..55]
+ 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [52]
+ 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [53]
+ 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [54]
+ 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [55]
+ 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [47]
+ 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [46]
+ 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
+ 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
+ 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [5..11,56]
+ 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
+ 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [48]
+ 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [49]
+ 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
+ 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [50]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00\x00", # [28..38,47]
+ 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [56]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [39]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [41]
+ 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00\x00", # [44,48..50]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [45]
);
-$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
-$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55", # [2,52..55,4,22,23,25]
-$LAST_BIT = 112 ;
-$BYTES = 14 ;
+$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
+$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x00", # [2,52..55,4,22,23,25]
+$LAST_BIT = 114 ;
+$BYTES = 15 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
diff --git a/perl.h b/perl.h
index d2c5568bcd..90495fd149 100644
--- a/perl.h
+++ b/perl.h
@@ -5671,6 +5671,12 @@ extern void moncontrol(int);
# define do_aexec(really, mark,sp) do_aexec5(really, mark, sp, 0, 0)
#endif
+/* check embedded \0 characters in pathnames passed to syscalls,
+ but allow one ending \0 */
+#define IS_SAFE_SYSCALL(pv, what, op_name) (S_is_safe_syscall(aTHX_ (pv), (what), (op_name)))
+
+#define IS_SAFE_PATHNAME(pv, op_name) IS_SAFE_SYSCALL((pv), "pathname", (op_name))
+
#if defined(OEMVS)
#define NO_ENV_ARRAY_IN_MAIN
#endif
diff --git a/perlio.c b/perlio.c
index 2e5a77d2af..963c3e80c4 100644
--- a/perlio.c
+++ b/perlio.c
@@ -310,6 +310,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
return PerlIO_tmpfile();
else {
const char *name = SvPV_nolen_const(*args);
+ if (!IS_SAFE_PATHNAME(*args, "open"))
+ return NULL;
+
if (*mode == IoTYPE_NUMERIC) {
fd = PerlLIO_open3(name, imode, perm);
if (fd >= 0)
@@ -2719,6 +2722,8 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
}
if (imode != -1) {
const char *path = SvPV_nolen_const(*args);
+ if (!IS_SAFE_PATHNAME(*args, "open"))
+ return NULL;
fd = PerlLIO_open3(path, imode, perm);
}
}
@@ -3033,6 +3038,8 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
const char * const path = SvPV_nolen_const(*args);
PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
FILE *stdio;
+ if (!IS_SAFE_PATHNAME(*args, "open"))
+ return NULL;
PerlIOUnix_refcnt_dec(fileno(s->stdio));
stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
s->stdio);
@@ -3045,6 +3052,8 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
else {
if (narg > 0) {
const char * const path = SvPV_nolen_const(*args);
+ if (!IS_SAFE_PATHNAME(*args, "open"))
+ return NULL;
if (*mode == IoTYPE_NUMERIC) {
mode++;
fd = PerlLIO_open3(path, imode, perm);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 23f147d29d..db8f89899b 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2505,6 +2505,12 @@ the indicated name isn't valid. See L<charnames/CUSTOM ALIASES>.
(F) Only certain characters are valid for character names. The
indicated one isn't. See L<charnames/CUSTOM ALIASES>.
+=item Invalid \0 character in %s for %s: %s\0%s
+
+(W syscalls) Embedded \0 characters in pathnames or other syscall
+arguments create a warning since 5.20. The parts after the \0 were
+formerly ignored by syscalls.
+
=item Invalid conversion in %s: "%s"
(W printf) Perl does not understand the given format conversion. See
diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod
index b193e3cdbb..0d76e93bc4 100644
--- a/pod/perllexwarn.pod
+++ b/pod/perllexwarn.pod
@@ -252,6 +252,8 @@ will be lost.
| |
| +- pipe
| |
+ | +- syscalls
+ | |
| +- unopened
|
+- misc
diff --git a/pp_ctl.c b/pp_ctl.c
index b71648c498..262c930026 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3586,10 +3586,21 @@ S_check_type_and_open(pTHX_ SV *name)
{
Stat_t st;
const char *p = SvPV_nolen_const(name);
- const int st_rc = PerlLIO_stat(p, &st);
+ int st_rc;
PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
+ /* checking here captures a reasonable error message when
+ * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
+ * user gets a confusing message about looking for the .pmc file
+ * rather than for the .pm file.
+ * This check prevents a \0 in @INC causing problems.
+ */
+ if (!IS_SAFE_PATHNAME(name, "require"))
+ return NULL;
+
+ st_rc = PerlLIO_stat(p, &st);
+
if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
return NULL;
}
@@ -3610,6 +3621,13 @@ S_doopen_pm(pTHX_ SV *name)
PERL_ARGS_ASSERT_DOOPEN_PM;
+ /* check the name before trying for the .pmc name to avoid the
+ * warning referring to the .pmc which the user probably doesn't
+ * know or care about
+ */
+ if (!IS_SAFE_PATHNAME(name, "require"))
+ return NULL;
+
if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
SV *const pmcsv = sv_newmortal();
Stat_t pmcstat;
@@ -3742,6 +3760,12 @@ PP(pp_require)
name = SvPV_const(sv, len);
if (!(name && len > 0 && *name))
DIE(aTHX_ "Null filename used");
+ if (!IS_SAFE_PATHNAME(sv, "require")) {
+ DIE(aTHX_ "Can't locate %s: %s",
+ pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
+ SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
+ Strerror(ENOENT));
+ }
TAINT_PROPER("require");
path_searchable = path_is_searchable(name);
diff --git a/proto.h b/proto.h
index 0bc3b55cb0..5b3a98f27e 100644
--- a/proto.h
+++ b/proto.h
@@ -1741,6 +1741,14 @@ PERL_CALLCONV bool Perl_is_ascii_string(const U8 *s, STRLEN len)
PERL_CALLCONV I32 Perl_is_lvalue_sub(pTHX)
__attribute__warn_unused_result__;
+PERL_STATIC_INLINE bool S_is_safe_syscall(pTHX_ SV *pv, const char *what, const char *op_name)
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_IS_SAFE_SYSCALL \
+ assert(pv); assert(what); assert(op_name)
+
PERL_CALLCONV bool Perl_is_uni_alnum(pTHX_ UV c)
__attribute__deprecated__
__attribute__warn_unused_result__
diff --git a/regen/warnings.pl b/regen/warnings.pl
index 72d9a0b410..a3e2b44dfe 100644
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -19,7 +19,7 @@
#
# This script is normally invoked from regen.pl.
-$VERSION = '1.02_03';
+$VERSION = '1.02_05';
BEGIN {
require 'regen/regen_lib.pl';
@@ -40,6 +40,7 @@ my $tree = {
'newline' => [ 5.008, DEFAULT_OFF],
'exec' => [ 5.008, DEFAULT_OFF],
'layer' => [ 5.008, DEFAULT_OFF],
+ 'syscalls' => [ 5.019, DEFAULT_OFF],
}],
'syntax' => [ 5.008, {
'ambiguous' => [ 5.008, DEFAULT_OFF],
@@ -59,7 +60,7 @@ my $tree = {
'internal' => [ 5.008, DEFAULT_OFF],
'debugging' => [ 5.008, DEFAULT_ON],
'malloc' => [ 5.008, DEFAULT_ON],
- }],
+ }],
'deprecated' => [ 5.008, DEFAULT_ON],
'void' => [ 5.008, DEFAULT_OFF],
'recursion' => [ 5.008, DEFAULT_OFF],
@@ -465,7 +466,7 @@ close_and_rename($lexwarn);
__END__
package warnings;
-our $VERSION = '1.18';
+our $VERSION = '1.19';
# Verify that we're called correctly so that warnings will work.
# see also strict.pm.
diff --git a/t/io/open.t b/t/io/open.t
index ef56ddad30..e170ab6123 100644
--- a/t/io/open.t
+++ b/t/io/open.t
@@ -10,7 +10,7 @@ $| = 1;
use warnings;
use Config;
-plan tests => 122;
+plan tests => 145;
my $Perl = which_perl();
@@ -391,3 +391,62 @@ sub _117941 { package _117941; open my $a, "TEST" }
delete $::{"_117941::"};
_117941();
pass("no crash when open autovivifies glob in freed package");
+
+# [perl #117265] check for embedded nul in pathnames, allow ending \0 though
+{
+ my $WARN;
+ local $SIG{__WARN__} = sub { $WARN = shift };
+ my $temp = tempfile();
+ my $temp_match = quotemeta $temp;
+
+ # create the file, so we can check nothing actually touched it
+ open my $temp_fh, ">", $temp;
+ close $temp_fh;
+ ok(utime(time()-10, time(), $temp), "set mtime to a known value");
+ ok(chmod(0666, $temp), "set mode to a known value");
+ my ($final_mode, $final_mtime) = (stat $temp)[2, 9];
+
+ my $fn = "$temp\0.invalid";
+ is(open(I, $fn), undef, "open with nul in pathnames since 5.18 [perl #117265]");
+ like($WARN, qr/^Invalid \\0 character in pathname for open: $temp_match\\0\.invalid/,
+ "warn on embedded nul"); $WARN = '';
+ is (unlink($fn), 0);
+ like($WARN, qr/^Invalid \\0 character in pathname for unlink: $temp_match\\0\.invalid/,
+ "also on unlink"); $WARN = '';
+ is(chmod(0444, $fn), 0);
+ like($WARN, qr/^Invalid \\0 character in pathname for chmod: $temp_match\\0\.invalid/,
+ "also on chmod"); $WARN = '';
+ is (glob($fn), ());
+ like($WARN, qr/^Invalid \\0 character in pattern for glob: $temp_match\\0\.invalid/,
+ "also on glob"); $WARN = '';
+
+ {
+ no warnings 'syscalls';
+ $WARN = '';
+ is(open(I, $fn), undef, "open with nul with no warnings syscalls");
+ is($WARN, '', "ignore warning on embedded nul with no warnings syscalls");
+ }
+
+ use Errno 'ENOENT';
+ # check handling of multiple arguments, which the original patch
+ # mis-handled
+ $! = 0;
+ is (unlink($fn, $fn), 0, "check multiple arguments to unlink");
+ is($!+0, ENOENT, "check errno");
+ $! = 0;
+ is (chmod(0644, $fn, $fn), 0, "check multiple arguments to chmod");
+ is($!+0, ENOENT, "check errno");
+ $! = 0;
+ is (utime(time, time, $fn, $fn), 0, "check multiple arguments to utime");
+ is($!+0, ENOENT, "check errno");
+ SKIP: {
+ skip "no chown", 2 unless $Config{d_chown};
+ $! = 0;
+ is(chown(-1, -1, $fn, $fn), 0, "check multiple arguments to chown");
+ is($!+0, ENOENT, "check errno");
+ }
+
+ ok(-f $temp, "nothing removed the temp file");
+ is((stat $temp)[2], $final_mode, "nothing changed its mode");
+ is((stat $temp)[9], $final_mtime, "nothing changes its mtime");
+}
diff --git a/t/lib/warnings/doio b/t/lib/warnings/doio
index 804161e712..bf0cd780c1 100644
--- a/t/lib/warnings/doio
+++ b/t/lib/warnings/doio
@@ -366,3 +366,35 @@ open ᶠᚻ2, ">doiowarn.tmp"; close ᶠᚻ2;
unlink "doiowarn.tmp";
EXPECT
Filehandle STDIN reopened as ᶠᚻ1 only for output at - line 16.
+########
+open(my $i, "foo\0bar");
+use warnings 'io';
+open(my $i, "foo\0bar");
+EXPECT
+Invalid \0 character in pathname for open: foo\0bar at - line 3.
+########
+chmod(0, "foo\0bar");
+use warnings 'io';
+chmod(0, "foo\0bar");
+EXPECT
+Invalid \0 character in pathname for chmod: foo\0bar at - line 3.
+########
+unlink("foo\0bar", "foo\0bar2");
+use warnings 'io';
+unlink("foo\0bar", "foo\0bar2");
+EXPECT
+Invalid \0 character in pathname for unlink: foo\0bar at - line 3.
+Invalid \0 character in pathname for unlink: foo\0bar2 at - line 3.
+########
+utime(-1, -1, "foo\0bar", "foo\0bar2");
+use warnings 'io';
+utime(-1, -1, "foo\0bar", "foo\0bar2");
+EXPECT
+Invalid \0 character in pathname for utime: foo\0bar at - line 3.
+Invalid \0 character in pathname for utime: foo\0bar2 at - line 3.
+########
+my @foo = glob "foo\0bar";
+use warnings 'io';
+my @bar = glob "foo\0bar";
+EXPECT
+Invalid \0 character in pattern for glob: foo\0bar at - line 3.
diff --git a/t/op/caller.t b/t/op/caller.t
index c37a6edb06..09728d3ec1 100644
--- a/t/op/caller.t
+++ b/t/op/caller.t
@@ -111,8 +111,8 @@ sub testwarn {
# The repetition number must be set to the value of $BYTES in
# lib/warnings.pm
- BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 14, 'all bits off via "no warnings"' ) }
- testwarn("\0" x 14, 'no bits');
+ BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 15, 'all bits off via "no warnings"' ) }
+ testwarn("\0" x 15, 'no bits');
use warnings;
BEGIN { check_bits( ${^WARNING_BITS}, $default,
diff --git a/t/op/require_errors.t b/t/op/require_errors.t
index e3239486be..28a52e35d9 100644
--- a/t/op/require_errors.t
+++ b/t/op/require_errors.t
@@ -7,7 +7,7 @@ BEGIN {
require './test.pl';
}
-plan(tests => 11);
+plan(tests => 17);
my $nonfile = tempfile();
@@ -111,3 +111,25 @@ SKIP: {
# I can't see how to test the EMFILE case
# I can't see how to test the case of not displaying @INC in the message.
# (and does that only happen on VMS?)
+
+# fail and print the full filename
+eval { no warnings 'syscalls'; require "strict.pm\0invalid"; };
+like $@, qr/^Can't locate strict\.pm\\0invalid: /, 'require nul check [perl #117265]';
+eval { no warnings 'syscalls'; do "strict.pm\0invalid"; };
+like $@, qr/^Can't locate strict\.pm\\0invalid: /, 'do nul check';
+{
+ my $WARN;
+ local $SIG{__WARN__} = sub { $WARN = shift };
+ eval { require "strict.pm\0invalid"; };
+ like $WARN, qr{^Invalid \\0 character in pathname for require: strict\.pm\\0invalid at }, 'nul warning';
+ like $@, qr{^Can't locate strict\.pm\\0invalid: }, 'nul error';
+
+ $WARN = '';
+ local @INC = @INC;
+ unshift @INC, "lib\0invalid";
+ eval { require "unknown.pm" };
+ like $WARN, qr{^Invalid \\0 character in pathname for require: lib\\0invalid/unknown\.pm at }, 'nul warning';
+}
+eval "require strict\0::invalid;";
+like $@, qr/^syntax error at \(eval \d+\) line 1/, 'parse error with \0 in barewords module names';
+
diff --git a/t/porting/diag.t b/t/porting/diag.t
index abe6b08d28..6b6081e098 100644
--- a/t/porting/diag.t
+++ b/t/porting/diag.t
@@ -463,6 +463,7 @@ Cannot apply "%s" in non-PerlIO perl
Can't find string terminator %c%s%c anywhere before EOF
Can't fix broken locale name "%s"
Can't get short module name from a handle
+Can't locate %s: %s
Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
Can't pipe "%s": %s
Can't spawn: %s
diff --git a/warnings.h b/warnings.h
index 5c40d5c398..f5ff791ccd 100644
--- a/warnings.h
+++ b/warnings.h
@@ -95,9 +95,13 @@
#define WARN_EXPERIMENTAL__REGEX_SETS 54
#define WARN_EXPERIMENTAL__SMARTMATCH 55
-#define WARNsize 14
-#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125"
-#define WARN_NONEstring "\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
+/* Warnings Categories added in Perl 5.019 */
+
+#define WARN_SYSCALLS 56
+
+#define WARNsize 15
+#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125"
+#define WARN_NONEstring "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
View Lorry Controller Status