#include "perl.h"
#include "patchlevel.h" /* for local_patches */
#include "XSUB.h"
-#include "charclass_invlists.h"
#ifdef NETWARE
#include "nwutil.h"
PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(XPosixPrint_invlist);
PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(XPosixPunct_invlist);
PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist);
- PL_XPosix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(XPosixSpace_invlist);
PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(XPosixUpper_invlist);
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(_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;
SvREFCNT_dec(PL_XPosix_ptrs[i]);
PL_XPosix_ptrs[i] = NULL;
}
+ PL_GCB_invlist = NULL;
+ PL_SB_invlist = NULL;
+ PL_WB_invlist = NULL;
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
TAINTING_set(FALSE);
TAINT_WARN_set(FALSE);
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
- PL_debug = 0;
DEBUG_P(debprofdump());
+ PL_debug = 0;
+
#ifdef USE_REENTRANT_API
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) {
"free this thread's memory\n");
PL_debug &= ~ DEBUG_m_FLAG;
}
- while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
- safesysfree(PERL_MEMORY_DEBUG_HEADER_SIZE + (char *)(aTHXx->Imemory_debug_header.next));
+ while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){
+ char * next = (char *)(aTHXx->Imemory_debug_header.next);
+ Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next;
+ safesysfree(ptr);
+ }
PL_debug = old_debug;
}
}
{
const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
- if (s && (grok_atou(s, NULL) == 1)) {
+ if (s && strEQ(s, "1")) {
unsigned char *seed= PERL_HASH_SEED;
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);
}
}
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
+
+#if defined(__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
# endif
;
PERL_UNUSED_ARG(cv);
- PERL_UNUSED_ARG(items);
+ PERL_UNUSED_VAR(items);
EXTEND(SP, entries);
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
CALLRUNOPS(aTHX);
}
my_exit(0);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
/*
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
*/
FREETMPS;
JMPENV_POP;
my_exit_jump();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_restartjmpenv = NULL;
=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
*/
FREETMPS;
JMPENV_POP;
my_exit_jump();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_restartjmpenv = NULL;
" 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++);
}
-# ifdef EBCDIC
- if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
- "-Dp not implemented on this platform\n");
-# endif
- 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 */
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2014, Larry Wall\n");
+ "\n\nCopyright 1987-2015, Larry Wall\n");
#ifdef MSDOS
PerlIO_printf(PIO_stdout,
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
GvMULTI_on(PL_replgv);
(void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
#ifdef PERL_DONT_CREATE_GVSV
- gv_SVadd(PL_errgv);
+ (void)gv_SVadd(PL_errgv);
#endif
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
CLEAR_ERRSV();
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));
}
#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
CopLINE_set(PL_curcop, oldline);
JMPENV_POP;
my_exit_jump();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_curcop = &PL_compiling;
return 1;
}
+/* removes boilerplate code at the end of each boot_Module xsub */
+void
+Perl_xs_boot_epilog(pTHX_ const I32 ax)
+{
+ if (PL_unitcheckav)
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+ XSRETURN_YES;
+}
+
/*
- * 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