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