#endif
#endif
-#ifndef NO_MATHOMS
-/* This reference ensures that the mathoms are linked with perl */
-extern void Perl_mathoms(void);
-void Perl_mathoms_ref(void);
-void Perl_mathoms_ref(void) {
- Perl_mathoms();
-}
-#endif
-
static void
S_init_tls_and_interp(PerlInterpreter *my_perl)
{
PL_Dir = ipD;
PL_Sock = ipS;
PL_Proc = ipP;
+ INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
return my_perl;
}
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
S_init_tls_and_interp(my_perl);
+#ifndef PERL_TRACK_MEMPOOL
return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
+#else
+ Zero(my_perl, 1, PerlInterpreter);
+ INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
+ return my_perl;
+#endif
}
#endif /* PERL_IMPLICIT_SYS */
if (!PL_linestr) {
PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
- PL_linestr = NEWSV(65,79);
+ PL_linestr = newSV(79);
sv_upgrade(PL_linestr,SVt_PVIV);
if (!SvREADONLY(&PL_sv_undef)) {
#endif
}
- PL_rs = newSVpvn("\n", 1);
+ PL_rs = newSVpvs("\n");
init_stacks();
PL_fdpid = newAV(); /* for remembering popen pids by fd */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
- PL_errors = newSVpvn("",0);
+ PL_errors = newSVpvs("");
sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
}
op_free(PL_main_root);
- PL_main_root = Nullop;
+ PL_main_root = NULL;
}
- PL_main_start = Nullop;
+ PL_main_start = NULL;
SvREFCNT_dec(PL_main_cv);
- PL_main_cv = Nullcv;
+ PL_main_cv = NULL;
PL_dirty = TRUE;
/* Tell PerlIO we are about to tear things apart in case
sv_clean_objs();
PL_sv_objcount = 0;
if (PL_defoutgv && !SvREFCNT(PL_defoutgv))
- PL_defoutgv = Nullgv; /* may have been freed */
+ PL_defoutgv = NULL; /* may have been freed */
}
/* unhook hooks which will soon be, or use, destroyed data */
SvREFCNT_dec(PL_warnhook);
- PL_warnhook = Nullsv;
+ PL_warnhook = NULL;
SvREFCNT_dec(PL_diehook);
- PL_diehook = Nullsv;
+ PL_diehook = NULL;
/* call exit list functions */
while (PL_exitlistlen-- > 0)
#endif /* !PERL_MICRO */
/* reset so print() ends up where we expect */
- setdefout(Nullgv);
+ setdefout(NULL);
#ifdef USE_ITHREADS
/* the syntax tree is shared between clones
PL_unsafe = FALSE;
Safefree(PL_inplace);
- PL_inplace = Nullch;
+ PL_inplace = NULL;
SvREFCNT_dec(PL_patchlevel);
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
- PL_e_script = Nullsv;
+ PL_e_script = NULL;
}
PL_perldb = 0;
/* magical thingies */
SvREFCNT_dec(PL_ofs_sv); /* $, */
- PL_ofs_sv = Nullsv;
+ PL_ofs_sv = NULL;
SvREFCNT_dec(PL_ors_sv); /* $\ */
- PL_ors_sv = Nullsv;
+ PL_ors_sv = NULL;
SvREFCNT_dec(PL_rs); /* $/ */
- PL_rs = Nullsv;
+ PL_rs = NULL;
PL_multiline = 0; /* $* */
Safefree(PL_osname); /* $^O */
- PL_osname = Nullch;
+ PL_osname = NULL;
SvREFCNT_dec(PL_statname);
- PL_statname = Nullsv;
- PL_statgv = Nullgv;
+ PL_statname = NULL;
+ PL_statgv = NULL;
/* defgv, aka *_ should be taken care of elsewhere */
/* clean up after study() */
SvREFCNT_dec(PL_lastscream);
- PL_lastscream = Nullsv;
+ PL_lastscream = NULL;
Safefree(PL_screamfirst);
PL_screamfirst = 0;
Safefree(PL_screamnext);
/* float buffer */
Safefree(PL_efloatbuf);
- PL_efloatbuf = Nullch;
+ PL_efloatbuf = NULL;
PL_efloatsize = 0;
/* startup and shutdown function lists */
PL_initav = NULL;
/* shortcuts just get cleared */
- PL_envgv = Nullgv;
- PL_incgv = Nullgv;
- PL_hintgv = Nullgv;
- PL_errgv = Nullgv;
- PL_argvgv = Nullgv;
- PL_argvoutgv = Nullgv;
- PL_stdingv = Nullgv;
- PL_stderrgv = Nullgv;
- PL_last_in_gv = Nullgv;
- PL_replgv = Nullgv;
- PL_DBgv = Nullgv;
- PL_DBline = Nullgv;
- PL_DBsub = Nullgv;
- PL_DBsingle = Nullsv;
- PL_DBtrace = Nullsv;
- PL_DBsignal = Nullsv;
- PL_DBassertion = Nullsv;
- PL_DBcv = Nullcv;
+ PL_envgv = NULL;
+ PL_incgv = NULL;
+ PL_hintgv = NULL;
+ PL_errgv = NULL;
+ PL_argvgv = NULL;
+ PL_argvoutgv = NULL;
+ PL_stdingv = NULL;
+ PL_stderrgv = NULL;
+ PL_last_in_gv = NULL;
+ PL_replgv = NULL;
+ PL_DBgv = NULL;
+ PL_DBline = NULL;
+ PL_DBsub = NULL;
+ PL_DBsingle = NULL;
+ PL_DBtrace = NULL;
+ PL_DBsignal = NULL;
+ PL_DBassertion = NULL;
+ PL_DBcv = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
SvREFCNT_dec(PL_preambleav);
PL_preambleav = NULL;
SvREFCNT_dec(PL_subname);
- PL_subname = Nullsv;
+ PL_subname = NULL;
SvREFCNT_dec(PL_linestr);
- PL_linestr = Nullsv;
+ PL_linestr = NULL;
#ifdef PERL_USES_PL_PIDSTATUS
SvREFCNT_dec(PL_pidstatus);
PL_pidstatus = NULL;
#endif
SvREFCNT_dec(PL_toptarget);
- PL_toptarget = Nullsv;
+ PL_toptarget = NULL;
SvREFCNT_dec(PL_bodytarget);
- PL_bodytarget = Nullsv;
- PL_formtarget = Nullsv;
+ PL_bodytarget = NULL;
+ PL_formtarget = NULL;
/* free locale stuff */
#ifdef USE_LOCALE_COLLATE
Safefree(PL_collation_name);
- PL_collation_name = Nullch;
+ PL_collation_name = NULL;
#endif
#ifdef USE_LOCALE_NUMERIC
Safefree(PL_numeric_name);
- PL_numeric_name = Nullch;
+ PL_numeric_name = NULL;
SvREFCNT_dec(PL_numeric_radix_sv);
- PL_numeric_radix_sv = Nullsv;
+ PL_numeric_radix_sv = NULL;
#endif
/* clear utf8 character classes */
SvREFCNT_dec(PL_utf8_tofold);
SvREFCNT_dec(PL_utf8_idstart);
SvREFCNT_dec(PL_utf8_idcont);
- PL_utf8_alnum = Nullsv;
- PL_utf8_alnumc = Nullsv;
- PL_utf8_ascii = Nullsv;
- PL_utf8_alpha = Nullsv;
- PL_utf8_space = Nullsv;
- PL_utf8_cntrl = Nullsv;
- PL_utf8_graph = Nullsv;
- PL_utf8_digit = Nullsv;
- PL_utf8_upper = Nullsv;
- PL_utf8_lower = Nullsv;
- PL_utf8_print = Nullsv;
- PL_utf8_punct = Nullsv;
- PL_utf8_xdigit = Nullsv;
- PL_utf8_mark = Nullsv;
- PL_utf8_toupper = Nullsv;
- PL_utf8_totitle = Nullsv;
- PL_utf8_tolower = Nullsv;
- PL_utf8_tofold = Nullsv;
- PL_utf8_idstart = Nullsv;
- PL_utf8_idcont = Nullsv;
+ PL_utf8_alnum = NULL;
+ PL_utf8_alnumc = NULL;
+ PL_utf8_ascii = NULL;
+ PL_utf8_alpha = NULL;
+ PL_utf8_space = NULL;
+ PL_utf8_cntrl = NULL;
+ PL_utf8_graph = NULL;
+ PL_utf8_digit = NULL;
+ PL_utf8_upper = NULL;
+ PL_utf8_lower = NULL;
+ PL_utf8_print = NULL;
+ PL_utf8_punct = NULL;
+ PL_utf8_xdigit = NULL;
+ 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;
if (!specialWARN(PL_compiling.cop_warnings))
SvREFCNT_dec(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = Nullsv;
+ PL_compiling.cop_warnings = NULL;
if (!specialCopIO(PL_compiling.cop_io))
SvREFCNT_dec(PL_compiling.cop_io);
- PL_compiling.cop_io = Nullsv;
+ PL_compiling.cop_io = NULL;
CopFILE_free(&PL_compiling);
CopSTASH_free(&PL_compiling);
PL_defstash = 0;
SvREFCNT_dec(hv);
SvREFCNT_dec(PL_curstname);
- PL_curstname = Nullsv;
+ PL_curstname = NULL;
/* clear queued errors */
SvREFCNT_dec(PL_errors);
- PL_errors = Nullsv;
+ PL_errors = NULL;
FREETMPS;
if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
HE * const next = HeNEXT(hent);
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Unbalanced string table refcount: (%ld) for \"%s\"",
- (long)(HeVAL(hent) - Nullsv), HeKEY(hent));
+ (long)hent->he_valu.hent_refcount, HeKEY(hent));
Safefree(hent);
hent = next;
}
#endif
/* sv_undef needs to stay immortal until after PerlIO_cleanup
- as currently layers use it rather than Nullsv as a marker
+ as currently layers use it rather than NULL as a marker
for no arg - and will try and SvREFCNT_dec it.
*/
SvREFCNT(&PL_sv_undef) = 0;
SvREADONLY_off(&PL_sv_undef);
Safefree(PL_origfilename);
- PL_origfilename = Nullch;
+ PL_origfilename = NULL;
Safefree(PL_reg_start_tmp);
PL_reg_start_tmp = (char**)NULL;
PL_reg_start_tmpl = 0;
Safefree(PL_psig_name);
PL_psig_name = (SV**)NULL;
Safefree(PL_bitcount);
- PL_bitcount = Nullch;
+ PL_bitcount = NULL;
Safefree(PL_psig_pend);
PL_psig_pend = (int*)NULL;
- PL_formfeed = Nullsv;
+ PL_formfeed = NULL;
nuke_stacks();
PL_tainting = FALSE;
PL_taint_warn = FALSE;
SvPV_free(PL_mess_sv);
Safefree(SvANY(PL_mess_sv));
Safefree(PL_mess_sv);
- PL_mess_sv = Nullsv;
+ PL_mess_sv = NULL;
}
return STATUS_EXIT;
}
void
perl_free(pTHXx)
{
+#ifdef PERL_TRACK_MEMPOOL
+ /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
+ thread at thread exit. */
+ while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
+ safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+#endif
+
#if defined(WIN32) || defined(NETWARE)
# if defined(PERL_IMPLICIT_SYS)
+ {
# ifdef NETWARE
- void *host = nw_internal_host;
+ void *host = nw_internal_host;
# else
- void *host = w32_internal_host;
+ void *host = w32_internal_host;
# endif
- PerlMem_free(aTHXx);
+ PerlMem_free(aTHXx);
# ifdef NETWARE
- nw_delete_internal_host(host);
+ nw_delete_internal_host(host);
# else
- win32_delete_internal_host(host);
+ win32_delete_internal_host(host);
# endif
+ }
# else
PerlMem_free(aTHXx);
# endif
#endif
}
-#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+#if defined(USE_ITHREADS)
/* provide destructors to clean up the thread key when libperl is unloaded */
#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
-#if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
+#if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
#pragma fini "perl_fini"
#endif
void
Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
{
+ dVAR;
Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
PL_exitlist[PL_exitlistlen].fn = fn;
PL_exitlist[PL_exitlistlen].ptr = ptr;
STATIC void
S_set_caret_X(pTHX) {
- GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
+ dVAR;
+ GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
if (tmpgv) {
#ifdef HAS_PROCSELFEXE
S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
PL_origargc = argc;
PL_origargv = argv;
- {
+ if (PL_origalen != 0) {
+ PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
+ }
+ else {
/* Set PL_origalen be the sum of the contiguous argv[]
* elements plus the size of the env in case that it is
* contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
}
}
/* Can we grab env area too to be used as the area for $0? */
- if (PL_origenviron) {
+ if (s && PL_origenviron) {
if ((PL_origenviron[0] == s + 1
#ifdef OS2
|| (PL_origenviron[0] == s + 9 && (s += 8))
s = PL_origenviron[0];
while (*s) s++;
#endif
- my_setenv("NoNe SuCh", Nullch);
+ my_setenv("NoNe SuCh", NULL);
/* Force copy of environment. */
for (i = 1; PL_origenviron[i]; i++) {
if (PL_origenviron[i] == s + 1
}
}
}
- PL_origalen = s - PL_origargv[0] + 1;
+ PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
}
if (PL_do_undump) {
if (PL_main_root) {
op_free(PL_main_root);
- PL_main_root = Nullop;
+ PL_main_root = NULL;
}
- PL_main_start = Nullop;
+ PL_main_start = NULL;
SvREFCNT_dec(PL_main_cv);
- PL_main_cv = Nullcv;
+ PL_main_cv = NULL;
time(&PL_basetime);
oldscope = PL_scopestack_ix;
const char *validarg = "";
register SV *sv;
register char *s;
- const char *cddir = Nullch;
+ const char *cddir = NULL;
#ifdef USE_SITECUSTOMIZE
bool minus_f = FALSE;
#endif
- PL_fdscript = -1;
- PL_suidscript = -1;
sv_setpvn(PL_linestr,"",0);
- sv = newSVpvn("",0); /* first used for -I flags */
+ sv = newSVpvs(""); /* first used for -I flags */
SAVEFREESV(sv);
init_main_stash();
if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
break;
#endif
- forbid_setid("-e");
+ forbid_setid('e', -1);
if (!PL_e_script) {
- PL_e_script = newSVpvn("",0);
+ PL_e_script = newSVpvs("");
filter_add(read_e_script, NULL);
}
if (*++s)
}
else
Perl_croak(aTHX_ "No code specified for -%c", *s);
- sv_catpv(PL_e_script, "\n");
+ sv_catpvs(PL_e_script, "\n");
break;
case 'f':
goto reswitch;
case 'I': /* -I handled both here and in moreswitches() */
- forbid_setid("-I");
- if (!*++s && (s=argv[1]) != Nullch) {
+ forbid_setid('I', -1);
+ if (!*++s && (s=argv[1]) != NULL) {
argc--,argv++;
}
if (s && *s) {
STRLEN len = strlen(s);
const char * const p = savepvn(s, len);
incpush(p, TRUE, TRUE, FALSE, FALSE);
- sv_catpvn(sv, "-I", 2);
+ sv_catpvs(sv, "-I");
sv_catpvn(sv, p, len);
- sv_catpvn(sv, " ", 1);
+ sv_catpvs(sv, " ");
Safefree(p);
}
else
Perl_croak(aTHX_ "No directory specified for -I");
break;
case 'P':
- forbid_setid("-P");
+ forbid_setid('P', -1);
PL_preprocess = TRUE;
s++;
goto reswitch;
case 'S':
- forbid_setid("-S");
+ forbid_setid('S', -1);
dosearch = TRUE;
s++;
goto reswitch;
if (!PL_preambleav)
PL_preambleav = newAV();
av_push(PL_preambleav,
- newSVpv("use Config;",0));
+ newSVpvs("use Config;"));
if (*++s != ':') {
STRLEN opts;
- opts_prog = newSVpv("print Config::myconfig(),",0);
+ opts_prog = newSVpvs("print Config::myconfig(),");
#ifdef VMS
- sv_catpv(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\",");
+ sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\",");
#else
- sv_catpv(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\",");
+ sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\",");
#endif
opts = SvCUR(opts_prog);
# ifdef PL_OP_SLAB_ALLOC
" PL_OP_SLAB_ALLOC"
# endif
-# ifdef SPRINTF_RETURNS_STRLEN
- " SPRINTF_RETURNS_STRLEN"
-# endif
# ifdef THREADS_HAVE_PIDS
" THREADS_HAVE_PIDS"
# endif
-# ifdef USE_5005THREADS
- " USE_5005THREADS"
-# endif
# ifdef USE_64_BIT_ALL
" USE_64_BIT_ALL"
# endif
/* break the line before that space */
opts = space - pv;
- sv_insert(opts_prog, opts, 0,
- "\\n ", 25);
+ Perl_sv_insert(aTHX_ opts_prog, opts, 0,
+ STR_WITH_LEN("\\n "));
}
- sv_catpv(opts_prog,"\\n\",");
+ sv_catpvs(opts_prog,"\\n\",");
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0) {
int i;
- sv_catpv(opts_prog,
+ sv_catpvs(opts_prog,
"\" Locally applied patches:\\n\",");
for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
if (PL_localpatches[i])
__DATE__);
# endif
#endif
- sv_catpv(opts_prog, "; $\"=\"\\n \"; "
+ sv_catpvs(opts_prog, "; $\"=\"\\n \"; "
"@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
"sort grep {/^PERL/} keys %ENV; ");
#ifdef __CYGWIN__
- sv_catpv(opts_prog,
+ sv_catpvs(opts_prog,
"push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
#endif
- sv_catpv(opts_prog,
+ sv_catpvs(opts_prog,
"print \" \\%ENV:\\n @env\\n\" if @env;"
"print \" \\@INC:\\n @INC\\n\";");
}
PL_taint_warn = FALSE;
}
else {
- char *popt_copy = Nullch;
+ char *popt_copy = NULL;
while (s && *s) {
char *d;
while (isSPACE(*s))
argc++,argv--;
scriptname = BIT_BUCKET; /* don't look for script or read stdin */
}
- else if (scriptname == Nullch) {
+ else if (scriptname == NULL) {
#ifdef MSDOS
if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
moreswitches("h");
TAINT_NOT;
init_perllib();
- open_script(scriptname,dosearch,sv);
+ {
+ int suidscript;
+ const int fdscript
+ = open_script(scriptname, dosearch, sv, &suidscript);
- validate_suid(validarg, scriptname);
+ validate_suid(validarg, scriptname, fdscript, suidscript);
#ifndef PERL_MICRO
-#if defined(SIGCHLD) || defined(SIGCLD)
- {
-#ifndef SIGCHLD
-# define SIGCHLD SIGCLD
-#endif
- Sighandler_t sigstate = rsignal_state(SIGCHLD);
- if (sigstate == (Sighandler_t) SIG_IGN) {
- if (ckWARN(WARN_SIGNAL))
- Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
- "Can't ignore signal CHLD, forcing to default");
- (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
+# if defined(SIGCHLD) || defined(SIGCLD)
+ {
+# ifndef SIGCHLD
+# define SIGCHLD SIGCLD
+# endif
+ Sighandler_t sigstate = rsignal_state(SIGCHLD);
+ if (sigstate == (Sighandler_t) SIG_IGN) {
+ if (ckWARN(WARN_SIGNAL))
+ Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
+ "Can't ignore signal CHLD, forcing to default");
+ (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
+ }
}
- }
-#endif
+# endif
#endif
+ if (PL_doextract
#ifdef MACOS_TRADITIONAL
- if (PL_doextract || gMacPerl_AlwaysExtract) {
-#else
- if (PL_doextract) {
+ || gMacPerl_AlwaysExtract
#endif
- find_beginning();
- if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
- Perl_croak(aTHX_ "Can't chdir to %s",cddir);
+ ) {
+
+ /* This will croak if suidscript is >= 0, as -x cannot be used with
+ setuid scripts. */
+ forbid_setid('x', suidscript);
+ /* Hence you can't get here if suidscript >= 0 */
+ find_beginning();
+ if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
+ Perl_croak(aTHX_ "Can't chdir to %s",cddir);
+ }
}
- PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
+ PL_main_cv = PL_compcv = (CV*)newSV(0);
sv_upgrade((SV *)PL_compcv, SVt_PVCV);
CvUNIQUE_on(PL_compcv);
CvPADLIST(PL_compcv) = pad_new(0);
-#ifdef USE_5005THREADS
- CvOWNER(PL_compcv) = 0;
- Newx(CvMUTEXP(PL_compcv), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(PL_compcv));
-#endif /* USE_5005THREADS */
boot_core_PerlIO();
boot_core_UNIVERSAL();
(fp = IoOFP(io)))
PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
- (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
+ (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
+ SVt_PV)))) {
U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
if (in) {
PL_preprocess = FALSE;
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
- PL_e_script = Nullsv;
+ PL_e_script = NULL;
}
if (PL_do_undump)
int
perl_run(pTHXx)
{
+ dVAR;
I32 oldscope;
int ret = 0;
dJMPENV;
STATIC void
S_run_body(pTHX_ I32 oldscope)
{
+ dVAR;
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
PL_sawampersand ? "Enabling" : "Omitting"));
Perl_get_sv(pTHX_ const char *name, I32 create)
{
GV *gv;
-#ifdef USE_5005THREADS
- if (name[1] == '\0' && !isALPHA(name[0])) {
- PADOFFSET tmp = find_threadsv(name);
- if (tmp != NOT_IN_PAD)
- return THREADSV(tmp);
- }
-#endif /* USE_5005THREADS */
gv = gv_fetchpv(name, create, SVt_PV);
if (gv)
return GvSV(gv);
- return Nullsv;
+ return NULL;
}
/*
if (create && !GvCVu(gv))
return newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
- Nullop,
- Nullop);
+ NULL, NULL);
if (gv)
return GvCVu(gv);
- return Nullcv;
+ return NULL;
}
/* Be sure to refetch the stack pointer after calling these routines. */
/* See G_* flags in cop.h */
/* null terminated arg list */
{
+ dVAR;
dSP;
PUSHMARK(SP);
}
Zero(&myop, 1, LOGOP);
- myop.op_next = Nullop;
+ myop.op_next = NULL;
if (!(flags & G_NOARGS))
myop.op_flags |= OPf_STACKED;
myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
STATIC void
S_call_body(pTHX_ const OP *myop, bool is_eval)
{
+ dVAR;
if (PL_op == myop) {
if (is_eval)
PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
/* See G_* flags in cop.h */
{
+ dVAR;
dSP;
UNOP myop; /* fake syntax tree node */
volatile I32 oldmark = SP - PL_stack_base;
if (!(flags & G_NOARGS))
myop.op_flags = OPf_STACKED;
- myop.op_next = Nullop;
+ myop.op_next = NULL;
myop.op_type = OP_ENTEREVAL;
myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
(flags & G_ARRAY) ? OPf_WANT_LIST :
SV*
Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
{
+ dVAR;
dSP;
SV* sv = newSVpv(p, 0);
void
Perl_require_pv(pTHX_ const char *pv)
{
- SV* sv;
+ dVAR;
dSP;
+ SV* sv;
PUSHSTACKi(PERLSI_REQUIRE);
PUTBACK;
sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
void
Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
{
- register GV * const gv = gv_fetchpv(sym,TRUE, SVt_PV);
+ register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV);
if (gv)
sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
numlen = 0;
s--;
}
- PL_rs = newSVpvn("", 0);
+ PL_rs = newSVpvs("");
SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
tmps = (U8*)SvPVX(PL_rs);
uvchr_to_utf8(tmps, rschar);
if (rschar & ~((U8)~0))
PL_rs = &PL_sv_undef;
else if (!rschar && numlen >= 2)
- PL_rs = newSVpvn("", 0);
+ PL_rs = newSVpvs("");
else {
char ch = (char)rschar;
PL_rs = newSVpvn(&ch, 1);
s++;
return s;
case 'd':
- forbid_setid("-d");
+ forbid_setid('d', -1);
s++;
/* -dt indicates to the debugger that threads will be used */
in the fashion that -MSome::Mod does. */
if (*s == ':' || *s == '=') {
const char *start;
- SV * const sv = newSVpv("use Devel::", 0);
+ SV * const sv = newSVpvs("use Devel::");
start = ++s;
/* We now allow -d:Module=Foo,Bar */
while(isALNUM(*s) || *s==':') ++s;
case 'D':
{
#ifdef DEBUGGING
- forbid_setid("-D");
+ forbid_setid('D', -1);
s++;
PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
#else /* !DEBUGGING */
Safefree(PL_inplace);
#if defined(__CYGWIN__) /* do backup extension automagically */
if (*(s+1) == '\0') {
- PL_inplace = savepv(".bak");
+ PL_inplace = savepvs(".bak");
return s+1;
}
#endif /* __CYGWIN__ */
}
return s;
case 'I': /* -I handled both here and in parse_body() */
- forbid_setid("-I");
+ forbid_setid('I', -1);
++s;
while (*s && isSPACE(*s))
++s;
s++;
if (PL_ors_sv) {
SvREFCNT_dec(PL_ors_sv);
- PL_ors_sv = Nullsv;
+ PL_ors_sv = NULL;
}
if (isDIGIT(*s)) {
I32 flags = 0;
STRLEN numlen;
- PL_ors_sv = newSVpvn("\n",1);
+ PL_ors_sv = newSVpvs("\n");
numlen = 3 + (*s == '0');
*SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
s += numlen;
}
else {
if (RsPARA(PL_rs)) {
- PL_ors_sv = newSVpvn("\n\n",2);
+ PL_ors_sv = newSVpvs("\n\n");
}
else {
PL_ors_sv = newSVsv(PL_rs);
}
return s;
case 'A':
- forbid_setid("-A");
+ forbid_setid('A', -1);
if (!PL_preambleav)
PL_preambleav = newAV();
s++;
{
char * const start = s;
- SV * const sv = newSVpv("use assertions::activate", 24);
+ SV * const sv = newSVpvs("use assertions::activate");
while(isALNUM(*s) || *s == ':') ++s;
if (s != start) {
- sv_catpvn(sv, "::", 2);
+ sv_catpvs(sv, "::");
sv_catpvn(sv, start, s-start);
}
if (*s == '=') {
return s;
}
case 'M':
- forbid_setid("-M"); /* XXX ? */
+ forbid_setid('M', -1); /* XXX ? */
/* FALL THROUGH */
case 'm':
- forbid_setid("-m"); /* XXX ? */
+ forbid_setid('m', -1); /* XXX ? */
if (*++s) {
char *start;
SV *sv;
if (*(start-1) == 'm') {
if (*s != '\0')
Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
- sv_catpv( sv, " ()");
+ sv_catpvs( sv, " ()");
}
} else {
if (s == start)
Perl_croak(aTHX_ "Module name required with -%c option",
s[-1]);
sv_catpvn(sv, start, s-start);
- sv_catpv(sv, " split(/,/,q");
- sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
+ sv_catpvs(sv, " split(/,/,q");
+ sv_catpvs(sv, "\0"); /* Use NUL as q//-delimiter. */
sv_catpv(sv, ++s);
- sv_catpvn(sv, "\0)", 2);
+ sv_catpvs(sv, "\0)");
}
s += strlen(s);
if (!PL_preambleav)
s++;
return s;
case 's':
- forbid_setid("-s");
+ forbid_setid('s', -1);
PL_doswitches = TRUE;
s++;
return s;
upg_version(PL_patchlevel);
#if !defined(DGUX)
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, %"SVf" built for %s",
+ Perl_form(aTHX_ "\nThis is perl, %"SVf
+#ifdef PERL_PATCHNUM
+ " DEVEL" STRINGIFY(PERL_PATCHNUM)
+#endif
+ " built for %s",
vstringify(PL_patchlevel),
ARCHNAME));
#else /* DGUX */
default:
Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
}
- return Nullch;
+ return NULL;
}
/* compliments of Tom Christiansen */
extern int etext;
prog = newSVpv(BIN_EXP, 0);
- sv_catpv(prog, "/perl");
+ sv_catpvs(prog, "/perl");
file = newSVpv(PL_origfilename, 0);
- sv_catpv(file, ".perldump");
+ sv_catpvs(file, ".perldump");
unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
/* unexec prints msg to stderr in case of failure */
# ifdef VMS
# include <lib$routines.h>
lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
+# elif defined(WIN32) || defined(__CYGWIN__)
+ Perl_croak(aTHX_ "dump is not supported");
# else
ABORT(); /* for use with undump */
# endif
STATIC void
S_init_interp(pTHX)
{
-
+ dVAR;
#ifdef MULTIPLICITY
# define PERLVAR(var,type)
# define PERLVARA(var,n,type)
# if defined(PERL_IMPLICIT_CONTEXT)
-# if defined(USE_5005THREADS)
-# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
-# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
-# else /* !USE_5005THREADS */
-# define PERLVARI(var,type,init) aTHX->var = init;
-# define PERLVARIC(var,type,init) aTHX->var = init;
-# endif /* USE_5005THREADS */
+# define PERLVARI(var,type,init) aTHX->var = init;
+# define PERLVARIC(var,type,init) aTHX->var = init;
# else
# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
# endif
# include "intrpvar.h"
-# ifndef USE_5005THREADS
-# include "thrdvar.h"
-# endif
+# include "thrdvar.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
# define PERLVARI(var,type,init) PL_##var = init;
# define PERLVARIC(var,type,init) PL_##var = init;
# include "intrpvar.h"
-# ifndef USE_5005THREADS
-# include "thrdvar.h"
-# endif
+# include "thrdvar.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
STATIC void
S_init_main_stash(pTHX)
{
+ dVAR;
GV *gv;
PL_curstash = PL_defstash = newHV();
/* We know that the string "main" will be in the global shared string
table, so it's a small saving to use it rather than allocate another
8 bytes. */
- PL_curstname = newSVpvn_share("main", 4, 0);
- gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
+ PL_curstname = newSVpvs_share("main");
+ gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
/* If we hadn't caused another reference to "main" to be in the shared
string table above, then it would be worth reordering these two,
because otherwise all we do is delete "main" from it as a consequence
hv_name_set(PL_defstash, "main", 4, 0);
GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
SvREADONLY_on(gv);
- PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
+ PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
+ SVt_PVAV)));
SvREFCNT_inc(PL_incgv); /* Don't allow it to be freed */
GvMULTI_on(PL_incgv);
- PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
+ PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
GvMULTI_on(PL_hintgv);
- PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
+ PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
SvREFCNT_inc(PL_defgv);
- PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
+ PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
SvREFCNT_inc(PL_errgv);
GvMULTI_on(PL_errgv);
- PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
+ PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
GvMULTI_on(PL_replgv);
(void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
#ifdef PERL_DONT_CREATE_GVSV
sv_setpvn(ERRSV, "", 0);
PL_curstash = PL_defstash;
CopSTASH_set(&PL_compiling, PL_defstash);
- PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
- PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
+ PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
+ PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
+ SVt_PVHV));
/* We must init $/ before switches are processed. */
sv_setpvn(get_sv("/", TRUE), "\n", 1);
}
-/* PSz 18 Nov 03 fdscript now global but do not change prototype */
-STATIC void
-S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
+STATIC int
+S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
+ int *suidscript)
{
#ifndef IAMSUID
const char *quote;
const char *cpp_discard_flag;
const char *perl;
#endif
+ int fdscript = -1;
dVAR;
- PL_fdscript = -1;
- PL_suidscript = -1;
+ *suidscript = -1;
if (PL_e_script) {
- PL_origfilename = savepvn("-e", 2);
+ PL_origfilename = savepvs("-e");
}
else {
/* if find_script() returns, it returns a malloc()-ed value */
if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
const char *s = scriptname + 8;
- PL_fdscript = atoi(s);
+ fdscript = atoi(s);
while (isDIGIT(*s))
s++;
if (*s) {
* Is it a mistake to use a similar /dev/fd/ construct for
* suidperl?
*/
- PL_suidscript = 1;
+ *suidscript = 1;
/* PSz 20 Feb 04
* Be supersafe and do some sanity-checks.
* Still, can we be sure we got the right thing?
CopFILE_set(PL_curcop, PL_origfilename);
if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
scriptname = (char *)"";
- if (PL_fdscript >= 0) {
- PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
+ if (fdscript >= 0) {
+ PL_rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
# if defined(HAS_FCNTL) && defined(F_SETFD)
if (PL_rsfp)
/* ensure close-on-exec */
* perl with that fd as it has always done.
*/
}
- if (PL_suidscript != 1) {
+ if (*suidscript != 1) {
Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
}
#else /* IAMSUID */
else if (PL_preprocess) {
const char * const cpp_cfg = CPPSTDIN;
- SV * const cpp = newSVpvn("",0);
- SV * const cmd = NEWSV(0,0);
+ SV * const cpp = newSVpvs("");
+ SV * const cmd = newSV(0);
if (cpp_cfg[0] == 0) /* PERL_MICRO? */
Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
sv_catpv(cpp, cpp_cfg);
# ifndef VMS
- sv_catpvn(sv, "-I", 2);
+ sv_catpvs(sv, "-I");
sv_catpv(sv,PRIVLIB_EXP);
# endif
SvREFCNT_dec(cpp);
}
else if (!*scriptname) {
- forbid_setid("program input from stdin");
+ forbid_setid(0, *suidscript);
PL_rsfp = PerlIO_stdin();
}
else {
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
CopFILE(PL_curcop), Strerror(errno));
}
+ return fdscript;
}
/* Mention
#endif /* IAMSUID */
STATIC void
-S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
+S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
+ int fdscript, int suidscript)
{
dVAR;
#ifdef IAMSUID
const char *s_end;
#ifdef IAMSUID
- if (PL_fdscript < 0 || PL_suidscript != 1)
+ if (fdscript < 0 || suidscript != 1)
Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
/* PSz 11 Nov 03
* Since the script is opened by perl, not suidperl, some of these
PL_doswitches = FALSE; /* -s is insecure in suid */
/* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
CopLINE_inc(PL_curcop);
+ if (sv_gets(PL_linestr, PL_rsfp, 0) == NULL)
+ Perl_croak(aTHX_ "No #! line");
linestr = SvPV_nolen_const(PL_linestr);
- if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
- strnNE(linestr,"#!",2) ) /* required even on Sys V */
+ /* required even on Sys V */
+ if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
Perl_croak(aTHX_ "No #! line");
- linestr+=2;
+ linestr += 2;
s = linestr;
/* PSz 27 Feb 04 */
/* Sanity check on line length */
Perl_croak(aTHX_ "Args must match #! line");
#ifndef IAMSUID
- if (PL_fdscript < 0 &&
+ if (fdscript < 0 &&
PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
PL_euid == PL_statbuf.st_uid)
if (!PL_do_undump)
FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
#endif /* IAMSUID */
- if (PL_fdscript < 0 &&
+ if (fdscript < 0 &&
PL_euid) { /* oops, we're not the setuid root perl */
/* PSz 18 Feb 04
* When root runs a setuid script, we do not go through the same
* might run also non-setuid ones, and deserves what he gets.
*
* Or, we might drop the PL_euid check above (and rely just on
- * PL_fdscript to avoid loops), and do the execs
+ * fdscript to avoid loops), and do the execs
* even for root.
*/
#ifndef IAMSUID
#ifdef IAMSUID
else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
- else if (PL_fdscript < 0 || PL_suidscript != 1)
+ else if (fdscript < 0 || suidscript != 1)
/* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
else {
Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
#endif /* IAMSUID */
#else /* !DOSUID */
+ PERL_UNUSED_ARG(fdscript);
+ PERL_UNUSED_ARG(suidscript);
if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
/* not set-id, must be wrapped */
}
#endif /* DOSUID */
- (void)validarg;
- (void)scriptname;
+ PERL_UNUSED_ARG(validarg);
+ PERL_UNUSED_ARG(scriptname);
}
STATIC void
S_find_beginning(pTHX)
{
+ dVAR;
register char *s;
register const char *s2;
#ifdef MACOS_TRADITIONAL
/* skip forward in input to the real script? */
- forbid_setid("-x");
#ifdef MACOS_TRADITIONAL
/* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
while (PL_doextract || gMacPerl_AlwaysExtract) {
- if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
+ if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
if (!gMacPerl_AlwaysExtract)
Perl_croak(aTHX_ "No Perl script found in input\n");
}
#else
while (PL_doextract) {
- if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
+ if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL)
Perl_croak(aTHX_ "No Perl script found in input\n");
#endif
s2 = s;
STATIC void
S_init_ids(pTHX)
{
+ dVAR;
PL_uid = PerlProc_getuid();
PL_euid = PerlProc_geteuid();
PL_gid = PerlProc_getgid();
return 0;
}
+/* Passing the flag as a single char rather than a string is a slight space
+ optimisation. The only message that isn't /^-.$/ is
+ "program input from stdin", which is substituted in place of '\0', which
+ could never be a command line flag. */
STATIC void
-S_forbid_setid(pTHX_ const char *s)
+S_forbid_setid(pTHX_ const char flag, const int suidscript)
{
+ dVAR;
+ char string[3] = "-x";
+ const char *message = "program input from stdin";
+
+ if (flag) {
+ string[1] = flag;
+ message = string;
+ }
+
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
if (PL_euid != PL_uid)
- Perl_croak(aTHX_ "No %s allowed while running setuid", s);
+ Perl_croak(aTHX_ "No %s allowed while running setuid", message);
if (PL_egid != PL_gid)
- Perl_croak(aTHX_ "No %s allowed while running setgid", s);
+ Perl_croak(aTHX_ "No %s allowed while running setgid", message);
#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
/* PSz 29 Feb 04
* Checks for UID/GID above "wrong": why disallow
*
* Also see comments about root running a setuid script, elsewhere.
*/
- if (PL_suidscript >= 0)
- Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
+ if (suidscript >= 0)
+ Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
#ifdef IAMSUID
/* PSz 11 Nov 03 Catch it in suidperl, always! */
- Perl_croak(aTHX_ "No %s allowed in suidperl", s);
+ Perl_croak(aTHX_ "No %s allowed in suidperl", message);
#endif /* IAMSUID */
}
void
Perl_init_debugger(pTHX)
{
+ dVAR;
HV * const ostash = PL_curstash;
PL_curstash = PL_debstash;
- PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
+ PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", GV_ADDMULTI,
+ SVt_PVAV))));
AvREAL_off(PL_dbargs);
- PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
- PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
- PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
- PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
+ PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
+ PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
+ PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
+ PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsingle, 0);
- PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
+ PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBtrace, 0);
- PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
+ PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
- PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
+ PL_DBassertion = GvSV((gv_fetchpvs("DB::assertion", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBassertion, 0);
PL_curstash = ostash;
}
void
Perl_init_stacks(pTHX)
{
+ dVAR;
/* start with 128-item stack and 8K cxstack */
PL_curstackinfo = new_stackinfo(REASONABLE(128),
REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
STATIC void
S_nuke_stacks(pTHX)
{
+ dVAR;
while (PL_curstackinfo->si_next)
PL_curstackinfo = PL_curstackinfo->si_next;
while (PL_curstackinfo) {
STATIC void
S_init_lexer(pTHX)
{
+ dVAR;
PerlIO *tmpfp;
tmpfp = PL_rsfp;
PL_rsfp = Nullfp;
lex_start(PL_linestr);
PL_rsfp = tmpfp;
- PL_subname = newSVpvn("main",4);
+ PL_subname = newSVpvs("main");
}
STATIC void
S_init_predump_symbols(pTHX)
{
+ dVAR;
GV *tmpgv;
IO *io;
sv_setpvn(get_sv("\"", TRUE), " ", 1);
- PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
+ PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
GvMULTI_on(PL_stdingv);
io = GvIOp(PL_stdingv);
IoTYPE(io) = IoTYPE_RDONLY;
IoIFP(io) = PerlIO_stdin();
- tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
+ tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
GvMULTI_on(tmpgv);
GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
- tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
+ tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
GvMULTI_on(tmpgv);
io = GvIOp(tmpgv);
IoTYPE(io) = IoTYPE_WRONLY;
IoOFP(io) = IoIFP(io) = PerlIO_stdout();
setdefout(tmpgv);
- tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
+ tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
GvMULTI_on(tmpgv);
GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
- PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
+ PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
GvMULTI_on(PL_stderrgv);
io = GvIOp(PL_stderrgv);
IoTYPE(io) = IoTYPE_WRONLY;
IoOFP(io) = IoIFP(io) = PerlIO_stderr();
- tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
+ tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
GvMULTI_on(tmpgv);
GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
- PL_statname = NEWSV(66,0); /* last filename we did stat on */
+ PL_statname = newSV(0); /* last filename we did stat on */
Safefree(PL_osname);
PL_osname = savepv(OSNAME);
void
Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
{
+ dVAR;
argc--,argv++; /* skip name of script */
if (PL_doswitches) {
for (; argc > 0 && **argv == '-'; argc--,argv++) {
break;
}
if ((s = strchr(argv[0], '='))) {
- *s++ = '\0';
- sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
+ const char *const start_name = argv[0] + 1;
+ sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
+ TRUE, SVt_PV)), s + 1);
}
else
- sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
+ sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
}
}
- if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
+ if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
GvMULTI_on(PL_argvgv);
(void)gv_AVadd(PL_argvgv);
av_clear(GvAVn(PL_argvgv));
dVAR;
GV* tmpgv;
- PL_toptarget = NEWSV(0,0);
+ PL_toptarget = newSV(0);
sv_upgrade(PL_toptarget, SVt_PVFM);
sv_setpvn(PL_toptarget, "", 0);
- PL_bodytarget = NEWSV(0,0);
+ PL_bodytarget = newSV(0);
sv_upgrade(PL_bodytarget, SVt_PVFM);
sv_setpvn(PL_bodytarget, "", 0);
PL_formtarget = PL_bodytarget;
init_argv_symbols(argc,argv);
- if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
+ if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
#ifdef MACOS_TRADITIONAL
/* $0 is not majick on a Mac */
sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
magicname("0", "0", 1);
#endif
}
- if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
+ if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
HV *hv;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
- hv_magic(hv, Nullgv, PERL_MAGIC_env);
+ hv_magic(hv, NULL, PERL_MAGIC_env);
#ifndef PERL_MICRO
#ifdef USE_ENVIRON_ARRAY
/* Note that if the supplied env parameter is actually a copy
# endif
)
{
- environ[0] = Nullch;
+ environ[0] = NULL;
}
if (env) {
char** origenv = environ;
#endif /* !PERL_MICRO */
}
TAINT_NOT;
- if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+ if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
STATIC void
S_init_perllib(pTHX)
{
+ dVAR;
char *s;
if (!PL_tainting) {
#ifndef VMS
#ifdef MACOS_TRADITIONAL
{
Stat_t tmpstatbuf;
- SV * privdir = NEWSV(55, 0);
+ SV * privdir = newSV(0);
char * macperl = PerlEnv_getenv("MACPERL");
if (!macperl)
STATIC SV *
S_incpush_if_exists(pTHX_ SV *dir)
{
+ dVAR;
Stat_t tmpstatbuf;
if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode)) {
av_push(GvAVn(PL_incgv), dir);
- dir = NEWSV(0,0);
+ dir = newSV(0);
}
return dir;
}
S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
bool canrelocate)
{
- SV *subdir = Nullsv;
+ dVAR;
+ SV *subdir = NULL;
const char *p = dir;
if (!p || !*p)
return;
if (addsubdirs || addoldvers) {
- subdir = NEWSV(0,0);
+ subdir = newSV(0);
}
/* Break at all separators */
while (p && *p) {
- SV *libdir = NEWSV(55,0);
+ SV *libdir = newSV(0);
const char *s;
/* skip any consecutive separators */
if (usesep) {
while ( *p == PERLLIB_SEP ) {
/* Uncomment the next line for PATH semantics */
- /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
+ /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
p++;
}
}
- if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
+ if ( usesep && (s = strchr(p, PERLLIB_SEP)) != NULL ) {
sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
(STRLEN)(s - p));
p = s + 1;
}
else {
sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
- p = Nullch; /* break out */
+ p = NULL; /* break out */
}
#ifdef MACOS_TRADITIONAL
if (!strchr(SvPVX(libdir), ':')) {
sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
}
if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
- sv_catpv(libdir, ":");
+ sv_catpvs(libdir, ":");
#endif
/* Do the if() outside the #ifdef to avoid warnings about an unused
char *unix;
STRLEN len;
- if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
+ if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
len = strlen(unix);
while (unix[len-1] == '/') len--; /* Cosmetic */
sv_usepvn(libdir,unix,len);
}
}
-#ifdef USE_5005THREADS
-STATIC struct perl_thread *
-S_init_main_thread(pTHX)
-{
-#if !defined(PERL_IMPLICIT_CONTEXT)
- struct perl_thread *thr;
-#endif
- XPV *xpv;
-
- Newxz(thr, 1, struct perl_thread);
- PL_curcop = &PL_compiling;
- thr->interp = PERL_GET_INTERP;
- thr->cvcache = newHV();
- thr->threadsv = newAV();
- /* thr->threadsvp is set when find_threadsv is called */
- thr->specific = newAV();
- thr->flags = THRf_R_JOINABLE;
- MUTEX_INIT(&thr->mutex);
- /* Handcraft thrsv similarly to mess_sv */
- Newx(PL_thrsv, 1, SV);
- Newxz(xpv, 1, XPV);
- SvFLAGS(PL_thrsv) = SVt_PV;
- SvANY(PL_thrsv) = (void*)xpv;
- SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
- SvPV_set(PL_thrsvr, (char*)thr);
- SvCUR_set(PL_thrsv, sizeof(thr));
- SvLEN_set(PL_thrsv, sizeof(thr));
- *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
- thr->oursv = PL_thrsv;
- PL_chopset = " \n-";
- PL_dumpindent = 4;
-
- MUTEX_LOCK(&PL_threads_mutex);
- PL_nthreads++;
- thr->tid = 0;
- thr->next = thr;
- thr->prev = thr;
- thr->thr_done = 0;
- MUTEX_UNLOCK(&PL_threads_mutex);
-
-#ifdef HAVE_THREAD_INTERN
- Perl_init_thread_intern(thr);
-#endif
-
-#ifdef SET_THREAD_SELF
- SET_THREAD_SELF(thr);
-#else
- thr->self = pthread_self();
-#endif /* SET_THREAD_SELF */
- PERL_SET_THX(thr);
-
- /*
- * These must come after the thread self setting
- * because sv_setpvn does SvTAINT and the taint
- * fields thread selfness being set.
- */
- PL_toptarget = NEWSV(0,0);
- sv_upgrade(PL_toptarget, SVt_PVFM);
- sv_setpvn(PL_toptarget, "", 0);
- PL_bodytarget = NEWSV(0,0);
- sv_upgrade(PL_bodytarget, SVt_PVFM);
- sv_setpvn(PL_bodytarget, "", 0);
- PL_formtarget = PL_bodytarget;
- thr->errsv = newSVpvn("", 0);
- (void) find_threadsv("@"); /* Ensure $@ is initialised early */
-
- PL_maxscream = -1;
- PL_peepp = MEMBER_TO_FPTR(Perl_peep);
- PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
- PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
- PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
- PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
- PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
- PL_regindent = 0;
- PL_reginterp_cnt = 0;
-
- return thr;
-}
-#endif /* USE_5005THREADS */
void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
if (paramList == PL_beginav)
- sv_catpv(atsv, "BEGIN failed--compilation aborted");
+ sv_catpvs(atsv, "BEGIN failed--compilation aborted");
else
Perl_sv_catpvf(aTHX_ atsv,
"%s failed--call queue aborted",
STATIC void *
S_call_list_body(pTHX_ CV *cv)
{
+ dVAR;
PUSHMARK(PL_stack_sp);
call_sv((SV*)cv, G_EVAL|G_DISCARD);
return NULL;
void
Perl_my_exit(pTHX_ U32 status)
{
+ dVAR;
DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
thr, (unsigned long) status));
switch (status) {
void
Perl_my_failure_exit(pTHX)
{
+ dVAR;
#ifdef VMS
/* We have been called to fall on our sword. The desired exit code
* should be already set in STATUS_UNIX, but could be shifted over
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
- PL_e_script = Nullsv;
+ PL_e_script = NULL;
}
POPSTACK_TO(PL_mainstack);
static I32
read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
{
+ dVAR;
const char * const p = SvPVX_const(PL_e_script);
const char *nl = strchr(p, '\n');
https://perl5.git.perl.org / perl5.git / blobdiff