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