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