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