This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move the function to set $^X to its own file
authorPeter Martini <PeterCMartini@GMail.com>
Sat, 2 Nov 2013 00:12:53 +0000 (20:12 -0400)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 4 Nov 2013 22:07:33 +0000 (14:07 -0800)
This also moves the indirect dependency on stdbool.h to its
own file, rather than being pulled in for all of perl.c, for
those cases where one may want to test using other definitions
of bool.

MANIFEST
Makefile.SH
caretx.c [new file with mode: 0644]
embed.fnc
embed.h
perl.c
perl.h
proto.h

index 2d94da4..5494384 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3,6 +3,7 @@ AUTHORS                 Contact info for contributors
 autodoc.pl             Creates pod/perlintern.pod and pod/perlapi.pod
 av.c                   Array value code
 av.h                   Array value header
+caretx.c               C file to create $^X
 cflags.SH              A script that emits C compilation flags per file
 Changes                        Describe how to peruse changes between releases
 charclass_invlists.h   Compiled-in inversion lists
index 25dcb81..bbd3313 100755 (executable)
@@ -487,7 +487,7 @@ h = $(h1) $(h2) $(h3) $(h4) $(h5) $(h6)
 c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c mro.c perl.c
 c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c
 c3 = taint.c toke.c util.c deb.c run.c universal.c pad.c globals.c keywords.c
-c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c
+c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c caretx.c
 c5 = $(madlysrc) $(mallocsrc)
 
 c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c opmini.c perlmini.c
@@ -496,7 +496,7 @@ obj0 = op$(OBJ_EXT) perl$(OBJ_EXT)
 obj0mini = perlmini$(OBJ_EXT) opmini$(OBJ_EXT) miniperlmain$(OBJ_EXT)
 obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT) mro$(OBJ_EXT) keywords$(OBJ_EXT)
 obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
-obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) mathoms$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT)
+obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) mathoms$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT) caretx$(OBJ_EXT)
 
 minindt_obj = $(obj0mini) $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
 mini_obj = $(minindt_obj) $(MINIDTRACE_O)
diff --git a/caretx.c b/caretx.c
new file mode 100644 (file)
index 0000000..184c7d0
--- /dev/null
+++ b/caretx.c
@@ -0,0 +1,128 @@
+/*    caretx.c
+ *
+ *    Copyright (C) 2013
+ *     by Larry Wall and others
+ *
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ *     TODO: Quote
+ */
+
+/* This file contains a single function, set_caret_X, to set the $^X
+ * variable.  It's only used in perl.c, but has various OS dependencies,
+ * so its been moved to its own file to reduce header pollution.
+ * See RT 120314 for details.
+ */
+
+#if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
+#  define USE_SITECUSTOMIZE
+#endif
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef NETWARE
+#include "nwutil.h"
+#endif
+
+#ifdef USE_KERN_PROC_PATHNAME
+#  include <sys/sysctl.h>
+#endif
+
+#ifdef USE_NSGETEXECUTABLEPATH
+# include <mach-o/dyld.h>
+#endif
+
+void
+Perl_set_caret_X(pTHX) {
+    dVAR;
+    GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
+    if (tmpgv) {
+        SV *const caret_x = GvSV(tmpgv);
+#if defined(OS2)
+        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;
+            }
+        }
+#  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;
+            }
+        }
+#  elif defined(HAS_PROCSELFEXE)
+        char buf[MAXPATHLEN];
+        int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
+
+        /* 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;
+        }
+#  endif
+        /* Fallback to this:  */
+        sv_setpv(caret_x, PL_origargv[0]);
+#endif
+    }
+}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: nil
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 et:
+ */
index dc9f17b..7d50d0b 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1261,6 +1261,8 @@ Apd       |NV     |scan_oct       |NN const char* start|STRLEN len|NN STRLEN* retlen
 AMpd   |OP*    |op_scope       |NULLOK OP* o
 Ap     |char*  |screaminstr    |NN SV *bigstr|NN SV *littlestr|I32 start_shift \
                                |I32 end_shift|NN I32 *old_posp|I32 last
