This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
SelfLoader can lose $@ in AUTOLOAD() (from Nicholas Clark
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW
1/* perl.c
2 *
3818b22b 3 * Copyright (c) 1987-2000 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 14#include "EXTERN.h"
864dbfa3 15#define PERL_IN_PERL_C
378cc40b 16#include "perl.h"
e3321bb0 17#include "patchlevel.h" /* for local_patches */
378cc40b 18
df5cef82 19/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW
20#ifdef I_UNISTD
21#include <unistd.h>
22#endif
a0d0e21e 23
54310121 24#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
20ce7b12 25char *getenv (char *); /* Usually in <stdlib.h> */
54310121
PP
26#endif
27
0cb96387
GS
28static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
29
a687059c
LW
30#ifdef IAMSUID
31#ifndef DOSUID
32#define DOSUID
33#endif
34#endif
378cc40b 35
a687059c
LW
36#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
37#ifdef DOSUID
38#undef DOSUID
39#endif
40#endif
8d063cd8 41
873ef191 42#ifdef PERL_OBJECT
7766f137
GS
43#define perl_construct Perl_construct
44#define perl_parse Perl_parse
45#define perl_run Perl_run
46#define perl_destruct Perl_destruct
47#define perl_free Perl_free
48#endif
32e30700 49
06d86050
GS
50#if defined(USE_THREADS)
51# define INIT_TLS_AND_INTERP \
52 STMT_START { \
53 if (!PL_curinterp) { \
54 PERL_SET_INTERP(my_perl); \
55 INIT_THREADS; \
56 ALLOC_THREAD_KEY; \
57 } \
58 } STMT_END
59#else
60# if defined(USE_ITHREADS)
61# define INIT_TLS_AND_INTERP \
62 STMT_START { \
63 if (!PL_curinterp) { \
64 PERL_SET_INTERP(my_perl); \
65 INIT_THREADS; \
66 ALLOC_THREAD_KEY; \
534825c4
GS
67 PERL_SET_THX(my_perl); \
68 OP_REFCNT_INIT; \
69 } \
70 else { \
71 PERL_SET_THX(my_perl); \
06d86050 72 } \
06d86050
GS
73 } STMT_END
74# else
75# define INIT_TLS_AND_INTERP \
76 STMT_START { \
77 if (!PL_curinterp) { \
78 PERL_SET_INTERP(my_perl); \
79 } \
80 PERL_SET_THX(my_perl); \
81 } STMT_END
82# endif
83#endif
84
32e30700
GS
85#ifdef PERL_IMPLICIT_SYS
86PerlInterpreter *
7766f137
GS
87perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
88 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
32e30700
GS
89 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
90 struct IPerlDir* ipD, struct IPerlSock* ipS,
91 struct IPerlProc* ipP)
92{
93 PerlInterpreter *my_perl;
7766f137
GS
94#ifdef PERL_OBJECT
95 my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
96 ipLIO, ipD, ipS, ipP);
06d86050 97 INIT_TLS_AND_INTERP;
7766f137 98#else
32e30700
GS
99 /* New() needs interpreter, so call malloc() instead */
100 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
06d86050 101 INIT_TLS_AND_INTERP;
32e30700
GS
102 Zero(my_perl, 1, PerlInterpreter);
103 PL_Mem = ipM;
7766f137
GS
104 PL_MemShared = ipMS;
105 PL_MemParse = ipMP;
32e30700
GS
106 PL_Env = ipE;
107 PL_StdIO = ipStd;
108 PL_LIO = ipLIO;
109 PL_Dir = ipD;
110 PL_Sock = ipS;
111 PL_Proc = ipP;
7766f137
GS
112#endif
113
32e30700
GS
114 return my_perl;
115}
116#else
954c1994
GS
117
118/*
119=for apidoc perl_alloc
120
121Allocates a new Perl interpreter. See L<perlembed>.
122
123=cut
124*/
125
93a17b20 126PerlInterpreter *
cea2e8a9 127perl_alloc(void)
79072805 128{
cea2e8a9 129 PerlInterpreter *my_perl;
79072805 130
54aff467 131 /* New() needs interpreter, so call malloc() instead */
e8ee3774 132 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 133
06d86050 134 INIT_TLS_AND_INTERP;
dedcbb81 135 Zero(my_perl, 1, PerlInterpreter);
cea2e8a9 136 return my_perl;
79072805 137}
32e30700 138#endif /* PERL_IMPLICIT_SYS */
79072805 139
954c1994
GS
140/*
141=for apidoc perl_construct
142
143Initializes a new Perl interpreter. See L<perlembed>.
144
145=cut
146*/
147
79072805 148void
0cb96387 149perl_construct(pTHXx)
79072805 150{
a863c7d1
MB
151#ifdef USE_THREADS
152 int i;
153#ifndef FAKE_THREADS
e1f15930 154 struct perl_thread *thr = NULL;
a863c7d1
MB
155#endif /* FAKE_THREADS */
156#endif /* USE_THREADS */
ba869deb 157
8990e307 158#ifdef MULTIPLICITY
54aff467
GS
159 init_interp();
160 PL_perl_destruct_level = 1;
161#else
162 if (PL_perl_destruct_level > 0)
163 init_interp();
164#endif
165
33f46ff6 166 /* Init the real globals (and main thread)? */
3280af22 167 if (!PL_linestr) {
1feb2720 168#ifdef USE_THREADS
533c011a 169 MUTEX_INIT(&PL_sv_mutex);
a863c7d1
MB
170 /*
171 * Safe to use basic SV functions from now on (though
172 * not things like mortals or tainting yet).
173 */
533c011a
NIS
174 MUTEX_INIT(&PL_eval_mutex);
175 COND_INIT(&PL_eval_cond);
176 MUTEX_INIT(&PL_threads_mutex);
177 COND_INIT(&PL_nthreads_cond);
ba869deb 178# ifdef EMULATE_ATOMIC_REFCOUNTS
533c011a 179 MUTEX_INIT(&PL_svref_mutex);
ba869deb 180# endif /* EMULATE_ATOMIC_REFCOUNTS */
a863c7d1 181
5ff3f7a4
GS
182 MUTEX_INIT(&PL_cred_mutex);
183
199100c8 184 thr = init_main_thread();
11343788
MB
185#endif /* USE_THREADS */
186
14dd3ad8 187#ifdef PERL_FLEXIBLE_EXCEPTIONS
0b94c7bb 188 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
14dd3ad8 189#endif
312caa8e 190
2aea9f8a
GS
191 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
192
3280af22
NIS
193 PL_linestr = NEWSV(65,79);
194 sv_upgrade(PL_linestr,SVt_PVIV);
79072805 195
3280af22 196 if (!SvREADONLY(&PL_sv_undef)) {
d689ffdd
JP
197 /* set read-only and try to insure than we wont see REFCNT==0
198 very often */
199
3280af22
NIS
200 SvREADONLY_on(&PL_sv_undef);
201 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
79072805 202
3280af22
NIS
203 sv_setpv(&PL_sv_no,PL_No);
204 SvNV(&PL_sv_no);
205 SvREADONLY_on(&PL_sv_no);
206 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
79072805 207
3280af22
NIS
208 sv_setpv(&PL_sv_yes,PL_Yes);
209 SvNV(&PL_sv_yes);
210 SvREADONLY_on(&PL_sv_yes);
211 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6e72f9df 212 }
79072805 213
76e3520e
GS
214#ifdef PERL_OBJECT
215 /* TODO: */
6b88bc9c 216 /* PL_sighandlerp = sighandler; */
76e3520e 217#else
cea2e8a9 218 PL_sighandlerp = Perl_sighandler;
76e3520e 219#endif
3280af22 220 PL_pidstatus = newHV();
44a8e56a 221
79072805
LW
222#ifdef MSDOS
223 /*
224 * There is no way we can refer to them from Perl so close them to save
225 * space. The other alternative would be to provide STDAUX and STDPRN
226 * filehandles.
227 */
228 (void)fclose(stdaux);
229 (void)fclose(stdprn);
230#endif
231 }
232
79cb57f6 233 PL_nrs = newSVpvn("\n", 1);
3280af22 234 PL_rs = SvREFCNT_inc(PL_nrs);
dc92893f 235
cea2e8a9 236 init_stacks();
79072805 237
748a9306 238 init_ids();
3280af22 239 PL_lex_state = LEX_NOTPARSING;
a5f75d66 240
312caa8e 241 JMPENV_BOOTSTRAP;
f86702cc
PP
242 STATUS_ALL_SUCCESS;
243
0672f40e 244 init_i18nl10n(1);
36477c24 245 SET_NUMERIC_STANDARD();
0b5b802d 246
a7cb1f99
GS
247 {
248 U8 *s;
249 PL_patchlevel = NEWSV(0,4);
155aba94 250 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
a7cb1f99 251 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
806e7201 252 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
a7cb1f99
GS
253 s = (U8*)SvPVX(PL_patchlevel);
254 s = uv_to_utf8(s, (UV)PERL_REVISION);
255 s = uv_to_utf8(s, (UV)PERL_VERSION);
256 s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
257 *s = '\0';
258 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
259 SvPOK_on(PL_patchlevel);
260 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
261 + ((NV)PERL_VERSION / (NV)1000)
cceca5ed 262#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
a7cb1f99 263 + ((NV)PERL_SUBVERSION / (NV)1000000)
a5f75d66 264#endif
a7cb1f99
GS
265 ;
266 SvNOK_on(PL_patchlevel); /* dual valued */
267 SvUTF8_on(PL_patchlevel);
268 SvREADONLY_on(PL_patchlevel);
269 }
79072805 270
ab821d7f 271#if defined(LOCAL_PATCH_COUNT)
3280af22 272 PL_localpatches = local_patches; /* For possible -v */
ab821d7f
PP
273#endif
274
52853b95
GS
275#ifdef HAVE_INTERP_INTERN
276 sys_intern_init();
277#endif
278
4b556e6c 279 PerlIO_init(); /* Hook to IO system */
760ac839 280
3280af22
NIS
281 PL_fdpid = newAV(); /* for remembering popen pids by fd */
282 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
24944567 283 PL_errors = newSVpvn("",0);
8990e307 284
8990e307 285 ENTER;
79072805
LW
286}
287
954c1994
GS
288/*
289=for apidoc perl_destruct
290
291Shuts down a Perl interpreter. See L<perlembed>.
292
293=cut
294*/
295
79072805 296void
0cb96387 297perl_destruct(pTHXx)
79072805 298{
11343788 299 dTHR;
748a9306 300 int destruct_level; /* 0=none, 1=full, 2=full with checks */
8990e307 301 I32 last_sv_count;
a0d0e21e 302 HV *hv;
1f2bfc8a 303#ifdef USE_THREADS
33f46ff6 304 Thread t;
cea2e8a9 305 dTHX;
1f2bfc8a 306#endif /* USE_THREADS */
8990e307 307
7766f137
GS
308 /* wait for all pseudo-forked children to finish */
309 PERL_WAIT_FOR_CHILDREN;
310
11343788 311#ifdef USE_THREADS
0f15f207 312#ifndef FAKE_THREADS
8023c3ce
MB
313 /* Pass 1 on any remaining threads: detach joinables, join zombies */
314 retry_cleanup:
533c011a 315 MUTEX_LOCK(&PL_threads_mutex);
bf49b057 316 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 317 "perl_destruct: waiting for %d threads...\n",
533c011a 318 PL_nthreads - 1));
33f46ff6 319 for (t = thr->next; t != thr; t = t->next) {
605e5515
MB
320 MUTEX_LOCK(&t->mutex);
321 switch (ThrSTATE(t)) {
322 AV *av;
c7848ba1 323 case THRf_ZOMBIE:
bf49b057 324 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 325 "perl_destruct: joining zombie %p\n", t));
605e5515
MB
326 ThrSETSTATE(t, THRf_DEAD);
327 MUTEX_UNLOCK(&t->mutex);
533c011a 328 PL_nthreads--;
8023c3ce
MB
329 /*
330 * The SvREFCNT_dec below may take a long time (e.g. av
331 * may contain an object scalar whose destructor gets
332 * called) so we have to unlock threads_mutex and start
333 * all over again.
334 */
533c011a 335 MUTEX_UNLOCK(&PL_threads_mutex);
ea0efc06 336 JOIN(t, &av);
605e5515 337 SvREFCNT_dec((SV*)av);
bf49b057 338 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 339 "perl_destruct: joined zombie %p OK\n", t));
8023c3ce 340 goto retry_cleanup;
c7848ba1 341 case THRf_R_JOINABLE:
bf49b057 342 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB
343 "perl_destruct: detaching thread %p\n", t));
344 ThrSETSTATE(t, THRf_R_DETACHED);
345 /*
346 * We unlock threads_mutex and t->mutex in the opposite order
347 * from which we locked them just so that DETACH won't
348 * deadlock if it panics. It's only a breach of good style
349 * not a bug since they are unlocks not locks.
350 */
533c011a 351 MUTEX_UNLOCK(&PL_threads_mutex);
c7848ba1
MB
352 DETACH(t);
353 MUTEX_UNLOCK(&t->mutex);
8023c3ce 354 goto retry_cleanup;
c7848ba1 355 default:
bf49b057 356 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB
357 "perl_destruct: ignoring %p (state %u)\n",
358 t, ThrSTATE(t)));
359 MUTEX_UNLOCK(&t->mutex);
c7848ba1 360 /* fall through and out */
33f46ff6
MB
361 }
362 }
8023c3ce
MB
363 /* We leave the above "Pass 1" loop with threads_mutex still locked */
364
365 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
533c011a 366 while (PL_nthreads > 1)
11343788 367 {
bf49b057 368 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 369 "perl_destruct: final wait for %d threads\n",
533c011a
NIS
370 PL_nthreads - 1));
371 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
11343788
MB
372 }
373 /* At this point, we're the last thread */
533c011a 374 MUTEX_UNLOCK(&PL_threads_mutex);
bf49b057 375 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
533c011a
NIS
376 MUTEX_DESTROY(&PL_threads_mutex);
377 COND_DESTROY(&PL_nthreads_cond);
0f15f207 378#endif /* !defined(FAKE_THREADS) */
11343788
MB
379#endif /* USE_THREADS */
380
3280af22 381 destruct_level = PL_perl_destruct_level;
4633a7c4
LW
382#ifdef DEBUGGING
383 {
384 char *s;
155aba94 385 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
5f05dabc
PP
386 int i = atoi(s);
387 if (destruct_level < i)
388 destruct_level = i;
389 }
4633a7c4
LW
390 }
391#endif
392
8990e307 393 LEAVE;
a0d0e21e
LW
394 FREETMPS;
395
ff0cee69
PP
396 /* We must account for everything. */
397
398 /* Destroy the main CV and syntax tree */
3280af22
NIS
399 if (PL_main_root) {
400 PL_curpad = AvARRAY(PL_comppad);
401 op_free(PL_main_root);
402 PL_main_root = Nullop;
a0d0e21e 403 }
3280af22
NIS
404 PL_curcop = &PL_compiling;
405 PL_main_start = Nullop;
406 SvREFCNT_dec(PL_main_cv);
407 PL_main_cv = Nullcv;
24d3c518 408 PL_dirty = TRUE;
ff0cee69 409
3280af22 410 if (PL_sv_objcount) {
a0d0e21e
LW
411 /*
412 * Try to destruct global references. We do this first so that the
413 * destructors and destructees still exist. Some sv's might remain.
414 * Non-referenced objects are on their own.
415 */
a0d0e21e 416 sv_clean_objs();
8990e307
LW
417 }
418
5cd24f17 419 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS
420 SvREFCNT_dec(PL_warnhook);
421 PL_warnhook = Nullsv;
422 SvREFCNT_dec(PL_diehook);
423 PL_diehook = Nullsv;
5cd24f17 424
4b556e6c 425 /* call exit list functions */
3280af22 426 while (PL_exitlistlen-- > 0)
0cb96387 427 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 428
3280af22 429 Safefree(PL_exitlist);
4b556e6c 430
a0d0e21e 431 if (destruct_level == 0){
8990e307 432
a0d0e21e
LW
433 DEBUG_P(debprofdump());
434
435 /* The exit() function will do everything that needs doing. */
436 return;
437 }
5dd60ef7 438
5f05dabc
PP
439 /* loosen bonds of global variables */
440
3280af22
NIS
441 if(PL_rsfp) {
442 (void)PerlIO_close(PL_rsfp);
443 PL_rsfp = Nullfp;
8ebc5c01
PP
444 }
445
446 /* Filters for program text */
3280af22
NIS
447 SvREFCNT_dec(PL_rsfp_filters);
448 PL_rsfp_filters = Nullav;
8ebc5c01
PP
449
450 /* switches */
3280af22
NIS
451 PL_preprocess = FALSE;
452 PL_minus_n = FALSE;
453 PL_minus_p = FALSE;
454 PL_minus_l = FALSE;
455 PL_minus_a = FALSE;
456 PL_minus_F = FALSE;
457 PL_doswitches = FALSE;
599cee73 458 PL_dowarn = G_WARN_OFF;
3280af22
NIS
459 PL_doextract = FALSE;
460 PL_sawampersand = FALSE; /* must save all match strings */
3280af22
NIS
461 PL_unsafe = FALSE;
462
463 Safefree(PL_inplace);
464 PL_inplace = Nullch;
a7cb1f99 465 SvREFCNT_dec(PL_patchlevel);
3280af22
NIS
466
467 if (PL_e_script) {
468 SvREFCNT_dec(PL_e_script);
469 PL_e_script = Nullsv;
8ebc5c01
PP
470 }
471
472 /* magical thingies */
473
d33b2eba 474 Safefree(PL_ofs); /* $, */
3280af22 475 PL_ofs = Nullch;
5f05dabc 476
d33b2eba 477 Safefree(PL_ors); /* $\ */
3280af22 478 PL_ors = Nullch;
8ebc5c01 479
3280af22
NIS
480 SvREFCNT_dec(PL_rs); /* $/ */
481 PL_rs = Nullsv;
dc92893f 482
3280af22
NIS
483 SvREFCNT_dec(PL_nrs); /* $/ helper */
484 PL_nrs = Nullsv;
5f05dabc 485
d33b2eba
GS
486 PL_multiline = 0; /* $* */
487 Safefree(PL_osname); /* $^O */
488 PL_osname = Nullch;
5f05dabc 489
3280af22
NIS
490 SvREFCNT_dec(PL_statname);
491 PL_statname = Nullsv;
492 PL_statgv = Nullgv;
5f05dabc 493
8ebc5c01
PP
494 /* defgv, aka *_ should be taken care of elsewhere */
495
8ebc5c01 496 /* clean up after study() */
3280af22
NIS
497 SvREFCNT_dec(PL_lastscream);
498 PL_lastscream = Nullsv;
499 Safefree(PL_screamfirst);
500 PL_screamfirst = 0;
501 Safefree(PL_screamnext);
502 PL_screamnext = 0;
8ebc5c01 503
7d5ea4e7
GS
504 /* float buffer */
505 Safefree(PL_efloatbuf);
506 PL_efloatbuf = Nullch;
507 PL_efloatsize = 0;
508
8ebc5c01 509 /* startup and shutdown function lists */
3280af22
NIS
510 SvREFCNT_dec(PL_beginav);
511 SvREFCNT_dec(PL_endav);
7d30b5c4 512 SvREFCNT_dec(PL_checkav);
3280af22
NIS
513 SvREFCNT_dec(PL_initav);
514 PL_beginav = Nullav;
515 PL_endav = Nullav;
7d30b5c4 516 PL_checkav = Nullav;
3280af22 517 PL_initav = Nullav;
5618dfe8 518
8ebc5c01 519 /* shortcuts just get cleared */
3280af22 520 PL_envgv = Nullgv;
3280af22
NIS
521 PL_incgv = Nullgv;
522 PL_hintgv = Nullgv;
523 PL_errgv = Nullgv;
524 PL_argvgv = Nullgv;
525 PL_argvoutgv = Nullgv;
526 PL_stdingv = Nullgv;
bf49b057 527 PL_stderrgv = Nullgv;
3280af22
NIS
528 PL_last_in_gv = Nullgv;
529 PL_replgv = Nullgv;
5c831c24 530 PL_debstash = Nullhv;
8ebc5c01
PP
531
532 /* reset so print() ends up where we expect */
533 setdefout(Nullgv);
5c831c24 534
7a1c5554
GS
535 SvREFCNT_dec(PL_argvout_stack);
536 PL_argvout_stack = Nullav;
8ebc5c01 537
5c831c24
GS
538 SvREFCNT_dec(PL_modglobal);
539 PL_modglobal = Nullhv;
540 SvREFCNT_dec(PL_preambleav);
541 PL_preambleav = Nullav;
542 SvREFCNT_dec(PL_subname);
543 PL_subname = Nullsv;
544 SvREFCNT_dec(PL_linestr);
545 PL_linestr = Nullsv;
546 SvREFCNT_dec(PL_pidstatus);
547 PL_pidstatus = Nullhv;
548 SvREFCNT_dec(PL_toptarget);
549 PL_toptarget = Nullsv;
550 SvREFCNT_dec(PL_bodytarget);
551 PL_bodytarget = Nullsv;
552 PL_formtarget = Nullsv;
553
d33b2eba 554 /* free locale stuff */
b9582b6a 555#ifdef USE_LOCALE_COLLATE
d33b2eba
GS
556 Safefree(PL_collation_name);
557 PL_collation_name = Nullch;
b9582b6a 558#endif
d33b2eba 559
b9582b6a 560#ifdef USE_LOCALE_NUMERIC
d33b2eba
GS
561 Safefree(PL_numeric_name);
562 PL_numeric_name = Nullch;
b9582b6a 563#endif
d33b2eba 564
5c831c24
GS
565 /* clear utf8 character classes */
566 SvREFCNT_dec(PL_utf8_alnum);
567 SvREFCNT_dec(PL_utf8_alnumc);
568 SvREFCNT_dec(PL_utf8_ascii);
569 SvREFCNT_dec(PL_utf8_alpha);
570 SvREFCNT_dec(PL_utf8_space);
571 SvREFCNT_dec(PL_utf8_cntrl);
572 SvREFCNT_dec(PL_utf8_graph);
573 SvREFCNT_dec(PL_utf8_digit);
574 SvREFCNT_dec(PL_utf8_upper);
575 SvREFCNT_dec(PL_utf8_lower);
576 SvREFCNT_dec(PL_utf8_print);
577 SvREFCNT_dec(PL_utf8_punct);
578 SvREFCNT_dec(PL_utf8_xdigit);
579 SvREFCNT_dec(PL_utf8_mark);
580 SvREFCNT_dec(PL_utf8_toupper);
581 SvREFCNT_dec(PL_utf8_tolower);
582 PL_utf8_alnum = Nullsv;
583 PL_utf8_alnumc = Nullsv;
584 PL_utf8_ascii = Nullsv;
585 PL_utf8_alpha = Nullsv;
586 PL_utf8_space = Nullsv;
587 PL_utf8_cntrl = Nullsv;
588 PL_utf8_graph = Nullsv;
589 PL_utf8_digit = Nullsv;
590 PL_utf8_upper = Nullsv;
591 PL_utf8_lower = Nullsv;
592 PL_utf8_print = Nullsv;
593 PL_utf8_punct = Nullsv;
594 PL_utf8_xdigit = Nullsv;
595 PL_utf8_mark = Nullsv;
596 PL_utf8_toupper = Nullsv;
597 PL_utf8_totitle = Nullsv;
598 PL_utf8_tolower = Nullsv;
599
971a9dd3
GS
600 if (!specialWARN(PL_compiling.cop_warnings))
601 SvREFCNT_dec(PL_compiling.cop_warnings);
5c831c24 602 PL_compiling.cop_warnings = Nullsv;
01724ea0
GS
603#ifndef USE_ITHREADS
604 SvREFCNT_dec(CopFILEGV(&PL_compiling));
605 CopFILEGV_set(&PL_compiling, Nullgv);
606#endif
5c831c24 607
a0d0e21e 608 /* Prepare to destruct main symbol table. */
5f05dabc 609
3280af22
NIS
610 hv = PL_defstash;
611 PL_defstash = 0;
a0d0e21e 612 SvREFCNT_dec(hv);
5c831c24
GS
613 SvREFCNT_dec(PL_curstname);
614 PL_curstname = Nullsv;
a0d0e21e 615
5a844595
GS
616 /* clear queued errors */
617 SvREFCNT_dec(PL_errors);
618 PL_errors = Nullsv;
619
a0d0e21e 620 FREETMPS;
0453d815 621 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
3280af22 622 if (PL_scopestack_ix != 0)
0453d815
PM
623 Perl_warner(aTHX_ WARN_INTERNAL,
624 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
3280af22
NIS
625 (long)PL_scopestack_ix);
626 if (PL_savestack_ix != 0)
0453d815
PM
627 Perl_warner(aTHX_ WARN_INTERNAL,
628 "Unbalanced saves: %ld more saves than restores\n",
3280af22
NIS
629 (long)PL_savestack_ix);
630 if (PL_tmps_floor != -1)
0453d815 631 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
3280af22 632 (long)PL_tmps_floor + 1);
a0d0e21e 633 if (cxstack_ix != -1)
0453d815 634 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
ff0cee69 635 (long)cxstack_ix + 1);
a0d0e21e 636 }
8990e307
LW
637
638 /* Now absolutely destruct everything, somehow or other, loops or no. */
8990e307 639 last_sv_count = 0;
d33b2eba 640 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
3280af22
NIS
641 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
642 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
643 last_sv_count = PL_sv_count;
8990e307
LW
644 sv_clean_all();
645 }
d33b2eba
GS
646 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
647 SvFLAGS(PL_fdpid) |= SVt_PVAV;
3280af22
NIS
648 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
649 SvFLAGS(PL_strtab) |= SVt_PVHV;
d33b2eba 650
d4777f27
GS
651 AvREAL_off(PL_fdpid); /* no surviving entries */
652 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
d33b2eba
GS
653 PL_fdpid = Nullav;
654
6e72f9df
PP
655 /* Destruct the global string table. */
656 {
657 /* Yell and reset the HeVAL() slots that are still holding refcounts,
658 * so that sv_free() won't fail on them.
659 */
660 I32 riter;
661 I32 max;
662 HE *hent;
663 HE **array;
664
665 riter = 0;
3280af22
NIS
666 max = HvMAX(PL_strtab);
667 array = HvARRAY(PL_strtab);
6e72f9df
PP
668 hent = array[0];
669 for (;;) {
0453d815
PM
670 if (hent && ckWARN_d(WARN_INTERNAL)) {
671 Perl_warner(aTHX_ WARN_INTERNAL,
672 "Unbalanced string table refcount: (%d) for \"%s\"",
6e72f9df
PP
673 HeVAL(hent) - Nullsv, HeKEY(hent));
674 HeVAL(hent) = Nullsv;
675 hent = HeNEXT(hent);
676 }
677 if (!hent) {
678 if (++riter > max)
679 break;
680 hent = array[riter];
681 }
682 }
683 }
3280af22 684 SvREFCNT_dec(PL_strtab);
6e72f9df 685
d33b2eba
GS
686 /* free special SVs */
687
688 SvREFCNT(&PL_sv_yes) = 0;
689 sv_clear(&PL_sv_yes);
690 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 691 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS
692
693 SvREFCNT(&PL_sv_no) = 0;
694 sv_clear(&PL_sv_no);
695 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 696 SvFLAGS(&PL_sv_no) = 0;
01724ea0
GS
697
698 SvREFCNT(&PL_sv_undef) = 0;
699 SvREADONLY_off(&PL_sv_undef);
d33b2eba 700
0453d815
PM
701 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
702 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 703
4633a7c4 704 sv_free_arenas();
44a8e56a
PP
705
706 /* No SVs have survived, need to clean out */
3280af22 707 Safefree(PL_origfilename);
3280af22 708 Safefree(PL_reg_start_tmp);
5c5e4c24
IZ
709 if (PL_reg_curpm)
710 Safefree(PL_reg_curpm);
82ba1be6 711 Safefree(PL_reg_poscache);
3280af22
NIS
712 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
713 Safefree(PL_op_mask);
6e72f9df 714 nuke_stacks();
3280af22 715 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
a0d0e21e
LW
716
717 DEBUG_P(debprofdump());
11343788 718#ifdef USE_THREADS
5f08fbcd 719 MUTEX_DESTROY(&PL_strtab_mutex);
533c011a
NIS
720 MUTEX_DESTROY(&PL_sv_mutex);
721 MUTEX_DESTROY(&PL_eval_mutex);
5ff3f7a4 722 MUTEX_DESTROY(&PL_cred_mutex);
533c011a 723 COND_DESTROY(&PL_eval_cond);
11d617a5
GS
724#ifdef EMULATE_ATOMIC_REFCOUNTS
725 MUTEX_DESTROY(&PL_svref_mutex);
726#endif /* EMULATE_ATOMIC_REFCOUNTS */
fc36a67e 727
8023c3ce 728 /* As the penultimate thing, free the non-arena SV for thrsv */
533c011a
NIS
729 Safefree(SvPVX(PL_thrsv));
730 Safefree(SvANY(PL_thrsv));
731 Safefree(PL_thrsv);
732 PL_thrsv = Nullsv;
8023c3ce 733#endif /* USE_THREADS */
d33b2eba 734
fc36a67e
PP
735 /* As the absolutely last thing, free the non-arena SV for mess() */
736
3280af22 737 if (PL_mess_sv) {
9c63abab
GS
738 /* it could have accumulated taint magic */
739 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
740 MAGIC* mg;
741 MAGIC* moremagic;
742 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
743 moremagic = mg->mg_moremagic;
744 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
745 Safefree(mg->mg_ptr);
746 Safefree(mg);
747 }
748 }
fc36a67e 749 /* we know that type >= SVt_PV */
155aba94 750 (void)SvOOK_off(PL_mess_sv);
3280af22
NIS
751 Safefree(SvPVX(PL_mess_sv));
752 Safefree(SvANY(PL_mess_sv));
753 Safefree(PL_mess_sv);
754 PL_mess_sv = Nullsv;
fc36a67e 755 }
79072805
LW
756}
757
954c1994
GS
758/*
759=for apidoc perl_free
760
761Releases a Perl interpreter. See L<perlembed>.
762
763=cut
764*/
765
79072805 766void
0cb96387 767perl_free(pTHXx)
79072805 768{
c5be433b 769#if defined(PERL_OBJECT)
7f0d82f7 770 PerlMem_free(this);
76e3520e 771#else
1c0ca838
GS
772# if defined(PERL_IMPLICIT_SYS) && defined(WIN32)
773 void *host = w32_internal_host;
7f0d82f7 774 PerlMem_free(aTHXx);
1c0ca838
GS
775 win32_delete_internal_host(host);
776# else
777 PerlMem_free(aTHXx);
778# endif
76e3520e 779#endif
79072805
LW
780}
781
4b556e6c 782void
864dbfa3 783Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 784{
3280af22
NIS
785 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
786 PL_exitlist[PL_exitlistlen].fn = fn;
787 PL_exitlist[PL_exitlistlen].ptr = ptr;
788 ++PL_exitlistlen;
4b556e6c
JD
789}
790
954c1994
GS
791/*
792=for apidoc perl_parse
793
794Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
795
796=cut
797*/
798
79072805 799int
0cb96387 800perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 801{
11343788 802 dTHR;
6224f72b 803 I32 oldscope;
6224f72b 804 int ret;
db36c5a1 805 dJMPENV;
cea2e8a9
GS
806#ifdef USE_THREADS
807 dTHX;
808#endif
8d063cd8 809
a687059c
LW
810#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
811#ifdef IAMSUID
812#undef IAMSUID
cea2e8a9 813 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW
814setuid perl scripts securely.\n");
815#endif
816#endif
817
8f1f23e8 818#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
6e72f9df
PP
819 _dyld_lookup_and_bind
820 ("__environ", (unsigned long *) &environ_pointer, NULL);
821#endif /* environ */
822
3280af22
NIS
823 PL_origargv = argv;
824 PL_origargc = argc;
a0d0e21e 825#ifndef VMS /* VMS doesn't have environ array */
3280af22 826 PL_origenviron = environ;
a0d0e21e
LW
827#endif
828
3280af22 829 if (PL_do_undump) {
a0d0e21e
LW
830
831 /* Come here if running an undumped a.out. */
832
3280af22
NIS
833 PL_origfilename = savepv(argv[0]);
834 PL_do_undump = FALSE;
a0d0e21e 835 cxstack_ix = -1; /* start label stack again */
748a9306 836 init_ids();
a0d0e21e
LW
837 init_postdump_symbols(argc,argv,env);
838 return 0;
839 }
840
3280af22
NIS
841 if (PL_main_root) {
842 PL_curpad = AvARRAY(PL_comppad);
843 op_free(PL_main_root);
844 PL_main_root = Nullop;
ff0cee69 845 }
3280af22
NIS
846 PL_main_start = Nullop;
847 SvREFCNT_dec(PL_main_cv);
848 PL_main_cv = Nullcv;
79072805 849
3280af22
NIS
850 time(&PL_basetime);
851 oldscope = PL_scopestack_ix;
599cee73 852 PL_dowarn = G_WARN_OFF;
f86702cc 853
14dd3ad8
GS
854#ifdef PERL_FLEXIBLE_EXCEPTIONS
855 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
856#else
857 JMPENV_PUSH(ret);
858#endif
6224f72b 859 switch (ret) {
312caa8e 860 case 0:
14dd3ad8
GS
861#ifndef PERL_FLEXIBLE_EXCEPTIONS
862 parse_body(env,xsinit);
863#endif
7d30b5c4
GS
864 if (PL_checkav)
865 call_list(oldscope, PL_checkav);
14dd3ad8
GS
866 ret = 0;
867 break;
6224f72b
GS
868 case 1:
869 STATUS_ALL_FAILURE;
870 /* FALL THROUGH */
871 case 2:
872 /* my_exit() was called */
3280af22 873 while (PL_scopestack_ix > oldscope)
6224f72b
GS
874 LEAVE;
875 FREETMPS;
3280af22 876 PL_curstash = PL_defstash;
7d30b5c4
GS
877 if (PL_checkav)
878 call_list(oldscope, PL_checkav);
14dd3ad8
GS
879 ret = STATUS_NATIVE_EXPORT;
880 break;
6224f72b 881 case 3:
bf49b057 882 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS
883 ret = 1;
884 break;
6224f72b 885 }
14dd3ad8
GS
886 JMPENV_POP;
887 return ret;
888}
889
890#ifdef PERL_FLEXIBLE_EXCEPTIONS
891STATIC void *
892S_vparse_body(pTHX_ va_list args)
893{
894 char **env = va_arg(args, char**);
895 XSINIT_t xsinit = va_arg(args, XSINIT_t);
896
897 return parse_body(env, xsinit);
312caa8e 898}
14dd3ad8 899#endif
312caa8e
CS
900
901STATIC void *
14dd3ad8 902S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e
CS
903{
904 dTHR;
905 int argc = PL_origargc;
906 char **argv = PL_origargv;
312caa8e
CS
907 char *scriptname = NULL;
908 int fdscript = -1;
909 VOL bool dosearch = FALSE;
910 char *validarg = "";
911 AV* comppadlist;
912 register SV *sv;
913 register char *s;
f4c556ac 914 char *cddir = Nullch;
312caa8e 915
3280af22 916 sv_setpvn(PL_linestr,"",0);
79cb57f6 917 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS
918 SAVEFREESV(sv);
919 init_main_stash();
54310121 920
6224f72b
GS
921 for (argc--,argv++; argc > 0; argc--,argv++) {
922 if (argv[0][0] != '-' || !argv[0][1])
923 break;
924#ifdef DOSUID
925 if (*validarg)
926 validarg = " PHOOEY ";
927 else
928 validarg = argv[0];
13281fa4 929#endif
6224f72b
GS
930 s = argv[0]+1;
931 reswitch:
932 switch (*s) {
729a02f2
GS
933 case 'C':
934#ifdef WIN32
c0932edc 935 win32_argv2utf8(argc-1, argv+1);
729a02f2
GS
936 /* FALL THROUGH */
937#endif
1d5472a9
GS
938#ifndef PERL_STRICT_CR
939 case '\r':
940#endif
6224f72b
GS
941 case ' ':
942 case '0':
943 case 'F':
944 case 'a':
945 case 'c':
946 case 'd':
947 case 'D':
948 case 'h':
949 case 'i':
950 case 'l':
951 case 'M':
952 case 'm':
953 case 'n':
954 case 'p':
955 case 's':
956 case 'u':
957 case 'U':
958 case 'v':
599cee73
PM
959 case 'W':
960 case 'X':
6224f72b 961 case 'w':
155aba94 962 if ((s = moreswitches(s)))
6224f72b
GS
963 goto reswitch;
964 break;
33b78306 965
6224f72b 966 case 'T':
3280af22 967 PL_tainting = TRUE;
6224f72b
GS
968 s++;
969 goto reswitch;
f86702cc 970
6224f72b 971 case 'e':
bf4acbe4
GS
972#ifdef MACOS_TRADITIONAL
973 /* ignore -e for Dev:Pseudo argument */
974 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
975 break;
976#endif
3280af22 977 if (PL_euid != PL_uid || PL_egid != PL_gid)
cea2e8a9 978 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
3280af22 979 if (!PL_e_script) {
79cb57f6 980 PL_e_script = newSVpvn("",0);
0cb96387 981 filter_add(read_e_script, NULL);
6224f72b
GS
982 }
983 if (*++s)
3280af22 984 sv_catpv(PL_e_script, s);
6224f72b 985 else if (argv[1]) {
3280af22 986 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS
987 argc--,argv++;
988 }
989 else
cea2e8a9 990 Perl_croak(aTHX_ "No code specified for -e");
3280af22 991 sv_catpv(PL_e_script, "\n");
6224f72b 992 break;
afe37c7d 993
6224f72b
GS
994 case 'I': /* -I handled both here and in moreswitches() */
995 forbid_setid("-I");
996 if (!*++s && (s=argv[1]) != Nullch) {
997 argc--,argv++;
998 }
6224f72b 999 if (s && *s) {
0df16ed7
GS
1000 char *p;
1001 STRLEN len = strlen(s);
1002 p = savepvn(s, len);
9c8a64f0 1003 incpush(p, TRUE, TRUE);
0df16ed7
GS
1004 sv_catpvn(sv, "-I", 2);
1005 sv_catpvn(sv, p, len);
1006 sv_catpvn(sv, " ", 1);
6224f72b 1007 Safefree(p);
0df16ed7
GS
1008 }
1009 else
a67e862a 1010 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS
1011 break;
1012 case 'P':
1013 forbid_setid("-P");
3280af22 1014 PL_preprocess = TRUE;
6224f72b
GS
1015 s++;
1016 goto reswitch;
1017 case 'S':
1018 forbid_setid("-S");
1019 dosearch = TRUE;
1020 s++;
1021 goto reswitch;
1022 case 'V':
3280af22
NIS
1023 if (!PL_preambleav)
1024 PL_preambleav = newAV();
1025 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1026 if (*++s != ':') {
3280af22 1027 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1028#ifdef VMS
6b88bc9c 1029 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1030#else
3280af22 1031 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1032#endif
3280af22 1033 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1034# ifdef DEBUGGING
3280af22 1035 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1036# endif
6224f72b 1037# ifdef MULTIPLICITY
8f872242 1038 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1039# endif
b363f7ed
GS
1040# ifdef USE_THREADS
1041 sv_catpv(PL_Sv," USE_THREADS");
1042# endif
ac5e8965
JH
1043# ifdef USE_ITHREADS
1044 sv_catpv(PL_Sv," USE_ITHREADS");
1045# endif
10cc9d2a
JH
1046# ifdef USE_64_BIT_INT
1047 sv_catpv(PL_Sv," USE_64_BIT_INT");
1048# endif
1049# ifdef USE_64_BIT_ALL
1050 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH
1051# endif
1052# ifdef USE_LONG_DOUBLE
1053 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1054# endif
53430762
JH
1055# ifdef USE_LARGE_FILES
1056 sv_catpv(PL_Sv," USE_LARGE_FILES");
1057# endif
ac5e8965
JH
1058# ifdef USE_SOCKS
1059 sv_catpv(PL_Sv," USE_SOCKS");
1060# endif
b363f7ed
GS
1061# ifdef PERL_OBJECT
1062 sv_catpv(PL_Sv," PERL_OBJECT");
1063# endif
1064# ifdef PERL_IMPLICIT_CONTEXT
1065 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1066# endif
1067# ifdef PERL_IMPLICIT_SYS
1068 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1069# endif
3280af22 1070 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1071
6224f72b
GS
1072#if defined(LOCAL_PATCH_COUNT)
1073 if (LOCAL_PATCH_COUNT > 0) {
1074 int i;
3280af22 1075 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1076 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1077 if (PL_localpatches[i])
cea2e8a9 1078 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS
1079 }
1080 }
1081#endif
cea2e8a9 1082 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS
1083#ifdef __DATE__
1084# ifdef __TIME__
cea2e8a9 1085 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1086# else
cea2e8a9 1087 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS
1088# endif
1089#endif
3280af22 1090 sv_catpv(PL_Sv, "; \
6224f72b
GS
1091$\"=\"\\n \"; \
1092@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
1093print \" \\%ENV:\\n @env\\n\" if @env; \
1094print \" \\@INC:\\n @INC\\n\";");
1095 }
1096 else {
3280af22
NIS
1097 PL_Sv = newSVpv("config_vars(qw(",0);
1098 sv_catpv(PL_Sv, ++s);
1099 sv_catpv(PL_Sv, "))");
6224f72b
GS
1100 s += strlen(s);
1101 }
3280af22 1102 av_push(PL_preambleav, PL_Sv);
6224f72b
GS
1103 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1104 goto reswitch;
1105 case 'x':
3280af22 1106 PL_doextract = TRUE;
6224f72b
GS
1107 s++;
1108 if (*s)
f4c556ac 1109 cddir = s;
6224f72b
GS
1110 break;
1111 case 0:
1112 break;
1113 case '-':
1114 if (!*++s || isSPACE(*s)) {
1115 argc--,argv++;
1116 goto switch_end;
1117 }
1118 /* catch use of gnu style long options */
1119 if (strEQ(s, "version")) {
1120 s = "v";
1121 goto reswitch;
1122 }
1123 if (strEQ(s, "help")) {
1124 s = "h";
1125 goto reswitch;
1126 }
1127 s--;
1128 /* FALL THROUGH */
1129 default:
cea2e8a9 1130 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW
1131 }
1132 }
6224f72b 1133 switch_end:
54310121 1134
f675dbe5
CB
1135 if (
1136#ifndef SECURE_INTERNAL_GETENV
1137 !PL_tainting &&
1138#endif
0df16ed7
GS
1139 (s = PerlEnv_getenv("PERL5OPT")))
1140 {
74288ac8
GS
1141 while (isSPACE(*s))
1142 s++;
1143 if (*s == '-' && *(s+1) == 'T')
1144 PL_tainting = TRUE;
1145 else {
1146 while (s && *s) {
1147 while (isSPACE(*s))
1148 s++;
1149 if (*s == '-') {
1150 s++;
1151 if (isSPACE(*s))
1152 continue;
1153 }
1154 if (!*s)
1155 break;
1156 if (!strchr("DIMUdmw", *s))
cea2e8a9 1157 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
74288ac8 1158 s = moreswitches(s);
6224f72b 1159 }
6224f72b
GS
1160 }
1161 }
a0d0e21e 1162
6224f72b
GS
1163 if (!scriptname)
1164 scriptname = argv[0];
3280af22 1165 if (PL_e_script) {
6224f72b
GS
1166 argc++,argv--;
1167 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1168 }
1169 else if (scriptname == Nullch) {
1170#ifdef MSDOS
1171 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1172 moreswitches("h");
1173#endif
1174 scriptname = "-";
1175 }
1176
1177 init_perllib();
1178
1179 open_script(scriptname,dosearch,sv,&fdscript);
1180
1181 validate_suid(validarg, scriptname,fdscript);
1182
0b5b802d
GS
1183#if defined(SIGCHLD) || defined(SIGCLD)
1184 {
1185#ifndef SIGCHLD
1186# define SIGCHLD SIGCLD
1187#endif
1188 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1189 if (sigstate == SIG_IGN) {
1190 if (ckWARN(WARN_SIGNAL))
1191 Perl_warner(aTHX_ WARN_SIGNAL,
1192 "Can't ignore signal CHLD, forcing to default");
1193 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1194 }
1195 }
1196#endif
1197
bf4acbe4
GS
1198#ifdef MACOS_TRADITIONAL
1199 if (PL_doextract || gMacPerl_AlwaysExtract) {
1200#else
f4c556ac 1201 if (PL_doextract) {
bf4acbe4 1202#endif
6224f72b 1203 find_beginning();
f4c556ac
GS
1204 if (cddir && PerlDir_chdir(cddir) < 0)
1205 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1206
1207 }
6224f72b 1208
3280af22
NIS
1209 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1210 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1211 CvUNIQUE_on(PL_compcv);
1212
1213 PL_comppad = newAV();
1214 av_push(PL_comppad, Nullsv);
1215 PL_curpad = AvARRAY(PL_comppad);
1216 PL_comppad_name = newAV();
1217 PL_comppad_name_fill = 0;
1218 PL_min_intro_pending = 0;
1219 PL_padix = 0;
6224f72b 1220#ifdef USE_THREADS
79cb57f6 1221 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS
1222 PL_curpad[0] = (SV*)newAV();
1223 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1224 CvOWNER(PL_compcv) = 0;
1225 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1226 MUTEX_INIT(CvMUTEXP(PL_compcv));
6224f72b
GS
1227#endif /* USE_THREADS */
1228
1229 comppadlist = newAV();
1230 AvREAL_off(comppadlist);
3280af22
NIS
1231 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1232 av_store(comppadlist, 1, (SV*)PL_comppad);
1233 CvPADLIST(PL_compcv) = comppadlist;
6224f72b
GS
1234
1235 boot_core_UNIVERSAL();
9a34ef1d 1236#ifndef PERL_MICRO
09bef843 1237 boot_core_xsutils();
9a34ef1d 1238#endif
6224f72b
GS
1239
1240 if (xsinit)
0cb96387 1241 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
5db16f6a 1242#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
c5be433b 1243 init_os_extras();
6224f72b
GS
1244#endif
1245
29209bc5
JH
1246#ifdef USE_SOCKS
1247 SOCKSinit(argv[0]);
1248#endif
1249
6224f72b
GS
1250 init_predump_symbols();
1251 /* init_postdump_symbols not currently designed to be called */
1252 /* more than once (ENV isn't cleared first, for example) */
1253 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1254 if (!PL_do_undump)
6224f72b
GS
1255 init_postdump_symbols(argc,argv,env);
1256
1257 init_lexer();
1258
1259 /* now parse the script */
1260
1261 SETERRNO(0,SS$_NORMAL);
3280af22 1262 PL_error_count = 0;
bf4acbe4
GS
1263#ifdef MACOS_TRADITIONAL
1264 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1265 if (PL_minus_c)
1266 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1267 else {
1268 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1269 MacPerl_MPWFileName(PL_origfilename));
1270 }
1271 }
1272#else
3280af22
NIS
1273 if (yyparse() || PL_error_count) {
1274 if (PL_minus_c)
cea2e8a9 1275 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1276 else {
cea2e8a9 1277 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1278 PL_origfilename);
6224f72b
GS
1279 }
1280 }
bf4acbe4 1281#endif
57843af0 1282 CopLINE_set(PL_curcop, 0);
3280af22
NIS
1283 PL_curstash = PL_defstash;
1284 PL_preprocess = FALSE;
1285 if (PL_e_script) {
1286 SvREFCNT_dec(PL_e_script);
1287 PL_e_script = Nullsv;
6224f72b
GS
1288 }
1289
1290 /* now that script is parsed, we can modify record separator */
3280af22
NIS
1291 SvREFCNT_dec(PL_rs);
1292 PL_rs = SvREFCNT_inc(PL_nrs);
864dbfa3 1293 sv_setsv(get_sv("/", TRUE), PL_rs);
3280af22 1294 if (PL_do_undump)
6224f72b
GS
1295 my_unexec();
1296
57843af0
GS
1297 if (isWARN_ONCE) {
1298 SAVECOPFILE(PL_curcop);
1299 SAVECOPLINE(PL_curcop);
3280af22 1300 gv_check(PL_defstash);
57843af0 1301 }
6224f72b
GS
1302
1303 LEAVE;
1304 FREETMPS;
1305
1306#ifdef MYMALLOC
1307 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1308 dump_mstats("after compilation:");
1309#endif
1310
1311 ENTER;
3280af22 1312 PL_restartop = 0;
312caa8e 1313 return NULL;
6224f72b
GS
1314}
1315
954c1994
GS
1316/*
1317=for apidoc perl_run
1318
1319Tells a Perl interpreter to run. See L<perlembed>.
1320
1321=cut
1322*/
1323
6224f72b 1324int
0cb96387 1325perl_run(pTHXx)
6224f72b 1326{
de616352 1327 dTHR;
6224f72b 1328 I32 oldscope;
14dd3ad8 1329 int ret = 0;
db36c5a1 1330 dJMPENV;
cea2e8a9
GS
1331#ifdef USE_THREADS
1332 dTHX;
1333#endif
6224f72b 1334
3280af22 1335 oldscope = PL_scopestack_ix;
6224f72b 1336
14dd3ad8 1337#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1338 redo_body:
14dd3ad8
GS
1339 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1340#else
1341 JMPENV_PUSH(ret);
1342#endif
6224f72b
GS
1343 switch (ret) {
1344 case 1:
1345 cxstack_ix = -1; /* start context stack again */
312caa8e 1346 goto redo_body;
14dd3ad8
GS
1347 case 0: /* normal completion */
1348#ifndef PERL_FLEXIBLE_EXCEPTIONS
1349 redo_body:
1350 run_body(oldscope);
1351#endif
1352 /* FALL THROUGH */
1353 case 2: /* my_exit() */
3280af22 1354 while (PL_scopestack_ix > oldscope)
6224f72b
GS
1355 LEAVE;
1356 FREETMPS;
3280af22 1357 PL_curstash = PL_defstash;
865be832 1358 if (PL_endav && !PL_minus_c)
3280af22 1359 call_list(oldscope, PL_endav);
6224f72b
GS
1360#ifdef MYMALLOC
1361 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1362 dump_mstats("after execution: ");
1363#endif
14dd3ad8
GS
1364 ret = STATUS_NATIVE_EXPORT;
1365 break;
6224f72b 1366 case 3:
312caa8e
CS
1367 if (PL_restartop) {
1368 POPSTACK_TO(PL_mainstack);
1369 goto redo_body;
6224f72b 1370 }
bf49b057 1371 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1372 FREETMPS;
14dd3ad8
GS
1373 ret = 1;
1374 break;
6224f72b
GS
1375 }
1376
14dd3ad8
GS
1377 JMPENV_POP;
1378 return ret;
312caa8e
CS
1379}
1380
14dd3ad8 1381#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1382STATIC void *
14dd3ad8 1383S_vrun_body(pTHX_ va_list args)
312caa8e 1384{
312caa8e
CS
1385 I32 oldscope = va_arg(args, I32);
1386
14dd3ad8
GS
1387 return run_body(oldscope);
1388}
1389#endif
1390
1391
1392STATIC void *
1393S_run_body(pTHX_ I32 oldscope)
1394{
1395 dTHR;
1396
6224f72b 1397 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1398 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1399
3280af22 1400 if (!PL_restartop) {
6224f72b
GS
1401 DEBUG_x(dump_all());
1402 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH
1403 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1404 PTR2UV(thr)));
6224f72b 1405
3280af22 1406 if (PL_minus_c) {
bf4acbe4
GS
1407#ifdef MACOS_TRADITIONAL
1408 PerlIO_printf(Perl_error_log, "%s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
1409#else
bf49b057 1410 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1411#endif
6224f72b
GS
1412 my_exit(0);
1413 }
3280af22 1414 if (PERLDB_SINGLE && PL_DBsingle)
312caa8e 1415 sv_setiv(PL_DBsingle, 1);
3280af22
NIS
1416 if (PL_initav)
1417 call_list(oldscope, PL_initav);
6224f72b
GS
1418 }
1419
1420 /* do it */
1421
3280af22 1422 if (PL_restartop) {
533c011a 1423 PL_op = PL_restartop;
3280af22 1424 PL_restartop = 0;
cea2e8a9 1425 CALLRUNOPS(aTHX);
6224f72b 1426 }
3280af22
NIS
1427 else if (PL_main_start) {
1428 CvDEPTH(PL_main_cv) = 1;
533c011a 1429 PL_op = PL_main_start;
cea2e8a9 1430 CALLRUNOPS(aTHX);
6224f72b
GS
1431 }
1432
f6b3007c
JH
1433 my_exit(0);
1434 /* NOTREACHED */
312caa8e 1435 return NULL;
6224f72b
GS
1436}
1437
954c1994
GS
1438/*
1439=for apidoc p||get_sv
1440
1441Returns the SV of the specified Perl scalar. If C<create> is set and the
1442Perl variable does not exist then it will be created. If C<create> is not
1443set and the variable does not exist then NULL is returned.
1444
1445=cut
1446*/
1447
6224f72b 1448SV*
864dbfa3 1449Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS
1450{
1451 GV *gv;
1452#ifdef USE_THREADS
1453 if (name[1] == '\0' && !isALPHA(name[0])) {
1454 PADOFFSET tmp = find_threadsv(name);
1455 if (tmp != NOT_IN_PAD) {
1456 dTHR;
1457 return THREADSV(tmp);
1458 }
1459 }
1460#endif /* USE_THREADS */
1461 gv = gv_fetchpv(name, create, SVt_PV);
1462 if (gv)
1463 return GvSV(gv);
1464 return Nullsv;
1465}
1466
954c1994
GS
1467/*
1468=for apidoc p||get_av
1469
1470Returns the AV of the specified Perl array. If C<create> is set and the
1471Perl variable does not exist then it will be created. If C<create> is not
1472set and the variable does not exist then NULL is returned.
1473
1474=cut
1475*/
1476
6224f72b 1477AV*
864dbfa3 1478Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS
1479{
1480 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1481 if (create)
1482 return GvAVn(gv);
1483 if (gv)
1484 return GvAV(gv);
1485 return Nullav;
1486}
1487
954c1994
GS
1488/*
1489=for apidoc p||get_hv
1490
1491Returns the HV of the specified Perl hash. If C<create> is set and the
1492Perl variable does not exist then it will be created. If C<create> is not
1493set and the variable does not exist then NULL is returned.
1494
1495=cut
1496*/
1497
6224f72b 1498HV*
864dbfa3 1499Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1500{
a0d0e21e
LW
1501 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1502 if (create)
1503 return GvHVn(gv);
1504 if (gv)
1505 return GvHV(gv);
1506 return Nullhv;
1507}
1508
954c1994
GS
1509/*
1510=for apidoc p||get_cv
1511
1512Returns the CV of the specified Perl subroutine. If C<create> is set and
1513the Perl subroutine does not exist then it will be declared (which has the
1514same effect as saying C<sub name;>). If C<create> is not set and the
1515subroutine does not exist then NULL is returned.
1516
1517=cut
1518*/
1519
a0d0e21e 1520CV*
864dbfa3 1521Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW
1522{
1523 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1524 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS
1525 /* XXX this is probably not what they think they're getting.
1526 * It has the same effect as "sub name;", i.e. just a forward
1527 * declaration! */
8ebc5c01 1528 if (create && !GvCVu(gv))
774d564b 1529 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1530 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1531 Nullop,
a0d0e21e
LW
1532 Nullop);
1533 if (gv)
8ebc5c01 1534 return GvCVu(gv);
a0d0e21e
LW
1535 return Nullcv;
1536}
1537
79072805
LW
1538/* Be sure to refetch the stack pointer after calling these routines. */
1539
954c1994
GS
1540/*
1541=for apidoc p||call_argv
1542
1543Performs a callback to the specified Perl sub. See L<perlcall>.
1544
1545=cut
1546*/
1547
a0d0e21e 1548I32
864dbfa3 1549Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
8ac85365
NIS
1550
1551 /* See G_* flags in cop.h */
1552 /* null terminated arg list */
8990e307 1553{
a0d0e21e 1554 dSP;
8990e307 1555
924508f0 1556 PUSHMARK(SP);
a0d0e21e 1557 if (argv) {
8990e307 1558 while (*argv) {
a0d0e21e 1559 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW
1560 argv++;
1561 }
a0d0e21e 1562 PUTBACK;
8990e307 1563 }
864dbfa3 1564 return call_pv(sub_name, flags);
8990e307
LW
1565}
1566
954c1994
GS
1567/*
1568=for apidoc p||call_pv
1569
1570Performs a callback to the specified Perl sub. See L<perlcall>.
1571
1572=cut
1573*/
1574
a0d0e21e 1575I32
864dbfa3 1576Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS
1577 /* name of the subroutine */
1578 /* See G_* flags in cop.h */
a0d0e21e 1579{
864dbfa3 1580 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW
1581}
1582
954c1994
GS
1583/*
1584=for apidoc p||call_method
1585
1586Performs a callback to the specified Perl method. The blessed object must
1587be on the stack. See L<perlcall>.
1588
1589=cut
1590*/
1591
a0d0e21e 1592I32
864dbfa3 1593Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS
1594 /* name of the subroutine */
1595 /* See G_* flags in cop.h */
a0d0e21e 1596{
968b3946 1597 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW
1598}
1599
1600/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS
1601/*
1602=for apidoc p||call_sv
1603
1604Performs a callback to the Perl sub whose name is in the SV. See
1605L<perlcall>.
1606
1607=cut
1608*/
1609
a0d0e21e 1610I32
864dbfa3 1611Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365
NIS
1612
1613 /* See G_* flags in cop.h */
a0d0e21e 1614{
924508f0 1615 dSP;
a0d0e21e 1616 LOGOP myop; /* fake syntax tree node */
968b3946 1617 UNOP method_op;
aa689395 1618 I32 oldmark;
a0d0e21e 1619 I32 retval;
a0d0e21e 1620 I32 oldscope;
54310121 1621 bool oldcatch = CATCH_GET;
6224f72b 1622 int ret;
533c011a 1623 OP* oldop = PL_op;
db36c5a1 1624 dJMPENV;
1e422769 1625
a0d0e21e
LW
1626 if (flags & G_DISCARD) {
1627 ENTER;
1628 SAVETMPS;
1629 }
1630
aa689395 1631 Zero(&myop, 1, LOGOP);
54310121 1632 myop.op_next = Nullop;
f51d4af5 1633 if (!(flags & G_NOARGS))
aa689395 1634 myop.op_flags |= OPf_STACKED;
54310121
PP
1635 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1636 (flags & G_ARRAY) ? OPf_WANT_LIST :
1637 OPf_WANT_SCALAR);
462e5cf6 1638 SAVEOP();
533c011a 1639 PL_op = (OP*)&myop;
aa689395 1640
3280af22
NIS
1641 EXTEND(PL_stack_sp, 1);
1642 *++PL_stack_sp = sv;
aa689395 1643 oldmark = TOPMARK;
3280af22 1644 oldscope = PL_scopestack_ix;
a0d0e21e 1645
3280af22 1646 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 1647 /* Handle first BEGIN of -d. */
3280af22 1648 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24
PP
1649 /* Try harder, since this may have been a sighandler, thus
1650 * curstash may be meaningless. */
3280af22 1651 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 1652 && !(flags & G_NODEBUG))
533c011a 1653 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1654
968b3946
GS
1655 if (flags & G_METHOD) {
1656 Zero(&method_op, 1, UNOP);
1657 method_op.op_next = PL_op;
1658 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1659 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 1660 PL_op = (OP*)&method_op;
968b3946
GS
1661 }
1662
312caa8e 1663 if (!(flags & G_EVAL)) {
0cdb2077 1664 CATCH_SET(TRUE);
14dd3ad8 1665 call_body((OP*)&myop, FALSE);
312caa8e 1666 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 1667 CATCH_SET(oldcatch);
312caa8e
CS
1668 }
1669 else {
533c011a 1670 cLOGOP->op_other = PL_op;
3280af22 1671 PL_markstack_ptr--;
4633a7c4
LW
1672 /* we're trying to emulate pp_entertry() here */
1673 {
c09156bb 1674 register PERL_CONTEXT *cx;
54310121 1675 I32 gimme = GIMME_V;
4633a7c4
LW
1676
1677 ENTER;
1678 SAVETMPS;
1679
968b3946 1680 push_return(Nullop);
1d76a5c3 1681 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 1682 PUSHEVAL(cx, 0, 0);
533c011a 1683 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4633a7c4 1684
faef0170 1685 PL_in_eval = EVAL_INEVAL;
4633a7c4 1686 if (flags & G_KEEPERR)
faef0170 1687 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 1688 else
38a03e6e 1689 sv_setpv(ERRSV,"");
4633a7c4 1690 }
3280af22 1691 PL_markstack_ptr++;
a0d0e21e 1692
14dd3ad8
GS
1693#ifdef PERL_FLEXIBLE_EXCEPTIONS
1694 redo_body:
1695 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 1696 (OP*)&myop, FALSE);
14dd3ad8
GS
1697#else
1698 JMPENV_PUSH(ret);
1699#endif
6224f72b
GS
1700 switch (ret) {
1701 case 0:
14dd3ad8
GS
1702#ifndef PERL_FLEXIBLE_EXCEPTIONS
1703 redo_body:
1704 call_body((OP*)&myop, FALSE);
1705#endif
312caa8e
CS
1706 retval = PL_stack_sp - (PL_stack_base + oldmark);
1707 if (!(flags & G_KEEPERR))
1708 sv_setpv(ERRSV,"");
a0d0e21e 1709 break;
6224f72b 1710 case 1:
f86702cc 1711 STATUS_ALL_FAILURE;
a0d0e21e 1712 /* FALL THROUGH */
6224f72b 1713 case 2:
a0d0e21e 1714 /* my_exit() was called */
3280af22 1715 PL_curstash = PL_defstash;
a0d0e21e 1716 FREETMPS;
14dd3ad8 1717 JMPENV_POP;
cc3604b1 1718 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 1719 Perl_croak(aTHX_ "Callback called exit");
f86702cc 1720 my_exit_jump();
a0d0e21e 1721 /* NOTREACHED */
6224f72b 1722 case 3:
3280af22 1723 if (PL_restartop) {
533c011a 1724 PL_op = PL_restartop;
3280af22 1725 PL_restartop = 0;
312caa8e 1726 goto redo_body;
a0d0e21e 1727 }
3280af22 1728 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW
1729 if (flags & G_ARRAY)
1730 retval = 0;
1731 else {
1732 retval = 1;
3280af22 1733 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 1734 }
312caa8e 1735 break;
a0d0e21e 1736 }
a0d0e21e 1737
3280af22 1738 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW
1739 SV **newsp;
1740 PMOP *newpm;
1741 I32 gimme;
c09156bb 1742 register PERL_CONTEXT *cx;
a0a2876f
LW
1743 I32 optype;
1744
1745 POPBLOCK(cx,newpm);
1746 POPEVAL(cx);
1747 pop_return();
3280af22 1748 PL_curpm = newpm;
a0a2876f 1749 LEAVE;
a0d0e21e 1750 }
14dd3ad8 1751 JMPENV_POP;
a0d0e21e 1752 }
1e422769 1753
a0d0e21e 1754 if (flags & G_DISCARD) {
3280af22 1755 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW
1756 retval = 0;
1757 FREETMPS;
1758 LEAVE;
1759 }
533c011a 1760 PL_op = oldop;
a0d0e21e
LW
1761 return retval;
1762}
1763
14dd3ad8 1764#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1765STATIC void *
14dd3ad8 1766S_vcall_body(pTHX_ va_list args)
312caa8e
CS
1767{
1768 OP *myop = va_arg(args, OP*);
1769 int is_eval = va_arg(args, int);
1770
14dd3ad8 1771 call_body(myop, is_eval);
312caa8e
CS
1772 return NULL;
1773}
14dd3ad8 1774#endif
312caa8e
CS
1775
1776STATIC void
14dd3ad8 1777S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e
CS
1778{
1779 dTHR;
1780
1781 if (PL_op == myop) {
1782 if (is_eval)
cea2e8a9 1783 PL_op = Perl_pp_entereval(aTHX);
312caa8e 1784 else
cea2e8a9 1785 PL_op = Perl_pp_entersub(aTHX);
312caa8e
CS
1786 }
1787 if (PL_op)
cea2e8a9 1788 CALLRUNOPS(aTHX);
312caa8e
CS
1789}
1790
6e72f9df 1791/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 1792
954c1994
GS
1793/*
1794=for apidoc p||eval_sv
1795
1796Tells Perl to C<eval> the string in the SV.
1797
1798=cut
1799*/
1800
a0d0e21e 1801I32
864dbfa3 1802Perl_eval_sv(pTHX_ SV *sv, I32 flags)
8ac85365
NIS
1803
1804 /* See G_* flags in cop.h */
a0d0e21e 1805{
924508f0 1806 dSP;
a0d0e21e 1807 UNOP myop; /* fake syntax tree node */
3280af22 1808 I32 oldmark = SP - PL_stack_base;
4633a7c4 1809 I32 retval;
4633a7c4 1810 I32 oldscope;
6224f72b 1811 int ret;
533c011a 1812 OP* oldop = PL_op;
db36c5a1 1813 dJMPENV;
84902520 1814
4633a7c4
LW
1815 if (flags & G_DISCARD) {
1816 ENTER;
1817 SAVETMPS;
1818 }
1819
462e5cf6 1820 SAVEOP();
533c011a
NIS
1821 PL_op = (OP*)&myop;
1822 Zero(PL_op, 1, UNOP);
3280af22
NIS
1823 EXTEND(PL_stack_sp, 1);
1824 *++PL_stack_sp = sv;
1825 oldscope = PL_scopestack_ix;
79072805 1826
4633a7c4
LW
1827 if (!(flags & G_NOARGS))
1828 myop.op_flags = OPf_STACKED;
79072805 1829 myop.op_next = Nullop;
6e72f9df 1830 myop.op_type = OP_ENTEREVAL;
54310121
PP
1831 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1832 (flags & G_ARRAY) ? OPf_WANT_LIST :
1833 OPf_WANT_SCALAR);
6e72f9df
PP
1834 if (flags & G_KEEPERR)
1835 myop.op_flags |= OPf_SPECIAL;
4633a7c4 1836
14dd3ad8 1837#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1838 redo_body:
14dd3ad8 1839 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 1840 (OP*)&myop, TRUE);
14dd3ad8
GS
1841#else
1842 JMPENV_PUSH(ret);
1843#endif
6224f72b
GS
1844 switch (ret) {
1845 case 0:
14dd3ad8
GS
1846#ifndef PERL_FLEXIBLE_EXCEPTIONS
1847 redo_body:
1848 call_body((OP*)&myop,TRUE);
1849#endif
312caa8e
CS
1850 retval = PL_stack_sp - (PL_stack_base + oldmark);
1851 if (!(flags & G_KEEPERR))
1852 sv_setpv(ERRSV,"");
4633a7c4 1853 break;
6224f72b 1854 case 1:
f86702cc 1855 STATUS_ALL_FAILURE;
4633a7c4 1856 /* FALL THROUGH */
6224f72b 1857 case 2:
4633a7c4 1858 /* my_exit() was called */
3280af22 1859 PL_curstash = PL_defstash;
4633a7c4 1860 FREETMPS;
14dd3ad8 1861 JMPENV_POP;
cc3604b1 1862 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 1863 Perl_croak(aTHX_ "Callback called exit");
f86702cc 1864 my_exit_jump();
4633a7c4 1865 /* NOTREACHED */
6224f72b 1866 case 3:
3280af22 1867 if (PL_restartop) {
533c011a 1868 PL_op = PL_restartop;
3280af22 1869 PL_restartop = 0;
312caa8e 1870 goto redo_body;
4633a7c4 1871 }
3280af22 1872 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW
1873 if (flags & G_ARRAY)
1874 retval = 0;
1875 else {
1876 retval = 1;
3280af22 1877 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 1878 }
312caa8e 1879 break;
4633a7c4
LW
1880 }
1881
14dd3ad8 1882 JMPENV_POP;
4633a7c4 1883 if (flags & G_DISCARD) {
3280af22 1884 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW
1885 retval = 0;
1886 FREETMPS;
1887 LEAVE;
1888 }
533c011a 1889 PL_op = oldop;
4633a7c4
LW
1890 return retval;
1891}
1892
954c1994
GS
1893/*
1894=for apidoc p||eval_pv
1895
1896Tells Perl to C<eval> the given string and return an SV* result.
1897
1898=cut
1899*/
1900
137443ea 1901SV*
864dbfa3 1902Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea
PP
1903{
1904 dSP;
1905 SV* sv = newSVpv(p, 0);
1906
924508f0 1907 PUSHMARK(SP);
864dbfa3 1908 eval_sv(sv, G_SCALAR);
137443ea
PP
1909 SvREFCNT_dec(sv);
1910
1911 SPAGAIN;
1912 sv = POPs;
1913 PUTBACK;
1914
2d8e6c8d
GS
1915 if (croak_on_error && SvTRUE(ERRSV)) {
1916 STRLEN n_a;
cea2e8a9 1917 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 1918 }
137443ea
PP
1919
1920 return sv;
1921}
1922
4633a7c4
LW
1923/* Require a module. */
1924
954c1994
GS
1925/*
1926=for apidoc p||require_pv
1927
1928Tells Perl to C<require> a module.
1929
1930=cut
1931*/
1932
4633a7c4 1933void
864dbfa3 1934Perl_require_pv(pTHX_ const char *pv)
4633a7c4 1935{
d3acc0f7
JP
1936 SV* sv;
1937 dSP;
e788e7d3 1938 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP
1939 PUTBACK;
1940 sv = sv_newmortal();
4633a7c4
LW
1941 sv_setpv(sv, "require '");
1942 sv_catpv(sv, pv);
1943 sv_catpv(sv, "'");
864dbfa3 1944 eval_sv(sv, G_DISCARD);
d3acc0f7
JP
1945 SPAGAIN;
1946 POPSTACK;
79072805
LW
1947}
1948
79072805 1949void
864dbfa3 1950Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW
1951{
1952 register GV *gv;
1953
155aba94 1954 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
79072805
LW
1955 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1956}
1957
76e3520e 1958STATIC void
cea2e8a9 1959S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 1960{
ab821d7f
PP
1961 /* This message really ought to be max 23 lines.
1962 * Removed -h because the user already knows that opton. Others? */
fb73857a 1963
76e3520e 1964 static char *usage_msg[] = {
fb73857a
PP
1965"-0[octal] specify record separator (\\0, if no argument)",
1966"-a autosplit mode with -n or -p (splits $_ into @F)",
46487f74 1967"-C enable native wide character system interfaces",
1950ee41 1968"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS
1969"-d[:debugger] run program under debugger",
1970"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1971"-e 'command' one line of program (several -e's allowed, omit programfile)",
1972"-F/pattern/ split() pattern for -a switch (//'s are optional)",
1973"-i[extension] edit <> files in place (makes backup if extension supplied)",
1974"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 1975"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS
1976"-[mM][-]module execute `use/no module...' before executing program",
1977"-n assume 'while (<>) { ... }' loop around program",
1978"-p assume loop like -n but print line also, like sed",
1979"-P run program through C preprocessor before compilation",
1980"-s enable rudimentary parsing for switches after programfile",
1981"-S look for programfile using PATH environment variable",
1982"-T enable tainting checks",
1983"-u dump core after parsing program",
fb73857a 1984"-U allow unsafe operations",
aac3bd0d
GS
1985"-v print version, subversion (includes VERY IMPORTANT perl info)",
1986"-V[:variable] print configuration summary (or a single Config.pm variable)",
1987"-w enable many useful warnings (RECOMMENDED)",
3c0facb2
GS
1988"-W enable all warnings",
1989"-X disable all warnings",
fb73857a
PP
1990"-x[directory] strip off text before #!perl line and perhaps cd to directory",
1991"\n",
1992NULL
1993};
76e3520e 1994 char **p = usage_msg;
fb73857a 1995
b0e47665
GS
1996 PerlIO_printf(PerlIO_stdout(),
1997 "\nUsage: %s [switches] [--] [programfile] [arguments]",
1998 name);
fb73857a 1999 while (*p)
b0e47665 2000 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW
2001}
2002
79072805
LW
2003/* This routine handles any switches that can be given during run */
2004
2005char *
864dbfa3 2006Perl_moreswitches(pTHX_ char *s)
79072805
LW
2007{
2008 I32 numlen;
c07a80fd 2009 U32 rschar;
79072805
LW
2010
2011 switch (*s) {
2012 case '0':
a863c7d1
MB
2013 {
2014 dTHR;
b21ed0a9 2015 numlen = 0; /* disallow underscores */
dff6d3cd 2016 rschar = (U32)scan_oct(s, 4, &numlen);
3280af22 2017 SvREFCNT_dec(PL_nrs);
c07a80fd 2018 if (rschar & ~((U8)~0))
3280af22 2019 PL_nrs = &PL_sv_undef;
c07a80fd 2020 else if (!rschar && numlen >= 2)
79cb57f6 2021 PL_nrs = newSVpvn("", 0);
c07a80fd
PP
2022 else {
2023 char ch = rschar;
79cb57f6 2024 PL_nrs = newSVpvn(&ch, 1);
79072805
LW
2025 }
2026 return s + numlen;
a863c7d1 2027 }
46487f74
GS
2028 case 'C':
2029 PL_widesyscalls = TRUE;
2030 s++;
2031 return s;
2304df62 2032 case 'F':
3280af22
NIS
2033 PL_minus_F = TRUE;
2034 PL_splitstr = savepv(s + 1);
2304df62
AD
2035 s += strlen(s);
2036 return s;
79072805 2037 case 'a':
3280af22 2038 PL_minus_a = TRUE;
79072805
LW
2039 s++;
2040 return s;
2041 case 'c':
3280af22 2042 PL_minus_c = TRUE;
79072805
LW
2043 s++;
2044 return s;
2045 case 'd':
bbce6d69 2046 forbid_setid("-d");
4633a7c4 2047 s++;
c07a80fd 2048 if (*s == ':' || *s == '=') {
cea2e8a9 2049 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
4633a7c4 2050 s += strlen(s);
4633a7c4 2051 }
ed094faf 2052 if (!PL_perldb) {
3280af22 2053 PL_perldb = PERLDB_ALL;
a0d0e21e 2054 init_debugger();
ed094faf 2055 }
79072805
LW
2056 return s;
2057 case 'D':
0453d815 2058 {
79072805 2059#ifdef DEBUGGING
bbce6d69 2060 forbid_setid("-D");
79072805 2061 if (isALPHA(s[1])) {
8b73bbec 2062 static char debopts[] = "psltocPmfrxuLHXDS";
79072805
LW
2063 char *d;
2064
93a17b20 2065 for (s++; *s && (d = strchr(debopts,*s)); s++)
3280af22 2066 PL_debug |= 1 << (d - debopts);
79072805
LW
2067 }
2068 else {
3280af22 2069 PL_debug = atoi(s+1);
79072805
LW
2070 for (s++; isDIGIT(*s); s++) ;
2071 }
3280af22 2072 PL_debug |= 0x80000000;
79072805 2073#else
0453d815
PM
2074 dTHR;
2075 if (ckWARN_d(WARN_DEBUGGING))
2076 Perl_warner(aTHX_ WARN_DEBUGGING,
2077 "Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 2078 for (s++; isALNUM(*s); s++) ;
79072805
LW
2079#endif
2080 /*SUPPRESS 530*/
2081 return s;
0453d815 2082 }
4633a7c4 2083 case 'h':
3280af22 2084 usage(PL_origargv[0]);
6ad3d225 2085 PerlProc_exit(0);
79072805 2086 case 'i':
3280af22
NIS
2087 if (PL_inplace)
2088 Safefree(PL_inplace);
2089 PL_inplace = savepv(s+1);
79072805 2090 /*SUPPRESS 530*/
3280af22 2091 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2092 if (*s) {
fb73857a 2093 *s++ = '\0';
7b8d334a
GS
2094 if (*s == '-') /* Additional switches on #! line. */
2095 s++;
2096 }
fb73857a
PP
2097 return s;
2098 case 'I': /* -I handled both here and in parse_perl() */
bbce6d69 2099 forbid_setid("-I");
fb73857a
PP
2100 ++s;
2101 while (*s && isSPACE(*s))
2102 ++s;
2103 if (*s) {
774d564b 2104 char *e, *p;
0df16ed7
GS
2105 p = s;
2106 /* ignore trailing spaces (possibly followed by other switches) */
2107 do {
2108 for (e = p; *e && !isSPACE(*e); e++) ;
2109 p = e;
2110 while (isSPACE(*p))
2111 p++;
2112 } while (*p && *p != '-');
2113 e = savepvn(s, e-s);
9c8a64f0 2114 incpush(e, TRUE, TRUE);
0df16ed7
GS
2115 Safefree(e);
2116 s = p;
2117 if (*s == '-')
2118 s++;
79072805
LW
2119 }
2120 else
a67e862a 2121 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2122 return s;
79072805 2123 case 'l':
3280af22 2124 PL_minus_l = TRUE;
79072805 2125 s++;
3280af22
NIS
2126 if (PL_ors)
2127 Safefree(PL_ors);
79072805 2128 if (isDIGIT(*s)) {
3280af22
NIS
2129 PL_ors = savepv("\n");
2130 PL_orslen = 1;
b21ed0a9 2131 numlen = 0; /* disallow underscores */
dff6d3cd 2132 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
79072805
LW
2133 s += numlen;
2134 }
2135 else {
a863c7d1 2136 dTHR;
3280af22
NIS
2137 if (RsPARA(PL_nrs)) {
2138 PL_ors = "\n\n";
2139 PL_orslen = 2;
c07a80fd
PP
2140 }
2141 else
3280af22
NIS
2142 PL_ors = SvPV(PL_nrs, PL_orslen);
2143 PL_ors = savepvn(PL_ors, PL_orslen);
79072805
LW
2144 }
2145 return s;
1a30305b 2146 case 'M':
bbce6d69 2147 forbid_setid("-M"); /* XXX ? */
1a30305b
PP
2148 /* FALL THROUGH */
2149 case 'm':
bbce6d69 2150 forbid_setid("-m"); /* XXX ? */
1a30305b 2151 if (*++s) {
a5f75d66 2152 char *start;
11343788 2153 SV *sv;
a5f75d66
AD
2154 char *use = "use ";
2155 /* -M-foo == 'no foo' */
2156 if (*s == '-') { use = "no "; ++s; }
11343788 2157 sv = newSVpv(use,0);
a5f75d66 2158 start = s;
1a30305b 2159 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd
PP
2160 while(isALNUM(*s) || *s==':') ++s;
2161 if (*s != '=') {
11343788 2162 sv_catpv(sv, start);
c07a80fd
PP
2163 if (*(start-1) == 'm') {
2164 if (*s != '\0')
cea2e8a9 2165 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2166 sv_catpv( sv, " ()");
c07a80fd
PP
2167 }
2168 } else {
6df41af2 2169 if (s == start)
be98fb35
GS
2170 Perl_croak(aTHX_ "Module name required with -%c option",
2171 s[-1]);
11343788
MB
2172 sv_catpvn(sv, start, s-start);
2173 sv_catpv(sv, " split(/,/,q{");
2174 sv_catpv(sv, ++s);
2175 sv_catpv(sv, "})");
c07a80fd 2176 }
1a30305b 2177 s += strlen(s);
5c831c24 2178 if (!PL_preambleav)
3280af22
NIS
2179 PL_preambleav = newAV();
2180 av_push(PL_preambleav, sv);
1a30305b
PP
2181 }
2182 else
cea2e8a9 2183 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2184 return s;
79072805 2185 case 'n':
3280af22 2186 PL_minus_n = TRUE;
79072805
LW
2187 s++;
2188 return s;
2189 case 'p':
3280af22 2190 PL_minus_p = TRUE;
79072805
LW
2191 s++;
2192 return s;
2193 case 's':
bbce6d69 2194 forbid_setid("-s");
3280af22 2195 PL_doswitches = TRUE;
79072805
LW
2196 s++;
2197 return s;
463ee0b2 2198 case 'T':
3280af22 2199 if (!PL_tainting)
cea2e8a9 2200 Perl_croak(aTHX_ "Too late for \"-T\" option");
463ee0b2
LW
2201 s++;
2202 return s;
79072805 2203 case 'u':
bf4acbe4
GS
2204#ifdef MACOS_TRADITIONAL
2205 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2206#endif
3280af22 2207 PL_do_undump = TRUE;
79072805
LW
2208 s++;
2209 return s;
2210 case 'U':
3280af22 2211 PL_unsafe = TRUE;
79072805
LW
2212 s++;
2213 return s;
2214 case 'v':
b0e47665
GS
2215 PerlIO_printf(PerlIO_stdout(),
2216 Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
2217 PL_patchlevel, ARCHNAME));
fb73857a
PP
2218#if defined(LOCAL_PATCH_COUNT)
2219 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS
2220 PerlIO_printf(PerlIO_stdout(),
2221 "\n(with %d registered patch%s, "
2222 "see perl -V for more detail)",
2223 (int)LOCAL_PATCH_COUNT,
2224 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2225#endif
1a30305b 2226
b0e47665
GS
2227 PerlIO_printf(PerlIO_stdout(),
2228 "\n\nCopyright 1987-2000, Larry Wall\n");
79072805 2229#ifdef MSDOS
b0e47665
GS
2230 PerlIO_printf(PerlIO_stdout(),
2231 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff
PP
2232#endif
2233#ifdef DJGPP
b0e47665
GS
2234 PerlIO_printf(PerlIO_stdout(),
2235 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2236 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2237#endif
79072805 2238#ifdef OS2
b0e47665
GS
2239 PerlIO_printf(PerlIO_stdout(),
2240 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2241 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2242#endif
79072805 2243#ifdef atarist
b0e47665
GS
2244 PerlIO_printf(PerlIO_stdout(),
2245 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2246#endif
a3f9223b 2247#ifdef __BEOS__
b0e47665
GS
2248 PerlIO_printf(PerlIO_stdout(),
2249 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2250#endif
1d84e8df 2251#ifdef MPE
b0e47665
GS
2252 PerlIO_printf(PerlIO_stdout(),
2253 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1d84e8df 2254#endif
9d116dd7 2255#ifdef OEMVS
b0e47665
GS
2256 PerlIO_printf(PerlIO_stdout(),
2257 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2258#endif
495c5fdc 2259#ifdef __VOS__
b0e47665
GS
2260 PerlIO_printf(PerlIO_stdout(),
2261 "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
495c5fdc 2262#endif
092bebab 2263#ifdef __OPEN_VM
b0e47665
GS
2264 PerlIO_printf(PerlIO_stdout(),
2265 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2266#endif
a1a0e61e 2267#ifdef POSIX_BC
b0e47665
GS
2268 PerlIO_printf(PerlIO_stdout(),
2269 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2270#endif
61ae2fbf 2271#ifdef __MINT__
b0e47665
GS
2272 PerlIO_printf(PerlIO_stdout(),
2273 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2274#endif
f83d2536 2275#ifdef EPOC
b0e47665
GS
2276 PerlIO_printf(PerlIO_stdout(),
2277 "EPOC port by Olaf Flebbe, 1999-2000\n");
f83d2536 2278#endif
baed7233
DL
2279#ifdef BINARY_BUILD_NOTICE
2280 BINARY_BUILD_NOTICE;
2281#endif
b0e47665
GS
2282 PerlIO_printf(PerlIO_stdout(),
2283 "\n\
79072805 2284Perl may be copied only under the terms of either the Artistic License or the\n\
95103687
GS
2285GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2286Complete documentation for Perl, including FAQ lists, should be found on\n\
2287this system using `man perl' or `perldoc perl'. If you have access to the\n\
2288Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
6ad3d225 2289 PerlProc_exit(0);
79072805 2290 case 'w':
599cee73
PM
2291 if (! (PL_dowarn & G_WARN_ALL_MASK))
2292 PL_dowarn |= G_WARN_ON;
2293 s++;
2294 return s;
2295 case 'W':
2296 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
d3a7d8c7 2297 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM
2298 s++;
2299 return s;
2300 case 'X':
2301 PL_dowarn = G_WARN_ALL_OFF;
d3a7d8c7 2302 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW
2303 s++;
2304 return s;
a0d0e21e 2305 case '*':
79072805
LW
2306 case ' ':
2307 if (s[1] == '-') /* Additional switches on #! line. */
2308 return s+2;
2309 break;
a0d0e21e 2310 case '-':
79072805 2311 case 0:
51882d45 2312#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS
2313 case '\r':
2314#endif
79072805
LW
2315 case '\n':
2316 case '\t':
2317 break;
aa689395
PP
2318#ifdef ALTERNATE_SHEBANG
2319 case 'S': /* OS/2 needs -S on "extproc" line. */
2320 break;
2321#endif
a0d0e21e 2322 case 'P':
3280af22 2323 if (PL_preprocess)
a0d0e21e
LW
2324 return s+1;
2325 /* FALL THROUGH */
79072805 2326 default:
cea2e8a9 2327 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW
2328 }
2329 return Nullch;
2330}
2331
2332/* compliments of Tom Christiansen */
2333
2334/* unexec() can be found in the Gnu emacs distribution */
ee580363 2335/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW
2336
2337void
864dbfa3 2338Perl_my_unexec(pTHX)
79072805
LW
2339{
2340#ifdef UNEXEC
46fc3d4c
PP
2341 SV* prog;
2342 SV* file;
ee580363 2343 int status = 1;
79072805
LW
2344 extern int etext;
2345
ee580363 2346 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2347 sv_catpv(prog, "/perl");
6b88bc9c 2348 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2349 sv_catpv(file, ".perldump");
79072805 2350
ee580363
GS
2351 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2352 /* unexec prints msg to stderr in case of failure */
6ad3d225 2353 PerlProc_exit(status);
79072805 2354#else
a5f75d66
AD
2355# ifdef VMS
2356# include <lib$routines.h>
2357 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2358# else
79072805 2359 ABORT(); /* for use with undump */
aa689395 2360# endif
a5f75d66 2361#endif
79072805
LW
2362}
2363
cb68f92d
GS
2364/* initialize curinterp */
2365STATIC void
cea2e8a9 2366S_init_interp(pTHX)
cb68f92d
GS
2367{
2368
066ef5b5 2369#ifdef PERL_OBJECT /* XXX kludge */
cb68f92d 2370#define I_REINIT \
6b88bc9c
GS
2371 STMT_START { \
2372 PL_chopset = " \n-"; \
2373 PL_copline = NOLINE; \
2374 PL_curcop = &PL_compiling;\
2375 PL_curcopdb = NULL; \
2376 PL_dbargs = 0; \
3967c732 2377 PL_dumpindent = 4; \
6b88bc9c
GS
2378 PL_laststatval = -1; \
2379 PL_laststype = OP_STAT; \
2380 PL_maxscream = -1; \
2381 PL_maxsysfd = MAXSYSFD; \
2382 PL_statname = Nullsv; \
2383 PL_tmps_floor = -1; \
2384 PL_tmps_ix = -1; \
2385 PL_op_mask = NULL; \
6b88bc9c
GS
2386 PL_laststatval = -1; \
2387 PL_laststype = OP_STAT; \
2388 PL_mess_sv = Nullsv; \
2389 PL_splitstr = " "; \
2390 PL_generation = 100; \
2391 PL_exitlist = NULL; \
2392 PL_exitlistlen = 0; \
2393 PL_regindent = 0; \
2394 PL_in_clean_objs = FALSE; \
2395 PL_in_clean_all = FALSE; \
2396 PL_profiledata = NULL; \
2397 PL_rsfp = Nullfp; \
2398 PL_rsfp_filters = Nullav; \
24d3c518 2399 PL_dirty = FALSE; \
cb68f92d 2400 } STMT_END
9666903d 2401 I_REINIT;
066ef5b5
GS
2402#else
2403# ifdef MULTIPLICITY
2404# define PERLVAR(var,type)
51371543 2405# define PERLVARA(var,n,type)
cea2e8a9 2406# if defined(PERL_IMPLICIT_CONTEXT)
54aff467
GS
2407# if defined(USE_THREADS)
2408# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2409# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2410# else /* !USE_THREADS */
2411# define PERLVARI(var,type,init) aTHX->var = init;
2412# define PERLVARIC(var,type,init) aTHX->var = init;
2413# endif /* USE_THREADS */
cea2e8a9 2414# else
c5be433b
GS
2415# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2416# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
cea2e8a9 2417# endif
066ef5b5
GS
2418# include "intrpvar.h"
2419# ifndef USE_THREADS
2420# include "thrdvar.h"
2421# endif
2422# undef PERLVAR
51371543 2423# undef PERLVARA
066ef5b5
GS
2424# undef PERLVARI
2425# undef PERLVARIC
3967c732 2426# else
066ef5b5 2427# define PERLVAR(var,type)
51371543 2428# define PERLVARA(var,n,type)
533c011a
NIS
2429# define PERLVARI(var,type,init) PL_##var = init;
2430# define PERLVARIC(var,type,init) PL_##var = init;
066ef5b5
GS
2431# include "intrpvar.h"
2432# ifndef USE_THREADS
2433# include "thrdvar.h"
2434# endif
2435# undef PERLVAR
51371543 2436# undef PERLVARA
066ef5b5
GS
2437# undef PERLVARI
2438# undef PERLVARIC
2439# endif
cb68f92d
GS
2440#endif
2441
cb68f92d
GS
2442}
2443
76e3520e 2444STATIC void
cea2e8a9 2445S_init_main_stash(pTHX)
79072805 2446{
11343788 2447 dTHR;
463ee0b2 2448 GV *gv;
6e72f9df
PP
2449
2450 /* Note that strtab is a rather special HV. Assumptions are made
2451 about not iterating on it, and not adding tie magic to it.
2452 It is properly deallocated in perl_destruct() */
3280af22 2453 PL_strtab = newHV();
5f08fbcd
GS
2454#ifdef USE_THREADS
2455 MUTEX_INIT(&PL_strtab_mutex);
2456#endif
3280af22
NIS
2457 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2458 hv_ksplit(PL_strtab, 512);
6e72f9df 2459
3280af22 2460 PL_curstash = PL_defstash = newHV();
79cb57f6 2461 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW
2462 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2463 SvREFCNT_dec(GvHV(gv));
3280af22 2464 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2465 SvREADONLY_on(gv);
3280af22
NIS
2466 HvNAME(PL_defstash) = savepv("main");
2467 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2468 GvMULTI_on(PL_incgv);
2469 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2470 GvMULTI_on(PL_hintgv);
2471 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2472 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2473 GvMULTI_on(PL_errgv);
2474 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2475 GvMULTI_on(PL_replgv);
cea2e8a9 2476 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB
2477 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2478 sv_setpvn(ERRSV, "", 0);
3280af22 2479 PL_curstash = PL_defstash;
11faa288 2480 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2481 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2482 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
92d29cee 2483 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2484 /* We must init $/ before switches are processed. */
864dbfa3 2485 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW
2486}
2487
76e3520e 2488STATIC void
cea2e8a9 2489S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2490{
0f15f207 2491 dTHR;
2a92aaa0 2492
6c4ab083 2493 *fdscript = -1;
79072805 2494
3280af22
NIS
2495 if (PL_e_script) {
2496 PL_origfilename = savepv("-e");
96436eeb 2497 }
6c4ab083
GS
2498 else {
2499 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2500 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS
2501
2502 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2503 char *s = scriptname + 8;
2504 *fdscript = atoi(s);
2505 while (isDIGIT(*s))
2506 s++;
2507 if (*s) {
2508 scriptname = savepv(s + 1);
3280af22
NIS
2509 Safefree(PL_origfilename);
2510 PL_origfilename = scriptname;
6c4ab083
GS
2511 }
2512 }
2513 }
2514
57843af0 2515 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2516 if (strEQ(PL_origfilename,"-"))
79072805 2517 scriptname = "";
01f988be 2518 if (*fdscript >= 0) {
3280af22 2519 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
96436eeb 2520#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS
2521 if (PL_rsfp)
2522 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
2523#endif
2524 }
3280af22 2525 else if (PL_preprocess) {
46fc3d4c 2526 char *cpp_cfg = CPPSTDIN;
79cb57f6 2527 SV *cpp = newSVpvn("",0);
46fc3d4c
PP
2528 SV *cmd = NEWSV(0,0);
2529
2530 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2531 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2532 sv_catpv(cpp, cpp_cfg);
79072805 2533
0df16ed7 2534 sv_catpvn(sv, "-I", 2);
fed7345c 2535 sv_catpv(sv,PRIVLIB_EXP);
46fc3d4c 2536
52853b95 2537#if defined(MSDOS) || defined(WIN32)
cea2e8a9 2538 Perl_sv_setpvf(aTHX_ cmd, "\
79072805
LW
2539sed %s -e \"/^[^#]/b\" \
2540 -e \"/^#[ ]*include[ ]/b\" \
2541 -e \"/^#[ ]*define[ ]/b\" \
2542 -e \"/^#[ ]*if[ ]/b\" \
2543 -e \"/^#[ ]*ifdef[ ]/b\" \
2544 -e \"/^#[ ]*ifndef[ ]/b\" \
2545 -e \"/^#[ ]*else/b\" \
2546 -e \"/^#[ ]*elif[ ]/b\" \
2547 -e \"/^#[ ]*undef[ ]/b\" \
2548 -e \"/^#[ ]*endif/b\" \
2549 -e \"s/^#.*//\" \
894356b3 2550 %s | %"SVf" -C %"SVf" %s",
6b88bc9c 2551 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
79072805 2552#else
092bebab 2553# ifdef __OPEN_VM
cea2e8a9 2554 Perl_sv_setpvf(aTHX_ cmd, "\
092bebab
JH
2555%s %s -e '/^[^#]/b' \
2556 -e '/^#[ ]*include[ ]/b' \
2557 -e '/^#[ ]*define[ ]/b' \
2558 -e '/^#[ ]*if[ ]/b' \
2559 -e '/^#[ ]*ifdef[ ]/b' \
2560 -e '/^#[ ]*ifndef[ ]/b' \
2561 -e '/^#[ ]*else/b' \
2562 -e '/^#[ ]*elif[ ]/b' \
2563 -e '/^#[ ]*undef[ ]/b' \
2564 -e '/^#[ ]*endif/b' \
2565 -e 's/^[ ]*#.*//' \
894356b3 2566 %s | %"SVf" %"SVf" %s",
092bebab 2567# else
cea2e8a9 2568 Perl_sv_setpvf(aTHX_ cmd, "\
79072805
LW
2569%s %s -e '/^[^#]/b' \
2570 -e '/^#[ ]*include[ ]/b' \
2571 -e '/^#[ ]*define[ ]/b' \
2572 -e '/^#[ ]*if[ ]/b' \
2573 -e '/^#[ ]*ifdef[ ]/b' \
2574 -e '/^#[ ]*ifndef[ ]/b' \
2575 -e '/^#[ ]*else/b' \
2576 -e '/^#[ ]*elif[ ]/b' \
2577 -e '/^#[ ]*undef[ ]/b' \
2578 -e '/^#[ ]*endif/b' \
2579 -e 's/^[ ]*#.*//' \
894356b3 2580 %s | %"SVf" -C %"SVf" %s",
092bebab 2581# endif
79072805
LW
2582#ifdef LOC_SED
2583 LOC_SED,
2584#else
2585 "sed",
2586#endif
3280af22 2587 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
79072805 2588#endif
46fc3d4c 2589 scriptname, cpp, sv, CPPMINUS);
3280af22 2590 PL_doextract = FALSE;
79072805 2591#ifdef IAMSUID /* actually, this is caught earlier */
b28d0864 2592 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
79072805 2593#ifdef HAS_SETEUID
b28d0864 2594 (void)seteuid(PL_uid); /* musn't stay setuid root */
79072805
LW
2595#else
2596#ifdef HAS_SETREUID
b28d0864 2597 (void)setreuid((Uid_t)-1, PL_uid);
85e6fe83
LW
2598#else
2599#ifdef HAS_SETRESUID
b28d0864 2600 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
79072805 2601#else
b28d0864 2602 PerlProc_setuid(PL_uid);
79072805
LW
2603#endif
2604#endif
85e6fe83 2605#endif
b28d0864 2606 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2607 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805
LW
2608 }
2609#endif /* IAMSUID */
3280af22 2610 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c
PP
2611 SvREFCNT_dec(cmd);
2612 SvREFCNT_dec(cpp);
79072805
LW
2613 }
2614 else if (!*scriptname) {
bbce6d69 2615 forbid_setid("program input from stdin");
3280af22 2616 PL_rsfp = PerlIO_stdin();
79072805 2617 }
96436eeb 2618 else {
3280af22 2619 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
96436eeb 2620#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS
2621 if (PL_rsfp)
2622 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
2623#endif
2624 }
3280af22 2625 if (!PL_rsfp) {
13281fa4 2626#ifdef DOSUID
a687059c 2627#ifndef IAMSUID /* in case script is not readable before setuid */
6b88bc9c 2628 if (PL_euid &&
cc49e20b 2629 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
6b88bc9c
GS
2630 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2631 {
46fc3d4c 2632 /* try again */
a7cb1f99 2633 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS
2634 (int)PERL_REVISION, (int)PERL_VERSION,
2635 (int)PERL_SUBVERSION), PL_origargv);
cea2e8a9 2636 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW
2637 }
2638#endif
2639#endif
cea2e8a9 2640 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
cc49e20b 2641 CopFILE(PL_curcop), Strerror(errno));
13281fa4 2642 }
79072805 2643}
8d063cd8 2644
7b89560d
JH
2645/* Mention
2646 * I_SYSSTATVFS HAS_FSTATVFS
2647 * I_SYSMOUNT
c890dc6c 2648 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH
2649 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2650 * here so that metaconfig picks them up. */
2651
104d25b7 2652#ifdef IAMSUID
864dbfa3 2653STATIC int
e688b231 2654S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 2655{
0545a864
JH
2656 int check_okay = 0; /* able to do all the required sys/libcalls */
2657 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 2658/*
ad27e871 2659 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 2660 * fstatvfs() is UNIX98.
0545a864 2661 * fstatfs() is 4.3 BSD.
ad27e871 2662 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH
2663 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2664 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH
2665 */
2666
6439433f
JH
2667#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2668
2669# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2670 defined(HAS_FSTATVFS)
2671# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 2672 struct statvfs stfs;
6439433f 2673
104d25b7
JH
2674 check_okay = fstatvfs(fd, &stfs) == 0;
2675 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
6439433f
JH
2676# endif /* fstatvfs */
2677
2678# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2679 defined(PERL_MOUNT_NOSUID) && \
2680 defined(HAS_FSTATFS) && \
2681 defined(HAS_STRUCT_STATFS) && \
2682 defined(HAS_STRUCT_STATFS_F_FLAGS)
2683# define FD_ON_NOSUID_CHECK_OKAY
e688b231 2684 struct statfs stfs;
6439433f 2685
104d25b7 2686 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 2687 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
6439433f
JH
2688# endif /* fstatfs */
2689
2690# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2691 defined(PERL_MOUNT_NOSUID) && \
2692 defined(HAS_FSTAT) && \
2693 defined(HAS_USTAT) && \
2694 defined(HAS_GETMNT) && \
2695 defined(HAS_STRUCT_FS_DATA) && \
2696 defined(NOSTAT_ONE)
2697# define FD_ON_NOSUID_CHECK_OKAY
0545a864 2698 struct stat fdst;
6439433f 2699
0545a864 2700 if (fstat(fd, &fdst) == 0) {
6439433f
JH
2701 struct ustat us;
2702 if (ustat(fdst.st_dev, &us) == 0) {
2703 struct fs_data fsd;
2704 /* NOSTAT_ONE here because we're not examining fields which
2705 * vary between that case and STAT_ONE. */
ad27e871 2706 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH
2707 size_t cmplen = sizeof(us.f_fname);
2708 if (sizeof(fsd.fd_req.path) < cmplen)
2709 cmplen = sizeof(fsd.fd_req.path);
2710 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2711 fdst.st_dev == fsd.fd_req.dev) {
2712 check_okay = 1;
2713 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2714 }
2715 }
2716 }
2717 }
0545a864 2718 }
6439433f
JH
2719# endif /* fstat+ustat+getmnt */
2720
2721# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2722 defined(HAS_GETMNTENT) && \
2723 defined(HAS_HASMNTOPT) && \
2724 defined(MNTOPT_NOSUID)
2725# define FD_ON_NOSUID_CHECK_OKAY
2726 FILE *mtab = fopen("/etc/mtab", "r");
2727 struct mntent *entry;
2728 struct stat stb, fsb;
104d25b7
JH
2729
2730 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH
2731 while (entry = getmntent(mtab)) {
2732 if (stat(entry->mnt_dir, &fsb) == 0
2733 && fsb.st_dev == stb.st_dev)
2734 {
2735 /* found the filesystem */
2736 check_okay = 1;
2737 if (hasmntopt(entry, MNTOPT_NOSUID))
2738 on_nosuid = 1;
2739 break;
2740 } /* A single fs may well fail its stat(). */
2741 }
104d25b7
JH
2742 }
2743 if (mtab)
6439433f
JH
2744 fclose(mtab);
2745# endif /* getmntent+hasmntopt */
0545a864 2746
104d25b7 2747 if (!check_okay)
0545a864 2748 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH
2749 return on_nosuid;
2750}
2751#endif /* IAMSUID */
2752
76e3520e 2753STATIC void
cea2e8a9 2754S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 2755{
155aba94 2756#ifdef IAMSUID
96436eeb 2757 int which;
155aba94 2758#endif
96436eeb 2759
13281fa4
LW
2760 /* do we need to emulate setuid on scripts? */
2761
2762 /* This code is for those BSD systems that have setuid #! scripts disabled
2763 * in the kernel because of a security problem. Merely defining DOSUID
2764 * in perl will not fix that problem, but if you have disabled setuid
2765 * scripts in the kernel, this will attempt to emulate setuid and setgid
2766 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW
2767 * root version must be called suidperl or sperlN.NNN. If regular perl
2768 * discovers that it has opened a setuid script, it calls suidperl with
2769 * the same argv that it had. If suidperl finds that the script it has
2770 * just opened is NOT setuid root, it sets the effective uid back to the
2771 * uid. We don't just make perl setuid root because that loses the
2772 * effective uid we had before invoking perl, if it was different from the
2773 * uid.
13281fa4
LW
2774 *
2775 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2776 * be defined in suidperl only. suidperl must be setuid root. The
2777 * Configure script will set this up for you if you want it.
2778 */
a687059c 2779
13281fa4 2780#ifdef DOSUID
ea0efc06 2781 dTHR;
6e72f9df 2782 char *s, *s2;
a0d0e21e 2783
b28d0864 2784 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 2785 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 2786 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2787 I32 len;
2d8e6c8d 2788 STRLEN n_a;
13281fa4 2789
a687059c 2790#ifdef IAMSUID
fe14fcc3 2791#ifndef HAS_SETREUID
a687059c
LW
2792 /* On this access check to make sure the directories are readable,
2793 * there is actually a small window that the user could use to make
2794 * filename point to an accessible directory. So there is a faint
2795 * chance that someone could execute a setuid script down in a
2796 * non-accessible directory. I don't know what to do about that.
2797 * But I don't think it's too important. The manual lies when
2798 * it says access() is useful in setuid programs.
2799 */
cc49e20b 2800 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 2801 Perl_croak(aTHX_ "Permission denied");
a687059c
LW
2802#else
2803 /* If we can swap euid and uid, then we can determine access rights
2804 * with a simple stat of the file, and then compare device and
2805 * inode to make sure we did stat() on the same file we opened.
2806 * Then we just have to make sure he or she can execute it.
2807 */
2808 {
2809 struct stat tmpstatbuf;
2810
85e6fe83
LW
2811 if (
2812#ifdef HAS_SETREUID
b28d0864 2813 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW
2814#else
2815# if HAS_SETRESUID
b28d0864 2816 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 2817# endif
85e6fe83 2818#endif
b28d0864 2819 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 2820 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 2821 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 2822 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 2823#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 2824 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 2825 Perl_croak(aTHX_ "Permission denied");
104d25b7 2826#endif
b28d0864
NIS
2827 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2828 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2829 (void)PerlIO_close(PL_rsfp);
2830 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2831 PerlIO_printf(PL_rsfp,
785fb66b
JH
2832"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2833(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2834 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
b28d0864 2835 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
cc49e20b 2836 CopFILE(PL_curcop),
785fb66b 2837 PL_statbuf.st_uid, PL_statbuf.st_gid);
b28d0864 2838 (void)PerlProc_pclose(PL_rsfp);
a687059c 2839 }
cea2e8a9 2840 Perl_croak(aTHX_ "Permission denied\n");
a687059c 2841 }
85e6fe83
LW
2842 if (
2843#ifdef HAS_SETREUID
b28d0864 2844 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW
2845#else
2846# if defined(HAS_SETRESUID)
b28d0864 2847 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 2848# endif
85e6fe83 2849#endif
b28d0864 2850 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 2851 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 2852 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 2853 Perl_croak(aTHX_ "Permission denied\n");
a687059c 2854 }
fe14fcc3 2855#endif /* HAS_SETREUID */
a687059c
LW
2856#endif /* IAMSUID */
2857
b28d0864 2858 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 2859 Perl_croak(aTHX_ "Permission denied");
b28d0864 2860 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 2861 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 2862 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 2863 CopLINE_inc(PL_curcop);
6b88bc9c 2864 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 2865 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 2866 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 2867 s = SvPV(PL_linestr,n_a)+2;
663a0e37 2868 if (*s == ' ') s++;
45d8adaa 2869 while (!isSPACE(*s)) s++;
2d8e6c8d 2870 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df
PP
2871 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2872 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 2873 Perl_croak(aTHX_ "Not a perl script");
a687059c 2874 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
2875 /*
2876 * #! arg must be what we saw above. They can invoke it by
2877 * mentioning suidperl explicitly, but they may not add any strange
2878 * arguments beyond what #! says if they do invoke suidperl that way.
2879 */
2880 len = strlen(validarg);
2881 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 2882 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 2883 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW
2884
2885#ifndef IAMSUID
b28d0864
NIS
2886 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2887 PL_euid == PL_statbuf.st_uid)
2888 if (!PL_do_undump)
cea2e8a9 2889 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2890FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2891#endif /* IAMSUID */
13281fa4 2892
b28d0864
NIS
2893 if (PL_euid) { /* oops, we're not the setuid root perl */
2894 (void)PerlIO_close(PL_rsfp);
13281fa4 2895#ifndef IAMSUID
46fc3d4c 2896 /* try again */
a7cb1f99 2897 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS
2898 (int)PERL_REVISION, (int)PERL_VERSION,
2899 (int)PERL_SUBVERSION), PL_origargv);
13281fa4 2900#endif
cea2e8a9 2901 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW
2902 }
2903
b28d0864 2904 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 2905#ifdef HAS_SETEGID
b28d0864 2906 (void)setegid(PL_statbuf.st_gid);
a687059c 2907#else
fe14fcc3 2908#ifdef HAS_SETREGID
b28d0864 2909 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW
2910#else
2911#ifdef HAS_SETRESGID
b28d0864 2912 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 2913#else
b28d0864 2914 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW
2915#endif
2916#endif
85e6fe83 2917#endif
b28d0864 2918 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 2919 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 2920 }
b28d0864
NIS
2921 if (PL_statbuf.st_mode & S_ISUID) {
2922 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 2923#ifdef HAS_SETEUID
b28d0864 2924 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 2925#else
fe14fcc3 2926#ifdef HAS_SETREUID
b28d0864 2927 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW
2928#else
2929#ifdef HAS_SETRESUID
b28d0864 2930 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 2931#else
b28d0864 2932 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW
2933#endif
2934#endif
85e6fe83 2935#endif
b28d0864 2936 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 2937 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 2938 }
b28d0864 2939 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 2940#ifdef HAS_SETEUID
b28d0864 2941 (void)seteuid((Uid_t)PL_uid);
a687059c 2942#else
fe14fcc3 2943#ifdef HAS_SETREUID
b28d0864 2944 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 2945#else
85e6fe83 2946#ifdef HAS_SETRESUID
b28d0864 2947 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 2948#else
b28d0864 2949 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 2950#endif
a687059c
LW
2951#endif
2952#endif
b28d0864 2953 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2954 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 2955 }
748a9306 2956 init_ids();
b28d0864 2957 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 2958 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW
2959 }
2960#ifdef IAMSUID
6b88bc9c 2961 else if (PL_preprocess)
cea2e8a9 2962 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 2963 else if (fdscript >= 0)
cea2e8a9 2964 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 2965 else
cea2e8a9 2966 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb
PP
2967
2968 /* We absolutely must clear out any saved ids here, so we */
2969 /* exec the real perl, substituting fd script for scriptname. */
2970 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS
2971 PerlIO_rewind(PL_rsfp);
2972 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS
2973 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2974 if (!PL_origargv[which])
cea2e8a9
GS
2975 Perl_croak(aTHX_ "Permission denied");
2976 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 2977 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 2978#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 2979 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 2980#endif
a7cb1f99 2981 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS
2982 (int)PERL_REVISION, (int)PERL_VERSION,
2983 (int)PERL_SUBVERSION), PL_origargv);/* try again */
cea2e8a9 2984 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 2985#endif /* IAMSUID */
a687059c 2986#else /* !DOSUID */
3280af22 2987 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 2988#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
96827780 2989 dTHR;
b28d0864
NIS
2990 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2991 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 2992 ||
b28d0864 2993 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 2994 )
b28d0864 2995 if (!PL_do_undump)
cea2e8a9 2996 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2997FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2998#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2999 /* not set-id, must be wrapped */
a687059c 3000 }
13281fa4 3001#endif /* DOSUID */
79072805 3002}
13281fa4 3003
76e3520e 3004STATIC void
cea2e8a9 3005S_find_beginning(pTHX)
79072805 3006{
6e72f9df 3007 register char *s, *s2;
33b78306
LW
3008
3009 /* skip forward in input to the real script? */
3010
bbce6d69 3011 forbid_setid("-x");
bf4acbe4
GS
3012#ifdef MACOS_TRADITIONAL
3013 /* Since the Mac OS does not honor !# arguments for us, we do it ourselves */
3014
3015 while (PL_doextract || gMacPerl_AlwaysExtract) {
3016 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3017 if (!gMacPerl_AlwaysExtract)
3018 Perl_croak(aTHX_ "No Perl script found in input\n");
3019
3020 if (PL_doextract) /* require explicit override ? */
3021 if (!OverrideExtract(PL_origfilename))
3022 Perl_croak(aTHX_ "User aborted script\n");
3023 else
3024 PL_doextract = FALSE;
3025
3026 /* Pater peccavi, file does not have #! */
3027 PerlIO_rewind(PL_rsfp);
3028
3029 break;
3030 }
3031#else
3280af22
NIS
3032 while (PL_doextract) {
3033 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3034 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3035#endif
6e72f9df 3036 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
3280af22
NIS
3037 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3038 PL_doextract = FALSE;
6e72f9df
PP
3039 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3040 s2 = s;
3041 while (*s == ' ' || *s == '\t') s++;
3042 if (*s++ == '-') {
3043 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3044 if (strnEQ(s2-4,"perl",4))
3045 /*SUPPRESS 530*/
155aba94
GS
3046 while ((s = moreswitches(s)))
3047 ;
33b78306 3048 }
83025b21
LW
3049 }
3050 }
3051}
3052
afe37c7d 3053
76e3520e 3054STATIC void
cea2e8a9 3055S_init_ids(pTHX)
352d5a3a 3056{
d8eceb89
JH
3057 PL_uid = PerlProc_getuid();
3058 PL_euid = PerlProc_geteuid();
3059 PL_gid = PerlProc_getgid();
3060 PL_egid = PerlProc_getegid();
748a9306 3061#ifdef VMS
b28d0864
NIS
3062 PL_uid |= PL_gid << 16;
3063 PL_euid |= PL_egid << 16;
748a9306 3064#endif
3280af22 3065 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 3066}
79072805 3067
76e3520e 3068STATIC void
cea2e8a9 3069S_forbid_setid(pTHX_ char *s)
bbce6d69 3070{
3280af22 3071 if (PL_euid != PL_uid)
cea2e8a9 3072 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 3073 if (PL_egid != PL_gid)
cea2e8a9 3074 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69
PP
3075}
3076
1ee4443e
IZ
3077void
3078Perl_init_debugger(pTHX)
748a9306 3079{
11343788 3080 dTHR;
1ee4443e
IZ
3081 HV *ostash = PL_curstash;
3082
3280af22
NIS
3083 PL_curstash = PL_debstash;
3084 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3085 AvREAL_off(PL_dbargs);
3086 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3087 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3088 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 3089 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22
NIS
3090 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3091 sv_setiv(PL_DBsingle, 0);
3092 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3093 sv_setiv(PL_DBtrace, 0);
3094 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3095 sv_setiv(PL_DBsignal, 0);
1ee4443e 3096 PL_curstash = ostash;
352d5a3a
LW
3097}
3098
2ce36478
SM
3099#ifndef STRESS_REALLOC
3100#define REASONABLE(size) (size)
3101#else
3102#define REASONABLE(size) (1) /* unreasonable */
3103#endif
3104
11343788 3105void
cea2e8a9 3106Perl_init_stacks(pTHX)
79072805 3107{
e336de0d 3108 /* start with 128-item stack and 8K cxstack */
3280af22 3109 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 3110 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS
3111 PL_curstackinfo->si_type = PERLSI_MAIN;
3112 PL_curstack = PL_curstackinfo->si_stack;
3113 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 3114
3280af22
NIS
3115 PL_stack_base = AvARRAY(PL_curstack);
3116 PL_stack_sp = PL_stack_base;
3117 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 3118
3280af22
NIS
3119 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3120 PL_tmps_floor = -1;
3121 PL_tmps_ix = -1;
3122 PL_tmps_max = REASONABLE(128);
8990e307 3123
3280af22
NIS
3124 New(54,PL_markstack,REASONABLE(32),I32);
3125 PL_markstack_ptr = PL_markstack;
3126 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 3127
ce2f7c3b 3128 SET_MARK_OFFSET;
e336de0d 3129
3280af22
NIS
3130 New(54,PL_scopestack,REASONABLE(32),I32);
3131 PL_scopestack_ix = 0;
3132 PL_scopestack_max = REASONABLE(32);
79072805 3133
3280af22
NIS
3134 New(54,PL_savestack,REASONABLE(128),ANY);
3135 PL_savestack_ix = 0;
3136 PL_savestack_max = REASONABLE(128);
79072805 3137
3280af22
NIS
3138 New(54,PL_retstack,REASONABLE(16),OP*);
3139 PL_retstack_ix = 0;
3140 PL_retstack_max = REASONABLE(16);
378cc40b 3141}
33b78306 3142
2ce36478
SM
3143#undef REASONABLE
3144
76e3520e 3145STATIC void
cea2e8a9 3146S_nuke_stacks(pTHX)
6e72f9df 3147{
e858de61 3148 dTHR;
3280af22
NIS
3149 while (PL_curstackinfo->si_next)
3150 PL_curstackinfo = PL_curstackinfo->si_next;
3151 while (PL_curstackinfo) {
3152 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 3153 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS
3154 Safefree(PL_curstackinfo->si_cxstack);
3155 Safefree(PL_curstackinfo);
3156 PL_curstackinfo = p;
e336de0d 3157 }
3280af22
NIS
3158 Safefree(PL_tmps_stack);
3159 Safefree(PL_markstack);
3160 Safefree(PL_scopestack);
3161 Safefree(PL_savestack);
3162 Safefree(PL_retstack);
378cc40b 3163}
33b78306 3164
76e3520e 3165#ifndef PERL_OBJECT
760ac839 3166static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
76e3520e 3167#endif
7aa04957 3168
76e3520e 3169STATIC void
cea2e8a9 3170S_init_lexer(pTHX)
8990e307 3171{
76e3520e
GS
3172#ifdef PERL_OBJECT
3173 PerlIO *tmpfp;
3174#endif
3280af22
NIS
3175 tmpfp = PL_rsfp;
3176 PL_rsfp = Nullfp;
3177 lex_start(PL_linestr);
3178 PL_rsfp = tmpfp;
79cb57f6 3179 PL_subname = newSVpvn("main",4);
8990e307
LW
3180}
3181
76e3520e 3182STATIC void
cea2e8a9 3183S_init_predump_symbols(pTHX)
45d8adaa 3184{
11343788 3185 dTHR;
93a17b20 3186 GV *tmpgv;
af8c498a 3187 IO *io;
79072805 3188
864dbfa3 3189 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS
3190 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3191 GvMULTI_on(PL_stdingv);
af8c498a
GS
3192 io = GvIOp(PL_stdingv);
3193 IoIFP(io) = PerlIO_stdin();
adbc6bb1 3194 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 3195 GvMULTI_on(tmpgv);
af8c498a 3196 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3197
85e6fe83 3198 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 3199 GvMULTI_on(tmpgv);
af8c498a
GS
3200 io = GvIOp(tmpgv);
3201 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 3202 setdefout(tmpgv);
adbc6bb1 3203 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 3204 GvMULTI_on(tmpgv);
af8c498a 3205 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3206
bf49b057
GS
3207 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3208 GvMULTI_on(PL_stderrgv);
3209 io = GvIOp(PL_stderrgv);
af8c498a 3210 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 3211 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 3212 GvMULTI_on(tmpgv);
af8c498a 3213 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3214
3280af22 3215 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 3216
bf4acbe4
GS
3217 if (PL_osname)
3218 Safefree(PL_osname);
3219 PL_osname = savepv(OSNAME);
79072805 3220}
33b78306 3221
76e3520e 3222STATIC void
cea2e8a9 3223S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
33b78306 3224{
a863c7d1 3225 dTHR;
79072805
LW
3226 char *s;
3227 SV *sv;
3228 GV* tmpgv;
fe14fcc3 3229
79072805 3230 argc--,argv++; /* skip name of script */
3280af22 3231 if (PL_doswitches) {
79072805
LW
3232 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3233 if (!argv[0][1])
3234 break;
379d538a 3235 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW
3236 argc--,argv++;
3237 break;
3238 }
155aba94 3239 if ((s = strchr(argv[0], '='))) {
79072805 3240 *s++ = '\0';
85e6fe83 3241 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW
3242 }
3243 else
85e6fe83 3244 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 3245 }
79072805 3246 }
3280af22
NIS
3247 PL_toptarget = NEWSV(0,0);
3248 sv_upgrade(PL_toptarget, SVt_PVFM);
3249 sv_setpvn(PL_toptarget, "", 0);
3250 PL_bodytarget = NEWSV(0,0);
3251 sv_upgrade(PL_bodytarget, SVt_PVFM);
3252 sv_setpvn(PL_bodytarget, "", 0);
3253 PL_formtarget = PL_bodytarget;
79072805 3254
bbce6d69 3255 TAINT;
155aba94 3256 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
bf4acbe4
GS
3257#ifdef MACOS_TRADITIONAL
3258 /* $0 is not majick on a Mac */
3259 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3260#else
3280af22 3261 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 3262 magicname("0", "0", 1);
bf4acbe4 3263#endif
79072805 3264 }
155aba94 3265 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
ed344e4f 3266#ifdef OS2
23da6c43 3267 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
ed344e4f 3268#else
3280af22 3269 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
ed344e4f 3270#endif
155aba94 3271 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3280af22
NIS
3272 GvMULTI_on(PL_argvgv);
3273 (void)gv_AVadd(PL_argvgv);
3274 av_clear(GvAVn(PL_argvgv));
79072805 3275 for (; argc > 0; argc--,argv++) {
729a02f2
GS
3276 SV *sv = newSVpv(argv[0],0);
3277 av_push(GvAVn(PL_argvgv),sv);
3278 if (PL_widesyscalls)
e84ff256 3279 (void)sv_utf8_decode(sv);
79072805
LW
3280 }
3281 }
155aba94 3282 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
79072805 3283 HV *hv;
3280af22
NIS
3284 GvMULTI_on(PL_envgv);
3285 hv = GvHVn(PL_envgv);
3286 hv_magic(hv, PL_envgv, 'E');
bf4acbe4 3287#if !defined( VMS) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) /* VMS doesn't have environ array */
4633a7c4
LW
3288 /* Note that if the supplied env parameter is actually a copy
3289 of the global environ then it may now point to free'd memory
3290 if the environment has been modified since. To avoid this
3291 problem we treat env==NULL as meaning 'use the default'
3292 */
3293 if (!env)
3294 env = environ;
5aabfad6 3295 if (env != environ)
79072805
LW
3296 environ[0] = Nullch;
3297 for (; *env; env++) {
93a17b20 3298 if (!(s = strchr(*env,'=')))
79072805
LW
3299 continue;
3300 *s++ = '\0';
60ce6247 3301#if defined(MSDOS)
137443ea
PP
3302 (void)strupr(*env);
3303#endif
79072805
LW
3304 sv = newSVpv(s--,0);
3305 (void)hv_store(hv, *env, s - *env, sv, 0);
3306 *s = '=';
3e3baf6d
TB
3307#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3308 /* Sins of the RTL. See note in my_setenv(). */
76e3520e 3309 (void)PerlEnv_putenv(savepv(*env));
3e3baf6d 3310#endif
fe14fcc3 3311 }
4550b24a
PP
3312#endif
3313#ifdef DYNAMIC_ENV_FETCH
3314 HvNAME(hv) = savepv(ENV_HV_NAME);
3315#endif
79072805 3316 }
bbce6d69 3317 TAINT_NOT;
155aba94 3318 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
7766f137 3319 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
33b78306 3320}
34de22dd 3321
76e3520e 3322STATIC void
cea2e8a9 3323S_init_perllib(pTHX)
34de22dd 3324{
85e6fe83 3325 char *s;
3280af22 3326 if (!PL_tainting) {
552a7a9b 3327#ifndef VMS
76e3520e 3328 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 3329 if (s)
9c8a64f0 3330 incpush(s, TRUE, TRUE);
85e6fe83 3331 else
9c8a64f0 3332 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
552a7a9b
PP
3333#else /* VMS */
3334 /* Treat PERL5?LIB as a possible search list logical name -- the
3335 * "natural" VMS idiom for a Unix path string. We allow each
3336 * element to be a set of |-separated directories for compatibility.
3337 */
3338 char buf[256];
3339 int idx = 0;
3340 if (my_trnlnm("PERL5LIB",buf,0))
9c8a64f0 3341 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 3342 else
9c8a64f0 3343 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
552a7a9b 3344#endif /* VMS */
85e6fe83 3345 }
34de22dd 3346
c90c0ff4 3347/* Use the ~-expanded versions of APPLLIB (undocumented),
65f19062 3348 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
df5cef82 3349*/
4633a7c4 3350#ifdef APPLLIB_EXP
9c8a64f0 3351 incpush(APPLLIB_EXP, TRUE, TRUE);
16d20bd9 3352#endif
4633a7c4 3353
fed7345c 3354#ifdef ARCHLIB_EXP
9c8a64f0 3355 incpush(ARCHLIB_EXP, FALSE, FALSE);
a0d0e21e 3356#endif
bf4acbe4
GS
3357#ifdef MACOS_TRADITIONAL
3358 {
3359 struct stat tmpstatbuf;
3360 SV * privdir = NEWSV(55, 0);
3361 char * macperl = PerlEnv_getenv("MACPERL");
3362
3363 if (!macperl)
3364 macperl = "";
3365
3366 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3367 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3368 incpush(SvPVX(privdir), TRUE, FALSE);
3369 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3370 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3371 incpush(SvPVX(privdir), TRUE, FALSE);
3372
3373 SvREFCNT_dec(privdir);
3374 }
3375 if (!PL_tainting)
3376 incpush(":", FALSE, FALSE);
3377#else
fed7345c 3378#ifndef PRIVLIB_EXP
65f19062 3379# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 3380#endif
00dc2f4f 3381#if defined(WIN32)
9c8a64f0 3382 incpush(PRIVLIB_EXP, TRUE, FALSE);
00dc2f4f 3383#else
9c8a64f0 3384 incpush(PRIVLIB_EXP, FALSE, FALSE);
00dc2f4f 3385#endif
4633a7c4 3386
65f19062 3387#ifdef SITEARCH_EXP
3b290362
GS
3388 /* sitearch is always relative to sitelib on Windows for
3389 * DLL-based path intuition to work correctly */
3390# if !defined(WIN32)
9c8a64f0 3391 incpush(SITEARCH_EXP, FALSE, FALSE);
65f19062
GS
3392# endif
3393#endif
3394
4633a7c4 3395#ifdef SITELIB_EXP
65f19062 3396# if defined(WIN32)
9c8a64f0 3397 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
65f19062 3398# else
9c8a64f0 3399 incpush(SITELIB_EXP, FALSE, FALSE);
65f19062
GS
3400# endif
3401#endif
189d1e8d 3402
65f19062 3403#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
9c8a64f0 3404 incpush(SITELIB_STEM, FALSE, TRUE);
81c6dfba 3405#endif
65f19062
GS
3406
3407#ifdef PERL_VENDORARCH_EXP
4ea817c6 3408 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS
3409 * DLL-based path intuition to work correctly */
3410# if !defined(WIN32)
9c8a64f0 3411 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
65f19062 3412# endif
4b03c463 3413#endif
65f19062
GS
3414
3415#ifdef PERL_VENDORLIB_EXP
3416# if defined(WIN32)
9c8a64f0 3417 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
65f19062 3418# else
9c8a64f0 3419 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
65f19062 3420# endif
a3635516 3421#endif
65f19062
GS
3422
3423#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
9c8a64f0 3424 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
00dc2f4f 3425#endif
65f19062 3426
3b777bb4
GS
3427#ifdef PERL_OTHERLIBDIRS
3428 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3429#endif
3430
3280af22 3431 if (!PL_tainting)
9c8a64f0 3432 incpush(".", FALSE, FALSE);
bf4acbe4 3433#endif /* MACOS_TRADITIONAL */
774d564b
PP
3434}
3435
3436#if defined(DOSISH)
3437# define PERLLIB_SEP ';'
3438#else
3439# if defined(VMS)
3440# define PERLLIB_SEP '|'
3441# else
bf4acbe4
GS
3442# if defined(MACOS_TRADITIONAL)
3443# define PERLLIB_SEP ','
3444# else
3445# define PERLLIB_SEP ':'
3446# endif
774d564b
PP
3447# endif
3448#endif
3449#ifndef PERLLIB_MANGLE
3450# define PERLLIB_MANGLE(s,n) (s)
3451#endif
3452
76e3520e 3453STATIC void
9c8a64f0 3454S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
774d564b
PP
3455{
3456 SV *subdir = Nullsv;
774d564b 3457
3b290362 3458 if (!p || !*p)
774d564b
PP
3459 return;
3460
9c8a64f0 3461 if (addsubdirs || addoldvers) {
00db4c45 3462 subdir = sv_newmortal();
774d564b
PP
3463 }
3464
3465 /* Break at all separators */
3466 while (p && *p) {
8c52afec 3467 SV *libdir = NEWSV(55,0);
774d564b
PP
3468 char *s;
3469
3470 /* skip any consecutive separators */
3471 while ( *p == PERLLIB_SEP ) {
3472 /* Uncomment the next line for PATH semantics */
79cb57f6 3473 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
774d564b
PP