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