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