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