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