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