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