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