[PATCH] move Win32's $^X code to where all other OSes' $^X code lives #15066
Comments
From @bulk88Created by @bulk882 patches attached. This patch came from research on EUMM commit "MM_Unix::find_perl() dont I attached syscall logs before and after of how EUMM searches for the Perl Info |
From @bulk88"Time of Day","Process Name","PID","Operation","Result","Path","Detail" |
From @bulk88"Time of Day","Process Name","PID","Operation","Result","Path","Detail" |
From @bulk880001-Perl_set_caret_X-gv_fetch-with-GV_ADD-can-t-return-N.patchFrom ab4e5d9a359813234cd516f8492eb0a218819b10 Mon Sep 17 00:00:00 2001
From: Daniel Dragan <bulk88@hotmail.com>
Date: Fri, 27 Nov 2015 22:29:49 -0500
Subject: [PATCH 1/2] Perl_set_caret_X gv_fetch with GV_ADD can't return NULL
The GV will be created if it doesn't exist. Remove the branch for smaller
code size.
---
caretx.c | 130 +++++++++++++++++++++++++++++++--------------------------------
1 file changed, 64 insertions(+), 66 deletions(-)
diff --git a/caretx.c b/caretx.c
index 9366bc4..fe884e4 100644
--- a/caretx.c
+++ b/caretx.c
@@ -53,85 +53,83 @@
void
Perl_set_caret_X(pTHX) {
GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
- if (tmpgv) {
- SV *const caret_x = GvSV(tmpgv);
+ SV *const caret_x = GvSV(tmpgv);
#if defined(OS2)
- sv_setpv(caret_x, os2_execname(aTHX));
+ sv_setpv(caret_x, os2_execname(aTHX));
#else
# ifdef USE_KERN_PROC_PATHNAME
- size_t size = 0;
- int mib[4];
- mib[0] = CTL_KERN;
- mib[1] = KERN_PROC;
- mib[2] = KERN_PROC_PATHNAME;
- mib[3] = -1;
-
- if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
- && size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
- sv_grow(caret_x, size);
-
- if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
- && size > 2) {
- SvPOK_only(caret_x);
- SvCUR_set(caret_x, size - 1);
- SvTAINT(caret_x);
- return;
- }
+ size_t size = 0;
+ int mib[4];
+ mib[0] = CTL_KERN;
+ mib[1] = KERN_PROC;
+ mib[2] = KERN_PROC_PATHNAME;
+ mib[3] = -1;
+
+ if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
+ && size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
+ sv_grow(caret_x, size);
+
+ if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
+ && size > 2) {
+ SvPOK_only(caret_x);
+ SvCUR_set(caret_x, size - 1);
+ SvTAINT(caret_x);
+ return;
}
+ }
# elif defined(USE_NSGETEXECUTABLEPATH)
- char buf[1];
- uint32_t size = sizeof(buf);
-
- _NSGetExecutablePath(buf, &size);
- if (size < MAXPATHLEN * MAXPATHLEN) {
- sv_grow(caret_x, size);
- if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
- char *const tidied = realpath(SvPVX(caret_x), NULL);
- if (tidied) {
- sv_setpv(caret_x, tidied);
- free(tidied);
- } else {
- SvPOK_only(caret_x);
- SvCUR_set(caret_x, size);
- }
- return;
+ char buf[1];
+ uint32_t size = sizeof(buf);
+
+ _NSGetExecutablePath(buf, &size);
+ if (size < MAXPATHLEN * MAXPATHLEN) {
+ sv_grow(caret_x, size);
+ if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
+ char *const tidied = realpath(SvPVX(caret_x), NULL);
+ if (tidied) {
+ sv_setpv(caret_x, tidied);
+ free(tidied);
+ } else {
+ SvPOK_only(caret_x);
+ SvCUR_set(caret_x, size);
}
+ return;
}
+ }
# elif defined(HAS_PROCSELFEXE)
- char buf[MAXPATHLEN];
- SSize_t len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
- /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
- * it is impossible to know whether the result was truncated. */
+ char buf[MAXPATHLEN];
+ SSize_t len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
+ /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
+ * it is impossible to know whether the result was truncated. */
- if (len != -1) {
- buf[len] = '\0';
- }
+ if (len != -1) {
+ buf[len] = '\0';
+ }
- /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
- includes a spurious NUL which will cause $^X to fail in system
- or backticks (this will prevent extensions from being built and
- many tests from working). readlink is not meant to add a NUL.
- Normal readlink works fine.
- */
- if (len > 0 && buf[len-1] == '\0') {
- len--;
- }
+ /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
+ includes a spurious NUL which will cause $^X to fail in system
+ or backticks (this will prevent extensions from being built and
+ many tests from working). readlink is not meant to add a NUL.
+ Normal readlink works fine.
+ */
+ if (len > 0 && buf[len-1] == '\0') {
+ len--;
+ }
- /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
- returning the text "unknown" from the readlink rather than the path
- to the executable (or returning an error from the readlink). Any
- valid path has a '/' in it somewhere, so use that to validate the
- result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
- */
- if (len > 0 && memchr(buf, '/', len)) {
- sv_setpvn(caret_x, buf, len);
- return;
- }
+ /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
+ returning the text "unknown" from the readlink rather than the path
+ to the executable (or returning an error from the readlink). Any
+ valid path has a '/' in it somewhere, so use that to validate the
+ result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
+ */
+ if (len > 0 && memchr(buf, '/', len)) {
+ sv_setpvn(caret_x, buf, len);
+ return;
+ }
# endif
- /* Fallback to this: */
- sv_setpv(caret_x, PL_origargv[0]);
+ /* Fallback to this: */
+ sv_setpv(caret_x, PL_origargv[0]);
#endif
- }
}
/*
--
1.9.5.msysgit.1
|
From @bulk880002-move-Win32-s-X-code-to-where-all-other-OSes-X-code-l.patchFrom be580dbc342ead956851b045094a06830b31a9e9 Mon Sep 17 00:00:00 2001
From: Daniel Dragan <bulk88@hotmail.com>
Date: Sat, 28 Nov 2015 00:29:17 -0500
Subject: [PATCH 2/2] move Win32's $^X code to where all other OSes' $^X code
lives
Back when the code in perllib.c was first added in 1999, in
commit 80252599d4 the large define tree function that today in 2015 is
Perl_set_caret_X was an unremarkable single statement
http://perl5.git.perl.org/perl.git/blob/80252599d4b7fb26eec4e3a0f451b4387c5dcc19:/perl.c#l2658
Over the years Perl_set_caret_X grew and grew with OS specific code. Move
the Win32 $^X code to match how all the other OSes do it. Fix a problem
where full perl's $^X is always absolute because perl5**.dll uses
GetModuleFileNameW in perllib.c, but miniperl's $^X is always a relative
path because it's coming from libc/command prompt/make tool/make_ext.pl.
Win32 miniperl's $^X being relative causes inefficiencies in EUMM as a
relative $^X is wrong the moment chdir executes in any perl process.
EUMM contains code to search PATH and some other places to guess/figure out
the absolute patch to the current perl to write the absolute perl path
into the makefile. By making $^X absolute on all Win32 perl build variants,
this find absolute perl path code won't execute in EUMM. It also harmonizes
behavior with other OSes and between Win32 mini and full perl. See details
in RT ticket for this patch.
---
caretx.c | 8 ++++++++
win32/perllib.c | 11 -----------
2 files changed, 8 insertions(+), 11 deletions(-)
diff --git a/caretx.c b/caretx.c
index fe884e4..67b8418 100644
--- a/caretx.c
+++ b/caretx.c
@@ -126,6 +126,14 @@ Perl_set_caret_X(pTHX) {
sv_setpvn(caret_x, buf, len);
return;
}
+# elif defined(WIN32)
+ char *ansi;
+ WCHAR widename[MAX_PATH];
+ GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
+ ansi = win32_ansipath(widename);
+ sv_setpv(caret_x, ansi);
+ win32_free(ansi);
+ return;
# endif
/* Fallback to this: */
sv_setpv(caret_x, PL_origargv[0]);
diff --git a/win32/perllib.c b/win32/perllib.c
index 0e44a24..cf7bf56 100644
--- a/win32/perllib.c
+++ b/win32/perllib.c
@@ -211,14 +211,8 @@ RunPerl(int argc, char **argv, char **env)
{
int exitstatus;
PerlInterpreter *my_perl, *new_perl = NULL;
- char *arg0 = argv[0];
- char *ansi = NULL;
bool use_environ = (env == environ);
- WCHAR widename[MAX_PATH];
- GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
- argv[0] = ansi = win32_ansipath(widename);
-
#ifdef PERL_GLOBAL_STRUCT
#define PERLVAR(prefix,var,type) /**/
#define PERLVARA(prefix,var,type) /**/
@@ -269,11 +263,6 @@ RunPerl(int argc, char **argv, char **env)
}
#endif
- /* Some RTLs may want to free argv[] after main() returns. */
- argv[0] = arg0;
- if (ansi)
- win32_free(ansi);
-
PERL_SYS_TERM();
return (exitstatus);
--
1.9.5.msysgit.1
|
From @bulk88On Fri Nov 27 21:45:50 2015, bulk88 wrote:
I will also note the patch cleans up some risky behavior in modifying libc's argv, since the C standards do not specify the type of memory that argv array, or the pointers in the array are allocated from. http://stackoverflow.com/questions/25737434/is-argvn-writable It could all be a static global buffer, or the start of a malloc block, or a pointer into a malloc block, or a non-libc-non-malloc memory allocator (HeapAlloc and friends with a random private heap pool). Previous the original pointer from libc was saved and then restored. Here is an excerpt from a commit that mentions the high risk behavior http://perl5.git.perl.org/perl.git/commitdiff/aa2b96eccca93a6fe7c95af71c0b4a027561512b - This risky code of patching argv is removed with this patch. Win32 perl libperl embedders will probably see a change in -- |
From @tonycozOn Fri Nov 27 21:45:50 2015, bulk88 wrote:
Thanks, applied as eb4e1ba and 7175d76. Tony |
|
The RT System itself - Status changed from 'new' to 'open' |
|
@tonycoz - Status changed from 'open' to 'pending release' |
From @khwilliamsonThank you for submitting this report. You have helped make Perl better. Perl 5.24.0 may be downloaded via https://metacpan.org/release/RJBS/perl-5.24.0 |
|
@khwilliamson - Status changed from 'pending release' to 'resolved' |
Migrated from rt.perl.org#126753 (status was 'resolved')
Searchable as RT126753$
The text was updated successfully, but these errors were encountered: