PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist);
PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist);
PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist);
- PL_GCB_invlist = _new_invlist_C_array(Grapheme_Cluster_Break_invlist);
- PL_SB_invlist = _new_invlist_C_array(Sentence_Break_invlist);
- PL_WB_invlist = _new_invlist_C_array(Word_Break_invlist);
+ PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist);
+ PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist);
+ PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist);
ENTER;
}
if (strEQ(s, "-1")) { /* Special case: modperl folklore. */
i = -1;
} else {
- i = grok_atou(s, NULL);
+ UV uv;
+ if (grok_atoUV(s, &uv, NULL) && uv <= INT_MAX)
+ i = (int)uv;
+ else
+ i = 0;
}
#ifdef DEBUGGING
if (destruct_level < i) destruct_level = i;
SvREFCNT_dec(PL_Latin1);
SvREFCNT_dec(PL_NonL1NonFinalFold);
SvREFCNT_dec(PL_HasMultiCharFold);
+#ifdef USE_LOCALE_CTYPE
SvREFCNT_dec(PL_warn_locale);
+#endif
PL_utf8_mark = NULL;
PL_utf8_toupper = NULL;
PL_utf8_totitle = NULL;
PL_AboveLatin1 = NULL;
PL_InBitmap = NULL;
PL_HasMultiCharFold = NULL;
+#ifdef USE_LOCALE_CTYPE
PL_warn_locale = NULL;
+#endif
PL_Latin1 = NULL;
PL_NonL1NonFinalFold = NULL;
PL_UpperLatin1 = NULL;
Perl_reentrant_free(aTHX);
#endif
+ /* These all point to HVs that are about to be blown away.
+ Code in core and on CPAN assumes that if the interpreter is re-started
+ that they will be cleanly NULL or pointing to a valid HV. */
+ PL_custom_op_names = NULL;
+ PL_custom_op_descs = NULL;
+ PL_custom_ops = NULL;
+
sv_free_arenas();
while (PL_regmatch_slab) {
{
const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
- if (s && (grok_atou(s, NULL) == 1)) {
- unsigned char *seed= PERL_HASH_SEED;
- unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
+ if (s && strEQ(s, "1")) {
+ const unsigned char *seed= PERL_HASH_SEED;
+ const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
while (seed < seed_end) {
PerlIO_printf(Perl_debug_log, "%02x", *seed++);
}
}
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
+
+#ifdef __amigaos4__
+ {
+ struct NameTranslationInfo nti;
+ __translate_amiga_to_unix_path_name(&argv[0],&nti);
+ }
+#endif
+
PL_origargc = argc;
PL_origargv = argv;
# ifdef PERL_BOOL_AS_CHAR
" PERL_BOOL_AS_CHAR"
# endif
+# ifdef PERL_COPY_ON_WRITE
+ " PERL_COPY_ON_WRITE"
+# endif
# ifdef PERL_DISABLE_PMC
" PERL_DISABLE_PMC"
# endif
# ifdef PERL_MEM_LOG_NOIMPL
" PERL_MEM_LOG_NOIMPL"
# endif
-# ifdef PERL_NEW_COPY_ON_WRITE
- " PERL_NEW_COPY_ON_WRITE"
-# endif
# ifdef PERL_PERTURB_KEYS_DETERMINISTIC
" PERL_PERTURB_KEYS_DETERMINISTIC"
# endif
# ifdef USE_LOCALE_CTYPE
" USE_LOCALE_CTYPE"
# endif
+# ifdef WIN32_NO_REGISTRY
+ " USE_NO_REGISTRY"
+# endif
# ifdef USE_PERL_ATOF
" USE_PERL_ATOF"
# endif
PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
sizeof(non_bincompat_options) - 1, SVs_TEMP));
-#ifdef __DATE__
-# ifdef __TIME__
+#ifndef PERL_BUILD_DATE
+# ifdef __DATE__
+# ifdef __TIME__
+# define PERL_BUILD_DATE __DATE__ " " __TIME__
+# else
+# define PERL_BUILD_DATE __DATE__
+# endif
+# endif
+#endif
+
+#ifdef PERL_BUILD_DATE
PUSHs(Perl_newSVpvn_flags(aTHX_
- STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__),
- SVs_TEMP));
-# else
- PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
+ STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
SVs_TEMP));
-# endif
#else
PUSHs(&PL_sv_undef);
#endif
int argc = PL_origargc;
char **argv = PL_origargv;
const char *scriptname = NULL;
- VOL bool dosearch = FALSE;
+ bool dosearch = FALSE;
char c;
bool doextract = FALSE;
const char *cddir = NULL;
#endif
(s = PerlEnv_getenv("PERL5OPT")))
{
+ /* s points to static memory in getenv(), which may be overwritten at
+ * any time; use a mortal copy instead */
+ s = SvPVX(sv_2mortal(newSVpv(s, 0)));
+
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T') {
#ifdef MYMALLOC
{
const char *s;
- if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && grok_atou(s, NULL) >= 2)
+ UV uv;
+ s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
+ if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
dump_mstats("after compilation:");
}
#endif
Returns the HV of the specified Perl hash. 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.
+and the variable does not exist then C<NULL> is returned.
=cut
*/
=for apidoc p||call_argv
Performs a callback to the specified named and package-scoped Perl subroutine
-with C<argv> (a NULL-terminated array of strings) as arguments. See
+with C<argv> (a C<NULL>-terminated array of strings) as arguments. See
L<perlcall>.
Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
PERL_ARGS_ASSERT_CALL_ARGV;
PUSHMARK(SP);
- if (argv) {
- while (*argv) {
- mXPUSHs(newSVpv(*argv,0));
- argv++;
- }
- PUTBACK;
+ while (*argv) {
+ mXPUSHs(newSVpv(*argv,0));
+ argv++;
}
+ PUTBACK;
return call_pv(sub_name, flags);
}
/*
=for apidoc p||call_sv
-Performs a callback to the Perl sub whose name is in the SV. See
-L<perlcall>.
+Performs a callback to the Perl sub specified by the SV.
+
+If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
+SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
+or C<SvPV(sv)> will be used as the name of the sub to call.
+
+If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
+C<SvPV(sv)> will be used as the name of the method to call.
+
+If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
+the name of the method to call.
+
+Some other values are treated specially for internal use and should
+not be depended on.
+
+See L<perlcall>.
=cut
*/
Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
/* See G_* flags in cop.h */
{
- dVAR; dSP;
+ dVAR;
LOGOP myop; /* fake syntax tree node */
METHOP method_op;
I32 oldmark;
SAVEOP();
PL_op = (OP*)&myop;
- EXTEND(PL_stack_sp, 1);
- if (!(flags & G_METHOD_NAMED))
- *++PL_stack_sp = sv;
+ if (!(flags & G_METHOD_NAMED)) {
+ dSP;
+ EXTEND(SP, 1);
+ PUSHs(sv);
+ PUTBACK;
+ }
oldmark = TOPMARK;
oldscope = PL_scopestack_ix;
=for apidoc p||eval_sv
Tells Perl to C<eval> the string in the SV. It supports the same flags
-as C<call_sv>, with the obvious exception of
G_EVAL. See L<perlcall>.
+as C<call_sv>, with the obvious exception of
C<G_EVAL>. See L<perlcall>.
=cut
*/
/* See G_* flags in cop.h */
{
dVAR;
- dSP;
UNOP myop; /* fake syntax tree node */
- VOL I32 oldmark = SP - PL_stack_base;
+ VOL I32 oldmark;
VOL I32 retval = 0;
int ret;
OP* const oldop = PL_op;
SAVEOP();
PL_op = (OP*)&myop;
Zero(&myop, 1, UNOP);
- EXTEND(PL_stack_sp, 1);
- *++PL_stack_sp = sv;
+ {
+ dSP;
+ oldmark = SP - PL_stack_base;
+ EXTEND(SP, 1);
+ PUSHs(sv);
+ PUTBACK;
+ }
if (!(flags & G_NOARGS))
myop.op_flags = OPf_STACKED;
" L trace some locale setting information--for Perl core development\n",
NULL
};
- int i = 0;
+ UV uv = 0;
PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
for (; isWORDCHAR(**s); (*s)++) {
const char * const d = strchr(debopts,**s);
if (d)
- i |= 1 << (d - debopts);
+ uv |= 1 << (d - debopts);
else if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
"invalid option -D%c, use -D'' to see choices\n", **s);
}
else if (isDIGIT(**s)) {
const char* e;
- i = grok_atou(*s, &e);
- if (e)
+ if (grok_atoUV(*s, &uv, &e))
*s = e;
for (; isWORDCHAR(**s); (*s)++) ;
}
const char *const *p = usage_msgd;
while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
}
- return i;
+ return (int)uv; /* ignore any UV->int conversion loss */
}
#endif
s--;
}
PL_rs = newSVpvs("");
- SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
+ SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
tmps = (U8*)SvPVX(PL_rs);
uvchr_to_utf8(tmps, rschar);
- SvCUR_set(PL_rs, UNISKIP(rschar));
+ SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
SvUTF8_on(PL_rs);
}
else {
for (s++; isWORDCHAR(*s); s++) ;
#endif
return s;
+ NOT_REACHED; /* NOTREACHED */
}
case 'h':
usage();
+ NOT_REACHED; /* NOTREACHED */
+
case 'i':
Safefree(PL_inplace);
#if defined(__CYGWIN__) /* do backup extension automagically */
PL_origfilename = savepvs("-e");
}
else {
+ const char *s;
+ UV uv;
/* if find_script() returns, it returns a malloc()-ed value */
scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
- if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
- const char *s = scriptname + 8;
- const char* e;
- fdscript = grok_atou(s, &e);
- s = e;
+ if (strnEQ(scriptname, "/dev/fd/", 8)
+ && isDIGIT(scriptname[8])
+ && grok_atoUV(scriptname + 8, &uv, &s)
+ && uv <= PERL_INT_MAX
+ ) {
+ fdscript = (int)uv;
if (*s) {
/* PSz 18 Feb 04
* Tell apart "normal" usage of fdscript, e.g.
CopFILE(PL_curcop), Strerror(errno));
}
fd = PerlIO_fileno(rsfp);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
+#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
if (fd >= 0) {
/* ensure close-on-exec */
- if (fcntl(fd, F_SETFD, 1) < 0) {
+ if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) {
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
CopFILE(PL_curcop), Strerror(errno));
}
if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
dVAR;
int fd = PerlIO_fileno(rsfp);
- if (fd < 0) {
- Perl_croak(aTHX_ "Illegal suidscript");
- } else {
- if (PerlLIO_fstat(fd, &PL_statbuf) < 0) { /* may be either wrapped or real suid */
- Perl_croak(aTHX_ "Illegal suidscript");
- }
+ Stat_t statbuf;
+ if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
+ Perl_croak_nocontext( "Illegal suidscript");
}
- if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+ if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
||
- (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+ (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
)
if (!PL_do_undump)
Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
#ifdef SITELIB_EXP
# if defined(WIN32)
/* this picks up sitearch as well */
- s = win32_get_sitelib(PERL_FS_VERSION, &len);
+ s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len);
if (s)
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
# else
#ifdef PERL_VENDORLIB_EXP
# if defined(WIN32)
/* this picks up vendorarch as well */
- s = win32_get_vendorlib(PERL_FS_VERSION, &len);
+ s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len);
if (s)
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
# else
#endif
#if defined(WIN32)
- s = win32_get_privlib(PERL_FS_VERSION, &len);
+ s = PerlEnv_lib_path(PERL_FS_VERSION, &len);
if (s)
incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
#else
/* removes boilerplate code at the end of each boot_Module xsub */
void
-Perl_xs_boot_epilog(pTHX_ const U32 ax)
+Perl_xs_boot_epilog(pTHX_ const I32 ax)
{
if (PL_unitcheckav)
call_list(PL_scopestack_ix, PL_unitcheckav);
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff