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