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