static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
-#endif
-
#ifdef IAMSUID
#ifndef DOSUID
#define DOSUID
#define perl_free Perl_free
#endif
+#if defined(USE_THREADS)
+# define INIT_TLS_AND_INTERP \
+ STMT_START { \
+ if (!PL_curinterp) { \
+ PERL_SET_INTERP(my_perl); \
+ INIT_THREADS; \
+ ALLOC_THREAD_KEY; \
+ } \
+ } STMT_END
+#else
+# if defined(USE_ITHREADS)
+# define INIT_TLS_AND_INTERP \
+ STMT_START { \
+ if (!PL_curinterp) { \
+ PERL_SET_INTERP(my_perl); \
+ INIT_THREADS; \
+ ALLOC_THREAD_KEY; \
+ PERL_SET_THX(my_perl); \
+ OP_REFCNT_INIT; \
+ } \
+ else { \
+ PERL_SET_THX(my_perl); \
+ } \
+ } STMT_END
+# else
+# define INIT_TLS_AND_INTERP \
+ STMT_START { \
+ if (!PL_curinterp) { \
+ PERL_SET_INTERP(my_perl); \
+ } \
+ PERL_SET_THX(my_perl); \
+ } STMT_END
+# endif
+#endif
+
#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
#ifdef PERL_OBJECT
my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
ipLIO, ipD, ipS, ipP);
- PERL_SET_INTERP(my_perl);
+ INIT_TLS_AND_INTERP;
#else
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
- PERL_SET_INTERP(my_perl);
+ INIT_TLS_AND_INTERP;
Zero(my_perl, 1, PerlInterpreter);
PL_Mem = ipM;
PL_MemShared = ipMS;
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
- PERL_SET_INTERP(my_perl);
+
+ INIT_TLS_AND_INTERP;
Zero(my_perl, 1, PerlInterpreter);
return my_perl;
}
struct perl_thread *thr = NULL;
#endif /* FAKE_THREADS */
#endif /* USE_THREADS */
-
+
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
/* Init the real globals (and main thread)? */
if (!PL_linestr) {
- INIT_THREADS;
#ifdef USE_THREADS
-#ifdef ALLOC_THREAD_KEY
- ALLOC_THREAD_KEY;
-#else
- if (pthread_key_create(&PL_thr_key, 0))
- Perl_croak(aTHX_ "panic: pthread_key_create");
-#endif
MUTEX_INIT(&PL_sv_mutex);
/*
* Safe to use basic SV functions from now on (though
COND_INIT(&PL_eval_cond);
MUTEX_INIT(&PL_threads_mutex);
COND_INIT(&PL_nthreads_cond);
-#ifdef EMULATE_ATOMIC_REFCOUNTS
+# ifdef EMULATE_ATOMIC_REFCOUNTS
MUTEX_INIT(&PL_svref_mutex);
-#endif /* EMULATE_ATOMIC_REFCOUNTS */
+# endif /* EMULATE_ATOMIC_REFCOUNTS */
MUTEX_INIT(&PL_cred_mutex);
thr = init_main_thread();
#endif /* USE_THREADS */
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
+#endif
PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
{
U8 *s;
PL_patchlevel = NEWSV(0,4);
- SvUPGRADE(PL_patchlevel, SVt_PVNV);
+ (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
- SvGROW(PL_patchlevel,24);
+ SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
s = (U8*)SvPVX(PL_patchlevel);
s = uv_to_utf8(s, (UV)PERL_REVISION);
s = uv_to_utf8(s, (UV)PERL_VERSION);
#ifdef DEBUGGING
{
char *s;
- if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
+ if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
int i = atoi(s);
if (destruct_level < i)
destruct_level = i;
/* magical thingies */
- Safefree(PL_ofs); /* $, */
+ Safefree(PL_ofs); /* $, */
PL_ofs = Nullch;
- Safefree(PL_ors); /* $\ */
+ Safefree(PL_ors); /* $\ */
PL_ors = Nullch;
SvREFCNT_dec(PL_rs); /* $/ */
SvREFCNT_dec(PL_nrs); /* $/ helper */
PL_nrs = Nullsv;
- PL_multiline = 0; /* $* */
+ PL_multiline = 0; /* $* */
+ Safefree(PL_osname); /* $^O */
+ PL_osname = Nullch;
SvREFCNT_dec(PL_statname);
PL_statname = Nullsv;
SvREFCNT_dec(PL_argvout_stack);
PL_argvout_stack = Nullav;
- SvREFCNT_dec(PL_fdpid);
- PL_fdpid = Nullav;
SvREFCNT_dec(PL_modglobal);
PL_modglobal = Nullhv;
SvREFCNT_dec(PL_preambleav);
PL_bodytarget = Nullsv;
PL_formtarget = Nullsv;
+ /* free locale stuff */
+#ifdef USE_LOCALE_COLLATE
+ Safefree(PL_collation_name);
+ PL_collation_name = Nullch;
+#endif
+
+#ifdef USE_LOCALE_NUMERIC
+ Safefree(PL_numeric_name);
+ PL_numeric_name = Nullch;
+#endif
+
/* clear utf8 character classes */
SvREFCNT_dec(PL_utf8_alnum);
SvREFCNT_dec(PL_utf8_alnumc);
if (!specialWARN(PL_compiling.cop_warnings))
SvREFCNT_dec(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = Nullsv;
+#ifndef USE_ITHREADS
+ SvREFCNT_dec(CopFILEGV(&PL_compiling));
+ CopFILEGV_set(&PL_compiling, Nullgv);
+#endif
/* Prepare to destruct main symbol table. */
/* Now absolutely destruct everything, somehow or other, loops or no. */
last_sv_count = 0;
+ SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
last_sv_count = PL_sv_count;
sv_clean_all();
}
+ SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
+ SvFLAGS(PL_fdpid) |= SVt_PVAV;
SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
SvFLAGS(PL_strtab) |= SVt_PVHV;
-
+
+ AvREAL_off(PL_fdpid); /* no surviving entries */
+ SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
+ PL_fdpid = Nullav;
+
/* Destruct the global string table. */
{
/* Yell and reset the HeVAL() slots that are still holding refcounts,
}
SvREFCNT_dec(PL_strtab);
+ /* free special SVs */
+
+ SvREFCNT(&PL_sv_yes) = 0;
+ sv_clear(&PL_sv_yes);
+ SvANY(&PL_sv_yes) = NULL;
+ SvREADONLY_off(&PL_sv_yes);
+
+ SvREFCNT(&PL_sv_no) = 0;
+ sv_clear(&PL_sv_no);
+ SvANY(&PL_sv_no) = NULL;
+ SvREADONLY_off(&PL_sv_no);
+
+ SvREFCNT(&PL_sv_undef) = 0;
+ SvREADONLY_off(&PL_sv_undef);
+
if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
Safefree(PL_thrsv);
PL_thrsv = Nullsv;
#endif /* USE_THREADS */
-
+
/* As the absolutely last thing, free the non-arena SV for mess() */
if (PL_mess_sv) {
}
}
/* we know that type >= SVt_PV */
- SvOOK_off(PL_mess_sv);
+ (void)SvOOK_off(PL_mess_sv);
Safefree(SvPVX(PL_mess_sv));
Safefree(SvANY(PL_mess_sv));
Safefree(PL_mess_sv);
oldscope = PL_scopestack_ix;
PL_dowarn = G_WARN_OFF;
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
- env, xsinit);
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ parse_body(env,xsinit);
+#endif
if (PL_checkav)
call_list(oldscope, PL_checkav);
- return 0;
+ ret = 0;
+ break;
case 1:
STATUS_ALL_FAILURE;
/* FALL THROUGH */
PL_curstash = PL_defstash;
if (PL_checkav)
call_list(oldscope, PL_checkav);
- return STATUS_NATIVE_EXPORT;
+ ret = STATUS_NATIVE_EXPORT;
+ break;
case 3:
PerlIO_printf(Perl_error_log, "panic: top_env\n");
- return 1;
+ ret = 1;
+ break;
}
- return 0;
+ JMPENV_POP;
+ return ret;
+}
+
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+STATIC void *
+S_vparse_body(pTHX_ va_list args)
+{
+ char **env = va_arg(args, char**);
+ XSINIT_t xsinit = va_arg(args, XSINIT_t);
+
+ return parse_body(env, xsinit);
}
+#endif
STATIC void *
-S_parse_body(pTHX_ va_list args)
+S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
dTHR;
int argc = PL_origargc;
char **argv = PL_origargv;
- char **env = va_arg(args, char**);
char *scriptname = NULL;
int fdscript = -1;
VOL bool dosearch = FALSE;
register char *s;
char *cddir = Nullch;
- XSINIT_t xsinit = va_arg(args, XSINIT_t);
-
sv_setpvn(PL_linestr,"",0);
sv = newSVpvn("",0); /* first used for -I flags */
SAVEFREESV(sv);
s = argv[0]+1;
reswitch:
switch (*s) {
+ case 'C':
+#ifdef WIN32
+ win32_argv2utf8(argc-1, argv+1);
+ /* FALL THROUGH */
+#endif
#ifndef PERL_STRICT_CR
case '\r':
#endif
case 'W':
case 'X':
case 'w':
- if (s = moreswitches(s))
+ if ((s = moreswitches(s)))
goto reswitch;
break;
char *p;
STRLEN len = strlen(s);
p = savepvn(s, len);
- incpush(p, TRUE);
+ incpush(p, TRUE, TRUE);
sv_catpvn(sv, "-I", 2);
sv_catpvn(sv, p, len);
sv_catpvn(sv, " ", 1);
# ifdef USE_ITHREADS
sv_catpv(PL_Sv," USE_ITHREADS");
# endif
-# ifdef USE_64_BITS
- sv_catpv(PL_Sv," USE_64_BITS");
+# ifdef USE_64_BIT_INT
+ sv_catpv(PL_Sv," USE_64_BIT_INT");
+# endif
+# ifdef USE_64_BIT_ALL
+ sv_catpv(PL_Sv," USE_64_BIT_ALL");
# endif
# ifdef USE_LONG_DOUBLE
sv_catpv(PL_Sv," USE_LONG_DOUBLE");
CvPADLIST(PL_compcv) = comppadlist;
boot_core_UNIVERSAL();
+#ifndef PERL_MICRO
boot_core_xsutils();
+#endif
if (xsinit)
(*xsinit)(aTHXo); /* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32) || defined(DJGPP)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
init_os_extras();
#endif
{
dTHR;
I32 oldscope;
- int ret;
+ int ret = 0;
dJMPENV;
#ifdef USE_THREADS
dTHX;
oldscope = PL_scopestack_ix;
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 1:
cxstack_ix = -1; /* start context stack again */
goto redo_body;
- case 0: /* normal completion */
- case 2: /* my_exit() */
+ case 0: /* normal completion */
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ run_body(oldscope);
+#endif
+ /* FALL THROUGH */
+ case 2: /* my_exit() */
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- return STATUS_NATIVE_EXPORT;
+ ret = STATUS_NATIVE_EXPORT;
+ break;
case 3:
if (PL_restartop) {
POPSTACK_TO(PL_mainstack);
}
PerlIO_printf(Perl_error_log, "panic: restartop\n");
FREETMPS;
- return 1;
+ ret = 1;
+ break;
}
- /* NOTREACHED */
- return 0;
+ JMPENV_POP;
+ return ret;
}
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
-S_run_body(pTHX_ va_list args)
+S_vrun_body(pTHX_ va_list args)
{
- dTHR;
I32 oldscope = va_arg(args, I32);
+ return run_body(oldscope);
+}
+#endif
+
+
+STATIC void *
+S_run_body(pTHX_ I32 oldscope)
+{
+ dTHR;
+
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
PL_sawampersand ? "Enabling" : "Omitting"));
{
dSP;
OP myop;
- if (!PL_op)
+ if (!PL_op) {
+ Zero(&myop, 1, OP);
PL_op = &myop;
+ }
XPUSHs(sv_2mortal(newSVpv(methname,0)));
PUTBACK;
pp_method();
- if(PL_op == &myop)
- PL_op = Nullop;
+ if (PL_op == &myop)
+ PL_op = Nullop;
return call_sv(*PL_stack_sp--, flags);
}
if (!(flags & G_EVAL)) {
CATCH_SET(TRUE);
- call_xbody((OP*)&myop, FALSE);
+ call_body((OP*)&myop, FALSE);
retval = PL_stack_sp - (PL_stack_base + oldmark);
CATCH_SET(oldcatch);
}
}
PL_markstack_ptr++;
- redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
(OP*)&myop, FALSE);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ call_body((OP*)&myop, FALSE);
+#endif
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
/* my_exit() was called */
PL_curstash = PL_defstash;
FREETMPS;
+ JMPENV_POP;
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
Perl_croak(aTHX_ "Callback called exit");
my_exit_jump();
PL_curpm = newpm;
LEAVE;
}
+ JMPENV_POP;
}
if (flags & G_DISCARD) {
return retval;
}
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
-S_call_body(pTHX_ va_list args)
+S_vcall_body(pTHX_ va_list args)
{
OP *myop = va_arg(args, OP*);
int is_eval = va_arg(args, int);
- call_xbody(myop, is_eval);
+ call_body(myop, is_eval);
return NULL;
}
+#endif
STATIC void
-S_call_xbody(pTHX_ OP *myop, int is_eval)
+S_call_body(pTHX_ OP *myop, int is_eval)
{
dTHR;
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
(OP*)&myop, TRUE);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ call_body((OP*)&myop,TRUE);
+#endif
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
/* my_exit() was called */
PL_curstash = PL_defstash;
FREETMPS;
+ JMPENV_POP;
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
Perl_croak(aTHX_ "Callback called exit");
my_exit_jump();
break;
}
+ JMPENV_POP;
if (flags & G_DISCARD) {
PL_stack_sp = PL_stack_base + oldmark;
retval = 0;
{
register GV *gv;
- if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
+ if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
}
static char *usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
"-a autosplit mode with -n or -p (splits $_ into @F)",
+"-C enable native wide character system interfaces",
"-c check syntax only (runs BEGIN and END blocks)",
"-d[:debugger] run program under debugger",
"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
"-v print version, subversion (includes VERY IMPORTANT perl info)",
"-V[:variable] print configuration summary (or a single Config.pm variable)",
"-w enable many useful warnings (RECOMMENDED)",
+"-W enable all warnings",
+"-X disable all warnings",
"-x[directory] strip off text before #!perl line and perhaps cd to directory",
"\n",
NULL
}
return s + numlen;
}
+ case 'C':
+ PL_widesyscalls = TRUE;
+ s++;
+ return s;
case 'F':
PL_minus_F = TRUE;
PL_splitstr = savepv(s + 1);
p++;
} while (*p && *p != '-');
e = savepvn(s, e-s);
- incpush(e, TRUE);
+ incpush(e, TRUE, TRUE);
Safefree(e);
s = p;
if (*s == '-')
s++;
return s;
case 'v':
- printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s",
+ printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
PL_patchlevel, ARCHNAME));
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
#ifdef __MINT__
printf("MiNT port by Guido Flohr, 1997-1999\n");
#endif
+#ifdef EPOC
+ printf("EPOC port by Olaf Flebbe, 1999-2000\n");
+#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
{
dTHR;
- register char *s;
*fdscript = -1;
/* Mention
* I_SYSSTATVFS HAS_FSTATVFS
* I_SYSMOUNT
- * I_STATFS HAS_FSTATFS
+ * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
* I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
* here so that metaconfig picks them up. */
STATIC void
S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
{
+#ifdef IAMSUID
int which;
+#endif
/* do we need to emulate setuid on scripts? */
while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
if (strnEQ(s2-4,"perl",4))
/*SUPPRESS 530*/
- while (s = moreswitches(s)) ;
+ while ((s = moreswitches(s)))
+ ;
}
}
}
{
dTHR;
GV *tmpgv;
- GV *othergv;
IO *io;
sv_setpvn(get_sv("\"", TRUE), " ", 1);
argc--,argv++;
break;
}
- if (s = strchr(argv[0], '=')) {
+ if ((s = strchr(argv[0], '='))) {
*s++ = '\0';
sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
}
PL_formtarget = PL_bodytarget;
TAINT;
- if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
+ if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
sv_setpv(GvSV(tmpgv),PL_origfilename);
magicname("0", "0", 1);
}
- if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
+ if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
#ifdef OS2
sv_setpv(GvSV(tmpgv), os2_execname());
#else
sv_setpv(GvSV(tmpgv),PL_origargv[0]);
#endif
- if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
+ if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
GvMULTI_on(PL_argvgv);
(void)gv_AVadd(PL_argvgv);
av_clear(GvAVn(PL_argvgv));
for (; argc > 0; argc--,argv++) {
- av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
+ SV *sv = newSVpv(argv[0],0);
+ av_push(GvAVn(PL_argvgv),sv);
+ if (PL_widesyscalls)
+ sv_utf8_upgrade(sv);
}
}
- if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
+ if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
HV *hv;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
#endif
}
TAINT_NOT;
- if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
+ if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
}
#ifndef VMS
s = PerlEnv_getenv("PERL5LIB");
if (s)
- incpush(s, TRUE);
+ incpush(s, TRUE, TRUE);
else
- incpush(PerlEnv_getenv("PERLLIB"), FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
* "natural" VMS idiom for a Unix path string. We allow each
char buf[256];
int idx = 0;
if (my_trnlnm("PERL5LIB",buf,0))
- do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
else
- while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
#endif /* VMS */
}
/* Use the ~-expanded versions of APPLLIB (undocumented),
- ARCHLIB PRIVLIB SITEARCH and SITELIB
+ ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP, TRUE);
+ incpush(APPLLIB_EXP, TRUE, TRUE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP, FALSE);
+ incpush(ARCHLIB_EXP, FALSE, FALSE);
#endif
#ifndef PRIVLIB_EXP
-#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
+# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
#if defined(WIN32)
- incpush(PRIVLIB_EXP, TRUE);
+ incpush(PRIVLIB_EXP, TRUE, FALSE);
#else
- incpush(PRIVLIB_EXP, FALSE);
+ incpush(PRIVLIB_EXP, FALSE, FALSE);
#endif
#ifdef SITEARCH_EXP
- incpush(SITEARCH_EXP, FALSE);
+ /* sitearch is always relative to sitelib on Windows for
+ * DLL-based path intuition to work correctly */
+# if !defined(WIN32)
+ incpush(SITEARCH_EXP, FALSE, FALSE);
+# endif
#endif
+
#ifdef SITELIB_EXP
-#if defined(WIN32)
- incpush(SITELIB_EXP, TRUE);
-#else
- incpush(SITELIB_EXP, FALSE);
+# if defined(WIN32)
+ incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
+# else
+ incpush(SITELIB_EXP, FALSE, FALSE);
+# endif
#endif
+
+#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
+ incpush(SITELIB_STEM, FALSE, TRUE);
#endif
-#if defined(PERL_VENDORLIB_EXP)
-#if defined(WIN32)
- incpush(PERL_VENDORLIB_EXP, TRUE);
-#else
- incpush(PERL_VENDORLIB_EXP, FALSE);
+
+#ifdef PERL_VENDORARCH_EXP
+ /* vendorarch is always relative to vendorlib on Windows for
+ * DLL-based path intuition to work correctly */
+# if !defined(WIN32)
+ incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
+# endif
#endif
+
+#ifdef PERL_VENDORLIB_EXP
+# if defined(WIN32)
+ incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
+# else
+ incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
+# endif
+#endif
+
+#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
+ incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
#endif
+
if (!PL_tainting)
- incpush(".", FALSE);
+ incpush(".", FALSE, FALSE);
}
#if defined(DOSISH)
#endif
STATIC void
-S_incpush(pTHX_ char *p, int addsubdirs)
+S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
{
SV *subdir = Nullsv;
- if (!p)
+ if (!p || !*p)
return;
- if (addsubdirs) {
+ if (addsubdirs || addoldvers) {
subdir = sv_newmortal();
}
* BEFORE pushing libdir onto @INC we may first push version- and
* archname-specific sub-directories.
*/
- if (addsubdirs) {
+ 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;
+#endif
struct stat tmpstatbuf;
#ifdef VMS
char *unix;
"Failed to unixify @INC element \"%s\"\n",
SvPV(libdir,len));
#endif
- /* .../archname/version if -d .../archname/version/auto */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s/"PERL_FS_VER_FMT"/auto", libdir,
- ARCHNAME, (int)PERL_REVISION,
- (int)PERL_VERSION, (int)PERL_SUBVERSION);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv),
- newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
-
- /* .../archname if -d .../archname/auto */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s/auto", libdir, ARCHNAME);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv),
- newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ if (addsubdirs) {
+ /* .../version/archname if -d .../version/archname */
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s",
+ libdir,
+ (int)PERL_REVISION, (int)PERL_VERSION,
+ (int)PERL_SUBVERSION, ARCHNAME);
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(PL_incgv), newSVsv(subdir));
+
+ /* .../version if -d .../version */
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
+ (int)PERL_REVISION, (int)PERL_VERSION,
+ (int)PERL_SUBVERSION);
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(PL_incgv), newSVsv(subdir));
+
+ /* .../archname if -d .../archname */
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ }
+
+ if (addoldvers) {
+#ifdef PERL_INC_VERSION_LIST
+ for (incver = incverlist; *incver; incver++) {
+ /* .../xxx if -d .../xxx */
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ }
+ }
+#endif
}
/* finally push this lib directory on the end of @INC */
#else
thr->self = pthread_self();
#endif /* SET_THREAD_SELF */
- SET_THR(thr);
+ PERL_SET_THX(thr);
/*
* These must come after the SET_THR because sv_setpvn does
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
SAVEFREESV(cv);
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ call_list_body(cv);
+#endif
atsv = ERRSV;
(void)SvPV(atsv, len);
if (len) {
: "END");
while (PL_scopestack_ix > oldscope)
LEAVE;
+ JMPENV_POP;
Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
}
break;
PL_curstash = PL_defstash;
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
+ JMPENV_POP;
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
if (paramList == PL_beginav)
Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
FREETMPS;
break;
}
+ JMPENV_POP;
}
}
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
-S_call_list_body(pTHX_ va_list args)
+S_vcall_list_body(pTHX_ va_list args)
{
- dTHR;
CV *cv = va_arg(args, CV*);
+ return call_list_body(cv);
+}
+#endif
+STATIC void *
+S_call_list_body(pTHX_ CV *cv)
+{
PUSHMARK(PL_stack_sp);
call_sv((SV*)cv, G_EVAL|G_DISCARD);
return NULL;
https://perl5.git.perl.org / perl5.git / blobdiff