*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
* 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
- * 2013, 2014, 2015, 2016, 2017, 2018 by Larry Wall and others
+ * 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
KEYWORD_PLUGIN_MUTEX_INIT;
HINTS_REFCNT_INIT;
LOCALE_INIT;
+ USER_PROP_MUTEX_INIT;
+ ENV_INIT;
MUTEX_INIT(&PL_dollarzero_mutex);
MUTEX_INIT(&PL_my_ctx_mutex);
# endif
=cut
*/
-static void
-S_fixup_platform_bugs(void)
-{
-#if defined(__GLIBC__) && IVSIZE == 8 \
- && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
- {
- IV l = 3;
- IV r = -10;
- /* Cannot do this check with inlined IV constants since
- * that seems to work correctly even with the buggy glibc. */
- if (l % r == -3) {
- dTHX;
- /* Yikes, we have the bug.
- * Patch in the workaround version. */
- PL_ppaddr[OP_I_MODULO] = &Perl_pp_i_modulo_glibc_bugfix;
- }
- }
-#endif
-}
-
void
perl_construct(pTHXx)
{
SvREADONLY_on(&PL_sv_placeholder);
SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
- PL_sighandlerp = (Sighandler_t) Perl_sighandler;
+ PL_sighandlerp = Perl_sighandler;
+ PL_sighandler1p = Perl_sighandler1;
+ PL_sighandler3p = Perl_sighandler3;
+
#ifdef PERL_USES_PL_PIDSTATUS
PL_pidstatus = newHV();
#endif
init_ids();
- S_fixup_platform_bugs();
-
JMPENV_BOOTSTRAP;
STATUS_ALL_SUCCESS;
- init_i18nl10n(1);
+ init_uniprops();
+ (void) uvchr_to_utf8_flags((U8 *) PL_TR_SPECIAL_HANDLING_UTF8,
+ TR_SPECIAL_HANDLING,
+ UNICODE_ALLOW_ABOVE_IV_MAX);
#if defined(LOCAL_PATCH_COUNT)
PL_localpatches = local_patches; /* For possible -v */
/* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
HvMAX(PL_registered_mros) = 0;
- PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist);
- PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(XPosixAlnum_invlist);
- PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(XPosixAlpha_invlist);
- PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist);
- PL_XPosix_ptrs[_CC_CASED] = _new_invlist_C_array(Cased_invlist);
- PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist);
- PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(XPosixDigit_invlist);
- PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(XPosixGraph_invlist);
- PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(XPosixLower_invlist);
- 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_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);
- PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist);
- PL_Assigned_invlist = _new_invlist_C_array(Assigned_invlist);
- PL_SCX_invlist = _new_invlist_C_array(_Perl_SCX_invlist);
-#ifdef HAS_POSIX_2008_LOCALE
+#ifdef USE_POSIX_2008_LOCALE
PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL);
#endif
ENTER;
+ init_i18nl10n(1);
}
/*
#endif
/*
-=for apidoc Am|int|perl_destruct|PerlInterpreter *my_perl
+=for apidoc perl_destruct
Shuts down a Perl interpreter. See L<perlembed> for a tutorial.
PERL_WAIT_FOR_CHILDREN;
destruct_level = PL_perl_destruct_level;
-#if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL)
{
const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
if (s) {
else
i = 0;
}
-#ifdef DEBUGGING
if (destruct_level < i) destruct_level = i;
-#endif
#ifdef PERL_TRACK_MEMPOOL
/* RT #114496, for perl_free */
PL_perl_destruct_level = i;
#endif
}
}
-#endif
if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
dJMPENV;
FREETMPS;
assert(PL_scopestack_ix == 0);
+ /* normally when we get here, PL_parser should be null due to having
+ * its original (null) value restored by SAVEt_PARSER during leaving
+ * scope (usually before run-time starts in fact).
+ * But if a thread is created within a BEGIN block, the parser is
+ * duped, but the SAVEt_PARSER savestack entry isn't. So PL_parser
+ * never gets cleaned up.
+ * Clean it up here instead. This is a bit of a hack.
+ */
+ if (PL_parser) {
+ /* stop parser_free() stomping on PL_curcop */
+ PL_parser->saved_curcop = PL_curcop;
+ parser_free(PL_parser);
+ }
+
+
/* Need to flush since END blocks can produce output */
/* flush stdout separately, since we can identify it */
#ifdef USE_PERLIO
Safefree(PL_collation_name);
PL_collation_name = NULL;
#endif
-
+#if defined(USE_POSIX_2008_LOCALE) \
+ && defined(USE_THREAD_SAFE_LOCALE) \
+ && ! defined(HAS_QUERYLOCALE)
+ for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) {
+ Safefree(PL_curlocales[i]);
+ PL_curlocales[i] = NULL;
+ }
+#endif
+#ifdef HAS_POSIX_2008_LOCALE
+ {
+ /* This also makes sure we aren't using a locale object that gets freed
+ * below */
+ const locale_t old_locale = uselocale(LC_GLOBAL_LOCALE);
+ if ( old_locale != LC_GLOBAL_LOCALE
+# ifdef USE_POSIX_2008_LOCALE
+ && old_locale != PL_C_locale_obj
+# endif
+ ) {
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s:%d: Freeing %p\n", __FILE__, __LINE__, old_locale));
+ freelocale(old_locale);
+ }
+ }
+# ifdef USE_LOCALE_NUMERIC
+ if (PL_underlying_numeric_obj) {
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s:%d: Freeing %p\n", __FILE__, __LINE__,
+ PL_underlying_numeric_obj));
+ freelocale(PL_underlying_numeric_obj);
+ PL_underlying_numeric_obj = (locale_t) NULL;
+ }
+# endif
+#endif
#ifdef USE_LOCALE_NUMERIC
Safefree(PL_numeric_name);
PL_numeric_name = NULL;
PL_numeric_radix_sv = NULL;
#endif
+ if (PL_setlocale_buf) {
+ Safefree(PL_setlocale_buf);
+ PL_setlocale_buf = NULL;
+ }
+
if (PL_langinfo_buf) {
Safefree(PL_langinfo_buf);
PL_langinfo_buf = NULL;
}
- /* clear character classes */
- for (i = 0; i < POSIX_SWASH_COUNT; i++) {
- SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
- PL_utf8_swash_ptrs[i] = NULL;
- }
- SvREFCNT_dec(PL_utf8_mark);
- SvREFCNT_dec(PL_utf8_toupper);
- SvREFCNT_dec(PL_utf8_totitle);
- SvREFCNT_dec(PL_utf8_tolower);
- SvREFCNT_dec(PL_utf8_tofold);
- SvREFCNT_dec(PL_utf8_idstart);
- SvREFCNT_dec(PL_utf8_idcont);
- 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_tolower = NULL;
- PL_utf8_tofold = NULL;
- PL_utf8_idstart = 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;
- for (i = 0; i < POSIX_CC_COUNT; i++) {
- SvREFCNT_dec(PL_XPosix_ptrs[i]);
- PL_XPosix_ptrs[i] = NULL;
- }
+
+ SvREFCNT_dec(PL_AboveLatin1);
+ PL_AboveLatin1 = NULL;
+ SvREFCNT_dec(PL_Assigned_invlist);
+ PL_Assigned_invlist = NULL;
+ SvREFCNT_dec(PL_GCB_invlist);
PL_GCB_invlist = NULL;
+ SvREFCNT_dec(PL_HasMultiCharFold);
+ PL_HasMultiCharFold = NULL;
+ SvREFCNT_dec(PL_InMultiCharFold);
+ PL_InMultiCharFold = NULL;
+ SvREFCNT_dec(PL_Latin1);
+ PL_Latin1 = NULL;
+ SvREFCNT_dec(PL_LB_invlist);
PL_LB_invlist = NULL;
+ SvREFCNT_dec(PL_SB_invlist);
PL_SB_invlist = NULL;
+ SvREFCNT_dec(PL_SCX_invlist);
PL_SCX_invlist = NULL;
+ SvREFCNT_dec(PL_UpperLatin1);
+ PL_UpperLatin1 = NULL;
+ SvREFCNT_dec(PL_in_some_fold);
+ PL_in_some_fold = NULL;
+ SvREFCNT_dec(PL_utf8_idcont);
+ PL_utf8_idcont = NULL;
+ SvREFCNT_dec(PL_utf8_idstart);
+ PL_utf8_idstart = NULL;
+ SvREFCNT_dec(PL_utf8_perl_idcont);
+ PL_utf8_perl_idcont = NULL;
+ SvREFCNT_dec(PL_utf8_perl_idstart);
+ PL_utf8_perl_idstart = NULL;
+ SvREFCNT_dec(PL_utf8_xidcont);
+ PL_utf8_xidcont = NULL;
+ SvREFCNT_dec(PL_utf8_xidstart);
+ PL_utf8_xidstart = NULL;
+ SvREFCNT_dec(PL_WB_invlist);
PL_WB_invlist = NULL;
- PL_Assigned_invlist = NULL;
+ SvREFCNT_dec(PL_utf8_toupper);
+ PL_utf8_toupper = NULL;
+ SvREFCNT_dec(PL_utf8_totitle);
+ PL_utf8_totitle = NULL;
+ SvREFCNT_dec(PL_utf8_tolower);
+ PL_utf8_tolower = NULL;
+ SvREFCNT_dec(PL_utf8_tofold);
+ PL_utf8_tofold = NULL;
+ SvREFCNT_dec(PL_utf8_tosimplefold);
+ PL_utf8_tosimplefold = NULL;
+ SvREFCNT_dec(PL_utf8_charname_begin);
+ PL_utf8_charname_begin = NULL;
+ SvREFCNT_dec(PL_utf8_charname_continue);
+ PL_utf8_charname_continue = NULL;
+ SvREFCNT_dec(PL_utf8_mark);
+ PL_utf8_mark = NULL;
+ SvREFCNT_dec(PL_InBitmap);
+ PL_InBitmap = NULL;
+ SvREFCNT_dec(PL_CCC_non0_non230);
+ PL_CCC_non0_non230 = NULL;
+ SvREFCNT_dec(PL_Private_Use);
+ PL_Private_Use = NULL;
+
+ for (i = 0; i < POSIX_CC_COUNT; i++) {
+ SvREFCNT_dec(PL_XPosix_ptrs[i]);
+ PL_XPosix_ptrs[i] = NULL;
+
+ if (i != _CC_CASED) { /* A copy of Alpha */
+ SvREFCNT_dec(PL_Posix_ptrs[i]);
+ PL_Posix_ptrs[i] = NULL;
+ }
+ }
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
- " flags=0x%"UVxf
- " refcnt=%"UVuf pTHX__FORMAT "\n"
+ " flags=0x%" UVxf
+ " refcnt=%" UVuf pTHX__FORMAT "\n"
"\tallocated at %s:%d %s %s (parent 0x%" UVxf ");"
"serial %" UVuf "\n",
(void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
}
/*
-=for apidoc Am|int|perl_parse|PerlInterpreter *my_perl|XSINIT_t xsinit|int argc|char **argv|char **env
+=for apidoc perl_parse
Tells a Perl interpreter to parse a Perl script. This performs most
of the initialisation of a Perl interpreter. See L<perlembed> for
" PERL_USE_SAFE_PUTENV"
# endif
# ifdef SILENT_NO_TAINT_SUPPORT
- " SILENT_NO_TAINT_SUPPORT"
+ " SILENT_NO_TAINT_SUPPORT"
# endif
# ifdef UNLINK_ALL_VERSIONS
" UNLINK_ALL_VERSIONS"
# ifdef USE_SITECUSTOMIZE
" USE_SITECUSTOMIZE"
# endif
+# ifdef USE_THREAD_SAFE_LOCALE
+ " USE_THREAD_SAFE_LOCALE"
+# endif
;
PERL_UNUSED_ARG(cv);
PERL_UNUSED_VAR(items);
#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') {
d = s;
if (!*s)
break;
- if (!strchr("CDIMUdmtwW", *s))
+ if (!memCHRs("CDIMUdmtwW", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
while (++s && *s) {
if (isSPACE(*s)) {
This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid,
but avoids duplicating the logic from perl_construct().
*/
- if (PL_tainting &&
+ if (TAINT_get &&
PerlProc_getuid() == PerlProc_geteuid() &&
PerlProc_getgid() == PerlProc_getegid()) {
Perl_drand48_init_r(&PL_internal_random_state, seed());
}
/*
-=for apidoc Am|int|perl_run|PerlInterpreter *my_perl
+=for apidoc perl_run
Tells a Perl interpreter to run its main program. See L<perlembed>
for a tutorial.
perl_run(pTHXx)
{
I32 oldscope;
- int ret = 0, exit_called = 0;
+ int ret = 0;
dJMPENV;
PERL_ARGS_ASSERT_PERL_RUN;
case 0: /* normal completion */
redo_body:
run_body(oldscope);
- goto handle_exit;
+ /* FALLTHROUGH */
case 2: /* my_exit() */
- exit_called = 1;
- handle_exit:
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- if (exit_called) {
- ret = STATUS_EXIT;
- if (ret == 0) ret = 0x100;
- } else {
- ret = 0;
- }
+ ret = STATUS_EXIT;
break;
case 3:
if (PL_restartop) {
/*
=head1 SV Manipulation Functions
-=for apidoc p||get_sv
+=for apidoc get_sv
Returns the SV of the specified Perl scalar. C<flags> are passed to
C<gv_fetchpv>. If C<GV_ADD> is set and the
/*
=head1 Array Manipulation Functions
-=for apidoc p||get_av
+=for apidoc get_av
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
/*
=head1 Hash Manipulation Functions
-=for apidoc p||get_hv
+=for apidoc get_hv
Returns the HV of the specified Perl hash. C<flags> are passed to
C<gv_fetchpv>. If C<GV_ADD> is set and the
/*
=head1 CV Manipulation Functions
-=for apidoc p||get_cvn_flags
+=for apidoc get_cvn_flags
Returns the CV of the specified Perl subroutine. C<flags> are passed to
C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
then NULL is returned.
-=for apidoc p||get_cv
+=for apidoc get_cv
Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
=head1 Callback Functions
-=for apidoc p||call_argv
+=for apidoc call_argv
Performs a callback to the specified named and package-scoped Perl subroutine
with C<argv> (a C<NULL>-terminated array of strings) as arguments. See
}
/*
-=for apidoc p||call_pv
+=for apidoc call_pv
Performs a callback to the specified Perl sub. See L<perlcall>.
}
/*
-=for apidoc p||call_method
+=for apidoc call_method
Performs a callback to the specified Perl method. The blessed object must
be on the stack. See L<perlcall>.
/* May be called with any of a CV, a GV, or an SV containing the name. */
/*
-=for apidoc p||call_sv
+=for apidoc call_sv
Performs a callback to the Perl sub specified by the SV.
See L<perlcall>.
+=for apidoc Amnh||G_METHOD
+=for apidoc Amnh||G_METHOD_NAMED
+
=cut
*/
/* Eval a string. The G_EVAL flag is always assumed. */
/*
-=for apidoc p||eval_sv
+=for apidoc 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 C<G_EVAL>. See L<perlcall>.
+The C<G_RETHROW> flag can be used if you only need eval_sv() to
+execute code specified by a string, but not catch any errors.
+
+=for apidoc Amnh||G_RETHROW
=cut
*/
goto redo_body;
}
fail:
+ if (flags & G_RETHROW) {
+ JMPENV_POP;
+ croak_sv(ERRSV);
+ }
+
PL_stack_sp = PL_stack_base + oldmark;
if ((flags & G_WANT) == G_ARRAY)
retval = 0;
}
/*
-=for apidoc p||eval_pv
+=for apidoc eval_pv
Tells Perl to C<eval> the given string in scalar context and return an SV* result.
PERL_ARGS_ASSERT_EVAL_PV;
- eval_sv(sv, G_SCALAR);
- SvREFCNT_dec(sv);
+ if (croak_on_error) {
+ sv_2mortal(sv);
+ eval_sv(sv, G_SCALAR | G_RETHROW);
+ }
+ else {
+ eval_sv(sv, G_SCALAR);
+ SvREFCNT_dec(sv);
+ }
{
dSP;
PUTBACK;
}
- /* just check empty string or undef? */
- if (croak_on_error) {
- SV * const errsv = ERRSV;
- if(SvTRUE_NN(errsv))
- /* replace with croak_sv? */
- Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
- }
-
return sv;
}
/*
=head1 Embedding Functions
-=for apidoc p||require_pv
+=for apidoc require_pv
Tells Perl to C<require> the file named by the string argument. It is
analogous to the Perl code C<eval "require '$file'">. It's even
" B dump suBroutine definitions, including special Blocks like BEGIN\n",
" L trace some locale setting information--for Perl core development\n",
" i trace PerlIO layer processing\n",
+ " y trace y///, tr/// compilation and execution\n",
NULL
};
UV uv = 0;
if (isALPHA(**s)) {
/* if adding extra options, remember to update DEBUG_MASK */
- static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi";
+ static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLiy";
for (; isWORDCHAR(**s); (*s)++) {
const char * const d = strchr(debopts,**s);
}
}
else if (isDIGIT(**s)) {
- const char* e;
+ const char* e = *s + strlen(*s);
if (grok_atoUV(*s, &uv, &e))
*s = e;
for (; isWORDCHAR(**s); (*s)++) ;
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2018, Larry Wall\n");
+ "\n\nCopyright 1987-2020, Larry Wall\n");
#ifdef MSDOS
PerlIO_printf(PIO_stdout,
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
PerlIO_printf(PIO_stdout,
"BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
#endif
-#ifdef UNDER_CE
- PerlIO_printf(PIO_stdout,
- "WINCE port by Rainer Keuchel, 2001-2002\n"
- "Built on " __DATE__ " " __TIME__ "\n\n");
- wce_hitreturn();
-#endif
#ifdef __SYMBIAN32__
PerlIO_printf(PIO_stdout,
"Symbian port by Nokia, 2004-2005\n");
UV uv;
/* if find_script() returns, it returns a malloc()-ed value */
scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
+ s = scriptname + strlen(scriptname);
if (strBEGINs(scriptname, "/dev/fd/")
&& isDIGIT(scriptname[8])
}
}
+/*
+=for apidoc my_exit
+
+A wrapper for the C library L<exit(3)>, honoring what L<perlapi/PL_exit_flags>
+say to do.
+
+=cut
+*/
+
void
Perl_my_exit(pTHX_ U32 status)
{
https://perl5.git.perl.org / perl5.git / blobdiff