This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline changes into win32 branch. Now would be a good time
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW
1/* perl.c
2 *
9607fc9c 3 * Copyright (c) 1987-1997 Larry Wall
a687059c 4 *
352d5a3a
LW
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
a687059c 7 *
8d063cd8
LW
8 */
9
a0d0e21e
LW
10/*
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
12 */
45d8adaa 13
378cc40b
LW
14#include "EXTERN.h"
15#include "perl.h"
a687059c 16#include "patchlevel.h"
378cc40b 17
df5cef82 18/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW
19#ifdef I_UNISTD
20#include <unistd.h>
21#endif
a0d0e21e 22
54310121
PP
23#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24char *getenv _((char *)); /* Usually in <stdlib.h> */
25#endif
26
71be2cbc 27dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
463ee0b2 28
a687059c
LW
29#ifdef IAMSUID
30#ifndef DOSUID
31#define DOSUID
32#endif
33#endif
378cc40b 34
a687059c
LW
35#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
36#ifdef DOSUID
37#undef DOSUID
38#endif
39#endif
8d063cd8 40
8ebc5c01
PP
41#define I_REINIT \
42 STMT_START { \
43 chopset = " \n-"; \
44 copline = NOLINE; \
45 curcop = &compiling; \
46 curcopdb = NULL; \
47 cxstack_ix = -1; \
48 cxstack_max = 128; \
49 dbargs = 0; \
50 dlmax = 128; \
51 laststatval = -1; \
52 laststype = OP_STAT; \
53 maxscream = -1; \
54 maxsysfd = MAXSYSFD; \
55 statname = Nullsv; \
56 tmps_floor = -1; \
57 tmps_ix = -1; \
58 op_mask = NULL; \
59 dlmax = 128; \
60 laststatval = -1; \
61 laststype = OP_STAT; \
46fc3d4c 62 mess_sv = Nullsv; \
8ebc5c01
PP
63 } STMT_END
64
a0d0e21e 65static void find_beginning _((void));
bbce6d69 66static void forbid_setid _((char *));
774d564b 67static void incpush _((char *, int));
748a9306 68static void init_ids _((void));
a0d0e21e
LW
69static void init_debugger _((void));
70static void init_lexer _((void));
71static void init_main_stash _((void));
199100c8
MB
72#ifdef USE_THREADS
73static struct thread * init_main_thread _((void));
74#endif /* USE_THREADS */
a0d0e21e
LW
75static void init_perllib _((void));
76static void init_postdump_symbols _((int, char **, char **));
77static void init_predump_symbols _((void));
f86702cc 78static void my_exit_jump _((void)) __attribute__((noreturn));
6e72f9df 79static void nuke_stacks _((void));
a0d0e21e 80static void open_script _((char *, bool, SV *));
ab821d7f 81static void usage _((char *));
96436eeb
PP
82static void validate_suid _((char *, char*));
83
84static int fdscript = -1;
79072805 85
77a005ab
MB
86#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
87#include <asm/sigcontext.h>
88static void
89catch_sigsegv(int signo, struct sigcontext_struct sc)
90{
91 signal(SIGSEGV, SIG_DFL);
92 fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
93 "return_address = 0x%lx, eip = 0x%lx\n",
94 sc.cr2, __builtin_return_address(0), sc.eip);
95 fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR);
96}
97#endif
98
93a17b20 99PerlInterpreter *
8ac85365 100perl_alloc(void)
79072805 101{
93a17b20 102 PerlInterpreter *sv_interp;
79072805 103
8990e307 104 curinterp = 0;
93a17b20 105 New(53, sv_interp, 1, PerlInterpreter);
79072805
LW
106 return sv_interp;
107}
108
109void
8ac85365 110perl_construct(register PerlInterpreter *sv_interp)
79072805 111{
a863c7d1
MB
112#ifdef USE_THREADS
113 int i;
114#ifndef FAKE_THREADS
11343788 115 struct thread *thr;
a863c7d1
MB
116#endif /* FAKE_THREADS */
117#endif /* USE_THREADS */
11343788 118
79072805
LW
119 if (!(curinterp = sv_interp))
120 return;
121
8990e307 122#ifdef MULTIPLICITY
93a17b20 123 Zero(sv_interp, 1, PerlInterpreter);
8990e307 124#endif
79072805 125
33f46ff6 126 /* Init the real globals (and main thread)? */
c116a00c 127 if (!linestr) {
11343788 128#ifdef USE_THREADS
8023c3ce 129
33f46ff6 130 INIT_THREADS;
d55594ae
GS
131#ifdef ALLOC_THREAD_KEY
132 ALLOC_THREAD_KEY;
133#else
a863c7d1
MB
134 if (pthread_key_create(&thr_key, 0))
135 croak("panic: pthread_key_create");
d55594ae 136#endif
c116a00c
MB
137 MUTEX_INIT(&malloc_mutex);
138 MUTEX_INIT(&sv_mutex);
a863c7d1
MB
139 /*
140 * Safe to use basic SV functions from now on (though
141 * not things like mortals or tainting yet).
142 */
c116a00c
MB
143 MUTEX_INIT(&eval_mutex);
144 COND_INIT(&eval_cond);
33f46ff6 145 MUTEX_INIT(&threads_mutex);
c116a00c 146 COND_INIT(&nthreads_cond);
a863c7d1 147
199100c8 148 thr = init_main_thread();
11343788
MB
149#endif /* USE_THREADS */
150
79072805 151 linestr = NEWSV(65,80);
ed6116ce 152 sv_upgrade(linestr,SVt_PVIV);
79072805 153
6e72f9df
PP
154 if (!SvREADONLY(&sv_undef)) {
155 SvREADONLY_on(&sv_undef);
79072805 156
6e72f9df
PP
157 sv_setpv(&sv_no,No);
158 SvNV(&sv_no);
159 SvREADONLY_on(&sv_no);
79072805 160
6e72f9df
PP
161 sv_setpv(&sv_yes,Yes);
162 SvNV(&sv_yes);
163 SvREADONLY_on(&sv_yes);
164 }
79072805 165
c07a80fd
PP
166 nrs = newSVpv("\n", 1);
167 rs = SvREFCNT_inc(nrs);
168
c23142e2 169 sighandlerp = sighandler;
44a8e56a
PP
170 pidstatus = newHV();
171
79072805
LW
172#ifdef MSDOS
173 /*
174 * There is no way we can refer to them from Perl so close them to save
175 * space. The other alternative would be to provide STDAUX and STDPRN
176 * filehandles.
177 */
178 (void)fclose(stdaux);
179 (void)fclose(stdprn);
180#endif
181 }
182
8990e307 183#ifdef MULTIPLICITY
8ebc5c01
PP
184 I_REINIT;
185 perl_destruct_level = 1;
186#else
187 if(perl_destruct_level > 0)
188 I_REINIT;
79072805
LW
189#endif
190
748a9306 191 init_ids();
fb73857a 192 lex_state = LEX_NOTPARSING;
a5f75d66 193
54310121
PP
194 start_env.je_prev = NULL;
195 start_env.je_ret = -1;
196 start_env.je_mustcatch = TRUE;
197 top_env = &start_env;
f86702cc
PP
198 STATUS_ALL_SUCCESS;
199
36477c24 200 SET_NUMERIC_STANDARD();
a5f75d66 201#if defined(SUBVERSION) && SUBVERSION > 0
e2666263
PP
202 sprintf(patchlevel, "%7.5f", (double) 5
203 + ((double) PATCHLEVEL / (double) 1000)
204 + ((double) SUBVERSION / (double) 100000));
a5f75d66 205#else
e2666263
PP
206 sprintf(patchlevel, "%5.3f", (double) 5 +
207 ((double) PATCHLEVEL / (double) 1000));
a5f75d66 208#endif
79072805 209
ab821d7f 210#if defined(LOCAL_PATCH_COUNT)
6e72f9df 211 localpatches = local_patches; /* For possible -v */
ab821d7f
PP
212#endif
213
760ac839
LW
214 PerlIO_init(); /* Hook to IO system */
215
79072805 216 fdpid = newAV(); /* for remembering popen pids by fd */
8990e307 217
11343788
MB
218 init_stacks(ARGS);
219 DEBUG( {
220 New(51,debname,128,char);
221 New(52,debdelim,128,char);
222 } )
223
8990e307 224 ENTER;
79072805
LW
225}
226
227void
8ac85365 228perl_destruct(register PerlInterpreter *sv_interp)
79072805 229{
11343788 230 dTHR;
748a9306 231 int destruct_level; /* 0=none, 1=full, 2=full with checks */
8990e307 232 I32 last_sv_count;
a0d0e21e 233 HV *hv;
1f2bfc8a 234#ifdef USE_THREADS
33f46ff6 235 Thread t;
1f2bfc8a 236#endif /* USE_THREADS */
8990e307 237
79072805
LW
238 if (!(curinterp = sv_interp))
239 return;
748a9306 240
11343788 241#ifdef USE_THREADS
0f15f207 242#ifndef FAKE_THREADS
8023c3ce
MB
243 /* Pass 1 on any remaining threads: detach joinables, join zombies */
244 retry_cleanup:
33f46ff6
MB
245 MUTEX_LOCK(&threads_mutex);
246 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
c7848ba1 247 "perl_destruct: waiting for %d threads...\n",
33f46ff6
MB
248 nthreads - 1));
249 for (t = thr->next; t != thr; t = t->next) {
605e5515
MB
250 MUTEX_LOCK(&t->mutex);
251 switch (ThrSTATE(t)) {
252 AV *av;
c7848ba1
MB
253 case THRf_ZOMBIE:
254 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
255 "perl_destruct: joining zombie %p\n", t));
605e5515
MB
256 ThrSETSTATE(t, THRf_DEAD);
257 MUTEX_UNLOCK(&t->mutex);
258 nthreads--;
8023c3ce
MB
259 /*
260 * The SvREFCNT_dec below may take a long time (e.g. av
261 * may contain an object scalar whose destructor gets
262 * called) so we have to unlock threads_mutex and start
263 * all over again.
264 */
605e5515 265 MUTEX_UNLOCK(&threads_mutex);
ea0efc06 266 JOIN(t, &av);
605e5515 267 SvREFCNT_dec((SV*)av);
c7848ba1
MB
268 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
269 "perl_destruct: joined zombie %p OK\n", t));
8023c3ce 270 goto retry_cleanup;
c7848ba1
MB
271 case THRf_R_JOINABLE:
272 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
273 "perl_destruct: detaching thread %p\n", t));
274 ThrSETSTATE(t, THRf_R_DETACHED);
275 /*
276 * We unlock threads_mutex and t->mutex in the opposite order
277 * from which we locked them just so that DETACH won't
278 * deadlock if it panics. It's only a breach of good style
279 * not a bug since they are unlocks not locks.
280 */
281 MUTEX_UNLOCK(&threads_mutex);
282 DETACH(t);
283 MUTEX_UNLOCK(&t->mutex);
8023c3ce 284 goto retry_cleanup;
c7848ba1
MB
285 default:
286 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
287 "perl_destruct: ignoring %p (state %u)\n",
288 t, ThrSTATE(t)));
289 MUTEX_UNLOCK(&t->mutex);
c7848ba1 290 /* fall through and out */
33f46ff6
MB
291 }
292 }
8023c3ce
MB
293 /* We leave the above "Pass 1" loop with threads_mutex still locked */
294
295 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
11343788
MB
296 while (nthreads > 1)
297 {
33f46ff6 298 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
c7848ba1 299 "perl_destruct: final wait for %d threads\n",
33f46ff6
MB
300 nthreads - 1));
301 COND_WAIT(&nthreads_cond, &threads_mutex);
11343788
MB
302 }
303 /* At this point, we're the last thread */
33f46ff6 304 MUTEX_UNLOCK(&threads_mutex);
d9f997d7 305 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
33f46ff6 306 MUTEX_DESTROY(&threads_mutex);
11343788 307 COND_DESTROY(&nthreads_cond);
0f15f207 308#endif /* !defined(FAKE_THREADS) */
11343788
MB
309#endif /* USE_THREADS */
310
748a9306 311 destruct_level = perl_destruct_level;
4633a7c4
LW
312#ifdef DEBUGGING
313 {
314 char *s;
5f05dabc
PP
315 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
316 int i = atoi(s);
317 if (destruct_level < i)
318 destruct_level = i;
319 }
4633a7c4
LW
320 }
321#endif
322
8990e307 323 LEAVE;
a0d0e21e
LW
324 FREETMPS;
325
ff0cee69
PP
326 /* We must account for everything. */
327
328 /* Destroy the main CV and syntax tree */
6e72f9df
PP
329 if (main_root) {
330 curpad = AvARRAY(comppad);
331 op_free(main_root);
ff0cee69 332 main_root = Nullop;
a0d0e21e 333 }
ff0cee69
PP
334 main_start = Nullop;
335 SvREFCNT_dec(main_cv);
336 main_cv = Nullcv;
337
a0d0e21e
LW
338 if (sv_objcount) {
339 /*
340 * Try to destruct global references. We do this first so that the
341 * destructors and destructees still exist. Some sv's might remain.
342 * Non-referenced objects are on their own.
343 */
344
345 dirty = TRUE;
346 sv_clean_objs();
8990e307
LW
347 }
348
5cd24f17
PP
349 /* unhook hooks which will soon be, or use, destroyed data */
350 SvREFCNT_dec(warnhook);
351 warnhook = Nullsv;
352 SvREFCNT_dec(diehook);
353 diehook = Nullsv;
354 SvREFCNT_dec(parsehook);
355 parsehook = Nullsv;
356
a0d0e21e 357 if (destruct_level == 0){
8990e307 358
a0d0e21e
LW
359 DEBUG_P(debprofdump());
360
361 /* The exit() function will do everything that needs doing. */
362 return;
363 }
5dd60ef7 364
5f05dabc
PP
365 /* loosen bonds of global variables */
366
8ebc5c01
PP
367 if(rsfp) {
368 (void)PerlIO_close(rsfp);
369 rsfp = Nullfp;
370 }
371
372 /* Filters for program text */
373 SvREFCNT_dec(rsfp_filters);
374 rsfp_filters = Nullav;
375
376 /* switches */
377 preprocess = FALSE;
378 minus_n = FALSE;
379 minus_p = FALSE;
380 minus_l = FALSE;
381 minus_a = FALSE;
382 minus_F = FALSE;
383 doswitches = FALSE;
384 dowarn = FALSE;
385 doextract = FALSE;
386 sawampersand = FALSE; /* must save all match strings */
387 sawstudy = FALSE; /* do fbm_instr on all strings */
388 sawvec = FALSE;
389 unsafe = FALSE;
390
391 Safefree(inplace);
392 inplace = Nullch;
393
394 Safefree(e_tmpname);
395 e_tmpname = Nullch;
396
397 if (e_fp) {
398 PerlIO_close(e_fp);
399 e_fp = Nullfp;
400 }
401
402 /* magical thingies */
403
404 Safefree(ofs); /* $, */
405 ofs = Nullch;
5f05dabc 406
8ebc5c01
PP
407 Safefree(ors); /* $\ */
408 ors = Nullch;
409
410 SvREFCNT_dec(nrs); /* $\ helper */
5f05dabc
PP
411 nrs = Nullsv;
412
8ebc5c01 413 multiline = 0; /* $* */
5f05dabc 414
8ebc5c01 415 SvREFCNT_dec(statname);
5f05dabc
PP
416 statname = Nullsv;
417 statgv = Nullgv;
5f05dabc 418
8ebc5c01
PP
419 /* defgv, aka *_ should be taken care of elsewhere */
420
421#if 0 /* just about all regexp stuff, seems to be ok */
422
423 /* shortcuts to regexp stuff */
424 leftgv = Nullgv;
425 ampergv = Nullgv;
426
427 SAVEFREEOP(curpm);
428 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
429
430 regprecomp = NULL; /* uncompiled string. */
431 regparse = NULL; /* Input-scan pointer. */
432 regxend = NULL; /* End of input for compile */
433 regnpar = 0; /* () count. */
434 regcode = NULL; /* Code-emit pointer; &regdummy = don't. */
435 regsize = 0; /* Code size. */
436 regnaughty = 0; /* How bad is this pattern? */
437 regsawback = 0; /* Did we see \1, ...? */
438
439 reginput = NULL; /* String-input pointer. */
440 regbol = NULL; /* Beginning of input, for ^ check. */
441 regeol = NULL; /* End of input, for $ check. */
442 regstartp = (char **)NULL; /* Pointer to startp array. */
443 regendp = (char **)NULL; /* Ditto for endp. */
444 reglastparen = 0; /* Similarly for lastparen. */
445 regtill = NULL; /* How far we are required to go. */
446 regflags = 0; /* are we folding, multilining? */
447 regprev = (char)NULL; /* char before regbol, \n if none */
448
449#endif /* if 0 */
450
451 /* clean up after study() */
452 SvREFCNT_dec(lastscream);
453 lastscream = Nullsv;
454 Safefree(screamfirst);
455 screamfirst = 0;
456 Safefree(screamnext);
457 screamnext = 0;
458
459 /* startup and shutdown function lists */
460 SvREFCNT_dec(beginav);
461 SvREFCNT_dec(endav);
77a005ab 462 SvREFCNT_dec(initav);
5618dfe8 463 beginav = Nullav;
5618dfe8 464 endav = Nullav;
77a005ab 465 initav = Nullav;
5618dfe8 466
8ebc5c01
PP
467 /* temp stack during pp_sort() */
468 SvREFCNT_dec(sortstack);
469 sortstack = Nullav;
470
471 /* shortcuts just get cleared */
472 envgv = Nullgv;
473 siggv = Nullgv;
474 incgv = Nullgv;
12f917ad 475 errgv = Nullgv;
8ebc5c01
PP
476 argvgv = Nullgv;
477 argvoutgv = Nullgv;
478 stdingv = Nullgv;
479 last_in_gv = Nullgv;
480
481 /* reset so print() ends up where we expect */
482 setdefout(Nullgv);
483
a0d0e21e 484 /* Prepare to destruct main symbol table. */
5f05dabc 485
a0d0e21e 486 hv = defstash;
85e6fe83 487 defstash = 0;
a0d0e21e
LW
488 SvREFCNT_dec(hv);
489
490 FREETMPS;
491 if (destruct_level >= 2) {
492 if (scopestack_ix != 0)
ff0cee69
PP
493 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
494 (long)scopestack_ix);
a0d0e21e 495 if (savestack_ix != 0)
ff0cee69
PP
496 warn("Unbalanced saves: %ld more saves than restores\n",
497 (long)savestack_ix);
a0d0e21e 498 if (tmps_floor != -1)
ff0cee69
PP
499 warn("Unbalanced tmps: %ld more allocs than frees\n",
500 (long)tmps_floor + 1);
a0d0e21e 501 if (cxstack_ix != -1)
ff0cee69
PP
502 warn("Unbalanced context: %ld more PUSHes than POPs\n",
503 (long)cxstack_ix + 1);
a0d0e21e 504 }
8990e307
LW
505
506 /* Now absolutely destruct everything, somehow or other, loops or no. */
8990e307 507 last_sv_count = 0;
6e72f9df 508 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
8990e307
LW
509 while (sv_count != 0 && sv_count != last_sv_count) {
510 last_sv_count = sv_count;
511 sv_clean_all();
512 }
6e72f9df
PP
513 SvFLAGS(strtab) &= ~SVTYPEMASK;
514 SvFLAGS(strtab) |= SVt_PVHV;
515
516 /* Destruct the global string table. */
517 {
518 /* Yell and reset the HeVAL() slots that are still holding refcounts,
519 * so that sv_free() won't fail on them.
520 */
521 I32 riter;
522 I32 max;
523 HE *hent;
524 HE **array;
525
526 riter = 0;
527 max = HvMAX(strtab);
528 array = HvARRAY(strtab);
529 hent = array[0];
530 for (;;) {
531 if (hent) {
532 warn("Unbalanced string table refcount: (%d) for \"%s\"",
533 HeVAL(hent) - Nullsv, HeKEY(hent));
534 HeVAL(hent) = Nullsv;
535 hent = HeNEXT(hent);
536 }
537 if (!hent) {
538 if (++riter > max)
539 break;
540 hent = array[riter];
541 }
542 }
543 }
544 SvREFCNT_dec(strtab);
545
8990e307 546 if (sv_count != 0)
ff0cee69 547 warn("Scalars leaked: %ld\n", (long)sv_count);
6e72f9df 548
4633a7c4 549 sv_free_arenas();
44a8e56a
PP
550
551 /* No SVs have survived, need to clean out */
552 linestr = NULL;
553 pidstatus = Nullhv;
6e72f9df
PP
554 if (origfilename)
555 Safefree(origfilename);
556 nuke_stacks();
fc36a67e 557 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
a0d0e21e
LW
558
559 DEBUG_P(debprofdump());
11343788
MB
560#ifdef USE_THREADS
561 MUTEX_DESTROY(&sv_mutex);
562 MUTEX_DESTROY(&malloc_mutex);
563 MUTEX_DESTROY(&eval_mutex);
c116a00c 564 COND_DESTROY(&eval_cond);
fc36a67e 565
8023c3ce
MB
566 /* As the penultimate thing, free the non-arena SV for thrsv */
567 Safefree(SvPVX(thrsv));
568 Safefree(SvANY(thrsv));
569 Safefree(thrsv);
570 thrsv = Nullsv;
571#endif /* USE_THREADS */
572
fc36a67e
PP
573 /* As the absolutely last thing, free the non-arena SV for mess() */
574
575 if (mess_sv) {
576 /* we know that type >= SVt_PV */
577 SvOOK_off(mess_sv);
578 Safefree(SvPVX(mess_sv));
579 Safefree(SvANY(mess_sv));
580 Safefree(mess_sv);
581 mess_sv = Nullsv;
582 }
79072805
LW
583}
584
585void
8ac85365 586perl_free(PerlInterpreter *sv_interp)
79072805
LW
587{
588 if (!(curinterp = sv_interp))
589 return;
590 Safefree(sv_interp);
591}
592
593int
8ac85365 594perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
8d063cd8 595{
11343788 596 dTHR;
79072805 597 register SV *sv;
8d063cd8 598 register char *s;
1a30305b 599 char *scriptname = NULL;
a0d0e21e 600 VOL bool dosearch = FALSE;
13281fa4 601 char *validarg = "";
2ae324a7 602 I32 oldscope;
748a9306 603 AV* comppadlist;
54310121 604 dJMPENV;
22921e25 605 int ret;
8d063cd8 606
a687059c
LW
607#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
608#ifdef IAMSUID
609#undef IAMSUID
463ee0b2 610 croak("suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW
611setuid perl scripts securely.\n");
612#endif
613#endif
614
79072805
LW
615 if (!(curinterp = sv_interp))
616 return 255;
617
6e72f9df
PP
618#if defined(NeXT) && defined(__DYNAMIC__)
619 _dyld_lookup_and_bind
620 ("__environ", (unsigned long *) &environ_pointer, NULL);
621#endif /* environ */
622
ac58e20f
LW
623 origargv = argv;
624 origargc = argc;
a0d0e21e 625#ifndef VMS /* VMS doesn't have environ array */
fe14fcc3 626 origenviron = environ;
a0d0e21e 627#endif
ab821d7f 628 e_tmpname = Nullch;
a0d0e21e
LW
629
630 if (do_undump) {
631
632 /* Come here if running an undumped a.out. */
633
634 origfilename = savepv(argv[0]);
635 do_undump = FALSE;
636 cxstack_ix = -1; /* start label stack again */
748a9306 637 init_ids();
a0d0e21e
LW
638 init_postdump_symbols(argc,argv,env);
639 return 0;
640 }
641
ff0cee69
PP
642 if (main_root) {
643 curpad = AvARRAY(comppad);
a0d0e21e 644 op_free(main_root);
ff0cee69
PP
645 main_root = Nullop;
646 }
647 main_start = Nullop;
648 SvREFCNT_dec(main_cv);
649 main_cv = Nullcv;
79072805 650
f86702cc 651 time(&basetime);
2ae324a7 652 oldscope = scopestack_ix;
f86702cc 653
22921e25
CS
654 JMPENV_PUSH(ret);
655 switch (ret) {
79072805 656 case 1:
f86702cc
PP
657 STATUS_ALL_FAILURE;
658 /* FALL THROUGH */
79072805 659 case 2:
f86702cc 660 /* my_exit() was called */
2ae324a7
PP
661 while (scopestack_ix > oldscope)
662 LEAVE;
84902520 663 FREETMPS;
8990e307
LW
664 curstash = defstash;
665 if (endav)
68dc0745 666 call_list(oldscope, endav);
54310121 667 JMPENV_POP;
f86702cc 668 return STATUS_NATIVE_EXPORT;
79072805 669 case 3:
54310121 670 JMPENV_POP;
760ac839 671 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
8990e307 672 return 1;
79072805
LW
673 }
674
79072805
LW
675 sv_setpvn(linestr,"",0);
676 sv = newSVpv("",0); /* first used for -I flags */
8990e307 677 SAVEFREESV(sv);
79072805 678 init_main_stash();
54310121 679
33b78306 680 for (argc--,argv++; argc > 0; argc--,argv++) {
8d063cd8
LW
681 if (argv[0][0] != '-' || !argv[0][1])
682 break;
13281fa4
LW
683#ifdef DOSUID
684 if (*validarg)
685 validarg = " PHOOEY ";
686 else
687 validarg = argv[0];
688#endif
689 s = argv[0]+1;
8d063cd8 690 reswitch:
13281fa4 691 switch (*s) {
27e2fb84 692 case '0':
2304df62 693 case 'F':
378cc40b 694 case 'a':
33b78306 695 case 'c':
a687059c 696 case 'd':
8d063cd8 697 case 'D':
4633a7c4 698 case 'h':
33b78306 699 case 'i':
fe14fcc3 700 case 'l':
1a30305b
PP
701 case 'M':
702 case 'm':
33b78306
LW
703 case 'n':
704 case 'p':
79072805 705 case 's':
33b78306
LW
706 case 'u':
707 case 'U':
708 case 'v':
709 case 'w':
710 if (s = moreswitches(s))
711 goto reswitch;
8d063cd8 712 break;
33b78306 713
f86702cc
PP
714 case 'T':
715 tainting = TRUE;
716 s++;
717 goto reswitch;
718
8d063cd8 719 case 'e':
a687059c 720 if (euid != uid || egid != gid)
463ee0b2 721 croak("No -e allowed in setuid scripts");
8d063cd8 722 if (!e_fp) {
a0d0e21e 723 e_tmpname = savepv(TMPPATH);
a687059c 724 (void)mktemp(e_tmpname);
83025b21 725 if (!*e_tmpname)
463ee0b2 726 croak("Can't mktemp()");
760ac839 727 e_fp = PerlIO_open(e_tmpname,"w");
33b78306 728 if (!e_fp)
463ee0b2 729 croak("Cannot open temporary file");
8d063cd8 730 }
552a7a9b
PP
731 if (*++s)
732 PerlIO_puts(e_fp,s);
733 else if (argv[1]) {
760ac839 734 PerlIO_puts(e_fp,argv[1]);
33b78306
LW
735 argc--,argv++;
736 }
552a7a9b
PP
737 else
738 croak("No code specified for -e");
760ac839 739 (void)PerlIO_putc(e_fp,'\n');
8d063cd8 740 break;
fb73857a 741 case 'I': /* -I handled both here and in moreswitches() */
bbce6d69 742 forbid_setid("-I");
fb73857a 743 if (!*++s && (s=argv[1]) != Nullch) {
8d063cd8 744 argc--,argv++;
8d063cd8 745 }
fb73857a
PP
746 while (s && isSPACE(*s))
747 ++s;
748 if (s && *s) {
749 char *e, *p;
750 for (e = s; *e && !isSPACE(*e); e++) ;
751 p = savepvn(s, e-s);
752 incpush(p, TRUE);
753 sv_catpv(sv,"-I");
754 sv_catpv(sv,p);
755 sv_catpv(sv," ");
756 Safefree(p);
757 } /* XXX else croak? */
8d063cd8 758 break;
8d063cd8 759 case 'P':
bbce6d69 760 forbid_setid("-P");
8d063cd8 761 preprocess = TRUE;
13281fa4 762 s++;
8d063cd8 763 goto reswitch;
378cc40b 764 case 'S':
bbce6d69 765 forbid_setid("-S");
378cc40b 766 dosearch = TRUE;
13281fa4 767 s++;
378cc40b 768 goto reswitch;
1a30305b
PP
769 case 'V':
770 if (!preambleav)
771 preambleav = newAV();
772 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
773 if (*++s != ':') {
6e72f9df
PP
774 Sv = newSVpv("print myconfig();",0);
775#ifdef VMS
776 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
777#else
778 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
779#endif
54310121 780#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
46fc3d4c 781 sv_catpv(Sv,"\" Compile-time options:");
6e72f9df 782# ifdef DEBUGGING
46fc3d4c 783 sv_catpv(Sv," DEBUGGING");
6e72f9df 784# endif
54310121 785# ifdef NO_EMBED
46fc3d4c 786 sv_catpv(Sv," NO_EMBED");
6e72f9df
PP
787# endif
788# ifdef MULTIPLICITY
46fc3d4c 789 sv_catpv(Sv," MULTIPLICITY");
6e72f9df 790# endif
46fc3d4c 791 sv_catpv(Sv,"\\n\",");
6e72f9df
PP
792#endif
793#if defined(LOCAL_PATCH_COUNT)
54310121
PP
794 if (LOCAL_PATCH_COUNT > 0) {
795 int i;
5cd24f17 796 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
6e72f9df 797 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
46fc3d4c
PP
798 if (localpatches[i])
799 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
6e72f9df
PP
800 }
801 }
802#endif
46fc3d4c 803 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
6e72f9df
PP
804#ifdef __DATE__
805# ifdef __TIME__
46fc3d4c 806 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6e72f9df 807# else
46fc3d4c 808 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
6e72f9df 809# endif
6e72f9df 810#endif
54310121
PP
811 sv_catpv(Sv, "; \
812$\"=\"\\n \"; \
813@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
814print \" \\%ENV:\\n @env\\n\" if @env; \
815print \" \\@INC:\\n @INC\\n\";");
1a30305b
PP
816 }
817 else {
818 Sv = newSVpv("config_vars(qw(",0);
819 sv_catpv(Sv, ++s);
820 sv_catpv(Sv, "))");
821 s += strlen(s);
822 }
823 av_push(preambleav, Sv);
c07a80fd 824 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1a30305b 825 goto reswitch;
33b78306
LW
826 case 'x':
827 doextract = TRUE;
13281fa4 828 s++;
33b78306 829 if (*s)
a0d0e21e 830 cddir = savepv(s);
33b78306 831 break;
8d063cd8
LW
832 case 0:
833 break;
fb73857a
PP
834 case '-':
835 if (!*++s || isSPACE(*s)) {
836 argc--,argv++;
837 goto switch_end;
838 }
839 /* catch use of gnu style long options */
840 if (strEQ(s, "version")) {
841 s = "v";
842 goto reswitch;
843 }
844 if (strEQ(s, "help")) {
845 s = "h";
846 goto reswitch;
847 }
848 s--;
849 /* FALL THROUGH */
8d063cd8 850 default:
90248788 851 croak("Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW
852 }
853 }
854 switch_end:
54310121
PP
855
856 if (!tainting && (s = getenv("PERL5OPT"))) {
fb73857a 857 while (s && *s) {
54310121
PP
858 while (isSPACE(*s))
859 s++;
860 if (*s == '-') {
861 s++;
862 if (isSPACE(*s))
863 continue;
864 }
865 if (!*s)
866 break;
867 if (!strchr("DIMUdmw", *s))
868 croak("Illegal switch in PERL5OPT: -%c", *s);
869 s = moreswitches(s);
870 }
871 }
872
1a30305b
PP
873 if (!scriptname)
874 scriptname = argv[0];
8d063cd8 875 if (e_fp) {
68dc0745
PP
876 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
877#ifndef MULTIPLICITY
878 warn("Did you forget to compile with -DMULTIPLICITY?");
879#endif
2304df62 880 croak("Can't write to temp file for -e: %s", Strerror(errno));
68dc0745 881 }
ab821d7f 882 e_fp = Nullfp;
8d063cd8 883 argc++,argv--;
45d8adaa 884 scriptname = e_tmpname;
8d063cd8 885 }
79072805
LW
886 else if (scriptname == Nullch) {
887#ifdef MSDOS
760ac839 888 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
55497cff 889 moreswitches("h");
fe14fcc3 890#endif
79072805
LW
891 scriptname = "-";
892 }
fe14fcc3 893
79072805 894 init_perllib();
8d063cd8 895
79072805 896 open_script(scriptname,dosearch,sv);
8d063cd8 897
96436eeb 898 validate_suid(validarg, scriptname);
378cc40b 899
79072805
LW
900 if (doextract)
901 find_beginning();
902
4fdae800 903 main_cv = compcv = (CV*)NEWSV(1104,0);
748a9306 904 sv_upgrade((SV *)compcv, SVt_PVCV);
07055b4c 905 CvUNIQUE_on(compcv);
748a9306 906
6e72f9df 907 comppad = newAV();
79072805
LW
908 av_push(comppad, Nullsv);
909 curpad = AvARRAY(comppad);
6e72f9df 910 comppad_name = newAV();
8990e307 911 comppad_name_fill = 0;
e858de61
MB
912 min_intro_pending = 0;
913 padix = 0;
11343788
MB
914#ifdef USE_THREADS
915 av_store(comppad_name, 0, newSVpv("@_", 2));
e858de61 916 curpad[0] = (SV*)newAV();
6d4ff0d2 917 SvPADMY_on(curpad[0]); /* XXX Needed? */
e858de61 918 CvOWNER(compcv) = 0;
12ca11f6 919 New(666, CvMUTEXP(compcv), 1, perl_mutex);
e858de61 920 MUTEX_INIT(CvMUTEXP(compcv));
11343788 921#endif /* USE_THREADS */
79072805 922
748a9306
LW
923 comppadlist = newAV();
924 AvREAL_off(comppadlist);
8e07c86e
AD
925 av_store(comppadlist, 0, (SV*)comppad_name);
926 av_store(comppadlist, 1, (SV*)comppad);
748a9306
LW
927 CvPADLIST(compcv) = comppadlist;
928
6e72f9df 929 boot_core_UNIVERSAL();
a0d0e21e
LW
930 if (xsinit)
931 (*xsinit)(); /* in case linked C routines want magical variables */
ad2e33dc 932#if defined(VMS) || defined(WIN32)
748a9306
LW
933 init_os_extras();
934#endif
93a17b20 935
77a005ab
MB
936#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
937 DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
938#endif
939
93a17b20 940 init_predump_symbols();
8990e307
LW
941 if (!do_undump)
942 init_postdump_symbols(argc,argv,env);
93a17b20 943
79072805
LW
944 init_lexer();
945
946 /* now parse the script */
947
948 error_count = 0;
949 if (yyparse() || error_count) {
950 if (minus_c)
463ee0b2 951 croak("%s had compilation errors.\n", origfilename);
79072805 952 else {
463ee0b2 953 croak("Execution of %s aborted due to compilation errors.\n",
79072805 954 origfilename);
378cc40b 955 }
79072805
LW
956 }
957 curcop->cop_line = 0;
958 curstash = defstash;
959 preprocess = FALSE;
ab821d7f 960 if (e_tmpname) {
79072805 961 (void)UNLINK(e_tmpname);
ab821d7f
PP
962 Safefree(e_tmpname);
963 e_tmpname = Nullch;
378cc40b 964 }
a687059c 965
93a17b20 966 /* now that script is parsed, we can modify record separator */
c07a80fd
PP
967 SvREFCNT_dec(rs);
968 rs = SvREFCNT_inc(nrs);
a863c7d1 969#ifdef USE_THREADS
554b3eca 970 sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs);
a863c7d1 971#else
c07a80fd 972 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
a863c7d1 973#endif /* USE_THREADS */
79072805
LW
974 if (do_undump)
975 my_unexec();
976
8990e307
LW
977 if (dowarn)
978 gv_check(defstash);
979
a0d0e21e
LW
980 LEAVE;
981 FREETMPS;
c07a80fd 982
3562ef9b 983#ifdef MYMALLOC
c07a80fd
PP
984 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
985 dump_mstats("after compilation:");
986#endif
987
a0d0e21e
LW
988 ENTER;
989 restartop = 0;
54310121 990 JMPENV_POP;
79072805
LW
991 return 0;
992}
993
994int
8ac85365 995perl_run(PerlInterpreter *sv_interp)
79072805 996{
11343788 997 dTHR;
2ae324a7 998 I32 oldscope;
22921e25
CS
999 dJMPENV;
1000 int ret;
2ae324a7 1001
79072805
LW
1002 if (!(curinterp = sv_interp))
1003 return 255;
2ae324a7
PP
1004
1005 oldscope = scopestack_ix;
1006
22921e25
CS
1007 JMPENV_PUSH(ret);
1008 switch (ret) {
79072805
LW
1009 case 1:
1010 cxstack_ix = -1; /* start context stack again */
1011 break;
1012 case 2:
f86702cc 1013 /* my_exit() was called */
2ae324a7
PP
1014 while (scopestack_ix > oldscope)
1015 LEAVE;
84902520 1016 FREETMPS;
79072805 1017 curstash = defstash;
93a17b20 1018 if (endav)
68dc0745 1019 call_list(oldscope, endav);
3562ef9b 1020#ifdef MYMALLOC
c07a80fd
PP
1021 if (getenv("PERL_DEBUG_MSTATS"))
1022 dump_mstats("after execution: ");
1023#endif
54310121 1024 JMPENV_POP;
f86702cc 1025 return STATUS_NATIVE_EXPORT;
79072805
LW
1026 case 3:
1027 if (!restartop) {
760ac839 1028 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
a0d0e21e 1029 FREETMPS;
54310121 1030 JMPENV_POP;
8990e307 1031 return 1;
83025b21 1032 }
6e72f9df 1033 if (curstack != mainstack) {
79072805 1034 dSP;
6e72f9df 1035 SWITCHSTACK(curstack, mainstack);
79072805
LW
1036 }
1037 break;
8d063cd8 1038 }
79072805 1039
fb73857a 1040 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
6e72f9df
PP
1041 sawampersand ? "Enabling" : "Omitting"));
1042
79072805
LW
1043 if (!restartop) {
1044 DEBUG_x(dump_all());
760ac839 1045 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
11343788 1046#ifdef USE_THREADS
5dc0d613
MB
1047 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1048 (unsigned long) thr));
11343788 1049#endif /* USE_THREADS */
79072805
LW
1050
1051 if (minus_c) {
760ac839 1052 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
79072805
LW
1053 my_exit(0);
1054 }
84902520 1055 if (PERLDB_SINGLE && DBsingle)
a0d0e21e 1056 sv_setiv(DBsingle, 1);
7d07dbc2
MB
1057 if (initav)
1058 call_list(oldscope, initav);
45d8adaa 1059 }
79072805
LW
1060
1061 /* do it */
1062
1063 if (restartop) {
1064 op = restartop;
1065 restartop = 0;
ab821d7f 1066 runops();
79072805
LW
1067 }
1068 else if (main_start) {
4fdae800 1069 CvDEPTH(main_cv) = 1;
79072805 1070 op = main_start;
ab821d7f 1071 runops();
79072805 1072 }
79072805
LW
1073
1074 my_exit(0);
54310121 1075 /* NOTREACHED */
a0d0e21e 1076 return 0;
79072805
LW
1077}
1078
a0d0e21e 1079SV*
8ac85365 1080perl_get_sv(char *name, I32 create)
a0d0e21e 1081{
2faa37cc 1082 GV *gv;
38a03e6e 1083#ifdef USE_THREADS
2faa37cc
MB
1084 if (name[1] == '\0' && !isALPHA(name[0])) {
1085 PADOFFSET tmp = find_thread_magical(name);
1086 if (tmp != NOT_IN_PAD) {
1087 dTHR;
1088 return *av_fetch(thr->magicals, tmp, FALSE);
1089 }
38a03e6e
MB
1090 }
1091#endif /* USE_THREADS */
2faa37cc 1092 gv = gv_fetchpv(name, create, SVt_PV);
a0d0e21e
LW
1093 if (gv)
1094 return GvSV(gv);
1095 return Nullsv;
1096}
1097
1098AV*
8ac85365 1099perl_get_av(char *name, I32 create)
a0d0e21e
LW
1100{
1101 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1102 if (create)
1103 return GvAVn(gv);
1104 if (gv)
1105 return GvAV(gv);
1106 return Nullav;
1107}
1108
1109HV*
8ac85365 1110perl_get_hv(char *name, I32 create)
a0d0e21e
LW
1111{
1112 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1113 if (create)
1114 return GvHVn(gv);
1115 if (gv)
1116 return GvHV(gv);
1117 return Nullhv;
1118}
1119
1120CV*
8ac85365 1121perl_get_cv(char *name, I32 create)
a0d0e21e
LW
1122{
1123 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
8ebc5c01 1124 if (create && !GvCVu(gv))
774d564b 1125 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1126 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1127 Nullop,
a0d0e21e
LW
1128 Nullop);
1129 if (gv)
8ebc5c01 1130 return GvCVu(gv);
a0d0e21e
LW
1131 return Nullcv;
1132}
1133
79072805
LW
1134/* Be sure to refetch the stack pointer after calling these routines. */
1135
a0d0e21e 1136I32
8ac85365
NIS
1137perl_call_argv(char *subname, I32 flags, register char **argv)
1138
1139 /* See G_* flags in cop.h */
1140 /* null terminated arg list */
8990e307 1141{
a0d0e21e 1142 dSP;
8990e307 1143
a0d0e21e
LW
1144 PUSHMARK(sp);
1145 if (argv) {
8990e307 1146 while (*argv) {
a0d0e21e 1147 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW
1148 argv++;
1149 }
a0d0e21e 1150 PUTBACK;
8990e307 1151 }
a0d0e21e 1152 return perl_call_pv(subname, flags);
8990e307
LW
1153}
1154
a0d0e21e 1155I32
8ac85365
NIS
1156perl_call_pv(char *subname, I32 flags)
1157 /* name of the subroutine */
1158 /* See G_* flags in cop.h */
a0d0e21e
LW
1159{
1160 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1161}
1162
1163I32
8ac85365
NIS
1164perl_call_method(char *methname, I32 flags)
1165 /* name of the subroutine */
1166 /* See G_* flags in cop.h */
a0d0e21e
LW
1167{
1168 dSP;
1169 OP myop;
1170 if (!op)
1171 op = &myop;
1172 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1173 PUTBACK;
11343788 1174 pp_method(ARGS);
a0d0e21e
LW
1175 return perl_call_sv(*stack_sp--, flags);
1176}
1177
1178/* May be called with any of a CV, a GV, or an SV containing the name. */
1179I32
8ac85365
NIS
1180perl_call_sv(SV *sv, I32 flags)
1181
1182 /* See G_* flags in cop.h */
a0d0e21e 1183{
11343788 1184 dTHR;
a0d0e21e
LW
1185 LOGOP myop; /* fake syntax tree node */
1186 SV** sp = stack_sp;
aa689395 1187 I32 oldmark;
a0d0e21e 1188 I32 retval;
a0d0e21e 1189 I32 oldscope;
6e72f9df 1190 static CV *DBcv;
54310121
PP
1191 bool oldcatch = CATCH_GET;
1192 dJMPENV;
22921e25 1193 int ret;
d6602a8c 1194 OP* oldop = op;
1e422769 1195
a0d0e21e
LW
1196 if (flags & G_DISCARD) {
1197 ENTER;
1198 SAVETMPS;
1199 }
1200
aa689395 1201 Zero(&myop, 1, LOGOP);
54310121 1202 myop.op_next = Nullop;
f51d4af5 1203 if (!(flags & G_NOARGS))
aa689395 1204 myop.op_flags |= OPf_STACKED;
54310121
PP
1205 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1206 (flags & G_ARRAY) ? OPf_WANT_LIST :
1207 OPf_WANT_SCALAR);
462e5cf6 1208 SAVEOP();
a0d0e21e 1209 op = (OP*)&myop;
aa689395 1210
a0d0e21e
LW
1211 EXTEND(stack_sp, 1);
1212 *++stack_sp = sv;
aa689395 1213 oldmark = TOPMARK;
a0d0e21e
LW
1214 oldscope = scopestack_ix;
1215
84902520 1216 if (PERLDB_SUB && curstash != debstash
36477c24
PP
1217 /* Handle first BEGIN of -d. */
1218 && (DBcv || (DBcv = GvCV(DBsub)))
1219 /* Try harder, since this may have been a sighandler, thus
1220 * curstash may be meaningless. */
1221 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
6e72f9df 1222 op->op_private |= OPpENTERSUB_DB;
a0d0e21e
LW
1223
1224 if (flags & G_EVAL) {
a0d0e21e
LW
1225 cLOGOP->op_other = op;
1226 markstack_ptr--;
4633a7c4
LW
1227 /* we're trying to emulate pp_entertry() here */
1228 {
c09156bb 1229 register PERL_CONTEXT *cx;
54310121 1230 I32 gimme = GIMME_V;
4633a7c4
LW
1231
1232 ENTER;
1233 SAVETMPS;
1234
1235 push_return(op->op_next);
1236 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1237 PUSHEVAL(cx, 0, 0);
1238 eval_root = op; /* Only needed so that goto works right. */
1239
1240 in_eval = 1;
1241 if (flags & G_KEEPERR)
1242 in_eval |= 4;
1243 else
38a03e6e 1244 sv_setpv(ERRSV,"");
4633a7c4 1245 }
a0d0e21e
LW
1246 markstack_ptr++;
1247
22921e25
CS
1248 JMPENV_PUSH(ret);
1249 switch (ret) {
a0d0e21e
LW
1250 case 0:
1251 break;
1252 case 1:
f86702cc 1253 STATUS_ALL_FAILURE;
a0d0e21e
LW
1254 /* FALL THROUGH */
1255 case 2:
1256 /* my_exit() was called */
1257 curstash = defstash;
1258 FREETMPS;
54310121 1259 JMPENV_POP;
a0d0e21e
LW
1260 if (statusvalue)
1261 croak("Callback called exit");
f86702cc 1262 my_exit_jump();
a0d0e21e
LW
1263 /* NOTREACHED */
1264 case 3:
1265 if (restartop) {
1266 op = restartop;
1267 restartop = 0;
54310121 1268 break;
a0d0e21e
LW
1269 }
1270 stack_sp = stack_base + oldmark;
1271 if (flags & G_ARRAY)
1272 retval = 0;
1273 else {
1274 retval = 1;
1275 *++stack_sp = &sv_undef;
1276 }
1277 goto cleanup;
1278 }
1279 }
1e422769 1280 else
54310121 1281 CATCH_SET(TRUE);
a0d0e21e
LW
1282
1283 if (op == (OP*)&myop)
11343788 1284 op = pp_entersub(ARGS);
a0d0e21e 1285 if (op)
ab821d7f 1286 runops();
a0d0e21e 1287 retval = stack_sp - (stack_base + oldmark);
4633a7c4 1288 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
38a03e6e 1289 sv_setpv(ERRSV,"");
a0d0e21e
LW
1290
1291 cleanup:
1292 if (flags & G_EVAL) {
1293 if (scopestack_ix > oldscope) {
a0a2876f
LW
1294 SV **newsp;
1295 PMOP *newpm;
1296 I32 gimme;
c09156bb 1297 register PERL_CONTEXT *cx;
a0a2876f
LW
1298 I32 optype;
1299
1300 POPBLOCK(cx,newpm);
1301 POPEVAL(cx);
1302 pop_return();
1303 curpm = newpm;
1304 LEAVE;
a0d0e21e 1305 }
54310121 1306 JMPENV_POP;
a0d0e21e 1307 }
1e422769 1308 else
54310121 1309 CATCH_SET(oldcatch);
1e422769 1310
a0d0e21e
LW
1311 if (flags & G_DISCARD) {
1312 stack_sp = stack_base + oldmark;
1313 retval = 0;
1314 FREETMPS;
1315 LEAVE;
1316 }
d6602a8c 1317 op = oldop;
a0d0e21e
LW
1318 return retval;
1319}
1320
6e72f9df 1321/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 1322
a0d0e21e 1323I32
8ac85365
NIS
1324perl_eval_sv(SV *sv, I32 flags)
1325
1326 /* See G_* flags in cop.h */
a0d0e21e 1327{
11343788 1328 dTHR;
a0d0e21e 1329 UNOP myop; /* fake syntax tree node */
4633a7c4
LW
1330 SV** sp = stack_sp;
1331 I32 oldmark = sp - stack_base;
1332 I32 retval;
4633a7c4 1333 I32 oldscope;
54310121 1334 dJMPENV;
22921e25 1335 int ret;
84902520
TB
1336 OP* oldop = op;
1337
4633a7c4
LW
1338 if (flags & G_DISCARD) {
1339 ENTER;
1340 SAVETMPS;
1341 }
1342
462e5cf6 1343 SAVEOP();
79072805 1344 op = (OP*)&myop;
a0d0e21e 1345 Zero(op, 1, UNOP);
4633a7c4
LW
1346 EXTEND(stack_sp, 1);
1347 *++stack_sp = sv;
1348 oldscope = scopestack_ix;
79072805 1349
4633a7c4
LW
1350 if (!(flags & G_NOARGS))
1351 myop.op_flags = OPf_STACKED;
79072805 1352 myop.op_next = Nullop;
6e72f9df 1353 myop.op_type = OP_ENTEREVAL;
54310121
PP
1354 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1355 (flags & G_ARRAY) ? OPf_WANT_LIST :
1356 OPf_WANT_SCALAR);
6e72f9df
PP
1357 if (flags & G_KEEPERR)
1358 myop.op_flags |= OPf_SPECIAL;
4633a7c4 1359
22921e25
CS
1360 JMPENV_PUSH(ret);
1361 switch (ret) {
4633a7c4
LW
1362 case 0:
1363 break;
1364 case 1:
f86702cc 1365 STATUS_ALL_FAILURE;
4633a7c4
LW
1366 /* FALL THROUGH */
1367 case 2:
1368 /* my_exit() was called */
1369 curstash = defstash;
1370 FREETMPS;
54310121 1371 JMPENV_POP;
4633a7c4
LW
1372 if (statusvalue)
1373 croak("Callback called exit");
f86702cc 1374 my_exit_jump();
4633a7c4
LW
1375 /* NOTREACHED */
1376 case 3:
1377 if (restartop) {
1378 op = restartop;
1379 restartop = 0;
54310121 1380 break;
4633a7c4
LW
1381 }
1382 stack_sp = stack_base + oldmark;
1383 if (flags & G_ARRAY)
1384 retval = 0;
1385 else {
1386 retval = 1;
1387 *++stack_sp = &sv_undef;
1388 }
1389 goto cleanup;
1390 }
1391
1392 if (op == (OP*)&myop)
11343788 1393 op = pp_entereval(ARGS);
4633a7c4 1394 if (op)
ab821d7f 1395 runops();
4633a7c4 1396 retval = stack_sp - (stack_base + oldmark);
6e72f9df 1397 if (!(flags & G_KEEPERR))
38a03e6e 1398 sv_setpv(ERRSV,"");
4633a7c4
LW
1399
1400 cleanup:
54310121 1401 JMPENV_POP;
4633a7c4
LW
1402 if (flags & G_DISCARD) {
1403 stack_sp = stack_base + oldmark;
1404 retval = 0;
1405 FREETMPS;
1406 LEAVE;
1407 }
84902520 1408 op = oldop;
4633a7c4
LW
1409 return retval;
1410}
1411
137443ea 1412SV*
8ac85365 1413perl_eval_pv(char *p, I32 croak_on_error)
137443ea
PP
1414{
1415 dSP;
1416 SV* sv = newSVpv(p, 0);
1417
1418 PUSHMARK(sp);
1419 perl_eval_sv(sv, G_SCALAR);
1420 SvREFCNT_dec(sv);
1421
1422 SPAGAIN;
1423 sv = POPs;
1424 PUTBACK;
1425
38a03e6e
MB
1426 if (croak_on_error && SvTRUE(ERRSV))
1427 croak(SvPVx(ERRSV, na));
137443ea
PP
1428
1429 return sv;
1430}
1431
4633a7c4
LW
1432/* Require a module. */
1433
1434void
8ac85365 1435perl_require_pv(char *pv)
4633a7c4
LW
1436{
1437 SV* sv = sv_newmortal();
1438 sv_setpv(sv, "require '");
1439 sv_catpv(sv, pv);
1440 sv_catpv(sv, "'");
1441 perl_eval_sv(sv, G_DISCARD);
79072805
LW
1442}
1443
79072805 1444void
8ac85365 1445magicname(char *sym, char *name, I32 namlen)
79072805
LW
1446{
1447 register GV *gv;
1448
85e6fe83 1449 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
79072805
LW
1450 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1451}
1452
ab821d7f 1453static void
8ac85365
NIS
1454usage(char *name) /* XXX move this out into a module ? */
1455
4633a7c4 1456{
ab821d7f
PP
1457 /* This message really ought to be max 23 lines.
1458 * Removed -h because the user already knows that opton. Others? */
fb73857a
PP
1459
1460 static char *usage[] = {
1461"-0[octal] specify record separator (\\0, if no argument)",
1462"-a autosplit mode with -n or -p (splits $_ into @F)",
1463"-c check syntax only (runs BEGIN and END blocks)",
1464"-d[:debugger] run scripts under debugger",
1465"-D[number/list] set debugging flags (argument is a bit mask or flags)",
1466"-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1467"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1468"-i[extension] edit <> files in place (make backup if extension supplied)",
1469"-Idirectory specify @INC/#include directory (may be used more than once)",
1470"-l[octal] enable line ending processing, specifies line terminator",
1471"-[mM][-]module.. executes `use/no module...' before executing your script.",
1472"-n assume 'while (<>) { ... }' loop around your script",
1473"-p assume loop like -n but print line also like sed",
1474"-P run script through C preprocessor before compilation",
1475"-s enable some switch parsing for switches after script name",
1476"-S look for the script using PATH environment variable",
1477"-T turn on tainting checks",
1478"-u dump core after parsing script",
1479"-U allow unsafe operations",
1480"-v print version number and patchlevel of perl",
1481"-V[:variable] print perl configuration information",
1482"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1483"-x[directory] strip off text before #!perl line and perhaps cd to directory",
1484"\n",
1485NULL
1486};
1487 char **p = usage;
1488
ab821d7f 1489 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
fb73857a
PP
1490 while (*p)
1491 printf("\n %s", *p++);
4633a7c4
LW
1492}
1493
79072805
LW
1494/* This routine handles any switches that can be given during run */
1495
1496char *
8ac85365 1497moreswitches(char *s)
79072805
LW
1498{
1499 I32 numlen;
c07a80fd 1500 U32 rschar;
79072805
LW
1501
1502 switch (*s) {
1503 case '0':
a863c7d1
MB
1504 {
1505 dTHR;
c07a80fd
PP
1506 rschar = scan_oct(s, 4, &numlen);
1507 SvREFCNT_dec(nrs);
1508 if (rschar & ~((U8)~0))
1509 nrs = &sv_undef;
1510 else if (!rschar && numlen >= 2)
1511 nrs = newSVpv("", 0);
1512 else {
1513 char ch = rschar;
1514 nrs = newSVpv(&ch, 1);
79072805
LW
1515 }
1516 return s + numlen;
a863c7d1 1517 }
2304df62
AD
1518 case 'F':
1519 minus_F = TRUE;
a0d0e21e 1520 splitstr = savepv(s + 1);
2304df62
AD
1521 s += strlen(s);
1522 return s;
79072805
LW
1523 case 'a':
1524 minus_a = TRUE;
1525 s++;
1526 return s;
1527 case 'c':
1528 minus_c = TRUE;
1529 s++;
1530 return s;
1531 case 'd':
bbce6d69 1532 forbid_setid("-d");
4633a7c4 1533 s++;
c07a80fd 1534 if (*s == ':' || *s == '=') {
46fc3d4c 1535 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
4633a7c4 1536 s += strlen(s);
4633a7c4 1537 }
a0d0e21e 1538 if (!perldb) {
84902520 1539 perldb = PERLDB_ALL;
a0d0e21e
LW
1540 init_debugger();
1541 }
79072805
LW
1542 return s;
1543 case 'D':
1544#ifdef DEBUGGING
bbce6d69 1545 forbid_setid("-D");
79072805 1546 if (isALPHA(s[1])) {
8990e307 1547 static char debopts[] = "psltocPmfrxuLHXD";
79072805
LW
1548 char *d;
1549
93a17b20 1550 for (s++; *s && (d = strchr(debopts,*s)); s++)
79072805
LW
1551 debug |= 1 << (d - debopts);
1552 }
1553 else {
1554 debug = atoi(s+1);
1555 for (s++; isDIGIT(*s); s++) ;
1556 }
8990e307 1557 debug |= 0x80000000;
79072805
LW
1558#else
1559 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 1560 for (s++; isALNUM(*s); s++) ;
79072805
LW
1561#endif
1562 /*SUPPRESS 530*/
1563 return s;
4633a7c4
LW
1564 case 'h':
1565 usage(origargv[0]);
1566 exit(0);
79072805
LW
1567 case 'i':
1568 if (inplace)
1569 Safefree(inplace);
a0d0e21e 1570 inplace = savepv(s+1);
79072805
LW
1571 /*SUPPRESS 530*/
1572 for (s = inplace; *s && !isSPACE(*s); s++) ;
fb73857a
PP
1573 if (*s)
1574 *s++ = '\0';
1575 return s;
1576 case 'I': /* -I handled both here and in parse_perl() */
bbce6d69 1577 forbid_setid("-I");
fb73857a
PP
1578 ++s;
1579 while (*s && isSPACE(*s))
1580 ++s;
1581 if (*s) {
774d564b 1582 char *e, *p;
748a9306 1583 for (e = s; *e && !isSPACE(*e); e++) ;
774d564b
PP
1584 p = savepvn(s, e-s);
1585 incpush(p, TRUE);
1586 Safefree(p);
fb73857a 1587 s = e;
79072805
LW
1588 }
1589 else
463ee0b2 1590 croak("No space allowed after -I");
fb73857a 1591 return s;
79072805
LW
1592 case 'l':
1593 minus_l = TRUE;
1594 s++;
a0d0e21e
LW
1595 if (ors)
1596 Safefree(ors);
79072805 1597 if (isDIGIT(*s)) {
a0d0e21e 1598 ors = savepv("\n");
79072805
LW
1599 orslen = 1;
1600 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1601 s += numlen;
1602 }
1603 else {
a863c7d1 1604 dTHR;
c07a80fd 1605 if (RsPARA(nrs)) {
6e72f9df 1606 ors = "\n\n";
c07a80fd
PP
1607 orslen = 2;
1608 }
1609 else
1610 ors = SvPV(nrs, orslen);
6e72f9df 1611 ors = savepvn(ors, orslen);
79072805
LW
1612 }
1613 return s;
1a30305b 1614 case 'M':
bbce6d69 1615 forbid_setid("-M"); /* XXX ? */
1a30305b
PP
1616 /* FALL THROUGH */
1617 case 'm':
bbce6d69 1618 forbid_setid("-m"); /* XXX ? */
1a30305b 1619 if (*++s) {
a5f75d66 1620 char *start;
11343788 1621 SV *sv;
a5f75d66
AD
1622 char *use = "use ";
1623 /* -M-foo == 'no foo' */
1624 if (*s == '-') { use = "no "; ++s; }
11343788 1625 sv = newSVpv(use,0);
a5f75d66 1626 start = s;
1a30305b 1627 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd
PP
1628 while(isALNUM(*s) || *s==':') ++s;
1629 if (*s != '=') {
11343788 1630 sv_catpv(sv, start);
c07a80fd
PP
1631 if (*(start-1) == 'm') {
1632 if (*s != '\0')
1633 croak("Can't use '%c' after -mname", *s);
11343788 1634 sv_catpv( sv, " ()");
c07a80fd
PP
1635 }
1636 } else {
11343788
MB
1637 sv_catpvn(sv, start, s-start);
1638 sv_catpv(sv, " split(/,/,q{");
1639 sv_catpv(sv, ++s);
1640 sv_catpv(sv, "})");
c07a80fd 1641 }
1a30305b 1642 s += strlen(s);
c07a80fd
PP
1643 if (preambleav == NULL)
1644 preambleav = newAV();
11343788 1645 av_push(preambleav, sv);
1a30305b
PP
1646 }
1647 else
1648 croak("No space allowed after -%c", *(s-1));
1649 return s;
79072805
LW
1650 case 'n':
1651 minus_n = TRUE;
1652 s++;
1653 return s;
1654 case 'p':
1655 minus_p = TRUE;
1656 s++;
1657 return s;
1658 case 's':
bbce6d69 1659 forbid_setid("-s");
79072805
LW
1660 doswitches = TRUE;
1661 s++;
1662 return s;
463ee0b2 1663 case 'T':
f86702cc 1664 if (!tainting)
9607fc9c 1665 croak("Too late for \"-T\" option");
463ee0b2
LW
1666 s++;
1667 return s;
79072805
LW
1668 case 'u':
1669 do_undump = TRUE;
1670 s++;
1671 return s;
1672 case 'U':
1673 unsafe = TRUE;
1674 s++;
1675 return s;
1676 case 'v':
a5f75d66 1677#if defined(SUBVERSION) && SUBVERSION > 0
fb73857a
PP
1678 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1679 PATCHLEVEL, SUBVERSION, ARCHNAME);
a5f75d66 1680#else
fb73857a
PP
1681 printf("\nThis is perl, version %s built for %s",
1682 patchlevel, ARCHNAME);
1683#endif
1684#if defined(LOCAL_PATCH_COUNT)
1685 if (LOCAL_PATCH_COUNT > 0)
1686 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1687 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 1688#endif
1a30305b 1689
44a8e56a 1690 printf("\n\nCopyright 1987-1997, Larry Wall\n");
79072805 1691#ifdef MSDOS
fb73857a 1692 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff
PP
1693#endif
1694#ifdef DJGPP
1695 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
4633a7c4 1696#endif
79072805 1697#ifdef OS2
5dd60ef7 1698 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
9607fc9c 1699 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
79072805 1700#endif
79072805 1701#ifdef atarist
760ac839 1702 printf("atariST series port, ++jrb bammi@cadence.com\n");
79072805 1703#endif
760ac839 1704 printf("\n\
79072805 1705Perl may be copied only under the terms of either the Artistic License or the\n\
760ac839 1706GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
79072805
LW
1707 exit(0);
1708 case 'w':
1709 dowarn = TRUE;
1710 s++;
1711 return s;
a0d0e21e 1712 case '*':
79072805
LW
1713 case ' ':
1714 if (s[1] == '-') /* Additional switches on #! line. */
1715 return s+2;
1716 break;
a0d0e21e 1717 case '-':
79072805
LW
1718 case 0:
1719 case '\n':
1720 case '\t':
1721 break;
aa689395
PP
1722#ifdef ALTERNATE_SHEBANG
1723 case 'S': /* OS/2 needs -S on "extproc" line. */
1724 break;
1725#endif
a0d0e21e
LW
1726 case 'P':
1727 if (preprocess)
1728 return s+1;
1729 /* FALL THROUGH */
79072805 1730 default:
a0d0e21e 1731 croak("Can't emulate -%.1s on #! line",s);
79072805
LW
1732 }
1733 return Nullch;
1734}
1735
1736/* compliments of Tom Christiansen */
1737
1738/* unexec() can be found in the Gnu emacs distribution */
1739
1740void
8ac85365 1741my_unexec(void)
79072805
LW
1742{
1743#ifdef UNEXEC
46fc3d4c
PP
1744 SV* prog;
1745 SV* file;
79072805
LW
1746 int status;
1747 extern int etext;
1748
46fc3d4c
PP
1749 prog = newSVpv(BIN_EXP);
1750 sv_catpv(prog, "/perl");
1751 file = newSVpv(origfilename);
1752 sv_catpv(file, ".perldump");
79072805 1753
46fc3d4c 1754 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
79072805 1755 if (status)
46fc3d4c
PP
1756 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1757 SvPVX(prog), SvPVX(file));
a0d0e21e 1758 exit(status);
79072805 1759#else
a5f75d66
AD
1760# ifdef VMS
1761# include <lib$routines.h>
1762 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 1763# else
79072805 1764 ABORT(); /* for use with undump */
aa689395 1765# endif
a5f75d66 1766#endif
79072805
LW
1767}
1768
1769static void
8ac85365 1770init_main_stash(void)
79072805 1771{
11343788 1772 dTHR;
463ee0b2 1773 GV *gv;
6e72f9df
PP
1774
1775 /* Note that strtab is a rather special HV. Assumptions are made
1776 about not iterating on it, and not adding tie magic to it.
1777 It is properly deallocated in perl_destruct() */
1778 strtab = newHV();
1779 HvSHAREKEYS_off(strtab); /* mandatory */
1780 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1781 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1782
463ee0b2 1783 curstash = defstash = newHV();
79072805 1784 curstname = newSVpv("main",4);
adbc6bb1
LW
1785 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1786 SvREFCNT_dec(GvHV(gv));
1787 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
463ee0b2 1788 SvREADONLY_on(gv);
a0d0e21e 1789 HvNAME(defstash) = savepv("main");
85e6fe83 1790 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
a5f75d66 1791 GvMULTI_on(incgv);
a0d0e21e 1792 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
12f917ad
MB
1793 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1794 GvMULTI_on(errgv);
84902520 1795 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB
1796 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1797 sv_setpvn(ERRSV, "", 0);
8990e307
LW
1798 curstash = defstash;
1799 compiling.cop_stash = defstash;
adbc6bb1 1800 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
49dc05e3 1801 globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4
LW
1802 /* We must init $/ before switches are processed. */
1803 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
79072805
LW
1804}
1805
a0d0e21e
LW
1806#ifdef CAN_PROTOTYPE
1807static void
1808open_script(char *scriptname, bool dosearch, SV *sv)
1809#else
79072805
LW
1810static void
1811open_script(scriptname,dosearch,sv)
1812char *scriptname;
1813bool dosearch;
1814SV *sv;
a0d0e21e 1815#endif
79072805 1816{
0f15f207 1817 dTHR;
79072805
LW
1818 char *xfound = Nullch;
1819 char *xfailed = Nullch;
1820 register char *s;
1821 I32 len;
a38d6535
LW
1822 int retval;
1823#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
fc36a67e
PP
1824# define SEARCH_EXTS ".bat", ".cmd", NULL
1825# define MAX_EXT_LEN 4
a38d6535 1826#endif
d8c2d278
IZ
1827#ifdef OS2
1828# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
1829# define MAX_EXT_LEN 4
1830#endif
ab821d7f
PP
1831#ifdef VMS
1832# define SEARCH_EXTS ".pl", ".com", NULL
fc36a67e 1833# define MAX_EXT_LEN 4
ab821d7f 1834#endif
a38d6535
LW
1835 /* additional extensions to try in each dir if scriptname not found */
1836#ifdef SEARCH_EXTS
1837 char *ext[] = { SEARCH_EXTS };
2a92aaa0
GS
1838 int extidx = 0, i = 0;
1839 char *curext = Nullch;
fc36a67e
PP
1840#else
1841# define MAX_EXT_LEN 0
a38d6535 1842#endif
79072805 1843
2a92aaa0
GS
1844 /*
1845 * If dosearch is true and if scriptname does not contain path
1846 * delimiters, search the PATH for scriptname.
1847 *
1848 * If SEARCH_EXTS is also defined, will look for each
1849 * scriptname{SEARCH_EXTS} whenever scriptname is not found
1850 * while searching the PATH.
1851 *
1852 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
1853 * proceeds as follows:
1854 * If DOSISH:
1855 * + look for ./scriptname{,.foo,.bar}
1856 * + search the PATH for scriptname{,.foo,.bar}
1857 *
1858 * If !DOSISH:
1859 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
1860 * this will not look in '.' if it's not in the PATH)
1861 */
1862
c07a80fd 1863#ifdef VMS
6e72f9df
PP
1864 if (dosearch) {
1865 int hasdir, idx = 0, deftypes = 1;
1a2dec3c 1866 bool seen_dot = 1;
6e72f9df
PP
1867
1868 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1869 /* The first time through, just add SEARCH_EXTS to whatever we
1870 * already have, so we can check for default file types. */
fc36a67e
PP
1871 while (deftypes ||
1872 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1873 {
1874 if (deftypes) {
1875 deftypes = 0;
1876 *tokenbuf = '\0';
1877 }
1878 if ((strlen(tokenbuf) + strlen(scriptname)
1879 + MAX_EXT_LEN) >= sizeof tokenbuf)
1880 continue; /* don't search dir with too-long name */
1881 strcat(tokenbuf, scriptname);
c07a80fd 1882#else /* !VMS */
2a92aaa0 1883
fc36a67e 1884#ifdef DOSISH
2a92aaa0 1885 if (strEQ(scriptname, "-"))
84902520 1886 dosearch = 0;
2a92aaa0
GS
1887 if (dosearch) { /* Look in '.' first. */
1888 char *cur = scriptname;
1889#ifdef SEARCH_EXTS
1890 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
1891 while (ext[i])
1892 if (strEQ(ext[i++],curext)) {
1893 extidx = -1; /* already has an ext */
1894 break;
1895 }
1896 do {
79072805 1897#endif
2a92aaa0
GS
1898 DEBUG_p(PerlIO_printf(Perl_debug_log,
1899 "Looking for %s\n",cur));
1900 if (Stat(cur,&statbuf) >= 0) {
1901 dosearch = 0;
1902 scriptname = cur;
84902520 1903#ifdef SEARCH_EXTS
2a92aaa0 1904 break;
84902520 1905#endif
2a92aaa0
GS
1906 }
1907#ifdef SEARCH_EXTS
1908 if (cur == scriptname) {
1909 len = strlen(scriptname);
1910 if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
1911 break;
1912 cur = strcpy(tokenbuf, scriptname);
1913 }
1914 } while (extidx >= 0 && ext[extidx] /* try an extension? */
1915 && strcpy(tokenbuf+len, ext[extidx++]));
1916#endif
1917 }
1918#endif
84902520 1919
e92c4225
WJ
1920 if (dosearch && !strchr(scriptname, '/')
1921#ifdef DOSISH
1922 && !strchr(scriptname, '\\')
1923#endif
1924 && (s = getenv("PATH"))) {
2a92aaa0 1925 bool seen_dot = 0;
84902520 1926
79072805 1927 bufend = s + strlen(s);
fc36a67e 1928 while (s < bufend) {
2a92aaa0
GS
1929#if defined(atarist) || defined(DOSISH)
1930 for (len = 0; *s
1931# ifdef atarist
1932 && *s != ','
1933# endif
1934 && *s != ';'; len++, s++) {
fc36a67e
PP
1935 if (len < sizeof tokenbuf)
1936 tokenbuf[len] = *s;
1937 }
1938 if (len < sizeof tokenbuf)
1939 tokenbuf[len] = '\0';
84902520
TB
1940#else /* ! (atarist || DOSISH) */
1941 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1942 ':',
1943 &len);
1944#endif /* ! (atarist || DOSISH) */
fc36a67e 1945 if (s < bufend)
79072805 1946 s++;
fc36a67e
PP
1947 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1948 continue; /* don't search dir with too-long name */
1949 if (len
fc36a67e 1950#if defined(atarist) || defined(DOSISH)
2a92aaa0 1951 && tokenbuf[len - 1] != '/'
fc36a67e 1952 && tokenbuf[len - 1] != '\\'
79072805 1953#endif
fc36a67e
PP
1954 )
1955 tokenbuf[len++] = '/';
84902520 1956 if (len == 2 && tokenbuf[0] == '.')
2a92aaa0 1957 seen_dot = 1;
fc36a67e 1958 (void)strcpy(tokenbuf + len, scriptname);
c07a80fd 1959#endif /* !VMS */
a38d6535
LW
1960
1961#ifdef SEARCH_EXTS
1962 len = strlen(tokenbuf);
1963 if (extidx > 0) /* reset after previous loop */
1964 extidx = 0;
1965 do {
1966#endif
760ac839 1967 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
a38d6535
LW
1968 retval = Stat(tokenbuf,&statbuf);
1969#ifdef SEARCH_EXTS
1970 } while ( retval < 0 /* not there */
1971 && extidx>=0 && ext[extidx] /* try an extension? */
1972 && strcpy(tokenbuf+len, ext[extidx++])
1973 );
1974#endif
1975 if (retval < 0)
79072805
LW
1976 continue;
1977 if (S_ISREG(statbuf.st_mode)
c90c0ff4
PP
1978 && cando(S_IRUSR,TRUE,&statbuf)
1979#ifndef DOSISH
1980 && cando(S_IXUSR,TRUE,&statbuf)
1981#endif
1982 )
1983 {
79072805
LW
1984 xfound = tokenbuf; /* bingo! */
1985 break;
1986 }
1987 if (!xfailed)
a0d0e21e 1988 xfailed = savepv(tokenbuf);
79072805 1989 }
2a92aaa0
GS
1990#ifndef DOSISH
1991 if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
84902520
TB
1992#endif
1993 seen_dot = 1; /* Disable message. */
79072805 1994 if (!xfound)
84902520 1995 croak("Can't %s %s%s%s",
2a92aaa0
GS
1996 (xfailed ? "execute" : "find"),
1997 (xfailed ? xfailed : scriptname),
1998 (xfailed ? "" : " on PATH"),
1999 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
79072805
LW
2000 if (xfailed)
2001 Safefree(xfailed);
2002 scriptname = xfound;
2003 }
2004
96436eeb
PP
2005 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2006 char *s = scriptname + 8;
2007 fdscript = atoi(s);
2008 while (isDIGIT(*s))
2009 s++;
2010 if (*s)
2011 scriptname = s + 1;
2012 }
2013 else
2014 fdscript = -1;
ab821d7f 2015 origfilename = savepv(e_tmpname ? "-e" : scriptname);
79072805
LW
2016 curcop->cop_filegv = gv_fetchfile(origfilename);
2017 if (strEQ(origfilename,"-"))
2018 scriptname = "";
96436eeb 2019 if (fdscript >= 0) {
760ac839 2020 rsfp = PerlIO_fdopen(fdscript,"r");
96436eeb 2021#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
2022 if (rsfp)
2023 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
2024#endif
2025 }
2026 else if (preprocess) {
46fc3d4c
PP
2027 char *cpp_cfg = CPPSTDIN;
2028 SV *cpp = NEWSV(0,0);
2029 SV *cmd = NEWSV(0,0);
2030
2031 if (strEQ(cpp_cfg, "cppstdin"))
2032 sv_catpvf(cpp, "%s/", BIN_EXP);
2033 sv_catpv(cpp, cpp_cfg);
79072805 2034
79072805 2035 sv_catpv(sv,"-I");
fed7345c 2036 sv_catpv(sv,PRIVLIB_EXP);
46fc3d4c 2037
79072805 2038#ifdef MSDOS
46fc3d4c 2039 sv_setpvf(cmd, "\
79072805
LW
2040sed %s -e \"/^[^#]/b\" \
2041 -e \"/^#[ ]*include[ ]/b\" \
2042 -e \"/^#[ ]*define[ ]/b\" \
2043 -e \"/^#[ ]*if[ ]/b\" \
2044 -e \"/^#[ ]*ifdef[ ]/b\" \
2045 -e \"/^#[ ]*ifndef[ ]/b\" \
2046 -e \"/^#[ ]*else/b\" \
2047 -e \"/^#[ ]*elif[ ]/b\" \
2048 -e \"/^#[ ]*undef[ ]/b\" \
2049 -e \"/^#[ ]*endif/b\" \
2050 -e \"s/^#.*//\" \
fc36a67e 2051 %s | %_ -C %_ %s",
79072805
LW
2052 (doextract ? "-e \"1,/^#/d\n\"" : ""),
2053#else
46fc3d4c 2054 sv_setpvf(cmd, "\
79072805
LW
2055%s %s -e '/^[^#]/b' \
2056 -e '/^#[ ]*include[ ]/b' \
2057 -e '/^#[ ]*define[ ]/b' \
2058 -e '/^#[ ]*if[ ]/b' \
2059 -e '/^#[ ]*ifdef[ ]/b' \
2060 -e '/^#[ ]*ifndef[ ]/b' \
2061 -e '/^#[ ]*else/b' \
2062 -e '/^#[ ]*elif[ ]/b' \
2063 -e '/^#[ ]*undef[ ]/b' \
2064 -e '/^#[ ]*endif/b' \
2065 -e 's/^[ ]*#.*//' \
fc36a67e 2066 %s | %_ -C %_ %s",
79072805
LW
2067#ifdef LOC_SED
2068 LOC_SED,
2069#else
2070 "sed",
2071#endif
2072 (doextract ? "-e '1,/^#/d\n'" : ""),
2073#endif
46fc3d4c 2074 scriptname, cpp, sv, CPPMINUS);
79072805
LW
2075 doextract = FALSE;
2076#ifdef IAMSUID /* actually, this is caught earlier */
2077 if (euid != uid && !euid) { /* if running suidperl */
2078#ifdef HAS_SETEUID
2079 (void)seteuid(uid); /* musn't stay setuid root */
2080#else
2081#ifdef HAS_SETREUID
85e6fe83
LW
2082 (void)setreuid((Uid_t)-1, uid);
2083#else
2084#ifdef HAS_SETRESUID
2085 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
79072805
LW
2086#else
2087 setuid(uid);
2088#endif
2089#endif
85e6fe83 2090#endif
79072805 2091 if (geteuid() != uid)
463ee0b2 2092 croak("Can't do seteuid!\n");
79072805
LW
2093 }
2094#endif /* IAMSUID */
46fc3d4c
PP
2095 rsfp = my_popen(SvPVX(cmd), "r");
2096 SvREFCNT_dec(cmd);
2097 SvREFCNT_dec(cpp);
79072805
LW
2098 }
2099 else if (!*scriptname) {
bbce6d69 2100 forbid_setid("program input from stdin");
760ac839 2101 rsfp = PerlIO_stdin();
79072805 2102 }
96436eeb 2103 else {
760ac839 2104 rsfp = PerlIO_open(scriptname,"r");
96436eeb 2105#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
2106 if (rsfp)
2107 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
2108#endif
2109 }
5dd60ef7
PP
2110 if (e_tmpname) {
2111 e_fp = rsfp;
2112 }
7aa04957 2113 if (!rsfp) {
13281fa4 2114#ifdef DOSUID
a687059c 2115#ifndef IAMSUID /* in case script is not readable before setuid */
a0d0e21e 2116 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
13281fa4 2117 statbuf.st_mode & (S_ISUID|S_ISGID)) {
46fc3d4c
PP
2118 /* try again */
2119 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
463ee0b2 2120 croak("Can't do setuid\n");
13281fa4
LW
2121 }
2122#endif
2123#endif
463ee0b2 2124 croak("Can't open perl script \"%s\": %s\n",
2304df62 2125 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
13281fa4 2126 }
79072805 2127}
8d063cd8 2128
79072805 2129static void
8ac85365 2130validate_suid(char *validarg, char *scriptname)
79072805 2131{
96436eeb
PP
2132 int which;
2133
13281fa4
LW
2134 /* do we need to emulate setuid on scripts? */
2135
2136 /* This code is for those BSD systems that have setuid #! scripts disabled
2137 * in the kernel because of a security problem. Merely defining DOSUID
2138 * in perl will not fix that problem, but if you have disabled setuid
2139 * scripts in the kernel, this will attempt to emulate setuid and setgid
2140 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW
2141 * root version must be called suidperl or sperlN.NNN. If regular perl
2142 * discovers that it has opened a setuid script, it calls suidperl with
2143 * the same argv that it had. If suidperl finds that the script it has
2144 * just opened is NOT setuid root, it sets the effective uid back to the
2145 * uid. We don't just make perl setuid root because that loses the
2146 * effective uid we had before invoking perl, if it was different from the
2147 * uid.
13281fa4
LW
2148 *
2149 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2150 * be defined in suidperl only. suidperl must be setuid root. The
2151 * Configure script will set this up for you if you want it.
2152 */
a687059c 2153
13281fa4 2154#ifdef DOSUID
ea0efc06 2155 dTHR;
6e72f9df 2156 char *s, *s2;
a0d0e21e 2157
760ac839 2158 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
463ee0b2 2159 croak("Can't stat script \"%s\"",origfilename);
96436eeb 2160 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2161 I32 len;
13281fa4 2162
a687059c 2163#ifdef IAMSUID
fe14fcc3 2164#ifndef HAS_SETREUID
a687059c
LW
2165 /* On this access check to make sure the directories are readable,
2166 * there is actually a small window that the user could use to make
2167 * filename point to an accessible directory. So there is a faint
2168 * chance that someone could execute a setuid script down in a
2169 * non-accessible directory. I don't know what to do about that.
2170 * But I don't think it's too important. The manual lies when
2171 * it says access() is useful in setuid programs.
2172 */
463ee0b2
LW
2173 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2174 croak("Permission denied");
a687059c
LW
2175#else
2176 /* If we can swap euid and uid, then we can determine access rights
2177 * with a simple stat of the file, and then compare device and
2178 * inode to make sure we did stat() on the same file we opened.
2179 * Then we just have to make sure he or she can execute it.
2180 */
2181 {
2182 struct stat tmpstatbuf;
2183
85e6fe83
LW
2184 if (
2185#ifdef HAS_SETREUID
2186 setreuid(euid,uid) < 0
a0d0e21e
LW
2187#else
2188# if HAS_SETRESUID
85e6fe83 2189 setresuid(euid,uid,(Uid_t)-1) < 0
a0d0e21e 2190# endif
85e6fe83
LW
2191#endif
2192 || getuid() != euid || geteuid() != uid)
463ee0b2 2193 croak("Can't swap uid and euid"); /* really paranoid */
a0d0e21e 2194 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
463ee0b2 2195 croak("Permission denied"); /* testing full pathname here */
a687059c
LW
2196 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2197 tmpstatbuf.st_ino != statbuf.st_ino) {
760ac839 2198 (void)PerlIO_close(rsfp);
79072805 2199 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
760ac839 2200 PerlIO_printf(rsfp,
ff0cee69
PP
2201"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2202(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2203 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2204 (long)statbuf.st_dev, (long)statbuf.st_ino,
463ee0b2 2205 SvPVX(GvSV(curcop->cop_filegv)),
ff0cee69 2206 (long)statbuf.st_uid, (long)statbuf.st_gid);
79072805 2207 (void)my_pclose(rsfp);
a687059c 2208 }
463ee0b2 2209 croak("Permission denied\n");
a687059c 2210 }
85e6fe83
LW
2211 if (
2212#ifdef HAS_SETREUID
2213 setreuid(uid,euid) < 0
a0d0e21e
LW
2214#else
2215# if defined(HAS_SETRESUID)
85e6fe83 2216 setresuid(uid,euid,(Uid_t)-1) < 0
a0d0e21e 2217# endif
85e6fe83
LW
2218#endif
2219 || getuid() != uid || geteuid() != euid)
463ee0b2 2220 croak("Can't reswap uid and euid");
27e2fb84 2221 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
463ee0b2 2222 croak("Permission denied\n");
a687059c 2223 }
fe14fcc3 2224#endif /* HAS_SETREUID */
a687059c
LW
2225#endif /* IAMSUID */
2226
27e2fb84 2227 if (!S_ISREG(statbuf.st_mode))
463ee0b2 2228 croak("Permission denied");
27e2fb84 2229 if (statbuf.st_mode & S_IWOTH)
463ee0b2 2230 croak("Setuid/gid script is writable by world");
13281fa4 2231 doswitches = FALSE; /* -s is insecure in suid */
79072805 2232 curcop->cop_line++;
760ac839
LW
2233 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2234 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
463ee0b2 2235 croak("No #! line");
760ac839 2236 s = SvPV(linestr,na)+2;
663a0e37 2237 if (*s == ' ') s++;
45d8adaa 2238 while (!isSPACE(*s)) s++;
760ac839 2239 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
6e72f9df
PP
2240 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2241 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
463ee0b2 2242 croak("Not a perl script");
a687059c 2243 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
2244 /*
2245 * #! arg must be what we saw above. They can invoke it by
2246 * mentioning suidperl explicitly, but they may not add any strange
2247 * arguments beyond what #! says if they do invoke suidperl that way.
2248 */
2249 len = strlen(validarg);
2250 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 2251 strnNE(s,validarg,len) || !isSPACE(s[len]))
463ee0b2 2252 croak("Args must match #! line");
a687059c
LW
2253
2254#ifndef IAMSUID
2255 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2256 euid == statbuf.st_uid)
2257 if (!do_undump)
463ee0b2 2258 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2259FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2260#endif /* IAMSUID */
13281fa4
LW
2261
2262 if (euid) { /* oops, we're not the setuid root perl */
760ac839 2263 (void)PerlIO_close(rsfp);
13281fa4 2264#ifndef IAMSUID
46fc3d4c
PP
2265 /* try again */
2266 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
13281fa4 2267#endif
463ee0b2 2268 croak("Can't do setuid\n");
13281fa4
LW
2269 }
2270
83025b21 2271 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
fe14fcc3 2272#ifdef HAS_SETEGID
a687059c
LW
2273 (void)setegid(statbuf.st_gid);
2274#else
fe14fcc3 2275#ifdef HAS_SETREGID
85e6fe83
LW
2276 (void)setregid((Gid_t)-1,statbuf.st_gid);
2277#else
2278#ifdef HAS_SETRESGID
2279 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
a687059c
LW
2280#else
2281 setgid(statbuf.st_gid);
2282#endif
2283#endif
85e6fe83 2284#endif
83025b21 2285 if (getegid() != statbuf.st_gid)
463ee0b2 2286 croak("Can't do setegid!\n");
83025b21 2287 }
a687059c
LW
2288 if (statbuf.st_mode & S_ISUID) {
2289 if (statbuf.st_uid != euid)
fe14fcc3 2290#ifdef HAS_SETEUID
a687059c
LW
2291 (void)seteuid(statbuf.st_uid); /* all that for this */
2292#else
fe14fcc3 2293#ifdef HAS_SETREUID
85e6fe83
LW
2294 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2295#else
2296#ifdef HAS_SETRESUID
2297 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
a687059c
LW
2298#else
2299 setuid(statbuf.st_uid);
2300#endif
2301#endif
85e6fe83 2302#endif
83025b21 2303 if (geteuid() != statbuf.st_uid)
463ee0b2 2304 croak("Can't do seteuid!\n");
a687059c 2305 }
83025b21 2306 else if (uid) { /* oops, mustn't run as root */
fe14fcc3 2307#ifdef HAS_SETEUID
85e6fe83 2308 (void)seteuid((Uid_t)uid);
a687059c 2309#else
fe14fcc3 2310#ifdef HAS_SETREUID
85e6fe83 2311 (void)setreuid((Uid_t)-1,(Uid_t)uid);
a687059c 2312#else
85e6fe83
LW
2313#ifdef HAS_SETRESUID
2314 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2315#else
2316 setuid((Uid_t)uid);
2317#endif
a687059c
LW
2318#endif
2319#endif
83025b21 2320 if (geteuid() != uid)
463ee0b2 2321 croak("Can't do seteuid!\n");
83025b21 2322 }
748a9306 2323 init_ids();
27e2fb84 2324 if (!cando(S_IXUSR,TRUE,&statbuf))
463ee0b2 2325 croak("Permission denied\n"); /* they can't do this */
13281fa4
LW
2326 }
2327#ifdef IAMSUID
2328 else if (preprocess)
463ee0b2 2329 croak("-P not allowed for setuid/setgid script\n");
96436eeb
PP
2330 else if (fdscript >= 0)
2331 croak("fd script not allowed in suidperl\n");
13281fa4 2332 else
463ee0b2 2333 croak("Script is not setuid/setgid in suidperl\n");
96436eeb
PP
2334
2335 /* We absolutely must clear out any saved ids here, so we */
2336 /* exec the real perl, substituting fd script for scriptname. */
2337 /* (We pass script name as "subdir" of fd, which perl will grok.) */
760ac839
LW
2338 PerlIO_rewind(rsfp);
2339 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
96436eeb
PP
2340 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2341 if (!origargv[which])
2342 croak("Permission denied");
46fc3d4c
PP
2343 origargv[which] = savepv(form("/dev/fd/%d/%s",
2344 PerlIO_fileno(rsfp), origargv[which]));
96436eeb 2345#if defined(HAS_FCNTL) && defined(F_SETFD)
760ac839 2346 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 2347#endif
46fc3d4c 2348 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
96436eeb 2349 croak("Can't do setuid\n");
13281fa4 2350#endif /* IAMSUID */
a687059c 2351#else /* !DOSUID */
a687059c
LW
2352 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2353#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
96827780 2354 dTHR;
760ac839 2355 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
a687059c
LW
2356 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2357 ||
2358 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2359 )
2360 if (!do_undump)
463ee0b2 2361 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2362FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2363#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2364 /* not set-id, must be wrapped */
a687059c 2365 }
13281fa4 2366#endif /* DOSUID */
79072805 2367}
13281fa4 2368
79072805 2369static void
8ac85365 2370find_beginning(void)
79072805 2371{
6e72f9df 2372 register char *s, *s2;
33b78306
LW
2373
2374 /* skip forward in input to the real script? */
2375
bbce6d69 2376 forbid_setid("-x");
33b78306 2377 while (doextract) {
79072805 2378 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
463ee0b2 2379 croak("No Perl script found in input\n");
6e72f9df 2380 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
760ac839 2381 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
33b78306 2382 doextract = FALSE;
6e72f9df
PP
2383 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2384 s2 = s;
2385 while (*s == ' ' || *s == '\t') s++;
2386 if (*s++ == '-') {
2387 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2388 if (strnEQ(s2-4,"perl",4))
2389 /*SUPPRESS 530*/
2390 while (s = moreswitches(s)) ;
33b78306 2391 }
79072805 2392 if (cddir && chdir(cddir) < 0)
463ee0b2 2393 croak("Can't chdir to %s",cddir);
83025b21
LW
2394 }
2395 }
2396}
2397
79072805 2398static void
8ac85365 2399init_ids(void)
352d5a3a 2400{
748a9306
LW
2401 uid = (int)getuid();
2402 euid = (int)geteuid();
2403 gid = (int)getgid();
2404 egid = (int)getegid();
2405#ifdef VMS
2406 uid |= gid << 16;
2407 euid |= egid << 16;
2408#endif
4633a7c4 2409 tainting |= (uid && (euid != uid || egid != gid));
748a9306 2410}
79072805 2411
748a9306 2412static void
8ac85365 2413forbid_setid(char *s)
bbce6d69
PP
2414{
2415 if (euid != uid)
2416 croak("No %s allowed while running setuid", s);
2417 if (egid != gid)
2418 croak("No %s allowed while running setgid", s);
2419}
2420
2421static void
8ac85365 2422init_debugger(void)
748a9306 2423{
11343788 2424 dTHR;
79072805 2425 curstash = debstash;
748a9306 2426 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
79072805 2427 AvREAL_off(dbargs);
a0d0e21e
LW
2428 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2429 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
748a9306
LW
2430 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2431 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
c07a80fd 2432 sv_setiv(DBsingle, 0);
748a9306 2433 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
c07a80fd 2434 sv_setiv(DBtrace, 0);
748a9306 2435 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
c07a80fd 2436 sv_setiv(DBsignal, 0);
79072805 2437 curstash = defstash;
352d5a3a
LW
2438}
2439
11343788 2440void
8ac85365 2441init_stacks(ARGSproto)
79072805 2442{
6e72f9df 2443 curstack = newAV();
5f05dabc
PP
2444 mainstack = curstack; /* remember in case we switch stacks */
2445 AvREAL_off(curstack); /* not a real array */
6e72f9df 2446 av_extend(curstack,127);
79072805 2447
6e72f9df 2448 stack_base = AvARRAY(curstack);
79072805 2449 stack_sp = stack_base;
8990e307 2450 stack_max = stack_base + 127;
79072805 2451
c09156bb
MB
2452 cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */
2453 New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
8990e307 2454 cxstack_ix = -1;
8990e307
LW
2455
2456 New(50,tmps_stack,128,SV*);
6d4ff0d2 2457 tmps_floor = -1;
8990e307
LW
2458 tmps_ix = -1;
2459 tmps_max = 128;
2460
5f05dabc
PP
2461 /*
2462 * The following stacks almost certainly should be per-interpreter,
2463 * but for now they're not. XXX
2464 */
2465
6e72f9df
PP
2466 if (markstack) {
2467 markstack_ptr = markstack;
2468 } else {
2469 New(54,markstack,64,I32);
2470 markstack_ptr = markstack;
2471 markstack_max = markstack + 64;
2472 }
79072805 2473
6e72f9df
PP
2474 if (scopestack) {
2475 scopestack_ix = 0;
2476 } else {
2477 New(54,scopestack,32,I32);
2478 scopestack_ix = 0;
2479 scopestack_max = 32;
2480 }
79072805 2481
6e72f9df
PP
2482 if (savestack) {
2483 savestack_ix = 0;
2484 } else {
2485 New(54,savestack,128,ANY);
2486 savestack_ix = 0;
2487 savestack_max = 128;
2488 }
79072805 2489
6e72f9df
PP
2490 if (retstack) {
2491 retstack_ix = 0;
2492 } else {
2493 New(54,retstack,16,OP*);
2494 retstack_ix = 0;
2495 retstack_max = 16;
5f05dabc 2496 }
378cc40b 2497}
33b78306 2498
6e72f9df 2499static void
8ac85365 2500nuke_stacks(void)
6e72f9df 2501{
e858de61 2502 dTHR;
6e72f9df
PP
2503 Safefree(cxstack);
2504 Safefree(tmps_stack);
5f05dabc
PP
2505 DEBUG( {
2506 Safefree(debname);
2507 Safefree(debdelim);
2508 } )
378cc40b 2509}
33b78306 2510
760ac839 2511static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
7aa04957 2512
79072805 2513static void
8ac85365 2514init_lexer(void)
8990e307 2515{
a0d0e21e 2516 tmpfp = rsfp;
90248788 2517 rsfp = Nullfp;
8990e307
LW
2518 lex_start(linestr);
2519 rsfp = tmpfp;
2520 subname = newSVpv("main",4);
2521}
2522
2523static void
8ac85365 2524init_predump_symbols(void)
45d8adaa 2525{
11343788 2526 dTHR;
93a17b20 2527 GV *tmpgv;
a0d0e21e 2528 GV *othergv;
79072805 2529
a863c7d1 2530#ifdef USE_THREADS
554b3eca 2531 sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1);
a863c7d1 2532#else
85e6fe83 2533 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
a863c7d1 2534#endif /* USE_THREADS */
79072805 2535
85e6fe83 2536 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
a5f75d66 2537 GvMULTI_on(stdingv);
760ac839 2538 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
adbc6bb1 2539 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 2540 GvMULTI_on(tmpgv);
a0d0e21e 2541 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
79072805 2542
85e6fe83 2543 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 2544 GvMULTI_on(tmpgv);
760ac839 2545 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
4633a7c4 2546 setdefout(tmpgv);
adbc6bb1 2547 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 2548 GvMULTI_on(tmpgv);
a0d0e21e 2549 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
79072805 2550
a0d0e21e 2551 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
a5f75d66 2552 GvMULTI_on(othergv);
760ac839 2553 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
adbc6bb1 2554 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 2555 GvMULTI_on(tmpgv);
a0d0e21e 2556 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
79072805
LW
2557
2558 statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 2559
6e72f9df
PP
2560 if (!osname)
2561 osname = savepv(OSNAME);
79072805 2562}
33b78306 2563
79072805 2564static void
8ac85365 2565init_postdump_symbols(register int argc, register char **argv, register char **env)
33b78306 2566{
a863c7d1 2567 dTHR;
79072805
LW
2568 char *s;
2569 SV *sv;
2570 GV* tmpgv;
fe14fcc3 2571
79072805
LW
2572 argc--,argv++; /* skip name of script */
2573 if (doswitches) {
2574 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2575 if (!argv[0][1])
2576 break;
2577 if (argv[0][1] == '-') {
2578 argc--,argv++;
2579 break;
2580 }
93a17b20 2581 if (s = strchr(argv[0], '=')) {
79072805 2582 *s++ = '\0';
85e6fe83 2583 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW
2584 }
2585 else
85e6fe83 2586 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 2587 }
79072805
LW
2588 }
2589 toptarget = NEWSV(0,0);
2590 sv_upgrade(toptarget, SVt_PVFM);
2591 sv_setpvn(toptarget, "", 0);
748a9306 2592 bodytarget = NEWSV(0,0);
79072805
LW
2593 sv_upgrade(bodytarget, SVt_PVFM);
2594 sv_setpvn(bodytarget, "", 0);
2595 formtarget = bodytarget;
2596
bbce6d69 2597 TAINT;
85e6fe83 2598 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
79072805
LW
2599 sv_setpv(GvSV(tmpgv),origfilename);
2600 magicname("0", "0", 1);
2601 }
85e6fe83 2602 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
79072805 2603 sv_setpv(GvSV(tmpgv),origargv[0]);
85e6fe83 2604 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
a5f75d66 2605 GvMULTI_on(argvgv);
79072805
LW
2606 (void)gv_AVadd(argvgv);
2607 av_clear(GvAVn(argvgv));
2608 for (; argc > 0; argc--,argv++) {
a0d0e21e 2609 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
79072805
LW
2610 }
2611 }
85e6fe83 2612 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 2613 HV *hv;
a5f75d66 2614 GvMULTI_on(envgv);
79072805 2615 hv = GvHVn(envgv);
5aabfad6 2616 hv_magic(hv, envgv, 'E');
a0d0e21e 2617#ifndef VMS /* VMS doesn't have environ array */
4633a7c4
LW
2618 /* Note that if the supplied env parameter is actually a copy
2619 of the global environ then it may now point to free'd memory
2620 if the environment has been modified since. To avoid this
2621 problem we treat env==NULL as meaning 'use the default'
2622 */
2623 if (!env)
2624 env = environ;
5aabfad6 2625 if (env != environ)
79072805
LW
2626 environ[0] = Nullch;
2627 for (; *env; env++) {
93a17b20 2628 if (!(s = strchr(*env,'=')))
79072805
LW
2629 continue;
2630 *s++ = '\0';
137443ea
PP
2631#ifdef WIN32
2632 (void)strupr(*env);
2633#endif
79072805
LW
2634 sv = newSVpv(s--,0);
2635 (void)hv_store(hv, *env, s - *env, sv, 0);
2636 *s = '=';
3e3baf6d
TB
2637#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2638 /* Sins of the RTL. See note in my_setenv(). */
2639 (void)putenv(savepv(*env));
2640#endif
fe14fcc3 2641 }
4550b24a
PP
2642#endif
2643#ifdef DYNAMIC_ENV_FETCH
2644 HvNAME(hv) = savepv(ENV_HV_NAME);
2645#endif
79072805 2646 }
bbce6d69 2647 TAINT_NOT;
85e6fe83 2648 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1e422769 2649 sv_setiv(GvSV(tmpgv), (IV)getpid());
33b78306 2650}
34de22dd 2651
79072805 2652static void
8ac85365 2653init_perllib(void)
34de22dd 2654{
85e6fe83
LW
2655 char *s;
2656 if (!tainting) {
552a7a9b 2657#ifndef VMS
85e6fe83
LW
2658 s = getenv("PERL5LIB");
2659 if (s)
774d564b 2660 incpush(s, TRUE);
85e6fe83 2661 else
774d564b 2662 incpush(getenv("PERLLIB"), FALSE);
552a7a9b
PP
2663#else /* VMS */
2664 /* Treat PERL5?LIB as a possible search list logical name -- the
2665 * "natural" VMS idiom for a Unix path string. We allow each
2666 * element to be a set of |-separated directories for compatibility.
2667 */
2668 char buf[256];
2669 int idx = 0;
2670 if (my_trnlnm("PERL5LIB",buf,0))
774d564b 2671 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 2672 else
774d564b 2673 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
552a7a9b 2674#endif /* VMS */
85e6fe83 2675 }
34de22dd 2676
c90c0ff4 2677/* Use the ~-expanded versions of APPLLIB (undocumented),
df5cef82
PP
2678 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2679*/
4633a7c4 2680#ifdef APPLLIB_EXP
774d564b 2681 incpush(APPLLIB_EXP, FALSE);
16d20bd9 2682#endif
4633a7c4 2683
fed7345c 2684#ifdef ARCHLIB_EXP
774d564b 2685 incpush(ARCHLIB_EXP, FALSE);
a0d0e21e 2686#endif
fed7345c
AD
2687#ifndef PRIVLIB_EXP
2688#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 2689#endif
774d564b 2690 incpush(PRIVLIB_EXP, FALSE);
4633a7c4
LW
2691
2692#ifdef SITEARCH_EXP
774d564b 2693 incpush(SITEARCH_EXP, FALSE);
4633a7c4
LW
2694#endif
2695#ifdef SITELIB_EXP
774d564b 2696 incpush(SITELIB_EXP, FALSE);
4633a7c4
LW
2697#endif
2698#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
774d564b 2699 incpush(OLDARCHLIB_EXP, FALSE);
4633a7c4 2700#endif
a0d0e21e 2701
4633a7c4 2702 if (!tainting)
774d564b
PP
2703 incpush(".", FALSE);
2704}
2705
2706#if defined(DOSISH)
2707# define PERLLIB_SEP ';'
2708#else
2709# if defined(VMS)
2710# define PERLLIB_SEP '|'
2711# else
2712# define PERLLIB_SEP ':'
2713# endif
2714#endif
2715#ifndef PERLLIB_MANGLE
2716# define PERLLIB_MANGLE(s,n) (s)
2717#endif
2718
2719static void
8ac85365 2720incpush(char *p, int addsubdirs)
774d564b
PP
2721{
2722 SV *subdir = Nullsv;
2723 static char *archpat_auto;
2724
2725 if (!p)
2726 return;
2727
2728 if (addsubdirs) {
2729 subdir = newSV(0);
2730 if (!archpat_auto) {
2731 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2732 + sizeof("//auto"));
2733 New(55, archpat_auto, len, char);
2734 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
aa689395
PP
2735#ifdef VMS
2736 for (len = sizeof(ARCHNAME) + 2;
2737 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2738 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2739#endif
774d564b
PP
2740 }
2741 }
2742
2743 /* Break at all separators */
2744 while (p && *p) {
2745 SV *libdir = newSV(0);
2746 char *s;
2747
2748 /* skip any consecutive separators */
2749 while ( *p == PERLLIB_SEP ) {
2750 /* Uncomment the next line for PATH semantics */
2751 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2752 p++;
2753 }
2754
2755 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2756 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2757 (STRLEN)(s - p));
2758 p = s + 1;
2759 }
2760 else {
2761 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2762 p = Nullch; /* break out */
2763 }
2764
2765 /*
2766 * BEFORE pushing libdir onto @INC we may first push version- and
2767 * archname-specific sub-directories.
2768 */
2769 if (addsubdirs) {
2770 struct stat tmpstatbuf;
aa689395
PP
2771#ifdef VMS
2772 char *unix;
2773 STRLEN len;
774d564b 2774
aa689395
PP
2775 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2776 len = strlen(unix);
2777 while (unix[len-1] == '/') len--; /* Cosmetic */
2778 sv_usepvn(libdir,unix,len);
2779 }
2780 else
2781 PerlIO_printf(PerlIO_stderr(),
2782 "Failed to unixify @INC element \"%s\"\n",
2783 SvPV(libdir,na));
2784#endif
4fdae800 2785 /* .../archname/version if -d .../archname/version/auto */
774d564b
PP
2786 sv_setsv(subdir, libdir);
2787 sv_catpv(subdir, archpat_auto);
2788 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2789 S_ISDIR(tmpstatbuf.st_mode))
2790 av_push(GvAVn(incgv),
2791 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2792
4fdae800 2793 /* .../archname if -d .../archname/auto */
774d564b
PP
2794 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2795 strlen(patchlevel) + 1, "", 0);
2796 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2797 S_ISDIR(tmpstatbuf.st_mode))
2798 av_push(GvAVn(incgv),
2799 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2800 }
2801
2802 /* finally push this lib directory on the end of @INC */
2803 av_push(GvAVn(incgv), libdir);
2804 }
2805
2806 SvREFCNT_dec(subdir);
34de22dd 2807}
93a17b20 2808
199100c8
MB
2809#ifdef USE_THREADS
2810static struct thread *
2811init_main_thread()
2812{
2813 struct thread *thr;
2814 XPV *xpv;
2815
2816 Newz(53, thr, 1, struct thread);
2817 curcop = &compiling;
2818 thr->cvcache = newHV();
2819 thr->magicals = newAV();
2820 thr->specific = newAV();
38a03e6e 2821 thr->errhv = newHV();
199100c8
MB
2822 thr->flags = THRf_R_JOINABLE;
2823 MUTEX_INIT(&thr->mutex);
2824 /* Handcraft thrsv similarly to mess_sv */
2825 New(53, thrsv, 1, SV);
2826 Newz(53, xpv, 1, XPV);
2827 SvFLAGS(thrsv) = SVt_PV;
2828 SvANY(thrsv) = (void*)xpv;
2829 SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
2830 SvPVX(thrsv) = (char*)thr;
2831 SvCUR_set(thrsv, sizeof(thr));
2832 SvLEN_set(thrsv, sizeof(thr));
2833 *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
2834 thr->oursv = thrsv;
2835 curcop = &compiling;
2836 chopset = " \n-";
2837
2838 MUTEX_LOCK(&threads_mutex);
2839 nthreads++;
2840 thr->tid = 0;
2841 thr->next = thr;
2842 thr->prev = thr;
2843 MUTEX_UNLOCK(&threads_mutex);
2844
4b026b9e
GS
2845#ifdef HAVE_THREAD_INTERN
2846 init_thread_intern(thr);
235db74f
GS
2847#endif
2848
2849#ifdef SET_THREAD_SELF
2850 SET_THREAD_SELF(thr);
199100c8
MB
2851#else
2852 thr->self = pthread_self();
235db74f 2853#endif /* SET_THREAD_SELF */
199100c8
MB
2854 SET_THR(thr);
2855
2856 /*
2857 * These must come after the SET_THR because sv_setpvn does
2858 * SvTAINT and the taint fields require dTHR.
2859 */
2860 toptarget = NEWSV(0,0);
2861 sv_upgrade(toptarget, SVt_PVFM);
2862 sv_setpvn(toptarget, "", 0);
2863 bodytarget = NEWSV(0,0);
2864 sv_upgrade(bodytarget, SVt_PVFM);
2865 sv_setpvn(bodytarget, "", 0);
2866 formtarget = bodytarget;
2faa37cc 2867 thr->errsv = newSVpv("", 0);
199100c8
MB
2868 return thr;
2869}
2870#endif /* USE_THREADS */
2871
93a17b20 2872void
8ac85365 2873call_list(I32 oldscope, AV *list)
93a17b20 2874{
11343788 2875 dTHR;
a0d0e21e 2876 line_t oldline = curcop->cop_line;
22921e25
CS
2877 STRLEN len;
2878 dJMPENV;
2879 int ret;
93a17b20 2880
8990e307
LW
2881 while (AvFILL(list) >= 0) {
2882 CV *cv = (CV*)av_shift(list);
93a17b20 2883
8990e307 2884 SAVEFREESV(cv);
a0d0e21e 2885
22921e25
CS
2886 JMPENV_PUSH(ret);
2887 switch (ret) {
748a9306 2888 case 0: {
38a03e6e 2889 SV* atsv = ERRSV;
748a9306
LW
2890 PUSHMARK(stack_sp);
2891 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
12f917ad 2892 (void)SvPV(atsv, len);
748a9306 2893 if (len) {
54310121 2894 JMPENV_POP;
748a9306
LW
2895 curcop = &compiling;
2896 curcop->cop_line = oldline;
2897 if (list == beginav)
12f917ad 2898 sv_catpv(atsv, "BEGIN failed--compilation aborted");
748a9306 2899 else
12f917ad 2900 sv_catpv(atsv, "END failed--cleanup aborted");
2ae324a7
PP
2901 while (scopestack_ix > oldscope)
2902 LEAVE;
12f917ad 2903 croak("%s", SvPVX(atsv));
748a9306 2904 }
a0d0e21e 2905 }
85e6fe83
LW
2906 break;
2907 case 1:
f86702cc 2908 STATUS_ALL_FAILURE;
85e6fe83
LW
2909 /* FALL THROUGH */
2910 case 2:
2911 /* my_exit() was called */
2ae324a7
PP
2912 while (scopestack_ix > oldscope)
2913 LEAVE;
84902520 2914 FREETMPS;
85e6fe83
LW
2915 curstash = defstash;
2916 if (endav)
68dc0745 2917 call_list(oldscope, endav);
54310121 2918 JMPENV_POP;
a0d0e21e
LW
2919 curcop = &compiling;
2920 curcop->cop_line = oldline;
85e6fe83
LW
2921 if (statusvalue) {
2922 if (list == beginav)
a0d0e21e 2923 croak("BEGIN failed--compilation aborted");
85e6fe83 2924 else
a0d0e21e 2925 croak("END failed--cleanup aborted");
85e6fe83 2926 }
f86702cc 2927 my_exit_jump();
85e6fe83 2928 /* NOTREACHED */
85e6fe83
LW
2929 case 3:
2930 if (!restartop) {
760ac839 2931 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
a0d0e21e 2932 FREETMPS;
85e6fe83
LW
2933 break;
2934 }
54310121 2935 JMPENV_POP;
a0d0e21e
LW
2936 curcop = &compiling;
2937 curcop->cop_line = oldline;
54310121 2938 JMPENV_JUMP(3);
8990e307 2939 }
54310121 2940 JMPENV_POP;
93a17b20 2941 }
93a17b20 2942}
93a17b20 2943
f86702cc 2944void
8ac85365 2945my_exit(U32 status)
f86702cc 2946{
5dc0d613
MB
2947 dTHR;
2948
2949#ifdef USE_THREADS
a863c7d1
MB
2950 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2951 thr, (unsigned long) status));
5dc0d613 2952#endif /* USE_THREADS */
f86702cc
PP
2953 switch (status) {
2954 case 0:
2955 STATUS_ALL_SUCCESS;
2956 break;
2957 case 1:
2958 STATUS_ALL_FAILURE;
2959 break;
2960 default:
2961 STATUS_NATIVE_SET(status);
2962 break;
2963 }
2964 my_exit_jump();
2965}
2966
2967void
8ac85365 2968my_failure_exit(void)
f86702cc
PP
2969{
2970#ifdef VMS
2971 if (vaxc$errno & 1) {
4fdae800
PP
2972 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2973 STATUS_NATIVE_SET(44);
f86702cc
PP
2974 }
2975 else {
ff0cee69 2976 if (!vaxc$errno && errno) /* unlikely */
4fdae800 2977 STATUS_NATIVE_SET(44);
f86702cc 2978 else
4fdae800 2979 STATUS_NATIVE_SET(vaxc$errno);
f86702cc
PP
2980 }
2981#else
2982 if (errno & 255)
2983 STATUS_POSIX_SET(errno);
2984 else if (STATUS_POSIX == 0)
2985 STATUS_POSIX_SET(255);
2986#endif
2987 my_exit_jump();
93a17b20
LW
2988}
2989
f86702cc 2990static void
8ac85365 2991my_exit_jump(void)
f86702cc 2992{
e858de61 2993 dTHR;
c09156bb 2994 register PERL_CONTEXT *cx;
f86702cc
PP
2995 I32 gimme;
2996 SV **newsp;
2997
2998 if (e_tmpname) {
2999 if (e_fp) {
3000 PerlIO_close(e_fp);
3001 e_fp = Nullfp;
3002 }
3003 (void)UNLINK(e_tmpname);
3004 Safefree(e_tmpname);
3005 e_tmpname = Nullch;
3006 }
3007
3008 if (cxstack_ix >= 0) {
3009 if (cxstack_ix > 0)
3010 dounwind(0);
3011 POPBLOCK(cx,curpm);
3012 LEAVE;
3013 }
ff0cee69 3014
54310121 3015 JMPENV_JUMP(2);
f86702cc 3016}
4e35701f 3017
aeea060c 3018