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