mess_sv = Nullsv; \
} STMT_END
+#ifndef PERL_OBJECT
static void find_beginning _((void));
static void forbid_setid _((char *));
static void incpush _((char *, int));
static void init_debugger _((void));
static void init_lexer _((void));
static void init_main_stash _((void));
+#ifdef USE_THREADS
+static struct perl_thread * init_main_thread _((void));
+#endif /* USE_THREADS */
static void init_perllib _((void));
static void init_postdump_symbols _((int, char **, char **));
static void init_predump_symbols _((void));
static void open_script _((char *, bool, SV *));
static void usage _((char *));
static void validate_suid _((char *, char*));
+#endif
static int fdscript = -1;
#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
#include <asm/sigcontext.h>
-static void
+STATIC void
catch_sigsegv(int signo, struct sigcontext_struct sc)
{
- signal(SIGSEGV, SIG_DFL);
+ PerlProc_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);
}
#endif
+#ifdef PERL_OBJECT
+CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
+ IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
+{
+ CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
+ if(pPerl != NULL)
+ pPerl->Init();
+
+ return pPerl;
+}
+#else
PerlInterpreter *
-perl_alloc()
+perl_alloc(void)
{
PerlInterpreter *sv_interp;
New(53, sv_interp, 1, PerlInterpreter);
return sv_interp;
}
+#endif
void
-perl_construct( sv_interp )
-register PerlInterpreter *sv_interp;
-{
-#if defined(USE_THREADS) && !defined(FAKE_THREADS)
- struct thread *thr;
+#ifdef PERL_OBJECT
+CPerlObj::perl_construct(void)
+#else
+perl_construct(register PerlInterpreter *sv_interp)
#endif
+{
+#ifdef USE_THREADS
+ int i;
+#ifndef FAKE_THREADS
+ struct perl_thread *thr;
+#endif /* FAKE_THREADS */
+#endif /* USE_THREADS */
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return;
+#endif
#ifdef MULTIPLICITY
Zero(sv_interp, 1, PerlInterpreter);
/* Init the real globals (and main thread)? */
if (!linestr) {
#ifdef USE_THREADS
+
INIT_THREADS;
- New(53, thr, 1, struct thread);
- MUTEX_INIT(&malloc_mutex);
+#ifdef ALLOC_THREAD_KEY
+ ALLOC_THREAD_KEY;
+#else
+ if (pthread_key_create(&thr_key, 0))
+ croak("panic: pthread_key_create");
+#endif
MUTEX_INIT(&sv_mutex);
+ /*
+ * Safe to use basic SV functions from now on (though
+ * not things like mortals or tainting yet).
+ */
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;
-#ifdef FAKE_THREADS
- self = thr;
- thr->next_run = thr->prev_run = thr;
- thr->wait_queue = 0;
- thr->private = 0;
- thr->tid = 0;
-#else
- self = pthread_self();
- if (pthread_key_create(&thr_key, 0))
- croak("panic: pthread_key_create");
- if (pthread_setspecific(thr_key, (void *) thr))
- croak("panic: pthread_setspecific");
-#endif /* FAKE_THREADS */
+
+ thr = init_main_thread();
#endif /* USE_THREADS */
linestr = NEWSV(65,80);
nrs = newSVpv("\n", 1);
rs = SvREFCNT_inc(nrs);
+#ifdef PERL_OBJECT
+ /* TODO: */
+ /* sighandlerp = sighandler; */
+#else
sighandlerp = sighandler;
+#endif
pidstatus = newHV();
#ifdef MSDOS
#endif
init_ids();
+ lex_state = LEX_NOTPARSING;
start_env.je_prev = NULL;
start_env.je_ret = -1;
}
void
-perl_destruct(sv_interp)
-register PerlInterpreter *sv_interp;
+#ifdef PERL_OBJECT
+CPerlObj::perl_destruct(void)
+#else
+perl_destruct(register PerlInterpreter *sv_interp)
+#endif
{
dTHR;
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 */
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return;
+#endif
#ifdef USE_THREADS
#ifndef FAKE_THREADS
- /* Join with any remaining non-detached threads */
+ /* 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",
+ "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 R_ZOMBIE:
+ 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);
- if (pthread_join(t->Tself, (void**)&av))
- croak("panic: pthread_join failed during global destruction");
+ JOIN(t, &av);
SvREFCNT_dec((SV*)av);
- break;
- case XXXX:
+ 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 */
}
}
- /* Now wait for the thread count nthreads to drop to one */
+ /* 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(PerlIO_printf(PerlIO_stderr(),
- "perl_destruct: waiting for %d threads\n",
+ "perl_destruct: final wait for %d threads\n",
nthreads - 1));
COND_WAIT(&nthreads_cond, &threads_mutex);
}
#ifdef DEBUGGING
{
char *s;
- if (s = getenv("PERL_DESTRUCT_LEVEL")) {
+ if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
int i = atoi(s);
if (destruct_level < i)
destruct_level = i;
/* defgv, aka *_ should be taken care of elsewhere */
-#if 0 /* just about all regexp stuff, seems to be ok */
-
- /* shortcuts to regexp stuff */
- leftgv = Nullgv;
- ampergv = Nullgv;
-
- SAVEFREEOP(curpm);
- SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
-
- regprecomp = NULL; /* uncompiled string. */
- regparse = NULL; /* Input-scan pointer. */
- regxend = NULL; /* End of input for compile */
- regnpar = 0; /* () count. */
- regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
- regsize = 0; /* Code size. */
- regnaughty = 0; /* How bad is this pattern? */
- regsawback = 0; /* Did we see \1, ...? */
-
- reginput = NULL; /* String-input pointer. */
- regbol = NULL; /* Beginning of input, for ^ check. */
- regeol = NULL; /* End of input, for $ check. */
- regstartp = (char **)NULL; /* Pointer to startp array. */
- regendp = (char **)NULL; /* Ditto for endp. */
- reglastparen = 0; /* Similarly for lastparen. */
- regtill = NULL; /* How far we are required to go. */
- regflags = 0; /* are we folding, multilining? */
- regprev = (char)NULL; /* char before regbol, \n if none */
-
-#endif /* if 0 */
-
/* clean up after study() */
SvREFCNT_dec(lastscream);
lastscream = Nullsv;
DEBUG_P(debprofdump());
#ifdef USE_THREADS
MUTEX_DESTROY(&sv_mutex);
- MUTEX_DESTROY(&malloc_mutex);
MUTEX_DESTROY(&eval_mutex);
COND_DESTROY(&eval_cond);
-#endif /* USE_THREADS */
+ /* 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) {
}
void
-perl_free(sv_interp)
-PerlInterpreter *sv_interp;
+#ifdef PERL_OBJECT
+CPerlObj::perl_free(void)
+#else
+perl_free(PerlInterpreter *sv_interp)
+#endif
{
+#ifdef PERL_OBJECT
+ Safefree(this);
+#else
if (!(curinterp = sv_interp))
return;
Safefree(sv_interp);
+#endif
}
int
-perl_parse(sv_interp, xsinit, argc, argv, env)
-PerlInterpreter *sv_interp;
-void (*xsinit)_((void));
-int argc;
-char **argv;
-char **env;
+#ifdef PERL_OBJECT
+CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
+#else
+perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
+#endif
{
dTHR;
register SV *sv;
#endif
#endif
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return 255;
+#endif
#if defined(NeXT) && defined(__DYNAMIC__)
_dyld_lookup_and_bind
croak("No -e allowed in setuid scripts");
if (!e_fp) {
e_tmpname = savepv(TMPPATH);
- (void)mktemp(e_tmpname);
+ (void)PerlLIO_mktemp(e_tmpname);
if (!*e_tmpname)
croak("Can't mktemp()");
e_fp = PerlIO_open(e_tmpname,"w");
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 '-':
- if (*++s) { /* catch use of gnu style long options */
- if (strEQ(s, "version")) {
- s = "v";
- goto reswitch;
- }
- if (strEQ(s, "help")) {
- s = "h";
- goto reswitch;
- }
- croak("Unrecognized switch: --%s (-h will show valid options)",s);
- }
- 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 (-h will show valid options)",s);
}
}
switch_end:
- if (!tainting && (s = getenv("PERL5OPT"))) {
- for (;;) {
+ if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
+ while (s && *s) {
while (isSPACE(*s))
s++;
if (*s == '-') {
}
else if (scriptname == Nullch) {
#ifdef MSDOS
- if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
+ if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
moreswitches("h");
#endif
scriptname = "-";
CvPADLIST(compcv) = comppadlist;
boot_core_UNIVERSAL();
+#if defined(WIN32) && defined(PERL_OBJECT)
+ BootDynaLoader();
+#endif
if (xsinit)
- (*xsinit)(); /* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32)
+ (*xsinit)(THIS); /* in case linked C routines want magical variables */
+#if defined(VMS) || defined(WIN32) || defined(DJGPP)
init_os_extras();
#endif
#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
- DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
+ DEBUG_L(PerlProc_signal(SIGSEGV, (void(*)(int))catch_sigsegv););
#endif
init_predump_symbols();
/* now parse the script */
+ SETERRNO(0,SS$_NORMAL);
error_count = 0;
if (yyparse() || error_count) {
if (minus_c)
/* now that script is parsed, we can modify record separator */
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
+#ifdef USE_THREADS
+ sv_setsv(*av_fetch(thr->threadsv, find_threadsv("/"), FALSE), rs);
+#else
sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
-
+#endif /* USE_THREADS */
if (do_undump)
my_unexec();
FREETMPS;
#ifdef MYMALLOC
- if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
+ if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
dump_mstats("after compilation:");
#endif
}
int
-perl_run(sv_interp)
-PerlInterpreter *sv_interp;
+#ifdef PERL_OBJECT
+CPerlObj::perl_run(void)
+#else
+perl_run(PerlInterpreter *sv_interp)
+#endif
{
dTHR;
I32 oldscope;
dJMPENV;
int ret;
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return 255;
+#endif
oldscope = scopestack_ix;
if (endav)
call_list(oldscope, endav);
#ifdef MYMALLOC
- if (getenv("PERL_DEBUG_MSTATS"))
+ if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
JMPENV_POP;
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) {
if (restartop) {
op = restartop;
restartop = 0;
- runops();
+ CALLRUNOPS();
}
else if (main_start) {
CvDEPTH(main_cv) = 1;
op = main_start;
- runops();
+ CALLRUNOPS();
}
my_exit(0);
}
SV*
-perl_get_sv(name, create)
-char* name;
-I32 create;
+perl_get_sv(char *name, I32 create)
{
- GV* gv = gv_fetchpv(name, create, SVt_PV);
+ GV *gv;
+#ifdef USE_THREADS
+ if (name[1] == '\0' && !isALPHA(name[0])) {
+ PADOFFSET tmp = find_threadsv(name);
+ if (tmp != NOT_IN_PAD) {
+ dTHR;
+ return *av_fetch(thr->threadsv, tmp, FALSE);
+ }
+ }
+#endif /* USE_THREADS */
+ gv = gv_fetchpv(name, create, SVt_PV);
if (gv)
return GvSV(gv);
return Nullsv;
}
AV*
-perl_get_av(name, create)
-char* name;
-I32 create;
+perl_get_av(char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVAV);
if (create)
}
HV*
-perl_get_hv(name, create)
-char* name;
-I32 create;
+perl_get_hv(char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVHV);
if (create)
}
CV*
-perl_get_cv(name, create)
-char* name;
-I32 create;
+perl_get_cv(char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVCV);
if (create && !GvCVu(gv))
/* Be sure to refetch the stack pointer after calling these routines. */
I32
-perl_call_argv(subname, flags, argv)
-char *subname;
-I32 flags; /* See G_* flags in cop.h */
-register char **argv; /* null terminated arg list */
+perl_call_argv(char *sub_name, I32 flags, register char **argv)
+
+ /* See G_* flags in cop.h */
+ /* null terminated arg list */
{
- dTHR;
dSP;
PUSHMARK(sp);
}
PUTBACK;
}
- return perl_call_pv(subname, flags);
+ return perl_call_pv(sub_name, flags);
}
I32
-perl_call_pv(subname, flags)
-char *subname; /* name of the subroutine */
-I32 flags; /* See G_* flags in cop.h */
+perl_call_pv(char *sub_name, I32 flags)
+ /* name of the subroutine */
+ /* See G_* flags in cop.h */
{
- return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
+ return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
}
I32
-perl_call_method(methname, flags)
-char *methname; /* name of the subroutine */
-I32 flags; /* See G_* flags in cop.h */
+perl_call_method(char *methname, I32 flags)
+ /* name of the subroutine */
+ /* See G_* flags in cop.h */
{
- dTHR;
dSP;
OP myop;
if (!op)
/* May be called with any of a CV, a GV, or an SV containing the name. */
I32
-perl_call_sv(sv, flags)
-SV* sv;
-I32 flags; /* See G_* flags in cop.h */
+perl_call_sv(SV *sv, I32 flags)
+
+ /* See G_* flags in cop.h */
{
dTHR;
LOGOP myop; /* fake syntax tree node */
markstack_ptr--;
/* we're trying to emulate pp_entertry() here */
{
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
ENTER;
if (flags & G_KEEPERR)
in_eval |= 4;
else
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(ERRSV,"");
}
markstack_ptr++;
if (op == (OP*)&myop)
op = pp_entersub(ARGS);
if (op)
- runops();
+ CALLRUNOPS();
retval = stack_sp - (stack_base + oldmark);
if ((flags & G_EVAL) && !(flags & G_KEEPERR))
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(ERRSV,"");
cleanup:
if (flags & G_EVAL) {
SV **newsp;
PMOP *newpm;
I32 gimme;
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
I32 optype;
POPBLOCK(cx,newpm);
/* Eval a string. The G_EVAL flag is always assumed. */
I32
-perl_eval_sv(sv, flags)
-SV* sv;
-I32 flags; /* See G_* flags in cop.h */
+perl_eval_sv(SV *sv, I32 flags)
+
+ /* See G_* flags in cop.h */
{
dTHR;
UNOP myop; /* fake syntax tree node */
if (op == (OP*)&myop)
op = pp_entereval(ARGS);
if (op)
- runops();
+ CALLRUNOPS();
retval = stack_sp - (stack_base + oldmark);
if (!(flags & G_KEEPERR))
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(ERRSV,"");
cleanup:
JMPENV_POP;
}
SV*
-perl_eval_pv(p, croak_on_error)
-char* p;
-I32 croak_on_error;
+perl_eval_pv(char *p, I32 croak_on_error)
{
- dTHR;
dSP;
SV* sv = newSVpv(p, 0);
sv = POPs;
PUTBACK;
- if (croak_on_error && SvTRUE(GvSV(errgv)))
- croak(SvPVx(GvSV(errgv), na));
+ if (croak_on_error && SvTRUE(ERRSV))
+ croak(SvPVx(ERRSV, na));
return sv;
}
/* Require a module. */
void
-perl_require_pv(pv)
-char* pv;
+perl_require_pv(char *pv)
{
SV* sv = sv_newmortal();
sv_setpv(sv, "require '");
}
void
-magicname(sym,name,namlen)
-char *sym;
-char *name;
-I32 namlen;
+magicname(char *sym, char *name, I32 namlen)
{
register GV *gv;
sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
}
-static void
-usage(name) /* XXX move this out into a module ? */
-char *name;
+STATIC void
+usage(char *name) /* XXX move this out into a module ? */
+
{
/* This message really ought to be max 23 lines.
* Removed -h because the user already knows that opton. Others? */
+
+ static char *usage_msg[] = {
+"-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_msg;
+
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 than once)");
- printf("\n -l[octal] enable line ending processing, specifies line terminator");
- printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
- printf("\n -n assume 'while (<>) { ... }' loop around 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. Recommended.");
- 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 */
char *
-moreswitches(s)
-char *s;
+moreswitches(char *s)
{
I32 numlen;
U32 rschar;
switch (*s) {
case '0':
+ {
+ dTHR;
rschar = scan_oct(s, 4, &numlen);
SvREFCNT_dec(nrs);
if (rschar & ~((U8)~0))
nrs = newSVpv(&ch, 1);
}
return s + numlen;
+ }
case 'F':
minus_F = TRUE;
splitstr = savepv(s + 1);
return s;
case 'h':
usage(origargv[0]);
- exit(0);
+ PerlProc_exit(0);
case 'i':
if (inplace)
Safefree(inplace);
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++;
s += numlen;
}
else {
+ dTHR;
if (RsPARA(nrs)) {
ors = "\n\n";
orslen = 2;
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");
+ printf("djgpp v2 port (perl5004) by Laszlo Molnar, 1997\n");
#endif
#ifdef OS2
printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
printf("\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
- exit(0);
+ PerlProc_exit(0);
case 'w':
dowarn = TRUE;
s++;
break;
case '-':
case 0:
+#ifdef WIN32
+ case '\r':
+#endif
case '\n':
case '\t':
break;
/* unexec() can be found in the Gnu emacs distribution */
void
-my_unexec()
+my_unexec(void)
{
#ifdef UNEXEC
SV* prog;
if (status)
PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
SvPVX(prog), SvPVX(file));
- exit(status);
+ PerlProc_exit(status);
#else
# ifdef VMS
# include <lib$routines.h>
#endif
}
-static void
-init_main_stash()
+STATIC void
+init_main_stash(void)
{
dTHR;
GV *gv;
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);
+ sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
+ sv_setpvn(ERRSV, "", 0);
curstash = defstash;
compiling.cop_stash = defstash;
debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
+ globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
/* We must init $/ before switches are processed. */
sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
}
#ifdef CAN_PROTOTYPE
-static void
+STATIC void
open_script(char *scriptname, bool dosearch, SV *sv)
#else
-static void
+STATIC void
open_script(scriptname,dosearch,sv)
char *scriptname;
bool dosearch;
*
* Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
* proceeds as follows:
- * If DOSISH:
+ * If DOSISH or VMSISH:
* + look for ./scriptname{,.foo,.bar}
* + search the PATH for scriptname{,.foo,.bar}
*
*/
#ifdef VMS
+# ifdef ALWAYS_DEFTYPES
+ len = strlen(scriptname);
+ if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
+ int hasdir, idx = 0, deftypes = 1;
+ bool seen_dot = 1;
+
+ hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
+# else
if (dosearch) {
int hasdir, idx = 0, deftypes = 1;
bool seen_dot = 1;
hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
+# endif
/* The first time through, just add SEARCH_EXTS to whatever we
* already have, so we can check for default file types. */
while (deftypes ||
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Looking for %s\n",cur));
- if (Stat(cur,&statbuf) >= 0) {
+ if (PerlLIO_stat(cur,&statbuf) >= 0) {
dosearch = 0;
scriptname = cur;
#ifdef SEARCH_EXTS
#ifdef DOSISH
&& !strchr(scriptname, '\\')
#endif
- && (s = getenv("PATH"))) {
+ && (s = PerlEnv_getenv("PATH"))) {
bool seen_dot = 0;
bufend = s + strlen(s);
do {
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
- retval = Stat(tokenbuf,&statbuf);
+ retval = PerlLIO_stat(tokenbuf,&statbuf);
#ifdef SEARCH_EXTS
} while ( retval < 0 /* not there */
&& extidx>=0 && ext[extidx] /* try an extension? */
xfailed = savepv(tokenbuf);
}
#ifndef DOSISH
- if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
+ if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
#endif
seen_dot = 1; /* Disable message. */
if (!xfound)
if (strEQ(origfilename,"-"))
scriptname = "";
if (fdscript >= 0) {
- rsfp = PerlIO_fdopen(fdscript,"r");
+ rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
#if defined(HAS_FCNTL) && defined(F_SETFD)
if (rsfp)
fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
#else
- setuid(uid);
+ PerlProc_setuid(uid);
#endif
#endif
#endif
- if (geteuid() != uid)
+ if (PerlProc_geteuid() != uid)
croak("Can't do seteuid!\n");
}
#endif /* IAMSUID */
- rsfp = my_popen(SvPVX(cmd), "r");
+ rsfp = PerlProc_popen(SvPVX(cmd), "r");
SvREFCNT_dec(cmd);
SvREFCNT_dec(cpp);
}
rsfp = PerlIO_stdin();
}
else {
- rsfp = PerlIO_open(scriptname,"r");
+ rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
#if defined(HAS_FCNTL) && defined(F_SETFD)
if (rsfp)
fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
if (!rsfp) {
#ifdef DOSUID
#ifndef IAMSUID /* in case script is not readable before setuid */
- if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
+ if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
statbuf.st_mode & (S_ISUID|S_ISGID)) {
/* try again */
- execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
croak("Can't do setuid\n");
}
#endif
}
}
-static void
-validate_suid(validarg, scriptname)
-char *validarg;
-char *scriptname;
+STATIC void
+validate_suid(char *validarg, char *scriptname)
{
int which;
*/
#ifdef DOSUID
+ dTHR;
char *s, *s2;
- if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
+ if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
croak("Can't stat script \"%s\"",origfilename);
if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
*/
- if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
+ if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
croak("Permission denied");
#else
/* If we can swap euid and uid, then we can determine access rights
setresuid(euid,uid,(Uid_t)-1) < 0
# endif
#endif
- || getuid() != euid || geteuid() != uid)
+ || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
croak("Can't swap uid and euid"); /* really paranoid */
- if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
+ if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
croak("Permission denied"); /* testing full pathname here */
if (tmpstatbuf.st_dev != statbuf.st_dev ||
tmpstatbuf.st_ino != statbuf.st_ino) {
(void)PerlIO_close(rsfp);
- if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
+ if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
PerlIO_printf(rsfp,
"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
(long)statbuf.st_dev, (long)statbuf.st_ino,
SvPVX(GvSV(curcop->cop_filegv)),
(long)statbuf.st_uid, (long)statbuf.st_gid);
- (void)my_pclose(rsfp);
+ (void)PerlProc_pclose(rsfp);
}
croak("Permission denied\n");
}
setresuid(uid,euid,(Uid_t)-1) < 0
# endif
#endif
- || getuid() != uid || geteuid() != euid)
+ || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
croak("Can't reswap uid and euid");
if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
croak("Permission denied\n");
(void)PerlIO_close(rsfp);
#ifndef IAMSUID
/* try again */
- execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
#endif
croak("Can't do setuid\n");
}
#ifdef HAS_SETRESGID
(void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
#else
- setgid(statbuf.st_gid);
+ PerlProc_setgid(statbuf.st_gid);
#endif
#endif
#endif
- if (getegid() != statbuf.st_gid)
+ if (PerlProc_getegid() != statbuf.st_gid)
croak("Can't do setegid!\n");
}
if (statbuf.st_mode & S_ISUID) {
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
#else
- setuid(statbuf.st_uid);
+ PerlProc_setuid(statbuf.st_uid);
#endif
#endif
#endif
- if (geteuid() != statbuf.st_uid)
+ if (PerlProc_geteuid() != statbuf.st_uid)
croak("Can't do seteuid!\n");
}
else if (uid) { /* oops, mustn't run as root */
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
#else
- setuid((Uid_t)uid);
+ PerlProc_setuid((Uid_t)uid);
#endif
#endif
#endif
- if (geteuid() != uid)
+ if (PerlProc_geteuid() != uid)
croak("Can't do seteuid!\n");
}
init_ids();
/* exec the real perl, substituting fd script for scriptname. */
/* (We pass script name as "subdir" of fd, which perl will grok.) */
PerlIO_rewind(rsfp);
- lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
if (!origargv[which])
croak("Permission denied");
#if defined(HAS_FCNTL) && defined(F_SETFD)
fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
#endif
- execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
+ PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
croak("Can't do setuid\n");
#endif /* IAMSUID */
#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 */
+ PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
||
(egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
#endif /* DOSUID */
}
-static void
-find_beginning()
+STATIC void
+find_beginning(void)
{
register char *s, *s2;
/*SUPPRESS 530*/
while (s = moreswitches(s)) ;
}
- if (cddir && chdir(cddir) < 0)
+ if (cddir && PerlDir_chdir(cddir) < 0)
croak("Can't chdir to %s",cddir);
}
}
}
-static void
-init_ids()
+STATIC void
+init_ids(void)
{
- uid = (int)getuid();
- euid = (int)geteuid();
- gid = (int)getgid();
- egid = (int)getegid();
+ uid = (int)PerlProc_getuid();
+ euid = (int)PerlProc_geteuid();
+ gid = (int)PerlProc_getgid();
+ egid = (int)PerlProc_getegid();
#ifdef VMS
uid |= gid << 16;
euid |= egid << 16;
tainting |= (uid && (euid != uid || egid != gid));
}
-static void
-forbid_setid(s)
-char *s;
+STATIC void
+forbid_setid(char *s)
{
if (euid != uid)
croak("No %s allowed while running setuid", s);
croak("No %s allowed while running setgid", s);
}
-static void
-init_debugger()
+STATIC void
+init_debugger(void)
{
dTHR;
curstash = debstash;
}
void
-init_stacks(ARGS)
-dARGS
+init_stacks(ARGSproto)
{
curstack = newAV();
mainstack = curstack; /* remember in case we switch stacks */
stack_sp = stack_base;
stack_max = stack_base + 127;
- cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
- New(50,cxstack,cxstack_max + 1,CONTEXT);
+ cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */
+ New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
cxstack_ix = -1;
New(50,tmps_stack,128,SV*);
}
}
-static void
-nuke_stacks()
+STATIC void
+nuke_stacks(void)
{
dTHR;
Safefree(cxstack);
} )
}
+#ifndef PERL_OBJECT
static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
+#endif
-static void
-init_lexer()
+STATIC void
+init_lexer(void)
{
+#ifdef PERL_OBJECT
+ PerlIO *tmpfp;
+#endif
tmpfp = rsfp;
rsfp = Nullfp;
lex_start(linestr);
subname = newSVpv("main",4);
}
-static void
-init_predump_symbols()
+STATIC void
+init_predump_symbols(void)
{
dTHR;
GV *tmpgv;
GV *othergv;
+#ifdef USE_THREADS
+ sv_setpvn(*av_fetch(thr->threadsv,find_threadsv("\""),FALSE)," ", 1);
+#else
sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
+#endif /* USE_THREADS */
stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
GvMULTI_on(stdingv);
osname = savepv(OSNAME);
}
-static void
-init_postdump_symbols(argc,argv,env)
-register int argc;
-register char **argv;
-register char **env;
+STATIC void
+init_postdump_symbols(register int argc, register char **argv, register char **env)
{
+ dTHR;
char *s;
SV *sv;
GV* tmpgv;
if (!(s = strchr(*env,'=')))
continue;
*s++ = '\0';
-#ifdef WIN32
+#if defined(WIN32) || defined(MSDOS)
(void)strupr(*env);
#endif
sv = newSVpv(s--,0);
*s = '=';
#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
/* Sins of the RTL. See note in my_setenv(). */
- (void)putenv(savepv(*env));
+ (void)PerlEnv_putenv(savepv(*env));
#endif
}
#endif
sv_setiv(GvSV(tmpgv), (IV)getpid());
}
-static void
-init_perllib()
+STATIC void
+init_perllib(void)
{
char *s;
if (!tainting) {
#ifndef VMS
- s = getenv("PERL5LIB");
+ s = PerlEnv_getenv("PERL5LIB");
if (s)
incpush(s, TRUE);
else
- incpush(getenv("PERLLIB"), FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), 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
# define PERLLIB_MANGLE(s,n) (s)
#endif
-static void
-incpush(p, addsubdirs)
-char *p;
-int addsubdirs;
+STATIC void
+incpush(char *p, int addsubdirs)
{
SV *subdir = Nullsv;
static char *archpat_auto;
/* .../archname/version if -d .../archname/version/auto */
sv_setsv(subdir, libdir);
sv_catpv(subdir, archpat_auto);
- if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(incgv),
newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
/* .../archname if -d .../archname/auto */
sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
strlen(patchlevel) + 1, "", 0);
- if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(incgv),
newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
SvREFCNT_dec(subdir);
}
+#ifdef USE_THREADS
+STATIC struct perl_thread *
+init_main_thread()
+{
+ struct perl_thread *thr;
+ XPV *xpv;
+
+ Newz(53, thr, 1, struct perl_thread);
+ curcop = &compiling;
+ thr->cvcache = newHV();
+ thr->threadsv = newAV();
+ thr->specific = newAV();
+ thr->errhv = newHV();
+ thr->flags = THRf_R_JOINABLE;
+ MUTEX_INIT(&thr->mutex);
+ /* 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 */
+ thr->oursv = thrsv;
+ curcop = &compiling;
+ chopset = " \n-";
+
+ MUTEX_LOCK(&threads_mutex);
+ nthreads++;
+ thr->tid = 0;
+ thr->next = thr;
+ thr->prev = thr;
+ MUTEX_UNLOCK(&threads_mutex);
+
+#ifdef HAVE_THREAD_INTERN
+ init_thread_intern(thr);
+#endif
+
+#ifdef SET_THREAD_SELF
+ SET_THREAD_SELF(thr);
+#else
+ thr->self = pthread_self();
+#endif /* SET_THREAD_SELF */
+ SET_THR(thr);
+
+ /*
+ * These must come after the SET_THR because sv_setpvn does
+ * SvTAINT and the taint fields require dTHR.
+ */
+ toptarget = NEWSV(0,0);
+ sv_upgrade(toptarget, SVt_PVFM);
+ sv_setpvn(toptarget, "", 0);
+ bodytarget = NEWSV(0,0);
+ sv_upgrade(bodytarget, SVt_PVFM);
+ sv_setpvn(bodytarget, "", 0);
+ formtarget = bodytarget;
+ thr->errsv = newSVpv("", 0);
+ return thr;
+}
+#endif /* USE_THREADS */
+
void
-call_list(oldscope, list)
-I32 oldscope;
-AV* list;
+call_list(I32 oldscope, AV *paramList)
{
dTHR;
line_t oldline = curcop->cop_line;
dJMPENV;
int ret;
- while (AvFILL(list) >= 0) {
- CV *cv = (CV*)av_shift(list);
+ while (AvFILL(paramList) >= 0) {
+ CV *cv = (CV*)av_shift(paramList);
SAVEFREESV(cv);
JMPENV_PUSH(ret);
switch (ret) {
case 0: {
- SV* atsv = GvSV(errgv);
+ SV* atsv = ERRSV;
PUSHMARK(stack_sp);
perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
(void)SvPV(atsv, len);
JMPENV_POP;
curcop = &compiling;
curcop->cop_line = oldline;
- if (list == beginav)
+ if (paramList == beginav)
sv_catpv(atsv, "BEGIN failed--compilation aborted");
else
sv_catpv(atsv, "END failed--cleanup aborted");
curcop = &compiling;
curcop->cop_line = oldline;
if (statusvalue) {
- if (list == beginav)
+ if (paramList == beginav)
croak("BEGIN failed--compilation aborted");
else
croak("END failed--cleanup aborted");
}
void
-my_exit(status)
-U32 status;
+my_exit(U32 status)
{
dTHR;
#ifdef USE_THREADS
- DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
- (unsigned long) thr, (unsigned long) status));
+ DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
+ thr, (unsigned long) status));
#endif /* USE_THREADS */
switch (status) {
case 0:
}
void
-my_failure_exit()
+my_failure_exit(void)
{
#ifdef VMS
if (vaxc$errno & 1) {
my_exit_jump();
}
-static void
-my_exit_jump()
+STATIC void
+my_exit_jump(void)
{
dTHR;
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
JMPENV_JUMP(2);
}
+
+
+
https://perl5.git.perl.org / perl5.git / blobdiff