/* perl.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
OP_REFCNT_INIT;
MUTEX_INIT(&PL_dollarzero_mutex);
# endif
+#ifdef PERL_IMPLICIT_CONTEXT
+ MUTEX_INIT(&PL_my_ctx_mutex);
+# endif
}
else {
PERL_SET_THX(my_perl);
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)) {
}
PL_sighandlerp = (Sighandler_t) Perl_sighandler;
+#ifdef PERL_USES_PL_PIDSTATUS
PL_pidstatus = newHV();
+#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. */
# endif
if ((long) PL_mmap_page_size < 0) {
if (errno) {
- SV *error = ERRSV;
+ SV * const error = ERRSV;
(void) SvUPGRADE(error, SVt_PV);
Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
}
if (CALL_FPTR(PL_threadhook)(aTHX)) {
/* Threads hook has vetoed further cleanup */
- return STATUS_NATIVE_EXPORT;
+ return STATUS_EXIT;
}
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
}
PL_main_start = Nullop;
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 */
}
/* unhook hooks which will soon be, or use, destroyed data */
#endif
/* The exit() function will do everything that needs doing. */
- return STATUS_NATIVE_EXPORT;
+ return STATUS_EXIT;
}
/* jettison our possibly duplicated environment */
*/
{
I32 i = AvFILLp(PL_regex_padav) + 1;
- SV **ary = AvARRAY(PL_regex_padav);
+ SV * const * const ary = AvARRAY(PL_regex_padav);
while (i) {
- SV *resv = ary[--i];
+ SV * const resv = ary[--i];
if (SvFLAGS(resv) & SVf_BREAK) {
/* this is PL_reg_curpm, already freed
}
}
SvREFCNT_dec(PL_regex_padav);
- PL_regex_padav = Nullav;
+ PL_regex_padav = NULL;
PL_regex_pad = NULL;
#endif
/* Filters for program text */
SvREFCNT_dec(PL_rsfp_filters);
- PL_rsfp_filters = Nullav;
+ PL_rsfp_filters = NULL;
/* switches */
PL_preprocess = FALSE;
PL_unsafe = FALSE;
Safefree(PL_inplace);
- PL_inplace = Nullch;
+ PL_inplace = NULL;
SvREFCNT_dec(PL_patchlevel);
if (PL_e_script) {
PL_multiline = 0; /* $* */
Safefree(PL_osname); /* $^O */
- PL_osname = Nullch;
+ PL_osname = NULL;
SvREFCNT_dec(PL_statname);
PL_statname = Nullsv;
/* float buffer */
Safefree(PL_efloatbuf);
- PL_efloatbuf = Nullch;
+ PL_efloatbuf = NULL;
PL_efloatsize = 0;
/* startup and shutdown function lists */
SvREFCNT_dec(PL_checkav);
SvREFCNT_dec(PL_checkav_save);
SvREFCNT_dec(PL_initav);
- PL_beginav = Nullav;
- PL_beginav_save = Nullav;
- PL_endav = Nullav;
- PL_checkav = Nullav;
- PL_checkav_save = Nullav;
- PL_initav = Nullav;
+ PL_beginav = NULL;
+ PL_beginav_save = NULL;
+ PL_endav = NULL;
+ PL_checkav = NULL;
+ PL_checkav_save = NULL;
+ PL_initav = NULL;
/* shortcuts just get cleared */
PL_envgv = Nullgv;
PL_DBtrace = Nullsv;
PL_DBsignal = Nullsv;
PL_DBassertion = Nullsv;
- PL_DBcv = Nullcv;
- PL_dbargs = Nullav;
- PL_debstash = Nullhv;
+ PL_DBcv = NULL;
+ PL_dbargs = NULL;
+ PL_debstash = NULL;
SvREFCNT_dec(PL_argvout_stack);
- PL_argvout_stack = Nullav;
+ PL_argvout_stack = NULL;
SvREFCNT_dec(PL_modglobal);
- PL_modglobal = Nullhv;
+ PL_modglobal = NULL;
SvREFCNT_dec(PL_preambleav);
- PL_preambleav = Nullav;
+ PL_preambleav = NULL;
SvREFCNT_dec(PL_subname);
PL_subname = Nullsv;
SvREFCNT_dec(PL_linestr);
PL_linestr = Nullsv;
+#ifdef PERL_USES_PL_PIDSTATUS
SvREFCNT_dec(PL_pidstatus);
- PL_pidstatus = Nullhv;
+ PL_pidstatus = NULL;
+#endif
SvREFCNT_dec(PL_toptarget);
PL_toptarget = Nullsv;
SvREFCNT_dec(PL_bodytarget);
/* 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;
#endif
AvREAL_off(PL_fdpid); /* no surviving entries */
SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
- PL_fdpid = Nullav;
+ PL_fdpid = NULL;
#ifdef HAVE_INTERP_INTERN
sys_intern_clear();
*/
I32 riter = 0;
const I32 max = HvMAX(PL_strtab);
- HE **array = HvARRAY(PL_strtab);
+ HE * const * const array = HvARRAY(PL_strtab);
HE *hent = array[0];
for (;;) {
if (hent && ckWARN_d(WARN_INTERNAL)) {
- HE *next = HeNEXT(hent);
+ HE * const next = HeNEXT(hent);
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Unbalanced string table refcount: (%d) for \"%s\"",
- HeVAL(hent) - Nullsv, HeKEY(hent));
+ "Unbalanced string table refcount: (%ld) for \"%s\"",
+ (long)hent->he_valu.hent_refcount, HeKEY(hent));
Safefree(hent);
hent = next;
}
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;
Safefree(PL_mess_sv);
PL_mess_sv = Nullsv;
}
- return STATUS_NATIVE_EXPORT;
+ return STATUS_EXIT;
}
/*
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) {
}
PL_main_start = Nullop;
SvREFCNT_dec(PL_main_cv);
- PL_main_cv = Nullcv;
+ PL_main_cv = NULL;
time(&PL_basetime);
oldscope = PL_scopestack_ix;
PL_curstash = PL_defstash;
if (PL_checkav)
call_list(oldscope, PL_checkav);
- ret = STATUS_NATIVE_EXPORT;
+ ret = STATUS_EXIT;
break;
case 3:
PerlIO_printf(Perl_error_log, "panic: top_env\n");
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();
s++;
goto reswitch;
+ case 'E':
+ PL_minus_E = TRUE;
+ /* FALL THROUGH */
case 'e':
#ifdef MACOS_TRADITIONAL
/* ignore -e for Dev:Pseudo argument */
#endif
forbid_setid("-e");
if (!PL_e_script) {
- PL_e_script = newSVpvn("",0);
+ PL_e_script = newSVpvs("");
filter_add(read_e_script, NULL);
}
if (*++s)
argc--,argv++;
}
else
- Perl_croak(aTHX_ "No code specified for -e");
- sv_catpv(PL_e_script, "\n");
+ Perl_croak(aTHX_ "No code specified for -%c", *s);
+ sv_catpvs(PL_e_script, "\n");
break;
case 'f':
case 'I': /* -I handled both here and in moreswitches() */
forbid_setid("-I");
- if (!*++s && (s=argv[1]) != Nullch) {
+ 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
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);
- sv_catpv(opts_prog,"\" Compile-time options:"
+ Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:"
# ifdef DEBUGGING
" DEBUGGING"
# endif
+# ifdef DEBUG_LEAKING_SCALARS
+ " DEBUG_LEAKING_SCALARS"
+# endif
# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
" DEBUG_LEAKING_SCALARS_FORK_DUMP"
# endif
# ifdef MYMALLOC
" MYMALLOC"
# endif
+# ifdef NO_MATHOMS
+ " NO_MATHOMS"
+# endif
# ifdef PERL_DONT_CREATE_GVSV
" PERL_DONT_CREATE_GVSV"
# endif
# ifdef PERL_OLD_COPY_ON_WRITE
" PERL_OLD_COPY_ON_WRITE"
# endif
+# ifdef PERL_TRACK_MEMPOOL
+ " PERL_TRACK_MEMPOOL"
+# endif
+# ifdef PERL_USE_SAFE_PUTENV
+ " PERL_USE_SAFE_PUTENV"
+# endif
+#ifdef PERL_USES_PL_PIDSTATUS
+ " PERL_USES_PL_PIDSTATUS"
+#endif
# ifdef PL_OP_SLAB_ALLOC
" PL_OP_SLAB_ALLOC"
# endif
*/
const char *space;
- char *pv = SvPV_nolen(opts_prog);
+ char * const pv = SvPV_nolen(opts_prog);
const char c = pv[opts+76];
pv[opts+76] = '\0';
space = strrchr(pv+opts+26, ' ');
/* 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))
d = s;
if (!*s)
break;
- if (!strchr("DIMUdmtwA", *s))
+ if (!strchr("CDIMUdmtwA", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
while (++s && *s) {
if (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");
}
- 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);
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(EPOC)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
init_os_extras();
#endif
#endif
* or explicitly in some platforms.
* locale.c:Perl_init_i18nl10n() if the environment
* look like the user wants to use UTF-8. */
-#if defined(SYMBIAN)
+#if defined(__SYMBIAN32__)
PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
#endif
if (PL_unicode) {
(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) {
int
perl_run(pTHXx)
{
+ dVAR;
I32 oldscope;
int ret = 0;
dJMPENV;
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- ret = STATUS_NATIVE_EXPORT;
+ ret = STATUS_EXIT;
break;
case 3:
if (PL_restartop) {
STATIC void
S_run_body(pTHX_ I32 oldscope)
{
+ dVAR;
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
PL_sawampersand ? "Enabling" : "Omitting"));
AV*
Perl_get_av(pTHX_ const char *name, I32 create)
{
- GV* gv = gv_fetchpv(name, create, SVt_PVAV);
+ GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
if (create)
return GvAVn(gv);
if (gv)
return GvAV(gv);
- return Nullav;
+ return NULL;
}
/*
return GvHVn(gv);
if (gv)
return GvHV(gv);
- return Nullhv;
+ return NULL;
}
/*
CV*
Perl_get_cv(pTHX_ const char *name, I32 create)
{
- GV* gv = gv_fetchpv(name, create, SVt_PVCV);
+ GV* const gv = gv_fetchpv(name, create, SVt_PVCV);
/* XXX unsafe for threads if eval_owner isn't held */
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
Nullop);
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);
I32 oldscope;
bool oldcatch = CATCH_GET;
int ret;
- OP* oldop = PL_op;
+ OP* const oldop = PL_op;
dJMPENV;
if (flags & G_DISCARD) {
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;
volatile I32 retval = 0;
int ret;
- OP* oldop = PL_op;
+ OP* const oldop = PL_op;
dJMPENV;
if (flags & G_DISCARD) {
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 *gv;
+ register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV);
- if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
+ if (gv)
sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
}
"-d[:debugger] run program under debugger",
"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
"-e program one line of program (several -e's allowed, omit programfile)",
+"-E program like -e, but enables all optional features",
"-f don't do $sitelib/sitecustomize.pl at startup",
"-F/pattern/ split() pattern for -a switch (//'s are optional)",
"-i[extension] edit <> files in place (makes backup if extension supplied)",
static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
for (; isALNUM(**s); (*s)++) {
- const char *d = strchr(debopts,**s);
+ const char * const d = strchr(debopts,**s);
if (d)
i |= 1 << (d - debopts);
else if (ckWARN_d(WARN_DEBUGGING))
for (; isALNUM(**s); (*s)++) ;
}
else if (givehelp) {
- char **p = (char **)usage_msgd;
+ const char *const *p = usage_msgd;
while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
}
# ifdef EBCDIC
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);
in the fashion that -MSome::Mod does. */
if (*s == ':' || *s == '=') {
const char *start;
- SV *sv;
- 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;
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__ */
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);
PL_preambleav = newAV();
s++;
{
- char *start = s;
- SV *sv = newSVpv("use assertions::activate", 24);
+ char * const start = s;
+ 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 == '=') {
s+=strlen(s);
}
else if (*s != '\0') {
- Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start);
+ Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start);
}
av_push(PL_preambleav, sv);
return s;
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)
return s;
case 'v':
if (!sv_derived_from(PL_patchlevel, "version"))
- (void *)upg_version(PL_patchlevel);
+ 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 */
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2005, Larry Wall\n");
+ "\n\nCopyright 1987-2006, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
"\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
wce_hitreturn();
#endif
-#ifdef SYMBIAN
+#ifdef __SYMBIAN32__
PerlIO_printf(PerlIO_stdout(),
"Symbian port by Nokia, 2004-2005\n");
#endif
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)
STATIC void
S_init_main_stash(pTHX)
{
+ dVAR;
GV *gv;
PL_curstash = PL_defstash = newHV();
- PL_curstname = newSVpvn("main",4);
- gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
+ /* 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 = 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
+ of the SvREFCNT_dec, only to add it again with hv_name_set */
SvREFCNT_dec(GvHV(gv));
+ hv_name_set(PL_defstash, "main", 4, 0);
GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
SvREADONLY_on(gv);
- hv_name_set(PL_defstash, "main", 4, 0);
- 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_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
+ PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
+ SvREFCNT_inc(PL_defgv);
+ 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);
}
PL_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 */
}
#else /* IAMSUID */
else if (PL_preprocess) {
- const char *cpp_cfg = CPPSTDIN;
- SV *cpp = newSVpvn("",0);
- SV *cmd = NEWSV(0,0);
+ const char * const cpp_cfg = CPPSTDIN;
+ 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
#endif /* IAMSUID */
if (!PL_rsfp) {
/* PSz 16 Sep 03 Keep neat error message */
- Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
- CopFILE(PL_curcop), Strerror(errno));
+ if (PL_e_script)
+ Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
+ else
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+ CopFILE(PL_curcop), Strerror(errno));
}
}
cmplen = sizeof(fsd.fd_req.path);
if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
fdst.st_dev == fsd.fd_req.dev) {
- check_okay = 1;
- on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
- on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
- }
+ check_okay = 1;
+ on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
+ on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
}
}
}
if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
const char *linestr;
+ const char *s_end;
#ifdef IAMSUID
if (PL_fdscript < 0 || PL_suidscript != 1)
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 */
- if (strlen(s) < 1 || strlen(s) > 4000)
+ s_end = s + strlen(s);
+ if (s_end == s || (s_end - s) > 4000)
Perl_croak(aTHX_ "Very long #! line");
/* Allow more than a single space after #! */
while (isSPACE(*s)) s++;
len = strlen(validarg);
if (strEQ(validarg," PHOOEY ") ||
strnNE(s,validarg,len) || !isSPACE(s[len]) ||
- !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
+ !((s_end - s) == len+1
+ || ((s_end - s) == len+2 && isSPACE(s[len+1]))))
Perl_croak(aTHX_ "Args must match #! line");
#ifndef IAMSUID
STATIC void
S_find_beginning(pTHX)
{
+ dVAR;
register char *s;
register const char *s2;
#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();
STATIC void
S_forbid_setid(pTHX_ const char *s)
{
+ dVAR;
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
if (PL_euid != PL_uid)
Perl_croak(aTHX_ "No %s allowed while running setuid", s);
void
Perl_init_debugger(pTHX)
{
- HV *ostash = PL_curstash;
+ 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);
# 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
s = PerlEnv_getenv("PERL5LIB");
+/*
+ * It isn't possible to delete an environment variable with
+ * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
+ * case we treat PERL5LIB as undefined if it has a zero-length value.
+ */
+#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
+ if (s && *s != '\0')
+#else
if (s)
+#endif
incpush(s, TRUE, TRUE, TRUE, FALSE);
else
incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
#ifdef MACOS_TRADITIONAL
{
Stat_t tmpstatbuf;
- SV * privdir = NEWSV(55, 0);
+ SV * privdir = newSV(0);
char * macperl = PerlEnv_getenv("MACPERL");
if (!macperl)
#endif /* MACOS_TRADITIONAL */
}
-#if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
+#if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
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)
{
+ dVAR;
SV *subdir = Nullsv;
const char *p = dir;
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
if (addsubdirs || addoldvers) {
#ifdef PERL_INC_VERSION_LIST
/* Configure terminates PERL_INC_VERSION_LIST with a NULL */
- const char *incverlist[] = { PERL_INC_VERSION_LIST };
- const char **incver;
+ const char * const incverlist[] = { PERL_INC_VERSION_LIST };
+ const char * const *incver;
#endif
#ifdef VMS
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);
* because sv_setpvn does SvTAINT and the taint
* fields thread selfness being set.
*/
- 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;
- thr->errsv = newSVpvn("", 0);
+ thr->errsv = newSVpvs("");
(void) find_threadsv("@"); /* Ensure $@ is initialised early */
PL_maxscream = -1;
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) {
STATUS_ALL_FAILURE;
break;
default:
- STATUS_NATIVE_SET(status);
+ STATUS_EXIT_SET(status);
break;
}
my_exit_jump();
void
Perl_my_failure_exit(pTHX)
{
+ dVAR;
#ifdef VMS
- if (vaxc$errno & 1) {
- if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
- STATUS_NATIVE_SET(44);
+ /* 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
+ * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
+ * that code is set.
+ *
+ * If an error code has not been set, then force the issue.
+ */
+ if (MY_POSIX_EXIT) {
+
+ /* In POSIX_EXIT mode follow Perl documentations and use 255 for
+ * the exit code when there isn't an error.
+ */
+
+ if (STATUS_UNIX == 0)
+ STATUS_UNIX_EXIT_SET(255);
+ else {
+ STATUS_UNIX_EXIT_SET(STATUS_UNIX);
+
+ /* The exit code could have been set by $? or vmsish which
+ * means that it may not be fatal. So convert
+ * success/warning codes to fatal.
+ */
+ if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0)
+ STATUS_UNIX_EXIT_SET(255);
+ }
}
else {
- if (!vaxc$errno) /* unlikely */
- STATUS_NATIVE_SET(44);
- else
- STATUS_NATIVE_SET(vaxc$errno);
+ /* Traditionally Perl on VMS always expects a Fatal Error. */
+ if (vaxc$errno & 1) {
+
+ /* So force success status to failure */
+ if (STATUS_NATIVE & 1)
+ STATUS_ALL_FAILURE;
+ }
+ else {
+ if (!vaxc$errno) {
+ STATUS_UNIX = EINTR; /* In case something cares */
+ STATUS_ALL_FAILURE;
+ }
+ else {
+ int severity;
+ STATUS_NATIVE = vaxc$errno; /* Should already be this */
+
+ /* Encode the severity code */
+ severity = STATUS_NATIVE & STS$M_SEVERITY;
+ STATUS_UNIX = (severity ? severity : 1) << 8;
+
+ /* Perl expects this to be a fatal error */
+ if (severity != STS$K_SEVERE)
+ STATUS_ALL_FAILURE;
+ }
+ }
}
+
#else
int exitstatus;
if (errno & 255)
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