#endif
#endif
+#ifndef NO_MATHOMS
+/* This reference ensures that the mathoms are linked with perl */
+extern void Perl_mathoms(void);
+void Perl_mathoms_ref(void);
+void Perl_mathoms_ref(void) {
+ Perl_mathoms();
+}
+#endif
+
static void
S_init_tls_and_interp(PerlInterpreter *my_perl)
{
struct IPerlProc* ipP)
{
PerlInterpreter *my_perl;
- /* New() needs interpreter, so call malloc() instead */
+ /* Newx() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
S_init_tls_and_interp(my_perl);
Zero(my_perl, 1, PerlInterpreter);
{
PerlInterpreter *my_perl;
- /* New() needs interpreter, so call malloc() instead */
+ /* Newx() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
S_init_tls_and_interp(my_perl);
SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
}
- PL_sighandlerp = Perl_sighandler;
+ PL_sighandlerp = (Sighandler_t) Perl_sighandler;
+#ifdef PERL_USES_PL_PIDSTATUS
PL_pidstatus = newHV();
+#endif
}
PL_rs = newSVpvn("\n", 1);
# endif
if ((long) PL_mmap_page_size < 0) {
if (errno) {
- SV *error = ERRSV;
+ SV * const error = ERRSV;
(void) SvUPGRADE(error, SVt_PV);
Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
}
if (CALL_FPTR(PL_threadhook)(aTHX)) {
/* Threads hook has vetoed further cleanup */
- return STATUS_NATIVE_EXPORT;
+ return STATUS_EXIT;
}
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
*/
sv_clean_objs();
PL_sv_objcount = 0;
+ if (PL_defoutgv && !SvREFCNT(PL_defoutgv))
+ PL_defoutgv = Nullgv; /* may have been freed */
}
/* unhook hooks which will soon be, or use, destroyed data */
#endif
/* The exit() function will do everything that needs doing. */
- return STATUS_NATIVE_EXPORT;
+ return STATUS_EXIT;
}
/* jettison our possibly duplicated environment */
*/
{
I32 i = AvFILLp(PL_regex_padav) + 1;
- SV **ary = AvARRAY(PL_regex_padav);
+ SV * const * const ary = AvARRAY(PL_regex_padav);
while (i) {
- SV *resv = ary[--i];
+ SV * const resv = ary[--i];
if (SvFLAGS(resv) & SVf_BREAK) {
/* this is PL_reg_curpm, already freed
PL_subname = Nullsv;
SvREFCNT_dec(PL_linestr);
PL_linestr = Nullsv;
+#ifdef PERL_USES_PL_PIDSTATUS
SvREFCNT_dec(PL_pidstatus);
PL_pidstatus = Nullhv;
+#endif
SvREFCNT_dec(PL_toptarget);
PL_toptarget = Nullsv;
SvREFCNT_dec(PL_bodytarget);
*/
I32 riter = 0;
const I32 max = HvMAX(PL_strtab);
- HE **array = HvARRAY(PL_strtab);
+ HE * const * const array = HvARRAY(PL_strtab);
HE *hent = array[0];
for (;;) {
if (hent && ckWARN_d(WARN_INTERNAL)) {
- HE *next = HeNEXT(hent);
+ HE * const next = HeNEXT(hent);
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Unbalanced string table refcount: (%d) for \"%s\"",
- HeVAL(hent) - Nullsv, HeKEY(hent));
+ "Unbalanced string table refcount: (%ld) for \"%s\"",
+ (long)(HeVAL(hent) - Nullsv), HeKEY(hent));
Safefree(hent);
hent = next;
}
Safefree(PL_reg_start_tmp);
PL_reg_start_tmp = (char**)NULL;
PL_reg_start_tmpl = 0;
- if (PL_reg_curpm)
- Safefree(PL_reg_curpm);
+ Safefree(PL_reg_curpm);
Safefree(PL_reg_poscache);
free_tied_hv_pool();
Safefree(PL_op_mask);
Safefree(PL_mess_sv);
PL_mess_sv = Nullsv;
}
- return STATUS_NATIVE_EXPORT;
+ return STATUS_EXIT;
}
/*
PL_curstash = PL_defstash;
if (PL_checkav)
call_list(oldscope, PL_checkav);
- ret = STATUS_NATIVE_EXPORT;
+ ret = STATUS_EXIT;
break;
case 3:
PerlIO_printf(Perl_error_log, "panic: top_env\n");
argc--,argv++;
}
if (s && *s) {
- char *p;
STRLEN len = strlen(s);
- p = savepvn(s, len);
+ const char * const p = savepvn(s, len);
incpush(p, TRUE, TRUE, FALSE, FALSE);
sv_catpvn(sv, "-I", 2);
sv_catpvn(sv, p, len);
#endif
opts = SvCUR(opts_prog);
- sv_catpv(opts_prog,"\" Compile-time options:");
+ Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:"
# ifdef DEBUGGING
- sv_catpv(opts_prog," DEBUGGING");
+ " DEBUGGING"
+# endif
+# ifdef DEBUG_LEAKING_SCALARS
+ " DEBUG_LEAKING_SCALARS"
+# endif
+# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ " DEBUG_LEAKING_SCALARS_FORK_DUMP"
+# endif
+# ifdef FAKE_THREADS
+ " FAKE_THREADS"
# endif
# ifdef MULTIPLICITY
- sv_catpv(opts_prog," MULTIPLICITY");
+ " MULTIPLICITY"
+# endif
+# ifdef MYMALLOC
+ " MYMALLOC"
+# endif
+# ifdef NO_MATHOMS
+ " NO_MATHOMS"
+# endif
+# ifdef PERL_DONT_CREATE_GVSV
+ " PERL_DONT_CREATE_GVSV"
+# endif
+# ifdef PERL_GLOBAL_STRUCT
+ " PERL_GLOBAL_STRUCT"
+# endif
+# ifdef PERL_IMPLICIT_CONTEXT
+ " PERL_IMPLICIT_CONTEXT"
+# endif
+# ifdef PERL_IMPLICIT_SYS
+ " PERL_IMPLICIT_SYS"
+# endif
+# ifdef PERL_MALLOC_WRAP
+ " PERL_MALLOC_WRAP"
+# endif
+# ifdef PERL_NEED_APPCTX
+ " PERL_NEED_APPCTX"
+# endif
+# ifdef PERL_NEED_TIMESBASE
+ " PERL_NEED_TIMESBASE"
+# endif
+# ifdef PERL_OLD_COPY_ON_WRITE
+ " PERL_OLD_COPY_ON_WRITE"
+# endif
+# ifdef PERL_TRACK_MEMPOOL
+ " PERL_TRACK_MEMPOOL"
+# endif
+# ifdef PERL_USE_SAFE_PUTENV
+ " PERL_USE_SAFE_PUTENV"
+# endif
+#ifdef PERL_USES_PL_PIDSTATUS
+ " PERL_USES_PL_PIDSTATUS"
+#endif
+# ifdef PL_OP_SLAB_ALLOC
+ " PL_OP_SLAB_ALLOC"
+# endif
+# ifdef SPRINTF_RETURNS_STRLEN
+ " SPRINTF_RETURNS_STRLEN"
+# endif
+# ifdef THREADS_HAVE_PIDS
+ " THREADS_HAVE_PIDS"
# endif
# ifdef USE_5005THREADS
- sv_catpv(opts_prog," USE_5005THREADS");
+ " USE_5005THREADS"
# endif
-# ifdef USE_ITHREADS
- sv_catpv(opts_prog," USE_ITHREADS");
+# ifdef USE_64_BIT_ALL
+ " USE_64_BIT_ALL"
# endif
# ifdef USE_64_BIT_INT
- sv_catpv(opts_prog," USE_64_BIT_INT");
+ " USE_64_BIT_INT"
# endif
-# ifdef USE_64_BIT_ALL
- sv_catpv(opts_prog," USE_64_BIT_ALL");
+# ifdef USE_ITHREADS
+ " USE_ITHREADS"
+# endif
+# ifdef USE_LARGE_FILES
+ " USE_LARGE_FILES"
# endif
# ifdef USE_LONG_DOUBLE
- sv_catpv(opts_prog," USE_LONG_DOUBLE");
+ " USE_LONG_DOUBLE"
# endif
-# ifdef USE_LARGE_FILES
- sv_catpv(opts_prog," USE_LARGE_FILES");
+# ifdef USE_PERLIO
+ " USE_PERLIO"
# endif
-# ifdef USE_SOCKS
- sv_catpv(opts_prog," USE_SOCKS");
+# ifdef USE_REENTRANT_API
+ " USE_REENTRANT_API"
+# endif
+# ifdef USE_SFIO
+ " USE_SFIO"
# endif
# ifdef USE_SITECUSTOMIZE
- sv_catpv(opts_prog," USE_SITECUSTOMIZE");
+ " USE_SITECUSTOMIZE"
# endif
-# ifdef PERL_IMPLICIT_CONTEXT
- sv_catpv(opts_prog," PERL_IMPLICIT_CONTEXT");
-# endif
-# ifdef PERL_IMPLICIT_SYS
- sv_catpv(opts_prog," PERL_IMPLICIT_SYS");
+# ifdef USE_SOCKS
+ " USE_SOCKS"
# endif
+ );
while (SvCUR(opts_prog) > opts+76) {
/* find last space after "options: " and before col 76
*/
const char *space;
- char *pv = SvPV_nolen(opts_prog);
+ char * const pv = SvPV_nolen(opts_prog);
const char c = pv[opts+76];
pv[opts+76] = '\0';
space = strrchr(pv+opts+26, ' ');
d = s;
if (!*s)
break;
- if (!strchr("DIMUdmtwA", *s))
+ if (!strchr("CDIMUdmtwA", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
while (++s && *s) {
if (isSPACE(*s)) {
# define SIGCHLD SIGCLD
#endif
Sighandler_t sigstate = rsignal_state(SIGCHLD);
- if (sigstate == SIG_IGN) {
+ if (sigstate == (Sighandler_t) SIG_IGN) {
if (ckWARN(WARN_SIGNAL))
Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
"Can't ignore signal CHLD, forcing to default");
CvPADLIST(PL_compcv) = pad_new(0);
#ifdef USE_5005THREADS
CvOWNER(PL_compcv) = 0;
- New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
+ Newx(CvMUTEXP(PL_compcv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(PL_compcv));
#endif /* USE_5005THREADS */
if (xsinit)
(*xsinit)(aTHX); /* in case linked C routines want magical variables */
#ifndef PERL_MICRO
-#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
init_os_extras();
#endif
#endif
* or explicitly in some platforms.
* locale.c:Perl_init_i18nl10n() if the environment
* look like the user wants to use UTF-8. */
-#if defined(SYMBIAN)
+#if defined(__SYMBIAN32__)
PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
#endif
if (PL_unicode) {
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- ret = STATUS_NATIVE_EXPORT;
+ ret = STATUS_EXIT;
break;
case 3:
if (PL_restartop) {
if (!PL_restartop) {
DEBUG_x(dump_all());
+#ifdef DEBUGGING
if (!DEBUG_q_TEST)
PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+#endif
DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
PTR2UV(thr)));
AV*
Perl_get_av(pTHX_ const char *name, I32 create)
{
- GV* gv = gv_fetchpv(name, create, SVt_PVAV);
+ GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
if (create)
return GvAVn(gv);
if (gv)
HV*
Perl_get_hv(pTHX_ const char *name, I32 create)
{
- GV* gv = gv_fetchpv(name, create, SVt_PVHV);
+ GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
if (create)
return GvHVn(gv);
if (gv)
CV*
Perl_get_cv(pTHX_ const char *name, I32 create)
{
- GV* gv = gv_fetchpv(name, create, SVt_PVCV);
+ GV* const gv = gv_fetchpv(name, create, SVt_PVCV);
/* XXX unsafe for threads if eval_owner isn't held */
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
I32 oldscope;
bool oldcatch = CATCH_GET;
int ret;
- OP* oldop = PL_op;
+ OP* const oldop = PL_op;
dJMPENV;
if (flags & G_DISCARD) {
volatile I32 oldmark = SP - PL_stack_base;
volatile I32 retval = 0;
int ret;
- OP* oldop = PL_op;
+ OP* const oldop = PL_op;
dJMPENV;
if (flags & G_DISCARD) {
void
Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
{
- register GV *gv;
+ register GV * const gv = gv_fetchpv(sym,TRUE, SVt_PV);
- if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
+ if (gv)
sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
}
static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
for (; isALNUM(**s); (*s)++) {
- const char *d = strchr(debopts,**s);
+ const char * const d = strchr(debopts,**s);
if (d)
i |= 1 << (d - debopts);
else if (ckWARN_d(WARN_DEBUGGING))
for (; isALNUM(**s); (*s)++) ;
}
else if (givehelp) {
- char **p = (char **)usage_msgd;
+ const char *const *p = usage_msgd;
while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
}
# ifdef EBCDIC
in the fashion that -MSome::Mod does. */
if (*s == ':' || *s == '=') {
const char *start;
- SV *sv;
- sv = newSVpv("use Devel::", 0);
+ SV * const sv = newSVpv("use Devel::", 0);
start = ++s;
/* We now allow -d:Module=Foo,Bar */
while(isALNUM(*s) || *s==':') ++s;
usage(PL_origargv[0]);
my_exit(0);
case 'i':
- if (PL_inplace)
- Safefree(PL_inplace);
+ Safefree(PL_inplace);
#if defined(__CYGWIN__) /* do backup extension automagically */
if (*(s+1) == '\0') {
PL_inplace = savepv(".bak");
PL_preambleav = newAV();
s++;
{
- char *start = s;
- SV *sv = newSVpv("use assertions::activate", 24);
+ char * const start = s;
+ SV * const sv = newSVpv("use assertions::activate", 24);
while(isALNUM(*s) || *s == ':') ++s;
if (s != start) {
sv_catpvn(sv, "::", 2);
s+=strlen(s);
}
else if (*s != '\0') {
- Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start);
+ Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start);
}
av_push(PL_preambleav, sv);
return s;
PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
wce_hitreturn();
#endif
-#ifdef SYMBIAN
+#ifdef __SYMBIAN32__
PerlIO_printf(PerlIO_stdout(),
"Symbian port by Nokia, 2004-2005\n");
#endif
SvREFCNT_dec(GvHV(gv));
GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
SvREADONLY_on(gv);
- Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0);
+ hv_name_set(PL_defstash, "main", 4, 0);
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
+ SvREFCNT_inc(PL_incgv); /* Don't allow it to be freed */
GvMULTI_on(PL_incgv);
PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
GvMULTI_on(PL_hintgv);
PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
+ SvREFCNT_inc(PL_defgv);
PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
+ SvREFCNT_inc(PL_errgv);
GvMULTI_on(PL_errgv);
PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
GvMULTI_on(PL_replgv);
}
#else /* IAMSUID */
else if (PL_preprocess) {
- const char *cpp_cfg = CPPSTDIN;
- SV *cpp = newSVpvn("",0);
- SV *cmd = NEWSV(0,0);
+ const char * const cpp_cfg = CPPSTDIN;
+ SV * const cpp = newSVpvn("",0);
+ SV * const cmd = NEWSV(0,0);
if (cpp_cfg[0] == 0) /* PERL_MICRO? */
Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
#endif /* IAMSUID */
if (!PL_rsfp) {
/* PSz 16 Sep 03 Keep neat error message */
- Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
- CopFILE(PL_curcop), Strerror(errno));
+ if (PL_e_script)
+ Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
+ else
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+ CopFILE(PL_curcop), Strerror(errno));
}
}
cmplen = sizeof(fsd.fd_req.path);
if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
fdst.st_dev == fsd.fd_req.dev) {
- check_okay = 1;
- on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
- on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
- }
+ check_okay = 1;
+ on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
+ on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
}
}
}
if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
const char *linestr;
+ const char *s_end;
#ifdef IAMSUID
if (PL_fdscript < 0 || PL_suidscript != 1)
s = linestr;
/* PSz 27 Feb 04 */
/* Sanity check on line length */
- if (strlen(s) < 1 || strlen(s) > 4000)
+ s_end = s + strlen(s);
+ if (s_end == s || (s_end - s) > 4000)
Perl_croak(aTHX_ "Very long #! line");
/* Allow more than a single space after #! */
while (isSPACE(*s)) s++;
len = strlen(validarg);
if (strEQ(validarg," PHOOEY ") ||
strnNE(s,validarg,len) || !isSPACE(s[len]) ||
- !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
+ !((s_end - s) == len+1
+ || ((s_end - s) == len+2 && isSPACE(s[len+1]))))
Perl_croak(aTHX_ "Args must match #! line");
#ifndef IAMSUID
void
Perl_init_debugger(pTHX)
{
- HV *ostash = PL_curstash;
+ HV * const ostash = PL_curstash;
PL_curstash = PL_debstash;
PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
PL_stack_sp = PL_stack_base;
PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
- New(50,PL_tmps_stack,REASONABLE(128),SV*);
+ Newx(PL_tmps_stack,REASONABLE(128),SV*);
PL_tmps_floor = -1;
PL_tmps_ix = -1;
PL_tmps_max = REASONABLE(128);
- New(54,PL_markstack,REASONABLE(32),I32);
+ Newx(PL_markstack,REASONABLE(32),I32);
PL_markstack_ptr = PL_markstack;
PL_markstack_max = PL_markstack + REASONABLE(32);
SET_MARK_OFFSET;
- New(54,PL_scopestack,REASONABLE(32),I32);
+ Newx(PL_scopestack,REASONABLE(32),I32);
PL_scopestack_ix = 0;
PL_scopestack_max = REASONABLE(32);
- New(54,PL_savestack,REASONABLE(128),ANY);
+ Newx(PL_savestack,REASONABLE(128),ANY);
PL_savestack_ix = 0;
PL_savestack_max = REASONABLE(128);
}
PL_statname = NEWSV(66,0); /* last filename we did stat on */
- if (PL_osname)
- Safefree(PL_osname);
+ Safefree(PL_osname);
PL_osname = savepv(OSNAME);
}
void
Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
{
- char *s;
argc--,argv++; /* skip name of script */
if (PL_doswitches) {
for (; argc > 0 && **argv == '-'; argc--,argv++) {
+ char *s;
if (!argv[0][1])
break;
if (argv[0][1] == '-' && !argv[0][2]) {
(void)gv_AVadd(PL_argvgv);
av_clear(GvAVn(PL_argvgv));
for (; argc > 0; argc--,argv++) {
- SV *sv = newSVpv(argv[0],0);
+ SV * const sv = newSVpv(argv[0],0);
av_push(GvAVn(PL_argvgv),sv);
if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
if (!PL_tainting) {
#ifndef VMS
s = PerlEnv_getenv("PERL5LIB");
+/*
+ * It isn't possible to delete an environment variable with
+ * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
+ * case we treat PERL5LIB as undefined if it has a zero-length value.
+ */
+#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
+ if (s && *s != '\0')
+#else
if (s)
+#endif
incpush(s, TRUE, TRUE, TRUE, FALSE);
else
incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
#endif /* MACOS_TRADITIONAL */
}
-#if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
+#if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
* The intent is that /usr/local/bin/perl and .../../lib/perl5
* generates /usr/local/lib/perl5
*/
- char *libpath = SvPVX(libdir);
+ const char *libpath = SvPVX(libdir);
STRLEN libpath_len = SvCUR(libdir);
if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
/* Game on! */
- SV *caret_X = get_sv("\030", 0);
+ SV * const caret_X = get_sv("\030", 0);
/* Going to use the SV just as a scratch buffer holding a C
string: */
SV *prefix_sv;
if (addsubdirs || addoldvers) {
#ifdef PERL_INC_VERSION_LIST
/* Configure terminates PERL_INC_VERSION_LIST with a NULL */
- const char *incverlist[] = { PERL_INC_VERSION_LIST };
- const char **incver;
+ const char * const incverlist[] = { PERL_INC_VERSION_LIST };
+ const char * const *incver;
#endif
#ifdef VMS
char *unix;
#endif
XPV *xpv;
- Newz(53, thr, 1, struct perl_thread);
+ Newxz(thr, 1, struct perl_thread);
PL_curcop = &PL_compiling;
thr->interp = PERL_GET_INTERP;
thr->cvcache = newHV();
thr->flags = THRf_R_JOINABLE;
MUTEX_INIT(&thr->mutex);
/* Handcraft thrsv similarly to mess_sv */
- New(53, PL_thrsv, 1, SV);
- Newz(53, xpv, 1, XPV);
+ Newx(PL_thrsv, 1, SV);
+ Newxz(xpv, 1, XPV);
SvFLAGS(PL_thrsv) = SVt_PV;
SvANY(PL_thrsv) = (void*)xpv;
SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
STATUS_ALL_FAILURE;
break;
default:
- STATUS_NATIVE_SET(status);
+ STATUS_EXIT_SET(status);
break;
}
my_exit_jump();
Perl_my_failure_exit(pTHX)
{
#ifdef VMS
- if (vaxc$errno & 1) {
- if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
- STATUS_NATIVE_SET(44);
+ /* We have been called to fall on our sword. The desired exit code
+ * should be already set in STATUS_UNIX, but could be shifted over
+ * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
+ * that code is set.
+ *
+ * If an error code has not been set, then force the issue.
+ */
+ if (MY_POSIX_EXIT) {
+
+ /* In POSIX_EXIT mode follow Perl documentations and use 255 for
+ * the exit code when there isn't an error.
+ */
+
+ if (STATUS_UNIX == 0)
+ STATUS_UNIX_EXIT_SET(255);
+ else {
+ STATUS_UNIX_EXIT_SET(STATUS_UNIX);
+
+ /* The exit code could have been set by $? or vmsish which
+ * means that it may not be fatal. So convert
+ * success/warning codes to fatal.
+ */
+ if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0)
+ STATUS_UNIX_EXIT_SET(255);
+ }
}
else {
- if (!vaxc$errno) /* unlikely */
- STATUS_NATIVE_SET(44);
- else
- STATUS_NATIVE_SET(vaxc$errno);
+ /* Traditionally Perl on VMS always expects a Fatal Error. */
+ if (vaxc$errno & 1) {
+
+ /* So force success status to failure */
+ if (STATUS_NATIVE & 1)
+ STATUS_ALL_FAILURE;
+ }
+ else {
+ if (!vaxc$errno) {
+ STATUS_UNIX = EINTR; /* In case something cares */
+ STATUS_ALL_FAILURE;
+ }
+ else {
+ int severity;
+ STATUS_NATIVE = vaxc$errno; /* Should already be this */
+
+ /* Encode the severity code */
+ severity = STATUS_NATIVE & STS$M_SEVERITY;
+ STATUS_UNIX = (severity ? severity : 1) << 8;
+
+ /* Perl expects this to be a fatal error */
+ if (severity != STS$K_SEVERE)
+ STATUS_ALL_FAILURE;
+ }
+ }
}
+
#else
int exitstatus;
if (errno & 255)
https://perl5.git.perl.org / perl5.git / blobdiff