*
* 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, 2019 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)
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;
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();
int
perl_destruct(pTHXx)
{
- dVAR;
volatile signed char destruct_level; /* see possible values in intrpvar.h */
HV *hv;
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
PL_langinfo_buf = NULL;
}
- /* clear character classes */
#ifdef USE_LOCALE_CTYPE
SvREFCNT_dec(PL_warn_locale);
PL_warn_locale = NULL;
#endif
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = 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;
+ 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;
+ }
+ }
+
+ 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);
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;
}
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
- dVAR;
I32 oldscope;
int ret;
dJMPENV;
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)) {
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) {
}
/*
-=head1 SV Manipulation Functions
+=for apidoc_section $SV
=for apidoc get_sv
}
/*
-=head1 Array Manipulation Functions
+=for apidoc_section $AV
=for apidoc get_av
}
/*
-=head1 Hash Manipulation Functions
+=for apidoc_section $HV
=for apidoc get_hv
}
/*
-=head1 CV Manipulation Functions
+=for apidoc_section $CV
-=for apidoc 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 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 call_argv
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;
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;
/* Require a module. */
/*
-=head1 Embedding Functions
+=for apidoc_section $embedding
=for apidoc require_pv
/* 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);
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-2019, 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 __SYMBIAN32__
- PerlIO_printf(PIO_stdout,
- "Symbian port by Nokia, 2004-2005\n");
-#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
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