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