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