*
* 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.
static void
S_init_tls_and_interp(PerlInterpreter *my_perl)
{
- dVAR;
if (!PL_curinterp) {
PERL_SET_INTERP(my_perl);
#if defined(USE_ITHREADS)
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
void
Perl_sys_init(int* argc, char*** argv)
{
- dVAR;
PERL_ARGS_ASSERT_SYS_INIT;
void
Perl_sys_init3(int* argc, char*** argv, char*** env)
{
- dVAR;
PERL_ARGS_ASSERT_SYS_INIT3;
void
Perl_sys_term(void)
{
- dVAR;
if (!PL_veto_cleanup) {
PERL_SYS_TERM_BODY();
}
#else
/*
-=head1 Embedding Functions
+=for apidoc_section $embedding
=for apidoc perl_alloc
=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)
{
- dVAR;
PERL_ARGS_ASSERT_PERL_CONSTRUCT;
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;
- 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);
-
- 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 */
}
#endif /* HAS_MMAP */
-#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
- PL_timesbase.tms_utime = 0;
- PL_timesbase.tms_stime = 0;
- PL_timesbase.tms_cutime = 0;
- PL_timesbase.tms_cstime = 0;
-#endif
-
PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
PL_registered_mros = newHV();
/* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
HvMAX(PL_registered_mros) = 0;
-#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.
int
perl_destruct(pTHXx)
{
- dVAR;
volatile signed char destruct_level; /* see possible values in intrpvar.h */
HV *hv;
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
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
PL_curlocales[i] = NULL;
}
#endif
-#ifdef USE_LOCALE_NUMERIC
- Safefree(PL_numeric_name);
- PL_numeric_name = NULL;
- SvREFCNT_dec(PL_numeric_radix_sv);
- PL_numeric_radix_sv = NULL;
-
-# ifdef HAS_POSIX_2008_LOCALE
+#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) {
- /* Make sure we aren't using the locale space we are about to free */
- uselocale(LC_GLOBAL_LOCALE);
+ 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;
+ SvREFCNT_dec(PL_numeric_radix_sv);
+ PL_numeric_radix_sv = NULL;
+#endif
if (PL_setlocale_buf) {
Safefree(PL_setlocale_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_foldclosures);
+ PL_utf8_foldclosures = 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 (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = NULL;
+ if (i != _CC_CASED) { /* A copy of Alpha */
+ SvREFCNT_dec(PL_Posix_ptrs[i]);
+ PL_Posix_ptrs[i] = NULL;
+ }
+ }
+
+ free_and_set_cop_warnings(&PL_compiling, NULL);
cophh_free(CopHINTHASH_get(&PL_compiling));
CopHINTHASH_set(&PL_compiling, cophh_new_empty());
CopFILE_free(&PL_compiling);
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
void
perl_free(pTHXx)
{
- dVAR;
PERL_ARGS_ASSERT_PERL_FREE;
#endif
perl_fini(void)
{
- dVAR;
if (
-#ifdef PERL_GLOBAL_STRUCT_PRIVATE
- my_vars &&
-#endif
PL_curinterp && !PL_veto_cleanup)
FREE_THREAD_KEY;
}
}
/*
-=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
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
- dVAR;
I32 oldscope;
int ret;
dJMPENV;
" 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);
STATIC void *
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
- dVAR;
PerlIO *rsfp;
int argc = PL_origargc;
char **argv = PL_origargv;
char c;
bool doextract = FALSE;
const char *cddir = NULL;
+ bool minus_e = FALSE; /* both -e and -E */
#ifdef USE_SITECUSTOMIZE
bool minus_f = FALSE;
#endif
/* FALLTHROUGH */
case 'e':
forbid_setid('e', FALSE);
+ minus_e = TRUE;
if (!PL_e_script) {
PL_e_script = newSVpvs("");
add_read_e_script = TRUE;
#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());
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(SYMBIAN)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
init_os_extras();
#endif
#endif
* PL_utf8locale is conditionally turned on by
* locale.c:Perl_init_i18nl10n() if the environment
* look like the user wants to use UTF-8. */
-#if defined(__SYMBIAN32__)
- PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
-#endif
# ifndef PERL_IS_MINIPERL
if (PL_unicode) {
/* Requires init_predump_symbols(). */
filter_add(read_e_script, NULL);
/* now parse the script */
+ if (minus_e == FALSE)
+ PL_hints |= HINTS_DEFAULT; /* after init_main_stash ; need to be after init_predump_symbols */
SETERRNO(0,SS_NORMAL);
if (yyparse(GRAMPROG) || PL_parser->error_count) {
}
/*
-=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_section $SV
-=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_section $AV
-=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_section $HV
-=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_section $CV
-=for apidoc p||get_cvn_flags
+=for apidoc get_cv
+=for apidoc_item |CV *|get_cvs|"string"|I32 flags
+=for apidoc_item get_cvn_flags
-Returns the CV of the specified Perl subroutine. C<flags> are passed to
+These return 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
exist then it will be declared (which has the same effect as saying
-C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
+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
+The forms differ only in how the subroutine is specified.. With C<get_cvs>,
+the name is a literal C string, enclosed in double quotes. With C<get_cv>, the
+name is given by the C<name> parameter, which must be a NUL-terminated C
+string. With C<get_cvn_flags>, the name is also given by the C<name>
+parameter, but it is a Perl string (possibly containing embedded NUL bytes),
+and its length in bytes is contained in the C<len> parameter.
-Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
+=for apidoc Amnh||GV_ADD
=cut
*/
/*
-=head1 Callback Functions
+=for apidoc_section $callback
-=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
*/
Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
/* See G_* flags in cop.h */
{
- dVAR;
LOGOP myop; /* fake syntax tree node */
METHOP method_op;
I32 oldmark;
/* 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
*/
/* See G_* flags in cop.h */
{
- dVAR;
UNOP myop; /* fake syntax tree node */
volatile I32 oldmark;
volatile I32 retval = 0;
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;
}
/* Require a module. */
/*
-=head1 Embedding Functions
+=for apidoc_section $embedding
-=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
/* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
minimum of 509 character string literals. */
static const char * const usage_msg[] = {
-" -0[octal] specify record separator (\\0, if no argument)\n"
-" -a autosplit mode with -n or -p (splits $_ into @F)\n"
-" -C[number/list] enables the listed Unicode features\n"
-" -c check syntax only (runs BEGIN and CHECK blocks)\n"
-" -d[:debugger] run program under debugger\n"
-" -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n",
-" -e program one line of program (several -e's allowed, omit programfile)\n"
-" -E program like -e, but enables all optional features\n"
-" -f don't do $sitelib/sitecustomize.pl at startup\n"
-" -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
-" -i[extension] edit <> files in place (makes backup if extension supplied)\n"
-" -Idirectory specify @INC/#include directory (several -I's allowed)\n",
-" -l[octal] enable line ending processing, specifies line terminator\n"
-" -[mM][-]module execute \"use/no module...\" before executing program\n"
-" -n assume \"while (<>) { ... }\" loop around program\n"
-" -p assume loop like -n but print line also, like sed\n"
-" -s enable rudimentary parsing for switches after programfile\n"
-" -S look for programfile using PATH environment variable\n",
-" -t enable tainting warnings\n"
-" -T enable tainting checks\n"
-" -u dump core after parsing program\n"
-" -U allow unsafe operations\n"
-" -v print version, patchlevel and license\n"
-" -V[:variable] print configuration summary (or a single Config.pm variable)\n",
-" -w enable many useful warnings\n"
-" -W enable all warnings\n"
-" -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
-" -X disable all warnings\n"
+" -0[octal/hexadecimal] specify record separator (\\0, if no argument)\n"
+" -a autosplit mode with -n or -p (splits $_ into @F)\n"
+" -C[number/list] enables the listed Unicode features\n"
+" -c check syntax only (runs BEGIN and CHECK blocks)\n"
+" -d[t][:MOD] run program under debugger or module Devel::MOD\n"
+" -D[number/letters] set debugging flags (argument is a bit mask or alphabets)\n",
+" -e commandline one line of program (several -e's allowed, omit programfile)\n"
+" -E commandline like -e, but enables all optional features\n"
+" -f don't do $sitelib/sitecustomize.pl at startup\n"
+" -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
+" -i[extension] edit <> files in place (makes backup if extension supplied)\n"
+" -Idirectory specify @INC/#include directory (several -I's allowed)\n",
+" -l[octnum] enable line ending processing, specifies line terminator\n"
+" -[mM][-]module execute \"use/no module...\" before executing program\n"
+" -n assume \"while (<>) { ... }\" loop around program\n"
+" -p assume loop like -n but print line also, like sed\n"
+" -s enable rudimentary parsing for switches after programfile\n"
+" -S look for programfile using PATH environment variable\n",
+" -t enable tainting warnings\n"
+" -T enable tainting checks\n"
+" -u dump core after parsing program\n"
+" -U allow unsafe operations\n"
+" -v print version, patchlevel and license\n"
+" -V[:configvar] print configuration summary (or a single Config.pm variable)\n",
+" -w enable many useful warnings\n"
+" -W enable all warnings\n"
+" -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
+" -X disable all warnings\n"
" \n"
"Run 'perldoc perl' for more help with Perl.\n\n",
NULL
" 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)++) ;
const char *
Perl_moreswitches(pTHX_ const char *s)
{
- dVAR;
UV rschar;
const char option = *s; /* used to remember option in -m/-M code */
return s;
case 'W':
PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_ALL ;
+ free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
s++;
return s;
case 'X':
PL_dowarn = G_WARN_ALL_OFF;
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_NONE ;
+ free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
s++;
return s;
case '*':
#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");
-#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
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])
PERL_ARGS_ASSERT_VALIDATE_SUID;
if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
- dVAR;
int fd = PerlIO_fileno(rsfp);
Stat_t statbuf;
if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
STATIC void
S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
{
-#ifdef USE_ITHREADS
- dVAR;
-#endif
GV* tmpgv;
PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
}
}
-#if defined(DOSISH) || defined(__SYMBIAN32__)
+#if defined(DOSISH)
# define PERLLIB_SEP ';'
#elif defined(__VMS)
# define PERLLIB_SEP PL_perllib_sep
#ifdef PERL_IS_MINIPERL
const Size_t extra = 0;
#else
- Size_t extra = av_tindex(av) + 1;
+ Size_t extra = av_count(av);
#endif
av_unshift(inc, extra + push_basedir);
if (push_basedir)
PERL_ARGS_ASSERT_CALL_LIST;
- while (av_tindex(paramList) >= 0) {
+ while (av_count(paramList) > 0) {
cv = MUTABLE_CV(av_shift(paramList));
if (PL_savebegin) {
if (paramList == PL_beginav) {
}
}
+/*
+=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)
{
* success/warning codes to fatal with out changing
* the POSIX status code. The severity makes VMS native
* status handling work, while UNIX mode programs use the
- * the POSIX exit codes.
+ * POSIX exit codes.
*/
if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
STATUS_NATIVE &= STS$M_COND_ID;
https://perl5.git.perl.org / perl5.git / blobdiff