static void my_exit_jump _((void)) __attribute__((noreturn));
static void nuke_stacks _((void));
static void open_script _((char *, bool, SV *));
-#ifdef USE_THREADS
-static void thread_destruct _((void *));
-#endif /* USE_THREADS */
static void usage _((char *));
static void validate_suid _((char *, char*));
static int fdscript = -1;
+#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
+#include <asm/sigcontext.h>
+static void
+catch_sigsegv(int signo, struct sigcontext_struct sc)
+{
+ signal(SIGSEGV, SIG_DFL);
+ fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
+ "return_address = 0x%lx, eip = 0x%lx\n",
+ sc.cr2, __builtin_return_address(0), sc.eip);
+ fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR);
+}
+#endif
+
PerlInterpreter *
perl_alloc()
{
Zero(sv_interp, 1, PerlInterpreter);
#endif
+ /* Init the real globals (and main thread)? */
+ if (!linestr) {
#ifdef USE_THREADS
-#ifdef NEED_PTHREAD_INIT
- pthread_init();
-#endif /* NEED_PTHREAD_INIT */
- New(53, thr, 1, struct thread);
-#ifdef FAKE_THREADS
- self = thr;
- thr->next = thr->prev = thr->next_run = thr->prev_run = thr;
- thr->wait_queue = 0;
- thr->private = 0;
+ XPV *xpv;
+
+ INIT_THREADS;
+ Newz(53, thr, 1, struct thread);
+ MUTEX_INIT(&malloc_mutex);
+ MUTEX_INIT(&sv_mutex);
+ /* Safe to use SVs from now on */
+ MUTEX_INIT(&eval_mutex);
+ COND_INIT(&eval_cond);
+ MUTEX_INIT(&threads_mutex);
+ COND_INIT(&nthreads_cond);
+ nthreads = 1;
+ cvcache = newHV();
+ curcop = &compiling;
+ thr->flags = THRf_R_JOINABLE;
+ MUTEX_INIT(&thr->mutex);
+ thr->next = thr;
+ thr->prev = thr;
+ thr->tid = 0;
+
+ /* Handcraft thrsv similarly to mess_sv */
+ New(53, thrsv, 1, SV);
+ Newz(53, xpv, 1, XPV);
+ SvFLAGS(thrsv) = SVt_PV;
+ SvANY(thrsv) = (void*)xpv;
+ SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
+ SvPVX(thrsv) = (char*)thr;
+ SvCUR_set(thrsv, sizeof(thr));
+ SvLEN_set(thrsv, sizeof(thr));
+ *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
+ oursv = thrsv;
+#ifdef HAVE_THREAD_INTERN
+ init_thread_intern(thr);
#else
- self = pthread_self();
- if (pthread_key_create(&thr_key, thread_destruct))
- croak("panic: pthread_key_create");
- if (pthread_setspecific(thr_key, (void *) thr))
- croak("panic: pthread_setspecific");
-#endif /* !FAKE_THREADS */
- nthreads = 1;
- cvcache = newHV();
- thrflags = 0;
- curcop = &compiling;
+ self = pthread_self();
+ if (pthread_key_create(&thr_key, 0))
+ croak("panic: pthread_key_create");
+#endif /* HAVE_THREAD_INTERN */
+ SET_THR(thr);
#endif /* USE_THREADS */
- /* Init the real globals? */
- if (!linestr) {
linestr = NEWSV(65,80);
sv_upgrade(linestr,SVt_PVIV);
nrs = newSVpv("\n", 1);
rs = SvREFCNT_inc(nrs);
- MUTEX_INIT(&malloc_mutex);
- MUTEX_INIT(&sv_mutex);
- MUTEX_INIT(&eval_mutex);
- MUTEX_INIT(&nthreads_mutex);
- COND_INIT(&nthreads_cond);
-
+ sighandlerp = sighandler;
pidstatus = newHV();
#ifdef MSDOS
#endif
init_ids();
+ lex_state = LEX_NOTPARSING;
start_env.je_prev = NULL;
start_env.je_ret = -1;
ENTER;
}
-#ifdef USE_THREADS
-void
-thread_destruct(arg)
-void *arg;
-{
- struct thread *thr = (struct thread *) arg;
- /*
- * Decrement the global thread count and signal anyone listening.
- * The only official thread listening is the original thread while
- * in perl_destruct. It waits until it's the only thread and then
- * performs END blocks and other process clean-ups.
- */
- DEBUG_L(fprintf(stderr, "thread_destruct: 0x%lx\n", (unsigned long) thr));
-
- Safefree(thr);
- MUTEX_LOCK(&nthreads_mutex);
- nthreads--;
- COND_BROADCAST(&nthreads_cond);
- MUTEX_UNLOCK(&nthreads_mutex);
-}
-#endif /* USE_THREADS */
-
void
perl_destruct(sv_interp)
register PerlInterpreter *sv_interp;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
I32 last_sv_count;
HV *hv;
+#ifdef USE_THREADS
+ Thread t;
+#endif /* USE_THREADS */
if (!(curinterp = sv_interp))
return;
#ifdef USE_THREADS
#ifndef FAKE_THREADS
- /* Wait until all user-created threads go away */
- MUTEX_LOCK(&nthreads_mutex);
+ /* Pass 1 on any remaining threads: detach joinables, join zombies */
+ retry_cleanup:
+ MUTEX_LOCK(&threads_mutex);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: waiting for %d threads...\n",
+ nthreads - 1));
+ for (t = thr->next; t != thr; t = t->next) {
+ MUTEX_LOCK(&t->mutex);
+ switch (ThrSTATE(t)) {
+ AV *av;
+ case THRf_ZOMBIE:
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: joining zombie %p\n", t));
+ ThrSETSTATE(t, THRf_DEAD);
+ MUTEX_UNLOCK(&t->mutex);
+ nthreads--;
+ /*
+ * The SvREFCNT_dec below may take a long time (e.g. av
+ * may contain an object scalar whose destructor gets
+ * called) so we have to unlock threads_mutex and start
+ * all over again.
+ */
+ MUTEX_UNLOCK(&threads_mutex);
+ JOIN(t, &av);
+ SvREFCNT_dec((SV*)av);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: joined zombie %p OK\n", t));
+ goto retry_cleanup;
+ case THRf_R_JOINABLE:
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: detaching thread %p\n", t));
+ ThrSETSTATE(t, THRf_R_DETACHED);
+ /*
+ * We unlock threads_mutex and t->mutex in the opposite order
+ * from which we locked them just so that DETACH won't
+ * deadlock if it panics. It's only a breach of good style
+ * not a bug since they are unlocks not locks.
+ */
+ MUTEX_UNLOCK(&threads_mutex);
+ DETACH(t);
+ MUTEX_UNLOCK(&t->mutex);
+ goto retry_cleanup;
+ default:
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: ignoring %p (state %u)\n",
+ t, ThrSTATE(t)));
+ MUTEX_UNLOCK(&t->mutex);
+ /* fall through and out */
+ }
+ }
+ /* We leave the above "Pass 1" loop with threads_mutex still locked */
+
+ /* Pass 2 on remaining threads: wait for the thread count to drop to one */
while (nthreads > 1)
{
- DEBUG_L(fprintf(stderr, "perl_destruct: waiting for %d threads\n",
- nthreads - 1));
- COND_WAIT(&nthreads_cond, &nthreads_mutex);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: final wait for %d threads\n",
+ nthreads - 1));
+ COND_WAIT(&nthreads_cond, &threads_mutex);
}
/* At this point, we're the last thread */
- MUTEX_UNLOCK(&nthreads_mutex);
- DEBUG_L(fprintf(stderr, "perl_destruct: armageddon has arrived\n"));
- MUTEX_DESTROY(&nthreads_mutex);
+ MUTEX_UNLOCK(&threads_mutex);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
+ MUTEX_DESTROY(&threads_mutex);
COND_DESTROY(&nthreads_cond);
#endif /* !defined(FAKE_THREADS) */
#endif /* USE_THREADS */
/* startup and shutdown function lists */
SvREFCNT_dec(beginav);
SvREFCNT_dec(endav);
+ SvREFCNT_dec(initav);
beginav = Nullav;
endav = Nullav;
+ initav = Nullav;
/* temp stack during pp_sort() */
SvREFCNT_dec(sortstack);
MUTEX_DESTROY(&sv_mutex);
MUTEX_DESTROY(&malloc_mutex);
MUTEX_DESTROY(&eval_mutex);
-#endif /* USE_THREADS */
+ COND_DESTROY(&eval_cond);
+ /* As the penultimate thing, free the non-arena SV for thrsv */
+ Safefree(SvPVX(thrsv));
+ Safefree(SvANY(thrsv));
+ Safefree(thrsv);
+ thrsv = Nullsv;
+#endif /* USE_THREADS */
+
/* As the absolutely last thing, free the non-arena SV for mess() */
if (mess_sv) {
/* my_exit() was called */
while (scopestack_ix > oldscope)
LEAVE;
+ FREETMPS;
curstash = defstash;
if (endav)
call_list(oldscope, endav);
croak("No code specified for -e");
(void)PerlIO_putc(e_fp,'\n');
break;
- case 'I':
+ case 'I': /* -I handled both here and in moreswitches() */
forbid_setid("-I");
- sv_catpv(sv,"-");
- sv_catpv(sv,s);
- sv_catpv(sv," ");
- if (*++s) {
- incpush(s, TRUE);
- }
- else if (argv[1]) {
- incpush(argv[1], TRUE);
- sv_catpv(sv,argv[1]);
+ if (!*++s && (s=argv[1]) != Nullch) {
argc--,argv++;
- sv_catpv(sv," ");
}
+ while (s && isSPACE(*s))
+ ++s;
+ if (s && *s) {
+ char *e, *p;
+ for (e = s; *e && !isSPACE(*e); e++) ;
+ p = savepvn(s, e-s);
+ incpush(p, TRUE);
+ sv_catpv(sv,"-I");
+ sv_catpv(sv,p);
+ sv_catpv(sv," ");
+ Safefree(p);
+ } /* XXX else croak? */
break;
case 'P':
forbid_setid("-P");
if (*s)
cddir = savepv(s);
break;
- case '-':
- argc--,argv++;
- goto switch_end;
case 0:
break;
+ case '-':
+ if (!*++s || isSPACE(*s)) {
+ argc--,argv++;
+ goto switch_end;
+ }
+ /* catch use of gnu style long options */
+ if (strEQ(s, "version")) {
+ s = "v";
+ goto reswitch;
+ }
+ if (strEQ(s, "help")) {
+ s = "h";
+ goto reswitch;
+ }
+ s--;
+ /* FALL THROUGH */
default:
- croak("Unrecognized switch: -%s",s);
+ croak("Unrecognized switch: -%s (-h will show valid options)",s);
}
}
switch_end:
if (!tainting && (s = getenv("PERL5OPT"))) {
- for (;;) {
+ while (s && *s) {
while (isSPACE(*s))
s++;
if (*s == '-') {
CvOWNER(compcv) = 0;
New(666, CvMUTEXP(compcv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(compcv));
- New(666, CvCONDP(compcv), 1, perl_cond);
- COND_INIT(CvCONDP(compcv));
#endif /* USE_THREADS */
comppadlist = newAV();
boot_core_UNIVERSAL();
if (xsinit)
(*xsinit)(); /* in case linked C routines want magical variables */
-#ifdef VMS
+#if defined(VMS) || defined(WIN32)
init_os_extras();
#endif
+#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
+ DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
+#endif
+
init_predump_symbols();
if (!do_undump)
init_postdump_symbols(argc,argv,env);
LEAVE;
FREETMPS;
-#ifdef DEBUGGING_MSTATS
+#ifdef MYMALLOC
if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
dump_mstats("after compilation:");
#endif
/* my_exit() was called */
while (scopestack_ix > oldscope)
LEAVE;
+ FREETMPS;
curstash = defstash;
if (endav)
call_list(oldscope, endav);
- FREETMPS;
-#ifdef DEBUGGING_MSTATS
+#ifdef MYMALLOC
if (getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
break;
}
- DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
sawampersand ? "Enabling" : "Omitting"));
if (!restartop) {
PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
my_exit(0);
}
- if (perldb && DBsingle)
- sv_setiv(DBsingle, 1);
- if (restartav)
- call_list(oldscope, restartav);
+ if (PERLDB_SINGLE && DBsingle)
+ sv_setiv(DBsingle, 1);
+ if (initav)
+ call_list(oldscope, initav);
}
/* do it */
bool oldcatch = CATCH_GET;
dJMPENV;
int ret;
+ OP* oldop = op;
if (flags & G_DISCARD) {
ENTER;
oldmark = TOPMARK;
oldscope = scopestack_ix;
- if (perldb && curstash != debstash
+ if (PERLDB_SUB && curstash != debstash
/* Handle first BEGIN of -d. */
&& (DBcv || (DBcv = GvCV(DBsub)))
/* Try harder, since this may have been a sighandler, thus
FREETMPS;
LEAVE;
}
+ op = oldop;
return retval;
}
I32 oldscope;
dJMPENV;
int ret;
-
+ OP* oldop = op;
+
if (flags & G_DISCARD) {
ENTER;
SAVETMPS;
FREETMPS;
LEAVE;
}
+ op = oldop;
return retval;
}
{
/* This message really ought to be max 23 lines.
* Removed -h because the user already knows that opton. Others? */
+
+ static char *usage[] = {
+"-0[octal] specify record separator (\\0, if no argument)",
+"-a autosplit mode with -n or -p (splits $_ into @F)",
+"-c check syntax only (runs BEGIN and END blocks)",
+"-d[:debugger] run scripts under debugger",
+"-D[number/list] set debugging flags (argument is a bit mask or flags)",
+"-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
+"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
+"-i[extension] edit <> files in place (make backup if extension supplied)",
+"-Idirectory specify @INC/#include directory (may be used more than once)",
+"-l[octal] enable line ending processing, specifies line terminator",
+"-[mM][-]module.. executes `use/no module...' before executing your script.",
+"-n assume 'while (<>) { ... }' loop around your script",
+"-p assume loop like -n but print line also like sed",
+"-P run script through C preprocessor before compilation",
+"-s enable some switch parsing for switches after script name",
+"-S look for the script using PATH environment variable",
+"-T turn on tainting checks",
+"-u dump core after parsing script",
+"-U allow unsafe operations",
+"-v print version number and patchlevel of perl",
+"-V[:variable] print perl configuration information",
+"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
+"-x[directory] strip off text before #!perl line and perhaps cd to directory",
+"\n",
+NULL
+};
+ char **p = usage;
+
printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
- printf("\n -0[octal] specify record separator (\\0, if no argument)");
- printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
- printf("\n -c check syntax only (runs BEGIN and END blocks)");
- printf("\n -d[:debugger] run scripts under debugger");
- printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
- printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
- printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
- printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
- printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
- printf("\n -l[octal] enable line ending processing, specifies line teminator");
- printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
- printf("\n -n assume 'while (<>) { ... }' loop arround your script");
- printf("\n -p assume loop like -n but print line also like sed");
- printf("\n -P run script through C preprocessor before compilation");
- printf("\n -s enable some switch parsing for switches after script name");
- printf("\n -S look for the script using PATH environment variable");
- printf("\n -T turn on tainting checks");
- printf("\n -u dump core after parsing script");
- printf("\n -U allow unsafe operations");
- printf("\n -v print version number and patchlevel of perl");
- printf("\n -V[:variable] print perl configuration information");
- printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
- printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
+ while (*p)
+ printf("\n %s", *p++);
}
/* This routine handles any switches that can be given during run */
s += strlen(s);
}
if (!perldb) {
- perldb = TRUE;
+ perldb = PERLDB_ALL;
init_debugger();
}
return s;
inplace = savepv(s+1);
/*SUPPRESS 530*/
for (s = inplace; *s && !isSPACE(*s); s++) ;
- *s = '\0';
- break;
- case 'I':
+ if (*s)
+ *s++ = '\0';
+ return s;
+ case 'I': /* -I handled both here and in parse_perl() */
forbid_setid("-I");
- if (*++s) {
+ ++s;
+ while (*s && isSPACE(*s))
+ ++s;
+ if (*s) {
char *e, *p;
for (e = s; *e && !isSPACE(*e); e++) ;
p = savepvn(s, e-s);
incpush(p, TRUE);
Safefree(p);
- if (*e)
- return e;
+ s = e;
}
else
croak("No space allowed after -I");
- break;
+ return s;
case 'l':
minus_l = TRUE;
s++;
return s;
case 'v':
#if defined(SUBVERSION) && SUBVERSION > 0
- printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
+ printf("\nThis is perl, version 5.%03d_%02d built for %s",
+ PATCHLEVEL, SUBVERSION, ARCHNAME);
#else
- printf("\nThis is perl, version %s",patchlevel);
+ printf("\nThis is perl, version %s built for %s",
+ patchlevel, ARCHNAME);
+#endif
+#if defined(LOCAL_PATCH_COUNT)
+ if (LOCAL_PATCH_COUNT > 0)
+ printf("\n(with %d registered patch%s, see perl -V for more detail)",
+ LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
#endif
printf("\n\nCopyright 1987-1997, Larry Wall\n");
#ifdef MSDOS
- printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
+ printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
#ifdef DJGPP
printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
GvMULTI_on(errgv);
+ (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
+ sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
sv_setpvn(GvSV(errgv), "", 0);
curstash = defstash;
compiling.cop_stash = defstash;
# define SEARCH_EXTS ".bat", ".cmd", NULL
# define MAX_EXT_LEN 4
#endif
+#ifdef OS2
+# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
+# define MAX_EXT_LEN 4
+#endif
#ifdef VMS
# define SEARCH_EXTS ".pl", ".com", NULL
# define MAX_EXT_LEN 4
/* additional extensions to try in each dir if scriptname not found */
#ifdef SEARCH_EXTS
char *ext[] = { SEARCH_EXTS };
- int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
+ int extidx = 0, i = 0;
+ char *curext = Nullch;
#else
# define MAX_EXT_LEN 0
#endif
+ /*
+ * If dosearch is true and if scriptname does not contain path
+ * delimiters, search the PATH for scriptname.
+ *
+ * If SEARCH_EXTS is also defined, will look for each
+ * scriptname{SEARCH_EXTS} whenever scriptname is not found
+ * while searching the PATH.
+ *
+ * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
+ * proceeds as follows:
+ * If DOSISH:
+ * + look for ./scriptname{,.foo,.bar}
+ * + search the PATH for scriptname{,.foo,.bar}
+ *
+ * If !DOSISH:
+ * + look *only* in the PATH for scriptname{,.foo,.bar} (note
+ * this will not look in '.' if it's not in the PATH)
+ */
+
#ifdef VMS
if (dosearch) {
int hasdir, idx = 0, deftypes = 1;
+ bool seen_dot = 1;
hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
/* The first time through, just add SEARCH_EXTS to whatever we
continue; /* don't search dir with too-long name */
strcat(tokenbuf, scriptname);
#else /* !VMS */
- if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
- bufend = s + strlen(s);
- while (s < bufend) {
-#ifndef atarist
- s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
+
#ifdef DOSISH
- ';',
-#else
- ':',
+ if (strEQ(scriptname, "-"))
+ dosearch = 0;
+ if (dosearch) { /* Look in '.' first. */
+ char *cur = scriptname;
+#ifdef SEARCH_EXTS
+ if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
+ while (ext[i])
+ if (strEQ(ext[i++],curext)) {
+ extidx = -1; /* already has an ext */
+ break;
+ }
+ do {
+#endif
+ DEBUG_p(PerlIO_printf(Perl_debug_log,
+ "Looking for %s\n",cur));
+ if (Stat(cur,&statbuf) >= 0) {
+ dosearch = 0;
+ scriptname = cur;
+#ifdef SEARCH_EXTS
+ break;
+#endif
+ }
+#ifdef SEARCH_EXTS
+ if (cur == scriptname) {
+ len = strlen(scriptname);
+ if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
+ break;
+ cur = strcpy(tokenbuf, scriptname);
+ }
+ } while (extidx >= 0 && ext[extidx] /* try an extension? */
+ && strcpy(tokenbuf+len, ext[extidx++]));
+#endif
+ }
+#endif
+
+ if (dosearch && !strchr(scriptname, '/')
+#ifdef DOSISH
+ && !strchr(scriptname, '\\')
#endif
- &len);
-#else /* atarist */
- for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
+ && (s = getenv("PATH"))) {
+ bool seen_dot = 0;
+
+ bufend = s + strlen(s);
+ while (s < bufend) {
+#if defined(atarist) || defined(DOSISH)
+ for (len = 0; *s
+# ifdef atarist
+ && *s != ','
+# endif
+ && *s != ';'; len++, s++) {
if (len < sizeof tokenbuf)
tokenbuf[len] = *s;
}
if (len < sizeof tokenbuf)
tokenbuf[len] = '\0';
-#endif /* atarist */
+#else /* ! (atarist || DOSISH) */
+ s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
+ ':',
+ &len);
+#endif /* ! (atarist || DOSISH) */
if (s < bufend)
s++;
if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
continue; /* don't search dir with too-long name */
if (len
-#if defined(atarist) && !defined(DOSISH)
- && tokenbuf[len - 1] != '/'
-#endif
#if defined(atarist) || defined(DOSISH)
+ && tokenbuf[len - 1] != '/'
&& tokenbuf[len - 1] != '\\'
#endif
)
tokenbuf[len++] = '/';
+ if (len == 2 && tokenbuf[0] == '.')
+ seen_dot = 1;
(void)strcpy(tokenbuf + len, scriptname);
#endif /* !VMS */
if (!xfailed)
xfailed = savepv(tokenbuf);
}
+#ifndef DOSISH
+ if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
+#endif
+ seen_dot = 1; /* Disable message. */
if (!xfound)
- croak("Can't execute %s", xfailed ? xfailed : scriptname );
+ croak("Can't %s %s%s%s",
+ (xfailed ? "execute" : "find"),
+ (xfailed ? xfailed : scriptname),
+ (xfailed ? "" : " on PATH"),
+ (xfailed || seen_dot) ? "" : ", '.' not in PATH");
if (xfailed)
Safefree(xfailed);
scriptname = xfound;
*/
#ifdef DOSUID
+ dTHR;
char *s, *s2;
if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
#else /* !DOSUID */
if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
+ dTHR;
Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
||
init_lexer()
{
tmpfp = rsfp;
+ rsfp = Nullfp;
lex_start(linestr);
rsfp = tmpfp;
subname = newSVpv("main",4);
sv = newSVpv(s--,0);
(void)hv_store(hv, *env, s - *env, sv, 0);
*s = '=';
+#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
+ /* Sins of the RTL. See note in my_setenv(). */
+ (void)putenv(savepv(*env));
+#endif
}
#endif
#ifdef DYNAMIC_ENV_FETCH
/* my_exit() was called */
while (scopestack_ix > oldscope)
LEAVE;
+ FREETMPS;
curstash = defstash;
if (endav)
call_list(oldscope, endav);
- FREETMPS;
JMPENV_POP;
curcop = &compiling;
curcop->cop_line = oldline;
https://perl5.git.perl.org / perl5.git / blobdiff