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