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