#include "perl.h"
#include "patchlevel.h" /* for local_patches */
#include "XSUB.h"
-#include "charclass_invlists.h"
#ifdef NETWARE
#include "nwutil.h"
PL_stashcache = newHV();
PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
- PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING);
#ifdef HAS_MMAP
if (!PL_mmap_page_size) {
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;
Safefree(PL_inplace);
PL_inplace = NULL;
SvREFCNT_dec(PL_patchlevel);
- SvREFCNT_dec(PL_apiversion);
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
PL_DBsingle = NULL;
PL_DBtrace = NULL;
PL_DBsignal = NULL;
+ PL_DBsingle_iv = 0;
+ PL_DBtrace_iv = 0;
+ PL_DBsignal_iv = 0;
PL_DBcv = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
SvREFCNT_dec(PL_utf8_foldable);
SvREFCNT_dec(PL_utf8_foldclosures);
SvREFCNT_dec(PL_AboveLatin1);
+ SvREFCNT_dec(PL_InBitmap);
SvREFCNT_dec(PL_UpperLatin1);
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_utf8_idcont = NULL;
PL_utf8_foldclosures = 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);
# 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') {
it should be reported immediately as a build failure. */
(void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
Perl_newSVpvf(aTHX_
- "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }",
- 0, SVfARG(*inc0), 0,
- 0, SVfARG(*inc0), 0));
+ "BEGIN { my $f = q%c%s%"SVf"/buildcustomize.pl%c; "
+ "do {local $!; -f $f }"
+ " and do $f || die $@ || qq '$f: $!' }",
+ 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
}
# else
/* SITELIB_EXP is a function call on Win32. */
PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
CvUNIQUE_on(PL_compcv);
- CvPADLIST(PL_compcv) = pad_new(0);
+ CvPADLIST_set(PL_compcv, pad_new(0));
PL_isarev = newHV();
#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
my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
- sv_setiv(PL_DBsingle, 1);
+ PL_DBsingle_iv = 1;
if (PL_initav) {
PERL_SET_PHASE(PERL_PHASE_INIT);
call_list(oldscope, PL_initav);
CALLRUNOPS(aTHX);
}
my_exit(0);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
/*
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);
}
{
dVAR; dSP;
LOGOP myop; /* fake syntax tree node */
- UNOP method_unop;
- SVOP method_svop;
+ METHOP method_op;
I32 oldmark;
VOL I32 retval = 0;
I32 oldscope;
myop.op_private |= OPpENTERSUB_DB;
if (flags & (G_METHOD|G_METHOD_NAMED)) {
+ Zero(&method_op, 1, METHOP);
+ method_op.op_next = (OP*)&myop;
+ PL_op = (OP*)&method_op;
if ( flags & G_METHOD_NAMED ) {
- Zero(&method_svop, 1, SVOP);
- method_svop.op_next = (OP*)&myop;
- method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
- method_svop.op_type = OP_METHOD_NAMED;
- method_svop.op_sv = sv;
- PL_op = (OP*)&method_svop;
+ method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
+ method_op.op_type = OP_METHOD_NAMED;
+ method_op.op_u.op_meth_sv = sv;
} else {
- Zero(&method_unop, 1, UNOP);
- method_unop.op_next = (OP*)&myop;
- method_unop.op_ppaddr = PL_ppaddr[OP_METHOD];
- method_unop.op_type = OP_METHOD;
- PL_op = (OP*)&method_unop;
+ method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
+ method_op.op_type = OP_METHOD;
}
myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
myop.op_type = OP_ENTERSUB;
-
}
if (!(flags & G_EVAL)) {
FREETMPS;
JMPENV_POP;
my_exit_jump();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_restartjmpenv = NULL;
FREETMPS;
JMPENV_POP;
my_exit_jump();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_restartjmpenv = NULL;
/*
=for apidoc p||eval_pv
-Tells Perl to C<eval> the given string and return an SV* result.
+Tells Perl to C<eval> the given string in scalar context and return an SV* result.
=cut
*/
" 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
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.
Perl_init_debugger(pTHX)
{
HV * const ostash = PL_curstash;
+ MAGIC *mg;
PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsingle))
sv_setiv(PL_DBsingle, 0);
+ mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_SINGLE;
+ SvSETMAGIC(PL_DBsingle);
+
PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBtrace))
sv_setiv(PL_DBtrace, 0);
+ mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_TRACE;
+ SvSETMAGIC(PL_DBtrace);
+
PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
if (!SvIOK(PL_DBsignal))
sv_setiv(PL_DBsignal, 0);
+ mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
+ mg->mg_private = DBVARMG_SIGNAL;
+ SvSETMAGIC(PL_DBsignal);
+
SvREFCNT_dec(PL_curstash);
PL_curstash = ostash;
}
#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 U32 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