[PATCH] e213661 no warnings 'safesyscalls', fatal nul checks #12868
Comments
From @rurbanThis is a bug report for perl from rurban@cpanel.net, From ccbb86ed06799dbc844f023ab6967338296bdee1 Mon Sep 17 00:00:00 2001 This is a multi-part message in MIME format. cp_if_diff used an old-style open(F,"< $from\0") to force an ending \0, dist/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm | 6 +++--- --------------1.7.10.4 Inline Patchdiff --git a/dist/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm b/dist/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm
index 5bcd6d6..82b4010 100644
--- a/dist/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm
+++ b/dist/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm
@@ -13,7 +13,7 @@ use vars qw($VERSION @ISA @EXPORT_OK
$Is_MacOS $Is_VMS $Is_VMS_mode $Is_VMS_lc $Is_VMS_nodot
$Debug $Verbose $Quiet $MANIFEST $DEFAULT_MSKIP);
-$VERSION = '1.63';
+$VERSION = '1.63_01';
@ISA=('Exporter');
@EXPORT_OK = qw(mkmanifest
manicheck filecheck fullcheck skipcheck
@@ -567,8 +567,8 @@ sub cp_if_diff {
}
my($diff) = 0;
local(*F,*T);
- open(F,"< $from\0") or die "Can't read $from: $!\n";
- if (open(T,"< $to\0")) {
+ open(F,"<",$from) or die "Can't read $from: $!\n";
+ if (open(T,"<",$to)) {
local $_;
while (<F>) { $diff++,last if $_ ne <T>; }
$diff++ unless eof(T);
--------------1.7.10.4--
---
This perlbug was built using Perl 5.17.8 - Fri Feb 1 11:00:49 CST 2013 Site configuration information for perl 5.17.8: Configured by rurban at Wed Jan 9 17:52:45 CST 2013. Summary of my perl5 (revision 5 version 17 subversion 8) configuration: Locally applied patches: @INC for perl 5.17.8: Environment for perl 5.17.8: |
From @rurbanpart 1 was missing from perlbug (mult. -f not supported) |
From @rurban0001-no-warnings-safesyscalls-fatal-0-checks.patchFrom e213661d72731f72caf3ce470119228bf5a870be Mon Sep 17 00:00:00 2001
From: Reini Urban <rurban@x-ray.at>
Date: Tue, 12 Mar 2013 19:25:26 +0100
Subject: [PATCH 1/2] no warnings 'safesyscalls', fatal \0 checks
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="------------1.7.10.4"
This is a multi-part message in MIME format.
--------------1.7.10.4
Content-Type: text/plain; charset=UTF-8; format=fixed
Content-Transfer-Encoding: 8bit
Add the fatal warnings category safesyscalls.
Disallow binary pathnames and arguments to other syscalls, strings
with embedded \0, which are ignored in the syscall but kept in
perl. Allow an ending \0 though, as several modules add a \0 to
such strings without adjusting the length.
The hidden payloads in these invalid string args may cause unnoticed
security problems, as they are ignored by the syscalls but kept around
in perl PVs.
---
doio.c | 9 ++++++++-
embed.fnc | 4 ++--
ext/File-Glob/Glob.xs | 1 +
lib/warnings.pm | 15 +++++++++------
perl.h | 17 +++++++++++++++++
perlio.c | 4 ++++
pod/perldiag.pod | 9 +++++++++
regen/warnings.pl | 6 +++---
t/io/open.t | 23 ++++++++++++++++++++++-
util.c | 1 +
warnings.h | 1 +
11 files changed, 77 insertions(+), 13 deletions(-)
--------------1.7.10.4
Content-Type: text/x-patch; name="0001-no-warnings-safesyscalls-fatal-0-checks.patch"
Content-Transfer-Encoding: 8bit
Content-Disposition: attachment; filename="0001-no-warnings-safesyscalls-fatal-0-checks.patch"
diff --git a/doio.c b/doio.c
index 4e8d48a..4d7c00a 100644
--- a/doio.c
+++ b/doio.c
@@ -216,6 +216,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw,
goto say_false;
}
#endif /* USE_STDIO */
+ CHECK_PATHNAME(*svp);
name = (SvOK(*svp) || SvGMAGICAL(*svp)) ?
savesvpv (*svp) : savepvs ("");
SAVEFREEPV(name);
@@ -1638,6 +1639,7 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
else {
const char *name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark);
if (PerlLIO_chmod(name, val))
tot--;
}
@@ -1672,6 +1674,7 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
else {
const char *name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark);
if (PerlLIO_chown(name, val, val2))
tot--;
}
@@ -1690,6 +1693,7 @@ nothing in the core.
APPLY_TAINT_PROPER();
if (mark == sp)
break;
+ CHECK_SYSCALL(*mark);
s = SvPVx_const(*++mark, len);
if (*s == '-' && isALPHA(s[1]))
{
@@ -1702,7 +1706,7 @@ nothing in the core.
s += 3;
len -= 3;
}
- if ((val = whichsig_pvn(s, len)) < 0)
+ if ((val = whichsig_pvn(s, len)) < 0)
Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
}
else
@@ -1773,6 +1777,7 @@ nothing in the core.
while (++mark <= sp) {
s = SvPV_nolen_const(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark);
if (PerlProc_geteuid() || PL_unsafe) {
if (UNLINK(s))
tot--;
@@ -1851,6 +1856,7 @@ nothing in the core.
else {
const char * const name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark);
#ifdef HAS_FUTIMES
if (utimes(name, (struct timeval *)utbufp))
#else
@@ -2343,6 +2349,7 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
PERL_ARGS_ASSERT_START_GLOB;
+ CHECK_SYSCALL(tmpglob);
ENTER;
SAVEFREESV(tmpcmd);
#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
diff --git a/embed.fnc b/embed.fnc
index 2f5e089..8c981f2 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2253,7 +2253,7 @@ s |void |printbuf |NN const char *const fmt|NN const char *const s
#endif
#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
@@ -2266,7 +2266,7 @@ s |char* |stdize_locale |NN char* locs
#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/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs
index df5530a..2cd762f 100644
--- a/ext/File-Glob/Glob.xs
+++ b/ext/File-Glob/Glob.xs
@@ -135,6 +135,7 @@ csh_glob(pTHX_ AV *entries, SV *patsv)
pat = "", len = 0, is_utf8 = 0;
else pat = SvPV_nomg(patsv,len), is_utf8 = !!SvUTF8(patsv);
patend = pat + len;
+ CHECK_SYSCALL(patsv);
/* extract patterns */
s = pat-1;
diff --git a/lib/warnings.pm b/lib/warnings.pm
index c0c2cc9..4ddd83a 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -232,10 +232,11 @@ our %Offsets = (
'experimental::lexical_subs'=> 104,
'experimental::lexical_topic'=> 106,
'experimental::regex_sets'=> 108,
+ 'safesyscalls' => 110,
);
our %Bits = (
- 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..54]
+ '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]
@@ -276,8 +277,9 @@ our %Bits = (
'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]
+ 'safesyscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [55]
'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]
+ 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x40", # [21..25,55]
'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]
@@ -293,7 +295,7 @@ our %Bits = (
);
our %DeadBits = (
- 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..54]
+ '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]
@@ -334,8 +336,9 @@ our %DeadBits = (
'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]
+ 'safesyscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [55]
'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]
+ 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x80", # [21..25,55]
'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]
@@ -351,8 +354,8 @@ our %DeadBits = (
);
$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\x15", # [2,52..54,4,22,23,25]
-$LAST_BIT = 110 ;
+$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55", # [2,52..54,4,22,23,25,55]
+$LAST_BIT = 112 ;
$BYTES = 14 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
diff --git a/perl.h b/perl.h
index 5639f1c..3c9544a 100644
--- a/perl.h
+++ b/perl.h
@@ -5814,6 +5814,23 @@ extern void moncontrol(int);
# define do_aexec(really, mark,sp) do_aexec5(really, mark, sp, 0, 0)
#endif
+/* die on embedded \0 characters in pathnames, but allow one ending \0 */
+#define CHECK_PATHNAME(pv) CHECK_SAFESYSCALLS("pathname",pv)
+/* die on embedded \0 characters in args for various syscalls.
+ user and group names, glob. */
+#define CHECK_SYSCALL(pv) CHECK_SAFESYSCALLS("syscall",pv)
+#define CHECK_SAFESYSCALLS(what,pv) \
+ if (SvPOK(pv)) { \
+ char *i; \
+ char *p = SvPVX(pv); \
+ if ( (i = strchr(p, 0))&&(i-p)&&((size_t)(i-p)<SvCUR(pv)-1) ) { \
+ SETERRNO(EINVAL, LIB_INVARG); \
+ if (ckWARN(WARN_SAFESYSCALLS)) \
+ Perl_croak(aTHX_ "Invalid \\0 character in %s: %s\\0%s",\
+ what,p,++i); \
+ } \
+ } \
+
#if defined(OEMVS)
#define NO_ENV_ARRAY_IN_MAIN
#endif
diff --git a/perlio.c b/perlio.c
index 097bc49..a4ada58 100644
--- a/perlio.c
+++ b/perlio.c
@@ -310,6 +310,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
return PerlIO_tmpfile();
else {
const char *name = SvPV_nolen_const(*args);
+ CHECK_PATHNAME(*args);
if (*mode == IoTYPE_NUMERIC) {
fd = PerlLIO_open3(name, imode, perm);
if (fd >= 0)
@@ -2713,6 +2714,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
}
if (imode != -1) {
const char *path = SvPV_nolen_const(*args);
+ CHECK_PATHNAME(*args);
fd = PerlLIO_open3(path, imode, perm);
}
}
@@ -3027,6 +3029,7 @@ 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;
+ CHECK_PATHNAME(*args);
PerlIOUnix_refcnt_dec(fileno(s->stdio));
stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
s->stdio);
@@ -3039,6 +3042,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
else {
if (narg > 0) {
const char * const path = SvPV_nolen_const(*args);
+ CHECK_PATHNAME(*args);
if (*mode == IoTYPE_NUMERIC) {
mode++;
fd = PerlLIO_open3(path, imode, perm);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 8d29e2d..8f547c5 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2468,6 +2468,15 @@ indicated one isn't. See L<charnames/CUSTOM ALIASES>.
the C<:alias> option to C<use charnames> and the specified character in
the indicated name isn't valid. See L<charnames/CUSTOM ALIASES>.
+=item Invalid \0 character in %s: %s\0%s
+
+(F) Embedded \0 in pathnames or other syscall arguments create now a
+fatal warning. These were ignored by the binary unsafe syscalls, but
+may lead to security problems.
+
+If you know what you are doing you can turn off this warning by
+C<no warnings 'safesyscalls';>.
+
=item Invalid conversion in %s: "%s"
(W printf) Perl does not understand the given format conversion. See
diff --git a/regen/warnings.pl b/regen/warnings.pl
index 94a9843..12b0590 100644
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -16,7 +16,7 @@
#
# This script is normally invoked from regen.pl.
-$VERSION = '1.02_03';
+$VERSION = '1.02_04';
BEGIN {
require 'regen/regen_lib.pl';
@@ -56,7 +56,8 @@ my $tree = {
'internal' => [ 5.008, DEFAULT_OFF],
'debugging' => [ 5.008, DEFAULT_ON],
'malloc' => [ 5.008, DEFAULT_ON],
- }],
+ 'safesyscalls' => [ 5.017, DEFAULT_ON],
+ }],
'deprecated' => [ 5.008, DEFAULT_ON],
'void' => [ 5.008, DEFAULT_OFF],
'recursion' => [ 5.008, DEFAULT_OFF],
@@ -92,7 +93,6 @@ my $tree = {
'experimental::lexical_topic' =>
[ 5.017, DEFAULT_ON ],
}],
-
#'default' => [ 5.008, DEFAULT_ON ],
}],
} ;
diff --git a/t/io/open.t b/t/io/open.t
index e06fc8e..91f1003 100644
--- a/t/io/open.t
+++ b/t/io/open.t
@@ -10,7 +10,7 @@ $| = 1;
use warnings;
use Config;
-plan tests => 121;
+plan tests => 126;
my $Perl = which_perl();
@@ -386,3 +386,24 @@ SKIP: {
ok( eval { $fh->autoflush(1); 1 }, '$fh->autoflush(1) lives' );
ok( $INC{'IO/File.pm'}, "IO::File now loaded" );
}
+
+my $fn = "tmp\0.invalid";
+eval { open(I, $fn); };
+like("$@", qr/^Invalid \\0 character in pathname: tmp/,
+ "die on open with embedded nul in pathnames since 5.18");
+eval { unlink($fn); };
+like("$@", qr/^Invalid \\0 character in pathname: tmp/,
+ "also on unlink");
+eval { chmod(0644, $fn); };
+like("$@", qr/^Invalid \\0 character in pathname: tmp/,
+ "also on chmod");
+eval { glob($fn); };
+like("$@", qr/^Invalid \\0 character in syscall: tmp/,
+ "also on glob");
+
+{
+ no warnings 'safesyscalls';
+ eval { open(I, $fn); };
+ is($@, '',
+ "ignore die on embedded nul with no warnings safesyscalls");
+}
diff --git a/util.c b/util.c
index 2c745bf..fb6cbf5 100644
--- a/util.c
+++ b/util.c
@@ -2010,6 +2010,7 @@ Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
PERL_ARGS_ASSERT_UNLNK;
+ CHECK_PATHNAME(f);
while (PerlLIO_unlink(f) >= 0)
retries++;
return retries ? 0 : -1;
diff --git a/warnings.h b/warnings.h
index d0bf710..1f3f8b0 100644
--- a/warnings.h
+++ b/warnings.h
@@ -93,6 +93,7 @@
#define WARN_EXPERIMENTAL__LEXICAL_SUBS 52
#define WARN_EXPERIMENTAL__LEXICAL_TOPIC 53
#define WARN_EXPERIMENTAL__REGEX_SETS 54
+#define WARN_SAFESYSCALLS 55
#define WARNsize 14
#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125"
--------------1.7.10.4--
|
|
The RT System itself - Status changed from 'new' to 'open' |
From @iabynOn Thu, Mar 21, 2013 at 12:37:27PM -0700, Reini Urban via RT wrote:
Thanks for this. Your description of this this change is a bit unclear; in particular, I'm From what I understand of this patch, it makes the following changes: First in the absence of 'use warnings' (or in the presence of open my $fh, ">", "foo\0bar" return false and sets $! to 'no such file' or some such appropriate Second, in the presence of 'use warnings', it instead causes the open to Is this a correct assessment? Before discussing the detailed implementation on the patch, I think we My own personal opinion is that I like the first part: causing system I'm not very keen on the second part. For a start, it doesn't add that -- |
From @rurbanOn Mar 23, 2013, at 8:54 AM, Dave Mitchell via RT <perlbug-followup@perl.org> wrote:
No, it actually follows the old behavior: silently ignore and go on.
Yes, the die part is correct.
There are four possible reactions: ignore, silently strip, warn and strip, or die. Without warnings or with no warnings 'syscalls' perl behaves as before: ignore. With warnings enabled I went for die, because such a string argument is I explicitly allow typical harmless programmer errors adding another \0 |
From @maukeOops, I accidentally sent this to Reini only when I meant to send it to -------- Original Message -------- On 23.03.2013 15:49, Reini Urban wrote:
I don't understand what you mean by "strip". Something like: my $foo = "XYZ\0ABC"; ?
So it works unlike every other warning category? AFAIK all other
My favorite semantics would be to not treat \0 specially, regardless of The only problem I see with this is that it might break older scripts -- |
From @iabynOn Sat, Mar 23, 2013 at 09:49:12AM -0500, Reini Urban wrote:
Ah I was confused by this: +#define CHECK_SAFESYSCALLS(what,pv) \ where you SETERRNO even when not warning. What purpose does that serve? -- |
From tchrist@perl.com
Hold on. You cannot have a fatal warning without asking for one. A use warnings pragma must never raise an exception simply because you --tom |
From @rjbs* Lukas Mai <plokinom@gmail.com> [2013-03-23T11:34:47]
This is also my feeling on the topic. -- |
From @rurbanOn Sat, Mar 23, 2013 at 7:11 PM, Ricardo Signes
You are right, my mistake. I was fooled by the existing severe I'll ditch the severe warnings category and go to ENOENT + return undef, I'm also not sure if I missed the most important part: nul in pp_require args. |
From @rurbanOn 03/23/2013 10:35 AM, Lukas Mai via RT wrote:
The syscall behind unlink sees only "XYZ", and deletes XYZ if it exists. ...
Agreed.
That's why I said: "I explicitly allow typical harmless programmer -- Working towards a true Modern Perl. |
From @demerphqOn 25 March 2013 15:12, Reini Urban <reini@cpanel.net> wrote:
Reini, on Win32 filenames are stored internally as UTF-16. What affect Yves -- |
From @LeontOn Mon, Mar 25, 2013 at 3:14 PM, demerphq <demerphq@gmail.com> wrote:
Perl uses legacy interfaces on Windows (that is, it accesses the I'd consider this our number one Windows bug (because it screws up Leon |
From @demerphqOn 25 March 2013 15:28, Leon Timmermans <fawaka@gmail.com> wrote:
Im just worried that Reinis null surpression might break something -- |
From @LeontOn Mon, Mar 25, 2013 at 3:34 PM, demerphq <demerphq@gmail.com> wrote:
Well, the second question is "do all non-unix operating systems deal Leon |
From @steve-m-hayLeon Timmermans wrote on 2013-03-25:
It is possible to open Unicode filenames on Windows using Win32API::File (see below). I assume this will at least still work? use Encode qw(encode); my $filename = "\x{65e5}.txt\0"; my $h = CreateFileW($utf16le_filename, GENERIC_WRITE, 0, [], CREATE_NEW, 0, []); |
From @rurbanOn 03/25/2013 09:35 AM, yves orton via RT wrote:
I'll test it. And I'm not sure if -C allows using wide chars (seems to set only -- Working towards a true Modern Perl. |
From @demerphqOn 25 March 2013 15:41, Steve Hay <Steve.Hay@verosoftware.com> wrote:
Is there an open ticket about this bug? (IOW, that Perl cant open -- |
From @steve-m-haydemerphq wrote on 2013-03-25:
Not sure whether there is an RT ticket for this specific issue without |
From @rurbanAttached is the revised patch Check for the nul char in pathnames and string arguments to -- |
From @rurban0001-safesyscalls-check-embedded-nul-in-syscall-args.patchFrom 376abbcc174dc5e9262a4c6a6a2c7862b611fbfd Mon Sep 17 00:00:00 2001
From: Reini Urban <rurban@x-ray.at>
Date: Tue, 12 Mar 2013 19:25:26 +0100
Subject: [PATCH] safesyscalls: check embedded nul in syscall args
Check for the nul char in pathnames and string arguments to
syscalls, return undef and set errno to ENOENT.
Added to the default severe warnings category syscalls.
Strings with embedded \0 chars were prev. ignored in the syscall but
kept in perl. The hidden payloads in these invalid string args may cause
unnoticed security problems, as they are hard to detect, ignored by
the syscalls but kept around in perl PVs.
Allow an ending \0 though, as several modules add a \0 to
such strings without adjusting the length.
Ignored on WinCE since this uses the wide char API.
---
doio.c | 9 ++++++++-
embed.fnc | 4 ++--
ext/File-Glob/Glob.xs | 3 ++-
lib/warnings.pm | 15 +++++++++------
perl.h | 23 +++++++++++++++++++++++
perlio.c | 4 ++++
pod/perldiag.pod | 9 +++++++++
pp_ctl.c | 5 +++++
regen/warnings.pl | 6 +++---
t/io/open.t | 27 ++++++++++++++++++++++++++-
t/lib/warnings/6default | 5 +++++
t/op/require_errors.t | 18 +++++++++++++++++-
t/porting/diag.t | 1 +
warnings.h | 1 +
14 files changed, 115 insertions(+), 15 deletions(-)
diff --git a/doio.c b/doio.c
index 4e8d48a..d6c1f81 100644
--- a/doio.c
+++ b/doio.c
@@ -216,6 +216,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw,
goto say_false;
}
#endif /* USE_STDIO */
+ CHECK_PATHNAME(*svp, FALSE);
name = (SvOK(*svp) || SvGMAGICAL(*svp)) ?
savesvpv (*svp) : savepvs ("");
SAVEFREEPV(name);
@@ -1638,6 +1639,7 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
else {
const char *name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark, --tot);
if (PerlLIO_chmod(name, val))
tot--;
}
@@ -1672,6 +1674,7 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
else {
const char *name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark, --tot);
if (PerlLIO_chown(name, val, val2))
tot--;
}
@@ -1690,6 +1693,7 @@ nothing in the core.
APPLY_TAINT_PROPER();
if (mark == sp)
break;
+ CHECK_SYSCALL(*mark, --tot);
s = SvPVx_const(*++mark, len);
if (*s == '-' && isALPHA(s[1]))
{
@@ -1702,7 +1706,7 @@ nothing in the core.
s += 3;
len -= 3;
}
- if ((val = whichsig_pvn(s, len)) < 0)
+ if ((val = whichsig_pvn(s, len)) < 0)
Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
}
else
@@ -1773,6 +1777,7 @@ nothing in the core.
while (++mark <= sp) {
s = SvPV_nolen_const(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark, --tot);
if (PerlProc_geteuid() || PL_unsafe) {
if (UNLINK(s))
tot--;
@@ -1851,6 +1856,7 @@ nothing in the core.
else {
const char * const name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark, --tot);
#ifdef HAS_FUTIMES
if (utimes(name, (struct timeval *)utbufp))
#else
@@ -2343,6 +2349,7 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
PERL_ARGS_ASSERT_START_GLOB;
+ CHECK_SYSCALL(tmpglob, 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 2f5e089..8c981f2 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2253,7 +2253,7 @@ s |void |printbuf |NN const char *const fmt|NN const char *const s
#endif
#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
@@ -2266,7 +2266,7 @@ s |char* |stdize_locale |NN char* locs
#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/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs
index df5530a..aa2b186 100644
--- a/ext/File-Glob/Glob.xs
+++ b/ext/File-Glob/Glob.xs
@@ -227,7 +227,8 @@ csh_glob(pTHX_ AV *entries, SV *patsv)
assert(SvTYPE(entries) != SVt_PVAV);
sv_upgrade((SV *)entries, SVt_PVAV);
-
+ CHECK_SYSCALL(patsv, TRUE);
+
if (patav) {
I32 items = AvFILLp(patav) + 1;
SV **svp = AvARRAY(patav);
diff --git a/lib/warnings.pm b/lib/warnings.pm
index c0c2cc9..3d9ac00 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -232,10 +232,11 @@ our %Offsets = (
'experimental::lexical_subs'=> 104,
'experimental::lexical_topic'=> 106,
'experimental::regex_sets'=> 108,
+ 'syscalls' => 110,
);
our %Bits = (
- 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..54]
+ '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]
@@ -277,11 +278,12 @@ our %Bits = (
'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]
+ 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x40", # [21..25,55]
'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]
+ 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [55]
'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]
@@ -293,7 +295,7 @@ our %Bits = (
);
our %DeadBits = (
- 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..54]
+ '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]
@@ -335,11 +337,12 @@ our %DeadBits = (
'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]
+ 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x80", # [21..25,55]
'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]
+ 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [55]
'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]
@@ -351,8 +354,8 @@ our %DeadBits = (
);
$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\x15", # [2,52..54,4,22,23,25]
-$LAST_BIT = 110 ;
+$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55", # [2,52..54,4,22,23,25,55]
+$LAST_BIT = 112 ;
$BYTES = 14 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
diff --git a/perl.h b/perl.h
index 5639f1c..2093c48 100644
--- a/perl.h
+++ b/perl.h
@@ -5814,6 +5814,29 @@ 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 CHECK_PATHNAME(pv,r) CHECK_SAFESYSCALLS("pathname",pv,r)
+/* check embedded \0 characters in args for various other syscalls.
+ user and group names, glob. */
+#define CHECK_SYSCALL(pv,r) CHECK_SAFESYSCALLS("syscall",pv,r)
+/* if (CHECK_SYSCALL(pv, return NULL)); */
+#if defined(WIN32) && (defined(UNICODE) || defined(UNDER_CE))
+#define CHECK_SAFESYSCALLS(what,pv,reaction)
+/* TODO: wchar API, so far only used on wince */
+#else
+#define CHECK_SAFESYSCALLS(what,pv,reaction) \
+ if (SvPOK(pv)) { \
+ char *i; \
+ char *p = SvPVX(pv); \
+ if ( (i = strchr(p, 0))&&(i-p)&&((size_t)(i-p)<SvCUR(pv)-1) ) { \
+ SETERRNO(ENOENT, LIB_INVARG); \
+ if (ckWARN_d(WARN_SYSCALLS)) { \
+ ck_warner_d(packWARN(WARN_SYSCALLS), \
+ "Invalid \\0 character in %s: %s\\0%s", what,p,++i); \
+ } return reaction; }}
+#endif
+
#if defined(OEMVS)
#define NO_ENV_ARRAY_IN_MAIN
#endif
diff --git a/perlio.c b/perlio.c
index 097bc49..77e6db3 100644
--- a/perlio.c
+++ b/perlio.c
@@ -310,6 +310,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
return PerlIO_tmpfile();
else {
const char *name = SvPV_nolen_const(*args);
+ CHECK_PATHNAME(*args, NULL);
if (*mode == IoTYPE_NUMERIC) {
fd = PerlLIO_open3(name, imode, perm);
if (fd >= 0)
@@ -2713,6 +2714,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
}
if (imode != -1) {
const char *path = SvPV_nolen_const(*args);
+ CHECK_PATHNAME(*args, NULL);
fd = PerlLIO_open3(path, imode, perm);
}
}
@@ -3027,6 +3029,7 @@ 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;
+ CHECK_PATHNAME(*args, NULL);
PerlIOUnix_refcnt_dec(fileno(s->stdio));
stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
s->stdio);
@@ -3039,6 +3042,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
else {
if (narg > 0) {
const char * const path = SvPV_nolen_const(*args);
+ CHECK_PATHNAME(*args, NULL);
if (*mode == IoTYPE_NUMERIC) {
mode++;
fd = PerlLIO_open3(path, imode, perm);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 8d29e2d..c448208 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2468,6 +2468,15 @@ indicated one isn't. See L<charnames/CUSTOM ALIASES>.
the C<:alias> option to C<use charnames> and the specified character in
the indicated name isn't valid. See L<charnames/CUSTOM ALIASES>.
+=item Invalid \0 character in %s: %s\0%s
+
+(S) Embedded \0 characters in pathnames or other syscall arguments
+create a warning since 5.18. The parts after the \0 were formerly
+ignored by syscalls.
+
+If you know what you are doing you can turn off this warning by
+C<no warnings 'syscalls';>.
+
=item Invalid conversion in %s: "%s"
(W printf) Perl does not understand the given format conversion. See
diff --git a/pp_ctl.c b/pp_ctl.c
index c9d833f..8f4cfbd 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3546,6 +3546,7 @@ S_check_type_and_open(pTHX_ SV *name)
PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
+ CHECK_PATHNAME(name, NULL);
if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
return NULL;
}
@@ -3671,6 +3672,10 @@ PP(pp_require)
name = SvPV_const(sv, len);
if (!(name && len > 0 && *name))
DIE(aTHX_ "Null filename used");
+ CHECK_PATHNAME(sv, Perl_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");
diff --git a/regen/warnings.pl b/regen/warnings.pl
index 94a9843..d8343a9 100644
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -16,7 +16,7 @@
#
# This script is normally invoked from regen.pl.
-$VERSION = '1.02_03';
+$VERSION = '1.02_04';
BEGIN {
require 'regen/regen_lib.pl';
@@ -56,7 +56,8 @@ my $tree = {
'internal' => [ 5.008, DEFAULT_OFF],
'debugging' => [ 5.008, DEFAULT_ON],
'malloc' => [ 5.008, DEFAULT_ON],
- }],
+ 'syscalls' => [ 5.017, DEFAULT_ON],
+ }],
'deprecated' => [ 5.008, DEFAULT_ON],
'void' => [ 5.008, DEFAULT_OFF],
'recursion' => [ 5.008, DEFAULT_OFF],
@@ -92,7 +93,6 @@ my $tree = {
'experimental::lexical_topic' =>
[ 5.017, DEFAULT_ON ],
}],
-
#'default' => [ 5.008, DEFAULT_ON ],
}],
} ;
diff --git a/t/io/open.t b/t/io/open.t
index e06fc8e..d7eaab7 100644
--- a/t/io/open.t
+++ b/t/io/open.t
@@ -10,7 +10,7 @@ $| = 1;
use warnings;
use Config;
-plan tests => 121;
+plan tests => 131;
my $Perl = which_perl();
@@ -386,3 +386,28 @@ SKIP: {
ok( eval { $fh->autoflush(1); 1 }, '$fh->autoflush(1) lives' );
ok( $INC{'IO/File.pm'}, "IO::File now loaded" );
}
+
+# [perl #117265] check for embedded nul in pathnames, allow ending \0 though
+{
+ my $WARN;
+ local $SIG{__WARN__} = sub { $WARN = shift };
+ my $fn = "tmp\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: tmp/,
+ "warn on embedded nul"); $WARN = '';
+ is (unlink($fn), 0);
+ like($WARN, qr/^Invalid \\0 character in pathname: tmp/,
+ "also on unlink"); $WARN = '';
+ is(chmod(0644, $fn), 0);
+ like($WARN, qr/^Invalid \\0 character in pathname: tmp/,
+ "also on chmod"); $WARN = '';
+ is (glob($fn), ());
+ like($WARN, qr/^Invalid \\0 character in syscall: tmp/,
+ "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");
+ }
+}
diff --git a/t/lib/warnings/6default b/t/lib/warnings/6default
index a8aafee..a501961 100644
--- a/t/lib/warnings/6default
+++ b/t/lib/warnings/6default
@@ -119,3 +119,8 @@ no warnings;
}
EXPECT
+########
+# Check if syscalls warn by default
+open(my $i, "foo\0bar");
+EXPECT
+Invalid \0 character in pathname: foo\0bar at - line 2.
diff --git a/t/op/require_errors.t b/t/op/require_errors.t
index e323948..7c102cd 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 => 16);
my $nonfile = tempfile();
@@ -111,3 +111,19 @@ 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: strict\.pm\\0invalid at }, 'nul warning';
+ like $@, qr{^Can't locate strict\.pm\\0invalid: }, 'nul error';
+}
+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 2473e65..c8a3db2 100644
--- a/t/porting/diag.t
+++ b/t/porting/diag.t
@@ -476,6 +476,7 @@ Can't coerce readonly %s to string in %s
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 d0bf710..cff4ed3 100644
--- a/warnings.h
+++ b/warnings.h
@@ -93,6 +93,7 @@
#define WARN_EXPERIMENTAL__LEXICAL_SUBS 52
#define WARN_EXPERIMENTAL__LEXICAL_TOPIC 53
#define WARN_EXPERIMENTAL__REGEX_SETS 54
+#define WARN_SYSCALLS 55
#define WARNsize 14
#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125"
--
1.7.10.4
|
From @tonycozOn Tue Mar 26 14:29:41 2013, rurban wrote:
Hi Reini, I've had a look over this patch, but I can see it's treating a failure tony@mars:.../git/perl$ ./perl -Wle 'print unlink "def", "abc\0def", "ghi"' I've attached a version of the patch updated to work with blead. Tony |
From @tonycoz0001-safesyscalls-check-embedded-nul-in-syscall-args.patchFrom ae9a37770ca59a6c76cc784bada78650c329bde1 Mon Sep 17 00:00:00 2001
From: Reini Urban <rurban@x-ray.at>
Date: Tue, 12 Mar 2013 19:25:26 +0100
Subject: [PATCH] safesyscalls: check embedded nul in syscall args
Check for the nul char in pathnames and string arguments to
syscalls, return undef and set errno to ENOENT.
Added to the default severe warnings category syscalls.
Strings with embedded \0 chars were prev. ignored in the syscall but
kept in perl. The hidden payloads in these invalid string args may cause
unnoticed security problems, as they are hard to detect, ignored by
the syscalls but kept around in perl PVs.
Allow an ending \0 though, as several modules add a \0 to
such strings without adjusting the length.
Ignored on WinCE since this uses the wide char API.
---
doio.c | 9 +-
embed.fnc | 4 +-
ext/File-Glob/Glob.pm | 2 +-
ext/File-Glob/Glob.xs | 3 +-
lib/warnings.pm | 237 ++++++++++++++++++++++++-----------------------
perl.h | 23 +++++
perlio.c | 4 +
pod/perldiag.pod | 9 ++
pod/perllexwarn.pod | 2 +
pp_ctl.c | 5 +
regen/warnings.pl | 7 +-
t/io/open.t | 27 +++++-
t/lib/warnings/6default | 5 +
t/op/caller.t | 4 +-
t/op/require_errors.t | 18 +++-
t/porting/diag.t | 1 +
warnings.h | 7 +-
17 files changed, 235 insertions(+), 132 deletions(-)
diff --git a/doio.c b/doio.c
index b24a5b4..7b631c2 100644
--- a/doio.c
+++ b/doio.c
@@ -216,6 +216,7 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw,
goto say_false;
}
#endif /* USE_STDIO */
+ CHECK_PATHNAME(*svp, FALSE);
name = (SvOK(*svp) || SvGMAGICAL(*svp)) ?
savesvpv (*svp) : savepvs ("");
SAVEFREEPV(name);
@@ -1660,6 +1661,7 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
else {
const char *name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark, --tot);
if (PerlLIO_chmod(name, val))
tot--;
}
@@ -1694,6 +1696,7 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
else {
const char *name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark, --tot);
if (PerlLIO_chown(name, val, val2))
tot--;
}
@@ -1712,6 +1715,7 @@ nothing in the core.
APPLY_TAINT_PROPER();
if (mark == sp)
break;
+ CHECK_SYSCALL(*mark, --tot);
s = SvPVx_const(*++mark, len);
if (*s == '-' && isALPHA(s[1]))
{
@@ -1724,7 +1728,7 @@ nothing in the core.
s += 3;
len -= 3;
}
- if ((val = whichsig_pvn(s, len)) < 0)
+ if ((val = whichsig_pvn(s, len)) < 0)
Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
}
else
@@ -1795,6 +1799,7 @@ nothing in the core.
while (++mark <= sp) {
s = SvPV_nolen_const(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark, --tot);
if (PerlProc_geteuid() || PL_unsafe) {
if (UNLINK(s))
tot--;
@@ -1873,6 +1878,7 @@ nothing in the core.
else {
const char * const name = SvPV_nomg_const_nolen(*mark);
APPLY_TAINT_PROPER();
+ CHECK_PATHNAME(*mark, --tot);
#ifdef HAS_FUTIMES
if (utimes(name, (struct timeval *)utbufp))
#else
@@ -2365,6 +2371,7 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
PERL_ARGS_ASSERT_START_GLOB;
+ CHECK_SYSCALL(tmpglob, 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 a906eae..070df24 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2257,7 +2257,7 @@ s |void |printbuf |NN const char *const fmt|NN const char *const s
#endif
#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
@@ -2270,7 +2270,7 @@ s |char* |stdize_locale |NN char* locs
#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/ext/File-Glob/Glob.pm b/ext/File-Glob/Glob.pm
index 379d7f0..3001679 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 df5530a..aa2b186 100644
--- a/ext/File-Glob/Glob.xs
+++ b/ext/File-Glob/Glob.xs
@@ -227,7 +227,8 @@ csh_glob(pTHX_ AV *entries, SV *patsv)
assert(SvTYPE(entries) != SVt_PVAV);
sv_upgrade((SV *)entries, SVt_PVAV);
-
+ CHECK_SYSCALL(patsv, TRUE);
+
if (patav) {
I32 items = AvFILLp(patav) + 1;
SV **svp = AvARRAY(patav);
diff --git a/lib/warnings.pm b/lib/warnings.pm
index 7d988cb..ad32517 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,133 @@ our %Offsets = (
'experimental::lexical_topic'=> 106,
'experimental::regex_sets'=> 108,
'experimental::smartmatch'=> 110,
+ '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\x00", # [5..11]
+ '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\x01", # [21..25,56]
+ '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\x00", # [5..11]
+ '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\x02", # [21..25,56]
+ '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\x01", # [2,52..55,4,22,23,25,56]
+$LAST_BIT = 114 ;
+$BYTES = 15 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
diff --git a/perl.h b/perl.h
index 613fd3c..fca7b22 100644
--- a/perl.h
+++ b/perl.h
@@ -5650,6 +5650,29 @@ 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 CHECK_PATHNAME(pv,r) CHECK_SAFESYSCALLS("pathname",pv,r)
+/* check embedded \0 characters in args for various other syscalls.
+ user and group names, glob. */
+#define CHECK_SYSCALL(pv,r) CHECK_SAFESYSCALLS("syscall",pv,r)
+/* if (CHECK_SYSCALL(pv, return NULL)); */
+#if defined(WIN32) && (defined(UNICODE) || defined(UNDER_CE))
+#define CHECK_SAFESYSCALLS(what,pv,reaction)
+/* TODO: wchar API, so far only used on wince */
+#else
+#define CHECK_SAFESYSCALLS(what,pv,reaction) \
+ if (SvPOK(pv)) { \
+ char *i; \
+ char *p = SvPVX(pv); \
+ if ( (i = strchr(p, 0))&&(i-p)&&((size_t)(i-p)<SvCUR(pv)-1) ) { \
+ SETERRNO(ENOENT, LIB_INVARG); \
+ if (ckWARN_d(WARN_SYSCALLS)) { \
+ ck_warner_d(packWARN(WARN_SYSCALLS), \
+ "Invalid \\0 character in %s: %s\\0%s", what,p,++i); \
+ } return reaction; }}
+#endif
+
#if defined(OEMVS)
#define NO_ENV_ARRAY_IN_MAIN
#endif
diff --git a/perlio.c b/perlio.c
index 2e5a77d..01fb764 100644
--- a/perlio.c
+++ b/perlio.c
@@ -310,6 +310,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
return PerlIO_tmpfile();
else {
const char *name = SvPV_nolen_const(*args);
+ CHECK_PATHNAME(*args, NULL);
if (*mode == IoTYPE_NUMERIC) {
fd = PerlLIO_open3(name, imode, perm);
if (fd >= 0)
@@ -2719,6 +2720,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
}
if (imode != -1) {
const char *path = SvPV_nolen_const(*args);
+ CHECK_PATHNAME(*args, NULL);
fd = PerlLIO_open3(path, imode, perm);
}
}
@@ -3033,6 +3035,7 @@ 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;
+ CHECK_PATHNAME(*args, NULL);
PerlIOUnix_refcnt_dec(fileno(s->stdio));
stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
s->stdio);
@@ -3045,6 +3048,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
else {
if (narg > 0) {
const char * const path = SvPV_nolen_const(*args);
+ CHECK_PATHNAME(*args, NULL);
if (*mode == IoTYPE_NUMERIC) {
mode++;
fd = PerlLIO_open3(path, imode, perm);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 80fafaf..60d436f 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2496,6 +2496,15 @@ 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: %s\0%s
+
+(S) Embedded \0 characters in pathnames or other syscall arguments
+create a warning since 5.18. The parts after the \0 were formerly
+ignored by syscalls.
+
+If you know what you are doing you can turn off this warning by
+C<no warnings '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 b193e3c..97d77f7 100644
--- a/pod/perllexwarn.pod
+++ b/pod/perllexwarn.pod
@@ -281,6 +281,8 @@ will be lost.
| +- internal
| |
| +- malloc
+ | |
+ | +- syscalls
|
+- signal
|
diff --git a/pp_ctl.c b/pp_ctl.c
index f68336a..488fcf3 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3590,6 +3590,7 @@ S_check_type_and_open(pTHX_ SV *name)
PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
+ CHECK_PATHNAME(name, NULL);
if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
return NULL;
}
@@ -3742,6 +3743,10 @@ PP(pp_require)
name = SvPV_const(sv, len);
if (!(name && len > 0 && *name))
DIE(aTHX_ "Null filename used");
+ CHECK_PATHNAME(sv, Perl_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/regen/warnings.pl b/regen/warnings.pl
index 72d9a0b..3265712 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';
@@ -59,7 +59,8 @@ my $tree = {
'internal' => [ 5.008, DEFAULT_OFF],
'debugging' => [ 5.008, DEFAULT_ON],
'malloc' => [ 5.008, DEFAULT_ON],
- }],
+ 'syscalls' => [ 5.017, 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 ef56dda..94601d0 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 => 132;
my $Perl = which_perl();
@@ -391,3 +391,28 @@ 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 $fn = "tmp\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: tmp/,
+ "warn on embedded nul"); $WARN = '';
+ is (unlink($fn), 0);
+ like($WARN, qr/^Invalid \\0 character in pathname: tmp/,
+ "also on unlink"); $WARN = '';
+ is(chmod(0644, $fn), 0);
+ like($WARN, qr/^Invalid \\0 character in pathname: tmp/,
+ "also on chmod"); $WARN = '';
+ is (glob($fn), ());
+ like($WARN, qr/^Invalid \\0 character in syscall: tmp/,
+ "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");
+ }
+}
diff --git a/t/lib/warnings/6default b/t/lib/warnings/6default
index a8aafee..a501961 100644
--- a/t/lib/warnings/6default
+++ b/t/lib/warnings/6default
@@ -119,3 +119,8 @@ no warnings;
}
EXPECT
+########
+# Check if syscalls warn by default
+open(my $i, "foo\0bar");
+EXPECT
+Invalid \0 character in pathname: foo\0bar at - line 2.
diff --git a/t/op/caller.t b/t/op/caller.t
index c37a6ed..09728d3 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 e323948..7c102cd 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 => 16);
my $nonfile = tempfile();
@@ -111,3 +111,19 @@ 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: strict\.pm\\0invalid at }, 'nul warning';
+ like $@, qr{^Can't locate strict\.pm\\0invalid: }, 'nul error';
+}
+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 729abaf..17aca0f 100644
--- a/t/porting/diag.t
+++ b/t/porting/diag.t
@@ -461,6 +461,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 5c40d5c..531876f 100644
--- a/warnings.h
+++ b/warnings.h
@@ -94,10 +94,11 @@
#define WARN_EXPERIMENTAL__LEXICAL_TOPIC 53
#define WARN_EXPERIMENTAL__REGEX_SETS 54
#define WARN_EXPERIMENTAL__SMARTMATCH 55
+#define WARN_SYSCALLS 56
-#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"
+#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)
--
1.7.10.4
|
From @rurbanOn 06/27/2013 01:45 AM, Tony Cook via RT wrote:
Great, Thanks for the improvements. Can someone please apply it now. -- Working towards a true Modern Perl. |
From @LeontOn Thu, Jun 27, 2013 at 3:41 PM, Reini Urban <reini@cpanel.net> wrote:
I think having macros called CHECK_<whatever> that return from the I also think we shouldn't turn this warning on by default without some Leon |
From @rurbanOn 06/27/2013 10:52 AM, Leon Timmermans via RT wrote:
Have you got a better idea? if (CHECK_SAFESYSCALL(pv)) return NULL; were the alternatives.
We return with undef from syscalling functions with a wrong name, I think turning on this warning by default makes sense: It only warns on wrong user data, not on code errors. With require I die immediately. ~ grep DEFAULT_ON regen/warnings.pl 'inplace' => [ 5.008, DEFAULT_ON], -- |
From @tonycozHi Reini, On Thu Jun 27 06:42:14 2013, reini@cpanel.net wrote:
I only updated it to merge cleanly with blead, I didn't fix the That needs to be fixed. I also missed updating the version number for DEFAULT_ON in warnings.pl. Tony [1] and related problems in other ops, that was just the simplest |
From @cpansproutOn Sat Mar 23 17:12:20 2013, perl.p5p@rjbs.manxome.org wrote:
And mine, too. Just to be clear, in case we misunderstand each other, -- Father Chrysostomos |
From @rjbs* Father Chrysostomos via RT <perlbug-followup@perl.org> [2013-06-28T02:56:27]
Exactamo. Here is the only thing that gives me a little pause: I check those return open ... or die "couldn't open <$filename>: $!"; And if $filename is "foo.txt\0" then the error message is confusing... -- |
|
@tonycoz - Status changed from 'open' to 'resolved' |
From @rurbanATT: RANT below.... On Thu Jul 18 22:33:53 2013, tonyc wrote:
In my entire career I never saw those usecases.
Disagree: Shutting up the attempt is okay for basic security,
Right. Always blame the user.
To repeat why I said p5p doesn't care much about security: Now finally after 15 years of p5p module laxness require dies on And you still blame the user, not yourself. On the other hand this simple non-security, only dummy windows/mac So p5p cares more to bitch at dummies (complaint discussed 1998, fatality finally added BTW: The module loader modules which do exist on CPAN also do not check p5p does not help, CPAN does not help, perldoc perlsec stays silent. |
From @b2gillsOn Wed, Aug 28, 2013 at 4:07 PM, Reini Urban via RT
There can not be a possible security problem at the point of calling The only possible problem we could possibly have, is not appending There could still be some problems with a Perl program which exhibits this I do agree that it should warn though (optionally). Only because the program
This would have a slightly higher risk, if `require` did anything I would like to point out that sending these warnings out on STDERR |
From @cpansproutOn Sun Aug 25 21:39:01 2013, tonyc wrote:
I see several problems with that commit: PERL_STATIC_INLINE bool PERL_ARGS_ASSERT_IS_SAFE_SYSCALL; if (SvPOK(pv) && SvCUR(pv) >= 1) { What if the argument is not SvPOK? What if it stringifies to something In Glob.xs, the pattern is parsed, and only after the parsing is the If a glob pattern is, say, "a{\0,}b*" it should still return all files Having the check in csh_glob instead of doglob makes it apply only to -- Father Chrysostomos |
From @tonycozOn Wed Aug 28 23:10:28 2013, sprout wrote:
I've pushed a fix for this to tonyc/more-safesyscalls. I misunderstood how "" overloading worked.
The change above now does the \0 check before the pattern check.
It returned nothing before the change.
While that might be useful, neither csh_glob nor bsd_glob handle NUL in Both stop at the NUL: $ ~/perl/5.18.1-thr/bin/perl -MFile::Glob=csh_glob -le 'print I think fixing that is beyond the scope of this ticket.
The branch above fixes that. Tony |
|
@tonycoz - Status changed from 'resolved' to 'open' |
From @cpansproutOn Mon Sep 02 23:44:13 2013, tonyc wrote:
Thank you. I still see a problem with the commit entitled ‘[perl #117265] do most Your patch changes that if the argument contains a null. -- Father Chrysostomos |
From @tonycozOn Tue Sep 03 06:04:14 2013, sprout wrote:
I've updated the branch to fix that. Tony |
From @cpansproutOn Tue Sep 03 17:06:22 2013, tonyc wrote:
I see no more problems with it. -- Father Chrysostomos |
From @craigberryOn Tue, Sep 3, 2013 at 7:56 PM, Father Chrysostomos via RT
I see one more. I haven't actually tried the new branch yet, but I When using File::Glob as unixy Perl does, we see only one warning: $ ./perl -Ilib -we 'glob(qq/foo\0bar/);' But when using "external" glob (which just means "something besides $ ./miniperl -Ilib -we 'glob(qq/foo\0bar/);' There are several tests (t/io/open, t/op/require_errors, and Not sure what the right thing to do is. Could be fiddling with the This doesn't preclude merging the new branch into blead as the tests |
From @cpansproutOn Tue Sep 03 19:57:43 2013, craig.a.berry@gmail.com wrote:
miniperl is affected on all platforms. $ ./miniperl -we 'glob "\0a"'
start_glob (in doio.c) is not part of the API. We can change it to -- Father Chrysostomos |
From @ikegamiOn Fri, Jul 19, 2013 at 1:33 AM, Tony Cook via RT <perlbug-followup@perl.org
Non-issue. You should be using unpack 'Z100' instead of unpack 'a100'. Now I'm not saying this is good code, but it's a possible case. In fact, I'd call that buggy code. It expects Perl to work with a file I don't know why this is just getting a warning?! Why is NUL treated |
From @cpansproutOn Tue Sep 03 20:43:52 2013, ikegami@adaelis.com wrote:
I agree there shouldn’t be a warning. I thought Ricardo thought so, too. -- Father Chrysostomos |
From @tonycozOn Tue Sep 03 20:09:31 2013, sprout wrote:
I moved the warning closer to where the failure occurs instead. Tony |
From @tonycozOn Wed Sep 04 06:14:40 2013, sprout wrote:
I discussed it in IRC with Ricardo, he only objects to default-on or Of course, you'll only ever see this warning if you try to use a string Tony |
|
@tonycoz - Status changed from 'open' to 'resolved' |
From @craigberryOn Mon, Sep 9, 2013 at 12:39 AM, Tony Cook via RT
tonyc++ for persisting with this (not so) little project through all t/io/open and t/lib/warnings now pass on VMS, but t/op/require_errors $ perl -we "@INC = qq/lib\0invalid/; require 'foo';" where you can see the warning is missing, a warning that should look like: $ ./perl -Ilib -we '@INC = qq/lib\0invalid/; require q/foo/;' The reason we don't get the warning is that (on VMS only) the http://perl5.git.perl.org/perl.git/blob/HEAD:/pp_ctl.c#l3972 I believe the __SYMBIAN32__ code path just under the VMS path will One possible fix would be to check the directory itself before ---- pp_ctl.c;-0 2013-09-10 10:19:04 -0500 + if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require")) That works: $ perl -we "@INC = qq/lib\0invalid/; require 'foo';" That will need an adjustment to require_errors.t and more testing than Oh, and I've been meaning to ask, why don't we put these checks in |
|
@tonycoz - Status changed from 'resolved' to 'open' |
From @cpansproutOn Sat Sep 14 15:45:17 2013, craig.a.berry@gmail.com wrote:
@INC can be modified at run time, so how would that help? -- Father Chrysostomos |
From @craigberryOn Sun, Sep 15, 2013 at 1:26 AM, Father Chrysostomos via RT
Sorry, I guess I was thinking of %ENV where run-time modifications do |
From @tonycozOn Sat Sep 14 15:45:17 2013, craig.a.berry@gmail.com wrote:
That looks sensible. Maybe the "library search path", but that may be more confusing than not Tony |
From @craigberryOn Sun, Sep 15, 2013 at 10:50 PM, Tony Cook via RT
Thanks. I've pushed it as ddc65b6.
I didn't see any other warnings that felt the need to elaborate on |
|
@tonycoz - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#117265 (status was 'resolved')
Searchable as RT117265$
The text was updated successfully, but these errors were encountered: