/*
* A ship then new they built for him
* of mithril and of elven-glass
- * --from Bilbo's song of Eärendil
+ * --from Bilbo's song of Eärendil
*
* [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
*/
#include "nwutil.h"
#endif
-/* XXX If this causes problems, set i_unistd=undef in the hint file. */
-#ifdef I_UNISTD
-#include <unistd.h>
+#ifdef USE_KERN_PROC_PATHNAME
+# include <sys/sysctl.h>
+#endif
+
+#ifdef USE_NSGETEXECUTABLEPATH
+# include <mach-o/dyld.h>
#endif
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
-# ifdef I_SYS_WAIT
-# include <sys/wait.h>
-# endif
# ifdef I_SYSUIO
# include <sys/uio.h>
# endif
JMPENV_PUSH(x);
PERL_UNUSED_VAR(x);
if (PL_endav && !PL_minus_c) {
- PL_phase = PERL_PHASE_END;
+ PERL_SET_PHASE(PERL_PHASE_END);
call_list(PL_scopestack_ix, PL_endav);
}
JMPENV_POP;
* destruct_level > 0 */
SvREFCNT_dec(PL_main_cv);
PL_main_cv = NULL;
- PL_phase = PERL_PHASE_DESTRUCT;
+ PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
/* Tell PerlIO we are about to tear things apart in case
we have layers which are using resources that should
/* defgv, aka *_ should be taken care of elsewhere */
- /* clean up after study() */
- SvREFCNT_dec(PL_lastscream);
- PL_lastscream = NULL;
- Safefree(PL_screamfirst);
- PL_screamfirst = 0;
- Safefree(PL_screamnext);
- PL_screamnext = 0;
-
/* float buffer */
Safefree(PL_efloatbuf);
PL_efloatbuf = NULL;
/* clear utf8 character classes */
SvREFCNT_dec(PL_utf8_alnum);
- SvREFCNT_dec(PL_utf8_ascii);
SvREFCNT_dec(PL_utf8_alpha);
SvREFCNT_dec(PL_utf8_space);
- SvREFCNT_dec(PL_utf8_cntrl);
SvREFCNT_dec(PL_utf8_graph);
SvREFCNT_dec(PL_utf8_digit);
SvREFCNT_dec(PL_utf8_upper);
SvREFCNT_dec(PL_utf8_idcont);
SvREFCNT_dec(PL_utf8_foldclosures);
PL_utf8_alnum = NULL;
- PL_utf8_ascii = NULL;
PL_utf8_alpha = NULL;
PL_utf8_space = NULL;
- PL_utf8_cntrl = NULL;
PL_utf8_graph = NULL;
PL_utf8_digit = NULL;
PL_utf8_upper = NULL;
for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
- if (SvTYPE(sv) != SVTYPEMASK) {
+ if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
" flags=0x%"UVxf
" refcnt=%"UVuf pTHX__FORMAT "\n"
++PL_exitlistlen;
}
-#ifdef HAS_PROCSELFEXE
-/* This is a function so that we don't hold on to MAXPATHLEN
- bytes of stack longer than necessary
- */
-STATIC void
-S_procself_val(pTHX_ SV *sv, const char *arg0)
-{
- 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(sv,buf,len);
- }
- else {
- sv_setpv(sv,arg0);
- }
-}
-#endif /* HAS_PROCSELFEXE */
-
STATIC void
S_set_caret_X(pTHX) {
dVAR;
GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
if (tmpgv) {
-#ifdef HAS_PROCSELFEXE
- S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
+ SV *const caret_x = GvSV(tmpgv);
+#if defined(OS2)
+ sv_setpv(caret_x, os2_execname(aTHX));
#else
-#ifdef OS2
- sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
-#else
- sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
-#endif
+# 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
}
}
call_list(oldscope, PL_unitcheckav);
}
if (PL_checkav) {
- PL_phase = PERL_PHASE_CHECK;
+ PERL_SET_PHASE(PERL_PHASE_CHECK);
call_list(oldscope, PL_checkav);
}
ret = 0;
call_list(oldscope, PL_unitcheckav);
}
if (PL_checkav) {
- PL_phase = PERL_PHASE_CHECK;
+ PERL_SET_PHASE(PERL_PHASE_CHECK);
call_list(oldscope, PL_checkav);
}
ret = STATUS_EXIT;
# ifdef DEBUGGING
" DEBUGGING"
# endif
+# ifdef HOMEGROWN_POSIX_SIGNALS
+ " HOMEGROWN_POSIX_SIGNALS"
+# endif
# ifdef NO_MATHOMS
" NO_MATHOMS"
# endif
# ifdef PERL_MEM_LOG_NOIMPL
" PERL_MEM_LOG_NOIMPL"
# endif
+# ifdef PERL_PRESERVE_IVUV
+ " PERL_PRESERVE_IVUV"
+# endif
# ifdef PERL_USE_DEVEL
" PERL_USE_DEVEL"
# endif
# ifdef PERL_USE_SAFE_PUTENV
" PERL_USE_SAFE_PUTENV"
# endif
+# ifdef UNLINK_ALL_VERSIONS
+ " UNLINK_ALL_VERSIONS"
+# endif
# ifdef USE_ATTRIBUTES_FOR_PERLIO
" USE_ATTRIBUTES_FOR_PERLIO"
# endif
# ifdef USE_FAST_STDIO
" USE_FAST_STDIO"
# endif
+# ifdef USE_LOCALE
+ " USE_LOCALE"
+# endif
+# ifdef USE_LOCALE_CTYPE
+ " USE_LOCALE_CTYPE"
+# endif
# ifdef USE_PERL_ATOF
" USE_PERL_ATOF"
# endif
SV *linestr_sv = newSV_type(SVt_PVIV);
bool add_read_e_script = FALSE;
- PL_phase = PERL_PHASE_START;
+ PERL_SET_PHASE(PERL_PHASE_START);
SvGROW(linestr_sv, 80);
sv_setpvs(linestr_sv,"");
PL_curstash = PL_defstash;
if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
PL_endav && !PL_minus_c) {
- PL_phase = PERL_PHASE_END;
+ PERL_SET_PHASE(PERL_PHASE_END);
call_list(oldscope, PL_endav);
}
#ifdef MYMALLOC
if (PERLDB_SINGLE && PL_DBsingle)
sv_setiv(PL_DBsingle, 1);
if (PL_initav) {
- PL_phase = PERL_PHASE_INIT;
+ PERL_SET_PHASE(PERL_PHASE_INIT);
call_list(oldscope, PL_initav);
}
#ifdef PERL_DEBUG_READONLY_OPS
/* do it */
- PL_phase = PERL_PHASE_RUN;
+ PERL_SET_PHASE(PERL_PHASE_RUN);
if (PL_restartop) {
PL_restartjmpenv = NULL;
=for apidoc p||get_av
-Returns the AV of the specified Perl array. C<flags> are passed to
-C<gv_fetchpv>. If C<GV_ADD> is set and the
+Returns the AV of the specified Perl global or package array with the given
+name (so it won't work on lexical variables). C<flags> are passed
+to C<gv_fetchpv>. If C<GV_ADD> is set and the
Perl variable does not exist then it will be created. If C<flags> is zero
and the variable does not exist then NULL is returned.
+Perl equivalent: C<@{"$name"}>.
+
=cut
*/
=for apidoc p||call_argv
-Performs a callback to the specified Perl sub. See L<perlcall>.
+Performs a callback to the specified named and package-scoped Perl subroutine
+with C<argv> (a NULL-terminated array of strings) as arguments. See L<perlcall>.
+
+Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
=cut
*/
{
dVAR;
#ifdef MULTIPLICITY
-# define PERLVAR(var,type)
-# define PERLVARA(var,n,type)
+# define PERLVAR(prefix,var,type)
+# define PERLVARA(prefix,var,n,type)
# if defined(PERL_IMPLICIT_CONTEXT)
-# define PERLVARI(var,type,init) aTHX->var = init;
-# define PERLVARIC(var,type,init) aTHX->var = init;
+# define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init;
+# define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init;
# else
-# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
-# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
+# define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init;
+# define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init;
# endif
# include "intrpvar.h"
# undef PERLVAR
# undef PERLVARI
# undef PERLVARIC
#else
-# define PERLVAR(var,type)
-# define PERLVARA(var,n,type)
-# define PERLVARI(var,type,init) PL_##var = init;
-# define PERLVARIC(var,type,init) PL_##var = init;
+# define PERLVAR(prefix,var,type)
+# define PERLVARA(prefix,var,n,type)
+# define PERLVARI(prefix,var,type,init) PL_##var = init;
+# define PERLVARIC(prefix,var,type,init) PL_##var = init;
# include "intrpvar.h"
# undef PERLVAR
# undef PERLVARA
"leak" until global destruction. */
av_clear(args);
}
- AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
+ AvREIFY_only(PL_dbargs);
}
void
#endif /* !PERL_MICRO */
}
TAINT_NOT;
- if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
- SvREADONLY_off(GvSV(tmpgv));
- sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
- SvREADONLY_on(GvSV(tmpgv));
- }
#ifdef THREADS_HAVE_PIDS
PL_ppid = (IV)getppid();
#endif
PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
+ /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
+ * argument to incpush_use_sep. This allows creation of relocatable
+ * Perl distributions that patch the binary at install time. Those
+ * distributions will have to provide their own relocation tools; this
+ * is not a feature otherwise supported by core Perl.
+ */
+#ifndef PERL_RELOCATABLE_INCPUSH
if (!len)
+#endif
len = strlen(p);
end = p + len;
https://perl5.git.perl.org / perl5.git / blobdiff