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