+: Only used by perl.c/miniperl.c, but defined in caretx.c
+px     |void   |set_caret_X
 Apd    |void   |setdefout      |NN GV* gv
 Ap     |HEK*   |share_hek      |NN const char* str|I32 len|U32 hash
 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
diff --git a/embed.h b/embed.h
index 3dd7978..eb94543 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define sawparens(a)           Perl_sawparens(aTHX_ a)
 #define scalar(a)              Perl_scalar(aTHX_ a)
 #define scalarvoid(a)          Perl_scalarvoid(aTHX_ a)
+#define set_caret_X()          Perl_set_caret_X(aTHX)
 #define sub_crush_depth(a)     Perl_sub_crush_depth(aTHX_ a)
 #define sv_2num(a)             Perl_sv_2num(aTHX_ a)
 #define sv_clean_all()         Perl_sv_clean_all(aTHX)
diff --git a/perl.c b/perl.c
index 15adb8a..6939f86 100644 (file)
--- a/perl.c
+++ b/perl.c
 #include "nwutil.h"    
 #endif
 
-#ifdef USE_KERN_PROC_PATHNAME
-#  include <sys/sysctl.h>
-#endif
-
 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 #  ifdef I_SYSUIO
 #    include <sys/uio.h>
@@ -1418,85 +1414,6 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
     ++PL_exitlistlen;
 }
 
-STATIC void
-S_set_caret_X(pTHX) {
-    dVAR;
-    GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
-    if (tmpgv) {
-       SV *const caret_x = GvSV(tmpgv);
-#if defined(OS2)
-       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;
-           }
-       }
-#  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;
-           }
-       }
-#  elif defined(HAS_PROCSELFEXE)
-       char buf[MAXPATHLEN];
-       int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
-
-       /* 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;
-       }
-#  endif
-       /* Fallback to this:  */
-       sv_setpv(caret_x, PL_origargv[0]);
-#endif
-    }
-}
-
 /*
 =for apidoc perl_parse
 
@@ -1646,7 +1563,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
        init_ids();
        assert (!TAINT_get);
        TAINT;
-       S_set_caret_X(aTHX);
+       set_caret_X();
        TAINT_NOT;
        init_postdump_symbols(argc,argv,env);
        return 0;
@@ -2121,7 +2038,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     /* and for SITELIB_EXP in USE_SITECUSTOMIZE                            */
     assert (!TAINT_get);
     TAINT;
-    S_set_caret_X(aTHX);
+    set_caret_X();
     TAINT_NOT;
 
 #if defined(USE_SITECUSTOMIZE)
diff --git a/perl.h b/perl.h
index 0a8beda..dc140bd 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2298,13 +2298,6 @@ typedef SV PADNAME;
 # define PERL_SAWAMPERSAND
 #endif
 
-/* Include mach-o/dyld.h here for perl.c’s sake, since it may #define bool,
-   and handy.h needs to be able to re#define it under
-  -Accflags=-DPERL_BOOL_AS_CHAR. */
-#if defined(USE_NSGETEXECUTABLEPATH) && defined(PERL_IN_PERL_C)
-# include <mach-o/dyld.h>
-#endif
-
 #include "handy.h"
 
 #if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_RAWIO)
diff --git a/proto.h b/proto.h
index 4fd5798..07729d2 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3811,6 +3811,7 @@ PERL_CALLCONV char*       Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_
        assert(bigstr); assert(littlestr); assert(old_posp)
 
 PERL_CALLCONV U32      Perl_seed(pTHX);
+PERL_CALLCONV void     Perl_set_caret_X(pTHX);
 PERL_CALLCONV void     Perl_set_context(void *t)
                        __attribute__nonnull__(1);
 #define PERL_ARGS_ASSERT_SET_CONTEXT   \