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