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