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