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