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