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
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
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)
--- /dev/null
+/* 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:
+ */
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)
#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)
#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>
++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
init_ids();
assert (!TAINT_get);
TAINT;
- S_set_caret_X(aTHX);
+ set_caret_X();
TAINT_NOT;
init_postdump_symbols(argc,argv,env);
return 0;
/* 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)
# 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)
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 \
projects / platform / upstream / perl.git / commitdiff