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