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