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