#endif
PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
+#ifdef PERL_TRACE_OPS
+ Zero(PL_op_exec_cnt, OP_max+2, UV);
+#endif
+
init_constants();
SvREADONLY_on(&PL_sv_placeholder);
HvSHAREKEYS_off(PL_strtab); /* mandatory */
hv_ksplit(PL_strtab, 512);
+ Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
+
#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
_dyld_lookup_and_bind
("__environ", (unsigned long *) &environ_pointer, NULL);
if (returned_errno || *buffer) {
Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
" %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
- returned_errno, strerror(returned_errno));
+ returned_errno, Strerror(returned_errno));
}
}
#endif
/* Need to flush since END blocks can produce output */
my_fflush_all();
+#ifdef PERL_TRACE_OPS
+ /* If we traced all Perl OP usage, report and clean up */
+ PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
+ for (i = 0; i <= OP_max; ++i) {
+ PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
+ PL_op_exec_cnt[i] = 0;
+ }
+ /* Utility slot for easily doing little tracing experiments in the runloop: */
+ if (PL_op_exec_cnt[OP_max+1] != 0)
+ PerlIO_printf(Perl_debug_log, " SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]);
+ PerlIO_printf(Perl_debug_log, "\n");
+#endif
+
+
if (PL_threadhook(aTHX)) {
/* Threads hook has vetoed further cleanup */
PL_veto_cleanup = TRUE;
/* ensure comppad/curpad to refer to main's pad */
if (CvPADLIST(PL_main_cv)) {
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
+ PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
}
op_free(PL_main_root);
PL_main_root = NULL;
PerlIO_destruct(aTHX);
- if (PL_sv_objcount) {
- /*
- * Try to destruct global references. We do this first so that the
- * destructors and destructees still exist. Some sv's might remain.
- * Non-referenced objects are on their own.
- */
- sv_clean_objs();
- PL_sv_objcount = 0;
- }
+ /*
+ * Try to destruct global references. We do this first so that the
+ * destructors and destructees still exist. Some sv's might remain.
+ * Non-referenced objects are on their own.
+ */
+ sv_clean_objs();
/* unhook hooks which will soon be, or use, destroyed data */
SvREFCNT_dec(PL_warnhook);
sys_intern_clear();
#endif
+ /* constant strings */
+ for (i = 0; i < SV_CONSTS_COUNT; i++) {
+ SvREFCNT_dec(PL_sv_consts[i]);
+ PL_sv_consts[i] = NULL;
+ }
+
/* Destruct the global string table. */
{
/* Yell and reset the HeVAL() slots that are still holding refcounts,
Safefree(PL_origfilename);
PL_origfilename = NULL;
Safefree(PL_reg_curpm);
- Safefree(PL_reg_poscache);
free_tied_hv_pool();
Safefree(PL_op_mask);
Safefree(PL_psig_name);
{
# ifdef NETWARE
void *host = nw_internal_host;
-# else
- void *host = w32_internal_host;
-# endif
PerlMem_free(aTHXx);
-# ifdef NETWARE
nw_delete_internal_host(host);
# else
+ void *host = w32_internal_host;
+ PerlMem_free(aTHXx);
win32_delete_internal_host(host);
# endif
}
perl_fini(void)
{
dVAR;
- if (PL_curinterp && !PL_veto_cleanup)
+ if (
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+ my_vars &&
+#endif
+ PL_curinterp && !PL_veto_cleanup)
FREE_THREAD_KEY;
}
while (seed < seed_end) {
PerlIO_printf(Perl_debug_log, "%02x", *seed++);
}
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
+ PL_HASH_RAND_BITS_ENABLED,
+ PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
+#endif
PerlIO_printf(Perl_debug_log, "\n");
}
}
# ifdef NO_MATHOMS
" NO_MATHOMS"
# endif
+# ifdef NO_HASH_SEED
+ " NO_HASH_SEED"
+# endif
+# ifdef NO_TAINT_SUPPORT
+ " NO_TAINT_SUPPORT"
+# endif
# ifdef PERL_DISABLE_PMC
" PERL_DISABLE_PMC"
# endif
# ifdef PERL_EXTERNAL_GLOB
" PERL_EXTERNAL_GLOB"
# endif
+# ifdef PERL_HASH_FUNC_SIPHASH
+ " PERL_HASH_FUNC_SIPHASH"
+# endif
+# ifdef PERL_HASH_FUNC_SDBM
+ " PERL_HASH_FUNC_SDBM"
+# endif
+# ifdef PERL_HASH_FUNC_DJB2
+ " PERL_HASH_FUNC_DJB2"
+# endif
+# ifdef PERL_HASH_FUNC_SUPERFAST
+ " PERL_HASH_FUNC_SUPERFAST"
+# endif
+# ifdef PERL_HASH_FUNC_MURMUR3
+ " PERL_HASH_FUNC_MURMUR3"
+# endif
+# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
+ " PERL_HASH_FUNC_ONE_AT_A_TIME"
+# endif
+# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
+ " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
+# endif
+# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
+ " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
+# endif
# ifdef PERL_IS_MINIPERL
" PERL_IS_MINIPERL"
# 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
+# ifdef PERL_PERTURB_KEYS_DISABLED
+ " PERL_PERTURB_KEYS_DISABLED"
+# endif
+# ifdef PERL_PERTURB_KEYS_RANDOM
+ " PERL_PERTURB_KEYS_RANDOM"
+# endif
# ifdef PERL_PRESERVE_IVUV
" PERL_PRESERVE_IVUV"
# endif
# ifdef USE_FAST_STDIO
" USE_FAST_STDIO"
# endif
+# ifdef USE_HASH_SEED_EXPLICIT
+ " USE_HASH_SEED_EXPLICIT"
+# endif
# ifdef USE_LOCALE
" USE_LOCALE"
# endif
#if SILENT_NO_TAINT_SUPPORT
/* silently ignore */
#elif NO_TAINT_SUPPORT
- Perl_croak("This perl was compiled without taint support. "
+ Perl_croak_nocontext("This perl was compiled without taint support. "
"Cowardly refusing to run with -t or -T flags");
#else
CHECK_MALLOC_TOO_LATE_FOR('t');
#if SILENT_NO_TAINT_SUPPORT
/* silently ignore */
#elif NO_TAINT_SUPPORT
- Perl_croak("This perl was compiled without taint support. "
+ Perl_croak_nocontext("This perl was compiled without taint support. "
"Cowardly refusing to run with -t or -T flags");
#else
CHECK_MALLOC_TOO_LATE_FOR('T');
#if SILENT_NO_TAINT_SUPPORT
/* silently ignore */
#elif NO_TAINT_SUPPORT
- Perl_croak("This perl was compiled without taint support. "
+ Perl_croak_nocontext("This perl was compiled without taint support. "
"Cowardly refusing to run with -t or -T flags");
#else
CHECK_MALLOC_TOO_LATE_FOR('T');
#if SILENT_NO_TAINT_SUPPORT
/* silently ignore */
#elif NO_TAINT_SUPPORT
- Perl_croak("This perl was compiled without taint support. "
+ Perl_croak_nocontext("This perl was compiled without taint support. "
"Cowardly refusing to run with -t or -T flags");
#else
if( !TAINTING_get) {
SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
if (inc0) {
+ /* if lib/buildcustomize.pl exists, it should not fail. If it does,
+ 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} && do q%c%"SVf"/buildcustomize.pl%c }",
+ "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }",
0, *inc0, 0,
0, *inc0, 0));
}
/* See G_* flags in cop.h */
{
STRLEN len;
+ SV* sv;
PERL_ARGS_ASSERT_CALL_METHOD;
len = strlen(methname);
+ sv = flags & G_METHOD_NAMED
+ ? sv_2mortal(newSVpvn_share(methname, len,0))
+ : newSVpvn_flags(methname, len, SVs_TEMP);
- /* XXX: sv_2mortal(newSVpvn_share(methname, len)) can be faster */
- return call_sv(newSVpvn_flags(methname, len, SVs_TEMP), flags | G_METHOD);
+ return call_sv(sv, flags | G_METHOD);
}
/* May be called with any of a CV, a GV, or an SV containing the name. */
{
dVAR; dSP;
LOGOP myop; /* fake syntax tree node */
- UNOP method_op;
+ UNOP method_unop;
+ SVOP method_svop;
I32 oldmark;
VOL I32 retval = 0;
I32 oldscope;
PL_op = (OP*)&myop;
EXTEND(PL_stack_sp, 1);
- *++PL_stack_sp = sv;
+ if (!(flags & G_METHOD_NAMED))
+ *++PL_stack_sp = sv;
oldmark = TOPMARK;
oldscope = PL_scopestack_ix;
&& !(flags & G_NODEBUG))
myop.op_private |= OPpENTERSUB_DB;
- if (flags & G_METHOD) {
- Zero(&method_op, 1, UNOP);
- method_op.op_next = (OP*)&myop;
- 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;
- PL_op = (OP*)&method_op;
+ if (flags & (G_METHOD|G_METHOD_NAMED)) {
+ 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;
+ } 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;
+ }
+ myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
+ myop.op_type = OP_ENTERSUB;
+
}
if (!(flags & G_EVAL)) {
myop.op_flags |= OP_GIMME_REVERSE(flags);
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
- if (PL_reg_state.re_reparsing)
- myop.op_private = OPpEVAL_COPHH;
+
+ if (flags & G_RE_REPARSING)
+ myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
/* fail now; otherwise we could fail after the JMPENV_PUSH but
* before a PUSHEVAL, which corrupts the stack after a croak */
PL_utf8cache = -1;
return s;
case 'F':
+ PL_minus_a = TRUE;
PL_minus_F = TRUE;
+ PL_minus_n = TRUE;
PL_splitstr = ++s;
while (*s && !isSPACE(*s)) ++s;
PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
return s;
case 'a':
PL_minus_a = TRUE;
+ PL_minus_n = TRUE;
s++;
return s;
case 'c':
#if SILENT_NO_TAINT_SUPPORT
/* silently ignore */
#elif NO_TAINT_SUPPORT
- Perl_croak("This perl was compiled without taint support. "
+ Perl_croak_nocontext("This perl was compiled without taint support. "
"Cowardly refusing to run with -t or -T flags");
#else
if (!TAINTING_get)
PerlIO * PIO_stdout;
if (!sv_derived_from(PL_patchlevel, "version"))
upg_version(PL_patchlevel, TRUE);
-#if !defined(DGUX)
{
SV* level= vstringify(PL_patchlevel);
#ifdef PERL_PATCHNUM
);
SvREFCNT_dec(level);
}
-#else /* DGUX */
- PIO_stdout = PerlIO_stdout();
-/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
- PerlIO_printf(PIO_stdout,
- Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
- SVfARG(vstringify(PL_patchlevel))));
- PerlIO_printf(PIO_stdout,
- Perl_form(aTHX_ " built under %s at %s %s\n",
- OSNAME, __DATE__, __TIME__));
- PerlIO_printf(PIO_stdout,
- Perl_form(aTHX_ " OS Specific Release: %s\n",
- OSVERS));
-#endif /* !DGUX */
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
PerlIO_printf(PIO_stdout,
#endif
PerlIO_printf(PIO_stdout,
- "\n\nCopyright 1987-2012, Larry Wall\n");
+ "\n\nCopyright 1987-2013, Larry Wall\n");
#ifdef MSDOS
PerlIO_printf(PIO_stdout,
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
#ifdef __VOS__
PerlIO_printf(PIO_stdout,
- "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
+ "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
#endif
#ifdef POSIX_BC
PerlIO_printf(PIO_stdout,
# undef PERLVARIC
#endif
- /* As these are inside a structure, PERLVARI isn't capable of initialising
- them */
- PL_reg_oldcurpm = PL_reg_curpm = NULL;
- PL_reg_poscache = PL_reg_starttry = NULL;
}
STATIC void
int fdscript = -1;
PerlIO *rsfp = NULL;
dVAR;
+ Stat_t tmpstatbuf;
PERL_ARGS_ASSERT_OPEN_SCRIPT;
/* ensure close-on-exec */
fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
#endif
+
+ if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
+ && S_ISDIR(tmpstatbuf.st_mode))
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+ CopFILE(PL_curcop),
+ Strerror(EISDIR));
+
return rsfp;
}
STATIC void
S_validate_suid(pTHX_ PerlIO *rsfp)
{
- const UV my_uid = PerlProc_getuid();
- const UV my_euid = PerlProc_geteuid();
- const UV my_gid = PerlProc_getgid();
- const UV my_egid = PerlProc_getegid();
+ const Uid_t my_uid = PerlProc_getuid();
+ const Uid_t my_euid = PerlProc_geteuid();
+ const Gid_t my_gid = PerlProc_getgid();
+ const Gid_t my_egid = PerlProc_getegid();
PERL_ARGS_ASSERT_VALIDATE_SUID;
* do tainting. */
#if !NO_TAINT_SUPPORT
dVAR;
- const UV my_uid = PerlProc_getuid();
- const UV my_euid = PerlProc_geteuid();
- const UV my_gid = PerlProc_getgid();
- const UV my_egid = PerlProc_getegid();
+ const Uid_t my_uid = PerlProc_getuid();
+ const Uid_t my_euid = PerlProc_geteuid();
+ const Gid_t my_gid = PerlProc_getgid();
+ const Gid_t my_egid = PerlProc_getegid();
/* Should not happen: */
CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
* have to add your own checks somewhere in here. The two most
* known samples of 'implicitness' are Win32 and NetWare, neither
* of which has much of concept of 'uids'. */
- int uid = PerlProc_getuid();
- int euid = PerlProc_geteuid();
- int gid = PerlProc_getgid();
- int egid = PerlProc_getegid();
+ Uid_t uid = PerlProc_getuid();
+ Uid_t euid = PerlProc_geteuid();
+ Gid_t gid = PerlProc_getgid();
+ Gid_t egid = PerlProc_getegid();
(void)envp;
#ifdef VMS
/* finally add this lib directory at the end of @INC */
if (unshift) {
#ifdef PERL_IS_MINIPERL
- const U32 extra = 0;
+ const Size_t extra = 0;
#else
- U32 extra = av_len(av) + 1;
+ Size_t extra = av_len(av) + 1;
#endif
av_unshift(inc, extra + push_basedir);
if (push_basedir)
Perl_my_exit(pTHX_ U32 status)
{
dVAR;
+ if (PL_exit_flags & PERL_EXIT_ABORT) {
+ abort();
+ }
+ if (PL_exit_flags & PERL_EXIT_WARN) {
+ PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
+ Perl_warn(aTHX_ "Unexpected exit %u", status);
+ PL_exit_flags &= ~PERL_EXIT_ABORT;
+ }
switch (status) {
case 0:
STATUS_ALL_SUCCESS;
STATUS_UNIX_SET(255);
}
#endif
+ if (PL_exit_flags & PERL_EXIT_ABORT) {
+ abort();
+ }
+ if (PL_exit_flags & PERL_EXIT_WARN) {
+ PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
+ Perl_warn(aTHX_ "Unexpected exit failure %u", PL_statusvalue);
+ PL_exit_flags &= ~PERL_EXIT_ABORT;
+ }
my_exit_jump();
}
https://perl5.git.perl.org / perl5.git / blobdiff