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