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