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