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