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