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