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