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