This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Update the -v copyright notice.
[perl5.git] / perl.c
<
CommitLineData
a0d0e21e
LW		 1/* perl.c
2 *
4bb101f2 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
b5f8cc5c 4 * 2000, 2001, 2002, 2003, 2004, 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 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 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 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 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 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 477 /* loosen bonds of global variables */
478
3280af22
NIS		 479 if(PL_rsfp) {
480 (void)PerlIO_close(PL_rsfp);
481 PL_rsfp = Nullfp;
8ebc5c01 482 }
483
484 /* Filters for program text */
3280af22
NIS		 485 SvREFCNT_dec(PL_rsfp_filters);
486 PL_rsfp_filters = Nullav;
8ebc5c01 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 508 }
509
bf9cdc68
RG		 510 PL_perldb = 0;
511
8ebc5c01 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 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 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 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 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 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
3280af22 812 Safefree(PL_origfilename);
bf9cdc68 813 PL_origfilename = Nullch;
3280af22 814 Safefree(PL_reg_start_tmp);
bf9cdc68
RG		 815 PL_reg_start_tmp = (char**)NULL;
816 PL_reg_start_tmpl = 0;
5c5e4c24
IZ		 817 if (PL_reg_curpm)
818 Safefree(PL_reg_curpm);
82ba1be6 819 Safefree(PL_reg_poscache);
dd28f7bb 820 free_tied_hv_pool();
3280af22 821 Safefree(PL_op_mask);
cf36064f 822 Safefree(PL_psig_ptr);
bf9cdc68 823 PL_psig_ptr = (SV**)NULL;
cf36064f 824 Safefree(PL_psig_name);
bf9cdc68 825 PL_psig_name = (SV**)NULL;
2c2666fc 826 Safefree(PL_bitcount);
bf9cdc68 827 PL_bitcount = Nullch;
ce08f86c 828 Safefree(PL_psig_pend);
bf9cdc68
RG		 829 PL_psig_pend = (int*)NULL;
830 PL_formfeed = Nullsv;
831 Safefree(PL_ofmt);
832 PL_ofmt = Nullch;
6e72f9df 833 nuke_stacks();
bf9cdc68
RG		 834 PL_tainting = FALSE;
835 PL_taint_warn = FALSE;
3280af22 836 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
bf9cdc68 837 PL_debug = 0;
ac27b0f5 838
a0d0e21e 839 DEBUG_P(debprofdump());
d33b2eba 840
e5dd39fc 841#ifdef USE_REENTRANT_API
10bc17b6 842 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 843#endif
844
612f20c3
GS		 845 sv_free_arenas();
846
fc36a67e 847 /* As the absolutely last thing, free the non-arena SV for mess() */
848
3280af22 849 if (PL_mess_sv) {
9c63abab
GS		 850 /* it could have accumulated taint magic */
851 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
852 MAGIC* mg;
853 MAGIC* moremagic;
854 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
855 moremagic = mg->mg_moremagic;
14befaf4
DM		 856 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
857 && mg->mg_len >= 0)
9c63abab
GS		 858 Safefree(mg->mg_ptr);
859 Safefree(mg);
860 }
861 }
fc36a67e 862 /* we know that type >= SVt_PV */
155aba94 863 (void)SvOOK_off(PL_mess_sv);
3280af22
NIS		 864 Safefree(SvPVX(PL_mess_sv));
865 Safefree(SvANY(PL_mess_sv));
866 Safefree(PL_mess_sv);
867 PL_mess_sv = Nullsv;
fc36a67e 868 }
31d77e54 869 return STATUS_NATIVE_EXPORT;
79072805
LW		 870}
871
954c1994
GS		 872/*
873=for apidoc perl_free
874
875Releases a Perl interpreter. See L<perlembed>.
876
877=cut
878*/
879
79072805 880void
0cb96387 881perl_free(pTHXx)
79072805 882{
acfe0abc 883#if defined(WIN32) || defined(NETWARE)
ce3e5b80 884# if defined(PERL_IMPLICIT_SYS)
acfe0abc
GS		 885# ifdef NETWARE
886 void *host = nw_internal_host;
887# else
888 void *host = w32_internal_host;
889# endif
ce3e5b80 890 PerlMem_free(aTHXx);
acfe0abc 891# ifdef NETWARE
011f1a1a 892 nw_delete_internal_host(host);
acfe0abc
GS		 893# else
894 win32_delete_internal_host(host);
895# endif
1c0ca838
GS		 896# else
897 PerlMem_free(aTHXx);
898# endif
acfe0abc
GS		 899#else
900 PerlMem_free(aTHXx);
76e3520e 901#endif
79072805
LW		 902}
903
4b556e6c 904void
864dbfa3 905Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 906{
3280af22
NIS		 907 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
908 PL_exitlist[PL_exitlistlen].fn = fn;
909 PL_exitlist[PL_exitlistlen].ptr = ptr;
910 ++PL_exitlistlen;
4b556e6c
JD		 911}
912
954c1994
GS		 913/*
914=for apidoc perl_parse
915
916Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
917
918=cut
919*/
920
79072805 921int
0cb96387 922perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 923{
6224f72b 924 I32 oldscope;
6224f72b 925 int ret;
db36c5a1 926 dJMPENV;
4d1ff10f 927#ifdef USE_5005THREADS
cea2e8a9
GS		 928 dTHX;
929#endif
8d063cd8 930
a687059c
LW		 931#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
932#ifdef IAMSUID
933#undef IAMSUID
cea2e8a9 934 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW		 935setuid perl scripts securely.\n");
936#endif
937#endif
938
b0891165
JH		 939#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
940 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
103dd899 941 * This MUST be done before any hash stores or fetches take place.
008fb0c0
NC		 942 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
943 * yourself, it is your responsibility to provide a good random seed!
830b38bd 944 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
008fb0c0
NC		 945 if (!PL_rehash_seed_set)
946 PL_rehash_seed = get_hash_seed();
b0891165 947 {
bed60192
JH		 948 char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
949
950 if (s) {
951 int i = atoi(s);
952
953 if (i == 1)
954 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
008fb0c0 955 PL_rehash_seed);
bed60192 956 }
b0891165
JH		 957 }
958#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
959
3280af22 960 PL_origargc = argc;
e2975953 961 PL_origargv = argv;
a0d0e21e 962
54bfe034 963 {
3cb9023d
JH		 964 /* Set PL_origalen be the sum of the contiguous argv[]
965 * elements plus the size of the env in case that it is
e9137a8e 966 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
3cb9023d
JH		 967 * as the maximum modifiable length of $0. In the worst case
968 * the area we are able to modify is limited to the size of
43c32782 969 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d 970 * --jhi */
84458fbf 971 char *s = NULL;
54bfe034 972 int i;
7d8e7db3
JH		 973 UV mask =
974 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
43c32782
JH		 975 /* Do the mask check only if the args seem like aligned. */
976 UV aligned =
977 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
978
979 /* See if all the arguments are contiguous in memory. Note
980 * that 'contiguous' is a loose term because some platforms
981 * align the argv[] and the envp[]. If the arguments look
982 * like non-aligned, assume that they are 'strictly' or
983 * 'traditionally' contiguous. If the arguments look like
984 * aligned, we just check that they are within aligned
985 * PTRSIZE bytes. As long as no system has something bizarre
986 * like the argv[] interleaved with some other data, we are
987 * fine. (Did I just evoke Murphy's Law?) --jhi */
c8941eeb
JH		 988 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
989 while (*s) s++;
990 for (i = 1; i < PL_origargc; i++) {
991 if ((PL_origargv[i] == s + 1
43c32782 992#ifdef OS2
c8941eeb 993 || PL_origargv[i] == s + 2
43c32782 994#endif
c8941eeb
JH		 995 )
996 ||
997 (aligned &&
998 (PL_origargv[i] > s &&
999 PL_origargv[i] <=
1000 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1001 )
1002 {
1003 s = PL_origargv[i];
1004 while (*s) s++;
1005 }
1006 else
1007 break;
54bfe034 1008 }
54bfe034 1009 }
3cb9023d 1010 /* Can we grab env area too to be used as the area for $0? */
43c32782
JH		 1011 if (PL_origenviron) {
1012 if ((PL_origenviron[0] == s + 1
1013#ifdef OS2
1014 || (PL_origenviron[0] == s + 9 && (s += 8))
1015#endif
1016 )
1017 ||
1018 (aligned &&
1019 (PL_origenviron[0] > s &&
1020 PL_origenviron[0] <=
1021 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1022 )
1023 {
1024#ifndef OS2
1025 s = PL_origenviron[0];
1026 while (*s) s++;
1027#endif
1028 my_setenv("NoNe SuCh", Nullch);
1029 /* Force copy of environment. */
1030 for (i = 1; PL_origenviron[i]; i++) {
1031 if (PL_origenviron[i] == s + 1
1032 ||
1033 (aligned &&
1034 (PL_origenviron[i] > s &&
1035 PL_origenviron[i] <=
1036 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1037 )
1038 {
1039 s = PL_origenviron[i];
1040 while (*s) s++;
1041 }
1042 else
1043 break;
54bfe034 1044 }
43c32782 1045 }
54bfe034 1046 }
284e1220 1047 PL_origalen = s - PL_origargv[0] + 1;
54bfe034
JH		 1048 }
1049
3280af22 1050 if (PL_do_undump) {
a0d0e21e
LW		 1051
1052 /* Come here if running an undumped a.out. */
1053
3280af22
NIS		 1054 PL_origfilename = savepv(argv[0]);
1055 PL_do_undump = FALSE;
a0d0e21e 1056 cxstack_ix = -1; /* start label stack again */
748a9306 1057 init_ids();
a0d0e21e
LW		 1058 init_postdump_symbols(argc,argv,env);
1059 return 0;
1060 }
1061
3280af22 1062 if (PL_main_root) {
3280af22
NIS		 1063 op_free(PL_main_root);
1064 PL_main_root = Nullop;
ff0cee69 1065 }
3280af22
NIS		 1066 PL_main_start = Nullop;
1067 SvREFCNT_dec(PL_main_cv);
1068 PL_main_cv = Nullcv;
79072805 1069
3280af22
NIS		 1070 time(&PL_basetime);
1071 oldscope = PL_scopestack_ix;
599cee73 1072 PL_dowarn = G_WARN_OFF;
f86702cc 1073
14dd3ad8
GS		 1074#ifdef PERL_FLEXIBLE_EXCEPTIONS
1075 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1076#else
1077 JMPENV_PUSH(ret);
1078#endif
6224f72b 1079 switch (ret) {
312caa8e 1080 case 0:
14dd3ad8
GS		 1081#ifndef PERL_FLEXIBLE_EXCEPTIONS
1082 parse_body(env,xsinit);
1083#endif
7d30b5c4
GS		 1084 if (PL_checkav)
1085 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1086 ret = 0;
1087 break;
6224f72b
GS		 1088 case 1:
1089 STATUS_ALL_FAILURE;
1090 /* FALL THROUGH */
1091 case 2:
1092 /* my_exit() was called */
3280af22 1093 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1094 LEAVE;
1095 FREETMPS;
3280af22 1096 PL_curstash = PL_defstash;
7d30b5c4
GS		 1097 if (PL_checkav)
1098 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1099 ret = STATUS_NATIVE_EXPORT;
1100 break;
6224f72b 1101 case 3:
bf49b057 1102 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1103 ret = 1;
1104 break;
6224f72b 1105 }
14dd3ad8
GS		 1106 JMPENV_POP;
1107 return ret;
1108}
1109
1110#ifdef PERL_FLEXIBLE_EXCEPTIONS
1111STATIC void *
1112S_vparse_body(pTHX_ va_list args)
1113{
1114 char **env = va_arg(args, char**);
1115 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1116
1117 return parse_body(env, xsinit);
312caa8e 1118}
14dd3ad8 1119#endif
312caa8e
CS		 1120
1121STATIC void *
14dd3ad8 1122S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1123{
312caa8e
CS		 1124 int argc = PL_origargc;
1125 char **argv = PL_origargv;
312caa8e
CS		 1126 char *scriptname = NULL;
1127 int fdscript = -1;
1128 VOL bool dosearch = FALSE;
1129 char *validarg = "";
312caa8e
CS		 1130 register SV *sv;
1131 register char *s;
cf756827 1132 char *cddir = Nullch;
312caa8e 1133
3280af22 1134 sv_setpvn(PL_linestr,"",0);
79cb57f6 1135 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 1136 SAVEFREESV(sv);
1137 init_main_stash();
54310121 1138
6224f72b
GS		 1139 for (argc--,argv++; argc > 0; argc--,argv++) {
1140 if (argv[0][0] != '-' || !argv[0][1])
1141 break;
1142#ifdef DOSUID
1143 if (*validarg)
1144 validarg = " PHOOEY ";
1145 else
1146 validarg = argv[0];
13281fa4 1147#endif
6224f72b
GS		 1148 s = argv[0]+1;
1149 reswitch:
1150 switch (*s) {
729a02f2 1151 case 'C':
1d5472a9
GS		 1152#ifndef PERL_STRICT_CR
1153 case '\r':
1154#endif
6224f72b
GS		 1155 case ' ':
1156 case '0':
1157 case 'F':
1158 case 'a':
1159 case 'c':
1160 case 'd':
1161 case 'D':
1162 case 'h':
1163 case 'i':
1164 case 'l':
1165 case 'M':
1166 case 'm':
1167 case 'n':
1168 case 'p':
1169 case 's':
1170 case 'u':
1171 case 'U':
1172 case 'v':
599cee73
PM		 1173 case 'W':
1174 case 'X':
6224f72b 1175 case 'w':
06492da6 1176 case 'A':
155aba94 1177 if ((s = moreswitches(s)))
6224f72b
GS		 1178 goto reswitch;
1179 break;
33b78306 1180
1dbad523 1181 case 't':
22f7c9c9 1182 CHECK_MALLOC_TOO_LATE_FOR('t');
317ea90d
MS		 1183 if( !PL_tainting ) {
1184 PL_taint_warn = TRUE;
1185 PL_tainting = TRUE;
1186 }
1187 s++;
1188 goto reswitch;
6224f72b 1189 case 'T':
22f7c9c9 1190 CHECK_MALLOC_TOO_LATE_FOR('T');
3280af22 1191 PL_tainting = TRUE;
317ea90d 1192 PL_taint_warn = FALSE;
6224f72b
GS		 1193 s++;
1194 goto reswitch;
f86702cc 1195
6224f72b 1196 case 'e':
bf4acbe4
GS		 1197#ifdef MACOS_TRADITIONAL
1198 /* ignore -e for Dev:Pseudo argument */
1199 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1200 break;
bf4acbe4 1201#endif
3280af22 1202 if (PL_euid != PL_uid || PL_egid != PL_gid)
cea2e8a9 1203 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
3280af22 1204 if (!PL_e_script) {
79cb57f6 1205 PL_e_script = newSVpvn("",0);
0cb96387 1206 filter_add(read_e_script, NULL);
6224f72b
GS		 1207 }
1208 if (*++s)
3280af22 1209 sv_catpv(PL_e_script, s);
6224f72b 1210 else if (argv[1]) {
3280af22 1211 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1212 argc--,argv++;
1213 }
1214 else
cea2e8a9 1215 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1216 sv_catpv(PL_e_script, "\n");
6224f72b 1217 break;
afe37c7d 1218
6224f72b
GS		 1219 case 'I': /* -I handled both here and in moreswitches() */
1220 forbid_setid("-I");
1221 if (!*++s && (s=argv[1]) != Nullch) {
1222 argc--,argv++;
1223 }
6224f72b 1224 if (s && *s) {
0df16ed7
GS		 1225 char *p;
1226 STRLEN len = strlen(s);
1227 p = savepvn(s, len);
574c798a 1228 incpush(p, TRUE, TRUE, FALSE);
0df16ed7
GS		 1229 sv_catpvn(sv, "-I", 2);
1230 sv_catpvn(sv, p, len);
1231 sv_catpvn(sv, " ", 1);
6224f72b 1232 Safefree(p);
0df16ed7
GS		 1233 }
1234 else
a67e862a 1235 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1236 break;
1237 case 'P':
1238 forbid_setid("-P");
3280af22 1239 PL_preprocess = TRUE;
6224f72b
GS		 1240 s++;
1241 goto reswitch;
1242 case 'S':
1243 forbid_setid("-S");
1244 dosearch = TRUE;
1245 s++;
1246 goto reswitch;
1247 case 'V':
3280af22
NIS		 1248 if (!PL_preambleav)
1249 PL_preambleav = newAV();
1250 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1251 if (*++s != ':') {
3280af22 1252 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1253#ifdef VMS
6b88bc9c 1254 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1255#else
3280af22 1256 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1257#endif
3280af22 1258 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1259# ifdef DEBUGGING
3280af22 1260 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1261# endif
6224f72b 1262# ifdef MULTIPLICITY
8f872242 1263 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1264# endif
4d1ff10f
AB		 1265# ifdef USE_5005THREADS
1266 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1267# endif
ac5e8965
JH		 1268# ifdef USE_ITHREADS
1269 sv_catpv(PL_Sv," USE_ITHREADS");
1270# endif
10cc9d2a
JH		 1271# ifdef USE_64_BIT_INT
1272 sv_catpv(PL_Sv," USE_64_BIT_INT");
1273# endif
1274# ifdef USE_64_BIT_ALL
1275 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1276# endif
1277# ifdef USE_LONG_DOUBLE
1278 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1279# endif
53430762
JH		 1280# ifdef USE_LARGE_FILES
1281 sv_catpv(PL_Sv," USE_LARGE_FILES");
1282# endif
ac5e8965
JH		 1283# ifdef USE_SOCKS
1284 sv_catpv(PL_Sv," USE_SOCKS");
1285# endif
b363f7ed
GS		 1286# ifdef PERL_IMPLICIT_CONTEXT
1287 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1288# endif
1289# ifdef PERL_IMPLICIT_SYS
1290 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1291# endif
3280af22 1292 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1293
6224f72b
GS		 1294#if defined(LOCAL_PATCH_COUNT)
1295 if (LOCAL_PATCH_COUNT > 0) {
1296 int i;
3280af22 1297 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1298 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1299 if (PL_localpatches[i])
cea2e8a9 1300 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS		 1301 }
1302 }
1303#endif
cea2e8a9 1304 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1305#ifdef __DATE__
1306# ifdef __TIME__
cea2e8a9 1307 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1308# else
cea2e8a9 1309 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1310# endif
1311#endif
3280af22 1312 sv_catpv(PL_Sv, "; \
6224f72b 1313$\"=\"\\n \"; \
69fcd688
JH		 1314@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1315#ifdef __CYGWIN__
1316 sv_catpv(PL_Sv,"\
1317push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1318#endif
1319 sv_catpv(PL_Sv, "\
6224f72b
GS		 1320print \" \\%ENV:\\n @env\\n\" if @env; \
1321print \" \\@INC:\\n @INC\\n\";");
1322 }
1323 else {
3280af22
NIS		 1324 PL_Sv = newSVpv("config_vars(qw(",0);
1325 sv_catpv(PL_Sv, ++s);
1326 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1327 s += strlen(s);
1328 }
3280af22 1329 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1330 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1331 goto reswitch;
1332 case 'x':
3280af22 1333 PL_doextract = TRUE;
6224f72b
GS		 1334 s++;
1335 if (*s)
f4c556ac 1336 cddir = s;
6224f72b
GS		 1337 break;
1338 case 0:
1339 break;
1340 case '-':
1341 if (!*++s || isSPACE(*s)) {
1342 argc--,argv++;
1343 goto switch_end;
1344 }
1345 /* catch use of gnu style long options */
1346 if (strEQ(s, "version")) {
1347 s = "v";
1348 goto reswitch;
1349 }
1350 if (strEQ(s, "help")) {
1351 s = "h";
1352 goto reswitch;
1353 }
1354 s--;
1355 /* FALL THROUGH */
1356 default:
cea2e8a9 1357 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1358 }
1359 }
6224f72b 1360 switch_end:
54310121 1361
f675dbe5
CB		 1362 if (
1363#ifndef SECURE_INTERNAL_GETENV
1364 !PL_tainting &&
1365#endif
cf756827 1366 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1367 {
cf756827 1368 char *popt = s;
74288ac8
GS		 1369 while (isSPACE(*s))
1370 s++;
317ea90d 1371 if (*s == '-' && *(s+1) == 'T') {
22f7c9c9 1372 CHECK_MALLOC_TOO_LATE_FOR('T');
74288ac8 1373 PL_tainting = TRUE;
317ea90d
MS		 1374 PL_taint_warn = FALSE;
1375 }
74288ac8 1376 else {
cf756827 1377 char *popt_copy = Nullch;
74288ac8 1378 while (s && *s) {
4ea8f8fb 1379 char *d;
74288ac8
GS		 1380 while (isSPACE(*s))
1381 s++;
1382 if (*s == '-') {
1383 s++;
1384 if (isSPACE(*s))
1385 continue;
1386 }
4ea8f8fb 1387 d = s;
74288ac8
GS		 1388 if (!*s)
1389 break;
06492da6 1390 if (!strchr("DIMUdmtwA", *s))
cea2e8a9 1391 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1392 while (++s && *s) {
1393 if (isSPACE(*s)) {
cf756827
GS		 1394 if (!popt_copy) {
1395 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1396 s = popt_copy + (s - popt);
1397 d = popt_copy + (d - popt);
1398 }
4ea8f8fb
MS		 1399 *s++ = '\0';
1400 break;
1401 }
1402 }
1c4db469 1403 if (*d == 't') {
317ea90d
MS		 1404 if( !PL_tainting ) {
1405 PL_taint_warn = TRUE;
1406 PL_tainting = TRUE;
1407 }
1c4db469
RGS		 1408 } else {
1409 moreswitches(d);
1410 }
6224f72b 1411 }
6224f72b
GS		 1412 }
1413 }
a0d0e21e 1414
317ea90d
MS		 1415 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1416 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1417 }
1418
6224f72b
GS		 1419 if (!scriptname)
1420 scriptname = argv[0];
3280af22 1421 if (PL_e_script) {
6224f72b
GS		 1422 argc++,argv--;
1423 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1424 }
1425 else if (scriptname == Nullch) {
1426#ifdef MSDOS
1427 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1428 moreswitches("h");
1429#endif
1430 scriptname = "-";
1431 }
1432
1433 init_perllib();
1434
1435 open_script(scriptname,dosearch,sv,&fdscript);
1436
1437 validate_suid(validarg, scriptname,fdscript);
1438
64ca3a65 1439#ifndef PERL_MICRO
0b5b802d
GS		 1440#if defined(SIGCHLD) || defined(SIGCLD)
1441 {
1442#ifndef SIGCHLD
1443# define SIGCHLD SIGCLD
1444#endif
1445 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1446 if (sigstate == SIG_IGN) {
1447 if (ckWARN(WARN_SIGNAL))
9014280d 1448 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1449 "Can't ignore signal CHLD, forcing to default");
1450 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1451 }
1452 }
1453#endif
64ca3a65 1454#endif
0b5b802d 1455
bf4acbe4
GS		 1456#ifdef MACOS_TRADITIONAL
1457 if (PL_doextract || gMacPerl_AlwaysExtract) {
1458#else
f4c556ac 1459 if (PL_doextract) {
bf4acbe4 1460#endif
6224f72b 1461 find_beginning();
f4c556ac
GS		 1462 if (cddir && PerlDir_chdir(cddir) < 0)
1463 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1464
1465 }
6224f72b 1466
3280af22
NIS		 1467 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1468 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1469 CvUNIQUE_on(PL_compcv);
1470
dd2155a4 1471 CvPADLIST(PL_compcv) = pad_new(0);
4d1ff10f 1472#ifdef USE_5005THREADS
533c011a
NIS		 1473 CvOWNER(PL_compcv) = 0;
1474 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1475 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1476#endif /* USE_5005THREADS */
6224f72b 1477
0c4f7ff0 1478 boot_core_PerlIO();
6224f72b 1479 boot_core_UNIVERSAL();
09bef843 1480 boot_core_xsutils();
6224f72b
GS		 1481
1482 if (xsinit)
acfe0abc 1483 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1484#ifndef PERL_MICRO
ed79a026 1485#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1486 init_os_extras();
6224f72b 1487#endif
64ca3a65 1488#endif
6224f72b 1489
29209bc5 1490#ifdef USE_SOCKS
1b9c9cf5
DH		 1491# ifdef HAS_SOCKS5_INIT
1492 socks5_init(argv[0]);
1493# else
29209bc5 1494 SOCKSinit(argv[0]);
1b9c9cf5 1495# endif
ac27b0f5 1496#endif
29209bc5 1497
6224f72b
GS		 1498 init_predump_symbols();
1499 /* init_postdump_symbols not currently designed to be called */
1500 /* more than once (ENV isn't cleared first, for example) */
1501 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1502 if (!PL_do_undump)
6224f72b
GS		 1503 init_postdump_symbols(argc,argv,env);
1504
a05d7ebb
JH		 1505 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1506 * PL_utf8locale is conditionally turned on by
085a54d9 1507 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 1508 * look like the user wants to use UTF-8. */
06e66572
JH		 1509 if (PL_unicode) {
1510 /* Requires init_predump_symbols(). */
a05d7ebb 1511 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH		 1512 IO* io;
1513 PerlIO* fp;
1514 SV* sv;
1515
a05d7ebb 1516 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 1517 * and the default open disciplines. */
a05d7ebb
JH		 1518 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1519 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1520 (fp = IoIFP(io)))
1521 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1522 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1523 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1524 (fp = IoOFP(io)))
1525 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1526 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1527 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1528 (fp = IoOFP(io)))
1529 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1530 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1531 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1532 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1533 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1534 if (in) {
1535 if (out)
1536 sv_setpvn(sv, ":utf8\0:utf8", 11);
1537 else
1538 sv_setpvn(sv, ":utf8\0", 6);
1539 }
1540 else if (out)
1541 sv_setpvn(sv, "\0:utf8", 6);
1542 SvSETMAGIC(sv);
1543 }
b310b053
JH		 1544 }
1545 }
1546
4ffa73a3
JH		 1547 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1548 if (strEQ(s, "unsafe"))
1549 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1550 else if (strEQ(s, "safe"))
1551 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1552 else
1553 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1554 }
1555
6224f72b
GS		 1556 init_lexer();
1557
1558 /* now parse the script */
1559
93189314 1560 SETERRNO(0,SS_NORMAL);
3280af22 1561 PL_error_count = 0;
bf4acbe4
GS		 1562#ifdef MACOS_TRADITIONAL
1563 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1564 if (PL_minus_c)
1565 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1566 else {
1567 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1568 MacPerl_MPWFileName(PL_origfilename));
1569 }
1570 }
1571#else
3280af22
NIS		 1572 if (yyparse() || PL_error_count) {
1573 if (PL_minus_c)
cea2e8a9 1574 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1575 else {
cea2e8a9 1576 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1577 PL_origfilename);
6224f72b
GS		 1578 }
1579 }
bf4acbe4 1580#endif
57843af0 1581 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1582 PL_curstash = PL_defstash;
1583 PL_preprocess = FALSE;
1584 if (PL_e_script) {
1585 SvREFCNT_dec(PL_e_script);
1586 PL_e_script = Nullsv;
6224f72b
GS		 1587 }
1588
3280af22 1589 if (PL_do_undump)
6224f72b
GS		 1590 my_unexec();
1591
57843af0
GS		 1592 if (isWARN_ONCE) {
1593 SAVECOPFILE(PL_curcop);
1594 SAVECOPLINE(PL_curcop);
3280af22 1595 gv_check(PL_defstash);
57843af0 1596 }
6224f72b
GS		 1597
1598 LEAVE;
1599 FREETMPS;
1600
1601#ifdef MYMALLOC
1602 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1603 dump_mstats("after compilation:");
1604#endif
1605
1606 ENTER;
3280af22 1607 PL_restartop = 0;
312caa8e 1608 return NULL;
6224f72b
GS		 1609}
1610
954c1994
GS		 1611/*
1612=for apidoc perl_run
1613
1614Tells a Perl interpreter to run. See L<perlembed>.
1615
1616=cut
1617*/
1618
6224f72b 1619int
0cb96387 1620perl_run(pTHXx)
6224f72b 1621{
6224f72b 1622 I32 oldscope;
14dd3ad8 1623 int ret = 0;
db36c5a1 1624 dJMPENV;
4d1ff10f 1625#ifdef USE_5005THREADS
cea2e8a9
GS		 1626 dTHX;
1627#endif
6224f72b 1628
3280af22 1629 oldscope = PL_scopestack_ix;
96e176bf
CL		 1630#ifdef VMS
1631 VMSISH_HUSHED = 0;
1632#endif
6224f72b 1633
14dd3ad8 1634#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1635 redo_body:
14dd3ad8
GS		 1636 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1637#else
1638 JMPENV_PUSH(ret);
1639#endif
6224f72b
GS		 1640 switch (ret) {
1641 case 1:
1642 cxstack_ix = -1; /* start context stack again */
312caa8e 1643 goto redo_body;
14dd3ad8
GS		 1644 case 0: /* normal completion */
1645#ifndef PERL_FLEXIBLE_EXCEPTIONS
1646 redo_body:
1647 run_body(oldscope);
1648#endif
1649 /* FALL THROUGH */
1650 case 2: /* my_exit() */
3280af22 1651 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1652 LEAVE;
1653 FREETMPS;
3280af22 1654 PL_curstash = PL_defstash;
3a1ee7e8 1655 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1656 PL_endav && !PL_minus_c)
1657 call_list(oldscope, PL_endav);
6224f72b
GS		 1658#ifdef MYMALLOC
1659 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1660 dump_mstats("after execution: ");
1661#endif
14dd3ad8
GS		 1662 ret = STATUS_NATIVE_EXPORT;
1663 break;
6224f72b 1664 case 3:
312caa8e
CS		 1665 if (PL_restartop) {
1666 POPSTACK_TO(PL_mainstack);
1667 goto redo_body;
6224f72b 1668 }
bf49b057 1669 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1670 FREETMPS;
14dd3ad8
GS		 1671 ret = 1;
1672 break;
6224f72b
GS		 1673 }
1674
14dd3ad8
GS		 1675 JMPENV_POP;
1676 return ret;
312caa8e
CS		 1677}
1678
14dd3ad8 1679#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1680STATIC void *
14dd3ad8 1681S_vrun_body(pTHX_ va_list args)
312caa8e 1682{
312caa8e
CS		 1683 I32 oldscope = va_arg(args, I32);
1684
14dd3ad8
GS		 1685 return run_body(oldscope);
1686}
1687#endif
1688
1689
1690STATIC void *
1691S_run_body(pTHX_ I32 oldscope)
1692{
6224f72b 1693 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1694 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1695
3280af22 1696 if (!PL_restartop) {
6224f72b 1697 DEBUG_x(dump_all());
ecae49c0
NC		 1698 if (!DEBUG_q_TEST)
1699 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1700 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1701 PTR2UV(thr)));
6224f72b 1702
3280af22 1703 if (PL_minus_c) {
bf4acbe4 1704#ifdef MACOS_TRADITIONAL
e69a2255
JH		 1705 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1706 (gMacPerl_ErrorFormat ? "# " : ""),
1707 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1708#else
bf49b057 1709 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1710#endif
6224f72b
GS		 1711 my_exit(0);
1712 }
3280af22 1713 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1714 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1715 if (PL_initav)
1716 call_list(oldscope, PL_initav);
6224f72b
GS		 1717 }
1718
1719 /* do it */
1720
3280af22 1721 if (PL_restartop) {
533c011a 1722 PL_op = PL_restartop;
3280af22 1723 PL_restartop = 0;
cea2e8a9 1724 CALLRUNOPS(aTHX);
6224f72b 1725 }
3280af22
NIS		 1726 else if (PL_main_start) {
1727 CvDEPTH(PL_main_cv) = 1;
533c011a 1728 PL_op = PL_main_start;
cea2e8a9 1729 CALLRUNOPS(aTHX);
6224f72b
GS		 1730 }
1731
f6b3007c
JH		 1732 my_exit(0);
1733 /* NOTREACHED */
312caa8e 1734 return NULL;
6224f72b
GS		 1735}
1736
954c1994 1737/*
ccfc67b7
JH		 1738=head1 SV Manipulation Functions
1739
954c1994
GS		 1740=for apidoc p||get_sv
1741
1742Returns the SV of the specified Perl scalar. If C<create> is set and the
1743Perl variable does not exist then it will be created. If C<create> is not
1744set and the variable does not exist then NULL is returned.
1745
1746=cut
1747*/
1748
6224f72b 1749SV*
864dbfa3 1750Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1751{
1752 GV *gv;
4d1ff10f 1753#ifdef USE_5005THREADS
6224f72b
GS		 1754 if (name[1] == '\0' && !isALPHA(name[0])) {
1755 PADOFFSET tmp = find_threadsv(name);
411caa50 1756 if (tmp != NOT_IN_PAD)
6224f72b 1757 return THREADSV(tmp);
6224f72b 1758 }
4d1ff10f 1759#endif /* USE_5005THREADS */
6224f72b
GS		 1760 gv = gv_fetchpv(name, create, SVt_PV);
1761 if (gv)
1762 return GvSV(gv);
1763 return Nullsv;
1764}
1765
954c1994 1766/*
ccfc67b7
JH		 1767=head1 Array Manipulation Functions
1768
954c1994
GS		 1769=for apidoc p||get_av
1770
1771Returns the AV of the specified Perl array. If C<create> is set and the
1772Perl variable does not exist then it will be created. If C<create> is not
1773set and the variable does not exist then NULL is returned.
1774
1775=cut
1776*/
1777
6224f72b 1778AV*
864dbfa3 1779Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1780{
1781 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1782 if (create)
1783 return GvAVn(gv);
1784 if (gv)
1785 return GvAV(gv);
1786 return Nullav;
1787}
1788
954c1994 1789/*
ccfc67b7
JH		 1790=head1 Hash Manipulation Functions
1791
954c1994
GS		 1792=for apidoc p||get_hv
1793
1794Returns the HV of the specified Perl hash. If C<create> is set and the
1795Perl variable does not exist then it will be created. If C<create> is not
1796set and the variable does not exist then NULL is returned.
1797
1798=cut
1799*/
1800
6224f72b 1801HV*
864dbfa3 1802Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1803{
a0d0e21e
LW		 1804 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1805 if (create)
1806 return GvHVn(gv);
1807 if (gv)
1808 return GvHV(gv);
1809 return Nullhv;
1810}
1811
954c1994 1812/*
ccfc67b7
JH		 1813=head1 CV Manipulation Functions
1814
954c1994
GS		 1815=for apidoc p||get_cv
1816
1817Returns the CV of the specified Perl subroutine. If C<create> is set and
1818the Perl subroutine does not exist then it will be declared (which has the
1819same effect as saying C<sub name;>). If C<create> is not set and the
1820subroutine does not exist then NULL is returned.
1821
1822=cut
1823*/
1824
a0d0e21e 1825CV*
864dbfa3 1826Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1827{
1828 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1829 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 1830 /* XXX this is probably not what they think they're getting.
1831 * It has the same effect as "sub name;", i.e. just a forward
1832 * declaration! */
8ebc5c01 1833 if (create && !GvCVu(gv))
774d564b 1834 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1835 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1836 Nullop,
a0d0e21e
LW		 1837 Nullop);
1838 if (gv)
8ebc5c01 1839 return GvCVu(gv);
a0d0e21e
LW		 1840 return Nullcv;
1841}
1842
79072805
LW		 1843/* Be sure to refetch the stack pointer after calling these routines. */
1844
954c1994 1845/*
ccfc67b7
JH		 1846
1847=head1 Callback Functions
1848
954c1994
GS		 1849=for apidoc p||call_argv
1850
1851Performs a callback to the specified Perl sub. See L<perlcall>.
1852
1853=cut
1854*/
1855
a0d0e21e 1856I32
864dbfa3 1857Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 1858
8ac85365
NIS		 1859 /* See G_* flags in cop.h */
1860 /* null terminated arg list */
8990e307 1861{
a0d0e21e 1862 dSP;
8990e307 1863
924508f0 1864 PUSHMARK(SP);
a0d0e21e 1865 if (argv) {
8990e307 1866 while (*argv) {
a0d0e21e 1867 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 1868 argv++;
1869 }
a0d0e21e 1870 PUTBACK;
8990e307 1871 }
864dbfa3 1872 return call_pv(sub_name, flags);
8990e307
LW		 1873}
1874
954c1994
GS		 1875/*
1876=for apidoc p||call_pv
1877
1878Performs a callback to the specified Perl sub. See L<perlcall>.
1879
1880=cut
1881*/
1882
a0d0e21e 1883I32
864dbfa3 1884Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 1885 /* name of the subroutine */
1886 /* See G_* flags in cop.h */
a0d0e21e 1887{
864dbfa3 1888 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 1889}
1890
954c1994
GS		 1891/*
1892=for apidoc p||call_method
1893
1894Performs a callback to the specified Perl method. The blessed object must
1895be on the stack. See L<perlcall>.
1896
1897=cut
1898*/
1899
a0d0e21e 1900I32
864dbfa3 1901Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 1902 /* name of the subroutine */
1903 /* See G_* flags in cop.h */
a0d0e21e 1904{
968b3946 1905 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 1906}
1907
1908/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 1909/*
1910=for apidoc p||call_sv
1911
1912Performs a callback to the Perl sub whose name is in the SV. See
1913L<perlcall>.
1914
1915=cut
1916*/
1917
a0d0e21e 1918I32
864dbfa3 1919Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 1920 /* See G_* flags in cop.h */
a0d0e21e 1921{
924508f0 1922 dSP;
a0d0e21e 1923 LOGOP myop; /* fake syntax tree node */
968b3946 1924 UNOP method_op;
aa689395 1925 I32 oldmark;
13689cfe 1926 volatile I32 retval = 0;
a0d0e21e 1927 I32 oldscope;
54310121 1928 bool oldcatch = CATCH_GET;
6224f72b 1929 int ret;
533c011a 1930 OP* oldop = PL_op;
db36c5a1 1931 dJMPENV;
1e422769 1932
a0d0e21e
LW		 1933 if (flags & G_DISCARD) {
1934 ENTER;
1935 SAVETMPS;
1936 }
1937
aa689395 1938 Zero(&myop, 1, LOGOP);
54310121 1939 myop.op_next = Nullop;
f51d4af5 1940 if (!(flags & G_NOARGS))
aa689395 1941 myop.op_flags |= OPf_STACKED;
54310121 1942 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1943 (flags & G_ARRAY) ? OPf_WANT_LIST :
1944 OPf_WANT_SCALAR);
462e5cf6 1945 SAVEOP();
533c011a 1946 PL_op = (OP*)&myop;
aa689395 1947
3280af22
NIS		 1948 EXTEND(PL_stack_sp, 1);
1949 *++PL_stack_sp = sv;
aa689395 1950 oldmark = TOPMARK;
3280af22 1951 oldscope = PL_scopestack_ix;
a0d0e21e 1952
3280af22 1953 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 1954 /* Handle first BEGIN of -d. */
3280af22 1955 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 1956 /* Try harder, since this may have been a sighandler, thus
1957 * curstash may be meaningless. */
3280af22 1958 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 1959 && !(flags & G_NODEBUG))
533c011a 1960 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1961
968b3946
GS		 1962 if (flags & G_METHOD) {
1963 Zero(&method_op, 1, UNOP);
1964 method_op.op_next = PL_op;
1965 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1966 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 1967 PL_op = (OP*)&method_op;
968b3946
GS		 1968 }
1969
312caa8e 1970 if (!(flags & G_EVAL)) {
0cdb2077 1971 CATCH_SET(TRUE);
14dd3ad8 1972 call_body((OP*)&myop, FALSE);
312caa8e 1973 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 1974 CATCH_SET(oldcatch);
312caa8e
CS		 1975 }
1976 else {
d78bda3d 1977 myop.op_other = (OP*)&myop;
3280af22 1978 PL_markstack_ptr--;
4633a7c4
LW		 1979 /* we're trying to emulate pp_entertry() here */
1980 {
c09156bb 1981 register PERL_CONTEXT *cx;
54310121 1982 I32 gimme = GIMME_V;
ac27b0f5 1983
4633a7c4
LW		 1984 ENTER;
1985 SAVETMPS;
ac27b0f5 1986
968b3946 1987 push_return(Nullop);
1d76a5c3 1988 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 1989 PUSHEVAL(cx, 0, 0);
533c011a 1990 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 1991
faef0170 1992 PL_in_eval = EVAL_INEVAL;
4633a7c4 1993 if (flags & G_KEEPERR)
faef0170 1994 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 1995 else
38a03e6e 1996 sv_setpv(ERRSV,"");
4633a7c4 1997 }
3280af22 1998 PL_markstack_ptr++;
a0d0e21e 1999
14dd3ad8
GS		 2000#ifdef PERL_FLEXIBLE_EXCEPTIONS
2001 redo_body:
2002 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 2003 (OP*)&myop, FALSE);
14dd3ad8
GS		 2004#else
2005 JMPENV_PUSH(ret);
2006#endif
6224f72b
GS		 2007 switch (ret) {
2008 case 0:
14dd3ad8
GS		 2009#ifndef PERL_FLEXIBLE_EXCEPTIONS
2010 redo_body:
2011 call_body((OP*)&myop, FALSE);
2012#endif
312caa8e
CS		 2013 retval = PL_stack_sp - (PL_stack_base + oldmark);
2014 if (!(flags & G_KEEPERR))
2015 sv_setpv(ERRSV,"");
a0d0e21e 2016 break;
6224f72b 2017 case 1:
f86702cc 2018 STATUS_ALL_FAILURE;
a0d0e21e 2019 /* FALL THROUGH */
6224f72b 2020 case 2:
a0d0e21e 2021 /* my_exit() was called */
3280af22 2022 PL_curstash = PL_defstash;
a0d0e21e 2023 FREETMPS;
14dd3ad8 2024 JMPENV_POP;
cc3604b1 2025 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2026 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2027 my_exit_jump();
a0d0e21e 2028 /* NOTREACHED */
6224f72b 2029 case 3:
3280af22 2030 if (PL_restartop) {
533c011a 2031 PL_op = PL_restartop;
3280af22 2032 PL_restartop = 0;
312caa8e 2033 goto redo_body;
a0d0e21e 2034 }
3280af22 2035 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2036 if (flags & G_ARRAY)
2037 retval = 0;
2038 else {
2039 retval = 1;
3280af22 2040 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2041 }
312caa8e 2042 break;
a0d0e21e 2043 }
a0d0e21e 2044
3280af22 2045 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 2046 SV **newsp;
2047 PMOP *newpm;
2048 I32 gimme;
c09156bb 2049 register PERL_CONTEXT *cx;
a0a2876f
LW		 2050 I32 optype;
2051
2052 POPBLOCK(cx,newpm);
2053 POPEVAL(cx);
2054 pop_return();
3280af22 2055 PL_curpm = newpm;
a0a2876f 2056 LEAVE;
a0d0e21e 2057 }
14dd3ad8 2058 JMPENV_POP;
a0d0e21e 2059 }
1e422769 2060
a0d0e21e 2061 if (flags & G_DISCARD) {
3280af22 2062 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2063 retval = 0;
2064 FREETMPS;
2065 LEAVE;
2066 }
533c011a 2067 PL_op = oldop;
a0d0e21e
LW		 2068 return retval;
2069}
2070
14dd3ad8 2071#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2072STATIC void *
14dd3ad8 2073S_vcall_body(pTHX_ va_list args)
312caa8e
CS		 2074{
2075 OP *myop = va_arg(args, OP*);
2076 int is_eval = va_arg(args, int);
2077
14dd3ad8 2078 call_body(myop, is_eval);
312caa8e
CS		 2079 return NULL;
2080}
14dd3ad8 2081#endif
312caa8e
CS		 2082
2083STATIC void
14dd3ad8 2084S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e 2085{
312caa8e
CS		 2086 if (PL_op == myop) {
2087 if (is_eval)
f807eda9 2088 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 2089 else
f807eda9 2090 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 2091 }
2092 if (PL_op)
cea2e8a9 2093 CALLRUNOPS(aTHX);
312caa8e
CS		 2094}
2095
6e72f9df 2096/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2097
954c1994
GS		 2098/*
2099=for apidoc p||eval_sv
2100
2101Tells Perl to C<eval> the string in the SV.
2102
2103=cut
2104*/
2105
a0d0e21e 2106I32
864dbfa3 2107Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2108
8ac85365 2109 /* See G_* flags in cop.h */
a0d0e21e 2110{
924508f0 2111 dSP;
a0d0e21e 2112 UNOP myop; /* fake syntax tree node */
8fa7f367 2113 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2114 volatile I32 retval = 0;
4633a7c4 2115 I32 oldscope;
6224f72b 2116 int ret;
533c011a 2117 OP* oldop = PL_op;
db36c5a1 2118 dJMPENV;
84902520 2119
4633a7c4
LW		 2120 if (flags & G_DISCARD) {
2121 ENTER;
2122 SAVETMPS;
2123 }
2124
462e5cf6 2125 SAVEOP();
533c011a
NIS		 2126 PL_op = (OP*)&myop;
2127 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2128 EXTEND(PL_stack_sp, 1);
2129 *++PL_stack_sp = sv;
2130 oldscope = PL_scopestack_ix;
79072805 2131
4633a7c4
LW		 2132 if (!(flags & G_NOARGS))
2133 myop.op_flags = OPf_STACKED;
79072805 2134 myop.op_next = Nullop;
6e72f9df 2135 myop.op_type = OP_ENTEREVAL;
54310121 2136 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2137 (flags & G_ARRAY) ? OPf_WANT_LIST :
2138 OPf_WANT_SCALAR);
6e72f9df 2139 if (flags & G_KEEPERR)
2140 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2141
14dd3ad8 2142#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2143 redo_body:
14dd3ad8 2144 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 2145 (OP*)&myop, TRUE);
14dd3ad8
GS		 2146#else
2147 JMPENV_PUSH(ret);
2148#endif
6224f72b
GS		 2149 switch (ret) {
2150 case 0:
14dd3ad8
GS		 2151#ifndef PERL_FLEXIBLE_EXCEPTIONS
2152 redo_body:
2153 call_body((OP*)&myop,TRUE);
2154#endif
312caa8e
CS		 2155 retval = PL_stack_sp - (PL_stack_base + oldmark);
2156 if (!(flags & G_KEEPERR))
2157 sv_setpv(ERRSV,"");
4633a7c4 2158 break;
6224f72b 2159 case 1:
f86702cc 2160 STATUS_ALL_FAILURE;
4633a7c4 2161 /* FALL THROUGH */
6224f72b 2162 case 2:
4633a7c4 2163 /* my_exit() was called */
3280af22 2164 PL_curstash = PL_defstash;
4633a7c4 2165 FREETMPS;
14dd3ad8 2166 JMPENV_POP;
cc3604b1 2167 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2168 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2169 my_exit_jump();
4633a7c4 2170 /* NOTREACHED */
6224f72b 2171 case 3:
3280af22 2172 if (PL_restartop) {
533c011a 2173 PL_op = PL_restartop;
3280af22 2174 PL_restartop = 0;
312caa8e 2175 goto redo_body;
4633a7c4 2176 }
3280af22 2177 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2178 if (flags & G_ARRAY)
2179 retval = 0;
2180 else {
2181 retval = 1;
3280af22 2182 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2183 }
312caa8e 2184 break;
4633a7c4
LW		 2185 }
2186
14dd3ad8 2187 JMPENV_POP;
4633a7c4 2188 if (flags & G_DISCARD) {
3280af22 2189 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2190 retval = 0;
2191 FREETMPS;
2192 LEAVE;
2193 }
533c011a 2194 PL_op = oldop;
4633a7c4
LW		 2195 return retval;
2196}
2197
954c1994
GS		 2198/*
2199=for apidoc p||eval_pv
2200
2201Tells Perl to C<eval> the given string and return an SV* result.
2202
2203=cut
2204*/
2205
137443ea 2206SV*
864dbfa3 2207Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2208{
2209 dSP;
2210 SV* sv = newSVpv(p, 0);
2211
864dbfa3 2212 eval_sv(sv, G_SCALAR);
137443ea 2213 SvREFCNT_dec(sv);
2214
2215 SPAGAIN;
2216 sv = POPs;
2217 PUTBACK;
2218
2d8e6c8d
GS		 2219 if (croak_on_error && SvTRUE(ERRSV)) {
2220 STRLEN n_a;
cea2e8a9 2221 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 2222 }
137443ea 2223
2224 return sv;
2225}
2226
4633a7c4
LW		 2227/* Require a module. */
2228
954c1994 2229/*
ccfc67b7
JH		 2230=head1 Embedding Functions
2231
954c1994
GS		 2232=for apidoc p||require_pv
2233
7d3fb230
BS		 2234Tells Perl to C<require> the file named by the string argument. It is
2235analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2236implemented that way; consider using load_module instead.
954c1994 2237
7d3fb230 2238=cut */
954c1994 2239
4633a7c4 2240void
864dbfa3 2241Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2242{
d3acc0f7
JP		 2243 SV* sv;
2244 dSP;
e788e7d3 2245 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2246 PUTBACK;
2247 sv = sv_newmortal();
4633a7c4
LW		 2248 sv_setpv(sv, "require '");
2249 sv_catpv(sv, pv);
2250 sv_catpv(sv, "'");
864dbfa3 2251 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2252 SPAGAIN;
2253 POPSTACK;
79072805
LW		 2254}
2255
79072805 2256void
864dbfa3 2257Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 2258{
2259 register GV *gv;
2260
155aba94 2261 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2262 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2263}
2264
76e3520e 2265STATIC void
cea2e8a9 2266S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 2267{
ab821d7f 2268 /* This message really ought to be max 23 lines.
75c72d73 2269 * Removed -h because the user already knows that option. Others? */
fb73857a 2270
76e3520e 2271 static char *usage_msg[] = {
fb73857a 2272"-0[octal] specify record separator (\\0, if no argument)",
2273"-a autosplit mode with -n or -p (splits $_ into @F)",
fb3560ee 2274"-C[number/list] enables the listed Unicode features",
1950ee41 2275"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS		 2276"-d[:debugger] run program under debugger",
2277"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
90490ea3 2278"-e program one line of program (several -e's allowed, omit programfile)",
aac3bd0d
GS		 2279"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2280"-i[extension] edit <> files in place (makes backup if extension supplied)",
2281"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 2282"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 2283"-[mM][-]module execute `use/no module...' before executing program",
2284"-n assume 'while (<>) { ... }' loop around program",
2285"-p assume loop like -n but print line also, like sed",
2286"-P run program through C preprocessor before compilation",
2287"-s enable rudimentary parsing for switches after programfile",
2288"-S look for programfile using PATH environment variable",
9cbc33e8 2289"-t enable tainting warnings",
90490ea3 2290"-T enable tainting checks",
aac3bd0d 2291"-u dump core after parsing program",
fb73857a 2292"-U allow unsafe operations",
aac3bd0d
GS		 2293"-v print version, subversion (includes VERY IMPORTANT perl info)",
2294"-V[:variable] print configuration summary (or a single Config.pm variable)",
2295"-w enable many useful warnings (RECOMMENDED)",
3c0facb2 2296"-W enable all warnings",
fb73857a 2297"-x[directory] strip off text before #!perl line and perhaps cd to directory",
90490ea3 2298"-X disable all warnings",
fb73857a 2299"\n",
2300NULL
2301};
76e3520e 2302 char **p = usage_msg;
fb73857a 2303
b0e47665
GS		 2304 PerlIO_printf(PerlIO_stdout(),
2305 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2306 name);
fb73857a 2307 while (*p)
b0e47665 2308 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2309}
2310
b4ab917c
DM		 2311/* convert a string of -D options (or digits) into an int.
2312 * sets *s to point to the char after the options */
2313
2314#ifdef DEBUGGING
2315int
2316Perl_get_debug_opts(pTHX_ char **s)
2317{
2318 int i = 0;
2319 if (isALPHA(**s)) {
2320 /* if adding extra options, remember to update DEBUG_MASK */
ecae49c0 2321 static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
b4ab917c
DM		 2322
2323 for (; isALNUM(**s); (*s)++) {
2324 char *d = strchr(debopts,**s);
2325 if (d)
2326 i |= 1 << (d - debopts);
2327 else if (ckWARN_d(WARN_DEBUGGING))
2328 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2329 "invalid option -D%c\n", **s);
2330 }
2331 }
2332 else {
2333 i = atoi(*s);
2334 for (; isALNUM(**s); (*s)++) ;
2335 }
2336# ifdef EBCDIC
2337 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2338 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2339 "-Dp not implemented on this platform\n");
2340# endif
2341 return i;
2342}
2343#endif
2344
79072805
LW		 2345/* This routine handles any switches that can be given during run */
2346
2347char *
864dbfa3 2348Perl_moreswitches(pTHX_ char *s)
79072805 2349{
ba210ebe 2350 STRLEN numlen;
84c133a0 2351 UV rschar;
79072805
LW		 2352
2353 switch (*s) {
2354 case '0':
a863c7d1 2355 {
f2095865
JH		 2356 I32 flags = 0;
2357
2358 SvREFCNT_dec(PL_rs);
2359 if (s[1] == 'x' && s[2]) {
2360 char *e;
2361 U8 *tmps;
2362
2363 for (s += 2, e = s; *e; e++);
2364 numlen = e - s;
2365 flags = PERL_SCAN_SILENT_ILLDIGIT;
2366 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2367 if (s + numlen < e) {
2368 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2369 numlen = 0;
2370 s--;
2371 }
2372 PL_rs = newSVpvn("", 0);
c5661c80 2373 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 2374 tmps = (U8*)SvPVX(PL_rs);
2375 uvchr_to_utf8(tmps, rschar);
2376 SvCUR_set(PL_rs, UNISKIP(rschar));
2377 SvUTF8_on(PL_rs);
2378 }
2379 else {
2380 numlen = 4;
2381 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2382 if (rschar & ~((U8)~0))
2383 PL_rs = &PL_sv_undef;
2384 else if (!rschar && numlen >= 2)
2385 PL_rs = newSVpvn("", 0);
2386 else {
2387 char ch = (char)rschar;
2388 PL_rs = newSVpvn(&ch, 1);
2389 }
2390 }
800633c3 2391 sv_setsv(get_sv("/", TRUE), PL_rs);
f2095865 2392 return s + numlen;
a863c7d1 2393 }
46487f74 2394 case 'C':
a05d7ebb
JH		 2395 s++;
2396 PL_unicode = parse_unicode_opts(&s);
46487f74 2397 return s;
2304df62 2398 case 'F':
3280af22 2399 PL_minus_F = TRUE;
ebce5377
RGS		 2400 PL_splitstr = ++s;
2401 while (*s && !isSPACE(*s)) ++s;
2402 *s = '\0';
2403 PL_splitstr = savepv(PL_splitstr);
2304df62 2404 return s;
79072805 2405 case 'a':
3280af22 2406 PL_minus_a = TRUE;
79072805
LW		 2407 s++;
2408 return s;
2409 case 'c':
3280af22 2410 PL_minus_c = TRUE;
79072805
LW		 2411 s++;
2412 return s;
2413 case 'd':
bbce6d69 2414 forbid_setid("-d");
4633a7c4 2415 s++;
70c94a19
RR		 2416 /* The following permits -d:Mod to accepts arguments following an =
2417 in the fashion that -MSome::Mod does. */
2418 if (*s == ':' || *s == '=') {
2419 char *start;
2420 SV *sv;
2421 sv = newSVpv("use Devel::", 0);
2422 start = ++s;
2423 /* We now allow -d:Module=Foo,Bar */
2424 while(isALNUM(*s) || *s==':') ++s;
2425 if (*s != '=')
2426 sv_catpv(sv, start);
2427 else {
2428 sv_catpvn(sv, start, s-start);
2429 sv_catpv(sv, " split(/,/,q{");
2430 sv_catpv(sv, ++s);
3d27e215 2431 sv_catpv(sv, "})");
70c94a19 2432 }
4633a7c4 2433 s += strlen(s);
70c94a19 2434 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2435 }
ed094faf 2436 if (!PL_perldb) {
3280af22 2437 PL_perldb = PERLDB_ALL;
a0d0e21e 2438 init_debugger();
ed094faf 2439 }
79072805
LW		 2440 return s;
2441 case 'D':
0453d815 2442 {
79072805 2443#ifdef DEBUGGING
bbce6d69 2444 forbid_setid("-D");
b4ab917c
DM		 2445 s++;
2446 PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
12a43e32 2447#else /* !DEBUGGING */
0453d815 2448 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2449 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
0453d815 2450 "Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 2451 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2452#endif
2453 /*SUPPRESS 530*/
2454 return s;
0453d815 2455 }
4633a7c4 2456 case 'h':
ac27b0f5 2457 usage(PL_origargv[0]);
7ca617d0 2458 my_exit(0);
79072805 2459 case 'i':
3280af22
NIS		 2460 if (PL_inplace)
2461 Safefree(PL_inplace);
c030f24b
GH		 2462#if defined(__CYGWIN__) /* do backup extension automagically */
2463 if (*(s+1) == '\0') {
2464 PL_inplace = savepv(".bak");
2465 return s+1;
2466 }
2467#endif /* __CYGWIN__ */
3280af22 2468 PL_inplace = savepv(s+1);
79072805 2469 /*SUPPRESS 530*/
3280af22 2470 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2471 if (*s) {
fb73857a 2472 *s++ = '\0';
7b8d334a
GS		 2473 if (*s == '-') /* Additional switches on #! line. */
2474 s++;
2475 }
fb73857a 2476 return s;
4e49a025 2477 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2478 forbid_setid("-I");
fb73857a 2479 ++s;
2480 while (*s && isSPACE(*s))
2481 ++s;
2482 if (*s) {
774d564b 2483 char *e, *p;
0df16ed7
GS		 2484 p = s;
2485 /* ignore trailing spaces (possibly followed by other switches) */
2486 do {
2487 for (e = p; *e && !isSPACE(*e); e++) ;
2488 p = e;
2489 while (isSPACE(*p))
2490 p++;
2491 } while (*p && *p != '-');
2492 e = savepvn(s, e-s);
574c798a 2493 incpush(e, TRUE, TRUE, FALSE);
0df16ed7
GS		 2494 Safefree(e);
2495 s = p;
2496 if (*s == '-')
2497 s++;
79072805
LW		 2498 }
2499 else
a67e862a 2500 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2501 return s;
79072805 2502 case 'l':
3280af22 2503 PL_minus_l = TRUE;
79072805 2504 s++;
7889fe52
NIS		 2505 if (PL_ors_sv) {
2506 SvREFCNT_dec(PL_ors_sv);
2507 PL_ors_sv = Nullsv;
2508 }
79072805 2509 if (isDIGIT(*s)) {
53305cf1 2510 I32 flags = 0;
7889fe52 2511 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2512 numlen = 3 + (*s == '0');
2513 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2514 s += numlen;
2515 }
2516 else {
8bfdd7d9 2517 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2518 PL_ors_sv = newSVpvn("\n\n",2);
2519 }
2520 else {
8bfdd7d9 2521 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2522 }
79072805
LW		 2523 }
2524 return s;
06492da6
SF		 2525 case 'A':
2526 forbid_setid("-A");
930366bd
RGS		 2527 if (!PL_preambleav)
2528 PL_preambleav = newAV();
06492da6 2529 if (*++s) {
3d27e215
LM		 2530 SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
2531 sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
06492da6 2532 sv_catpv(sv,s);
3d27e215 2533 sv_catpvn(sv, "\0)", 2);
06492da6 2534 s+=strlen(s);
06492da6
SF		 2535 av_push(PL_preambleav, sv);
2536 }
2537 else
930366bd 2538 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
06492da6 2539 return s;
1a30305b 2540 case 'M':
bbce6d69 2541 forbid_setid("-M"); /* XXX ? */
1a30305b 2542 /* FALL THROUGH */
2543 case 'm':
bbce6d69 2544 forbid_setid("-m"); /* XXX ? */
1a30305b 2545 if (*++s) {
a5f75d66 2546 char *start;
11343788 2547 SV *sv;
a5f75d66
AD		 2548 char *use = "use ";
2549 /* -M-foo == 'no foo' */
2550 if (*s == '-') { use = "no "; ++s; }
11343788 2551 sv = newSVpv(use,0);
a5f75d66 2552 start = s;
1a30305b 2553 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2554 while(isALNUM(*s) || *s==':') ++s;
2555 if (*s != '=') {
11343788 2556 sv_catpv(sv, start);
c07a80fd 2557 if (*(start-1) == 'm') {
2558 if (*s != '\0')
cea2e8a9 2559 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2560 sv_catpv( sv, " ()");
c07a80fd 2561 }
2562 } else {
6df41af2 2563 if (s == start)
be98fb35
GS		 2564 Perl_croak(aTHX_ "Module name required with -%c option",
2565 s[-1]);
11343788 2566 sv_catpvn(sv, start, s-start);
3d27e215
LM		 2567 sv_catpv(sv, " split(/,/,q");
2568 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
11343788 2569 sv_catpv(sv, ++s);
3d27e215 2570 sv_catpvn(sv, "\0)", 2);
c07a80fd 2571 }
1a30305b 2572 s += strlen(s);
5c831c24 2573 if (!PL_preambleav)
3280af22
NIS		 2574 PL_preambleav = newAV();
2575 av_push(PL_preambleav, sv);
1a30305b 2576 }
2577 else
cea2e8a9 2578 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2579 return s;
79072805 2580 case 'n':
3280af22 2581 PL_minus_n = TRUE;
79072805
LW		 2582 s++;
2583 return s;
2584 case 'p':
3280af22 2585 PL_minus_p = TRUE;
79072805
LW		 2586 s++;
2587 return s;
2588 case 's':
bbce6d69 2589 forbid_setid("-s");
3280af22 2590 PL_doswitches = TRUE;
79072805
LW		 2591 s++;
2592 return s;
6537fe72
MS		 2593 case 't':
2594 if (!PL_tainting)
22f7c9c9 2595 TOO_LATE_FOR('t');
6537fe72
MS		 2596 s++;
2597 return s;
463ee0b2 2598 case 'T':
3280af22 2599 if (!PL_tainting)
22f7c9c9 2600 TOO_LATE_FOR('T');
463ee0b2
LW		 2601 s++;
2602 return s;
79072805 2603 case 'u':
bf4acbe4
GS		 2604#ifdef MACOS_TRADITIONAL
2605 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2606#endif
3280af22 2607 PL_do_undump = TRUE;
79072805
LW		 2608 s++;
2609 return s;
2610 case 'U':
3280af22 2611 PL_unsafe = TRUE;
79072805
LW		 2612 s++;
2613 return s;
2614 case 'v':
8e9464f1 2615#if !defined(DGUX)
b0e47665 2616 PerlIO_printf(PerlIO_stdout(),
d2560b70 2617 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
b0e47665 2618 PL_patchlevel, ARCHNAME));
8e9464f1
JH		 2619#else /* DGUX */
2620/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2621 PerlIO_printf(PerlIO_stdout(),
2622 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2623 PerlIO_printf(PerlIO_stdout(),
2624 Perl_form(aTHX_ " built under %s at %s %s\n",
2625 OSNAME, __DATE__, __TIME__));
2626 PerlIO_printf(PerlIO_stdout(),
2627 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2628 OSVERS));
8e9464f1
JH		 2629#endif /* !DGUX */
2630
fb73857a 2631#if defined(LOCAL_PATCH_COUNT)
2632 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2633 PerlIO_printf(PerlIO_stdout(),
2634 "\n(with %d registered patch%s, "
2635 "see perl -V for more detail)",
2636 (int)LOCAL_PATCH_COUNT,
2637 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2638#endif
1a30305b 2639
b0e47665 2640 PerlIO_printf(PerlIO_stdout(),
45a2796c 2641 "\n\nCopyright 1987-2004, Larry Wall\n");
eae9c151
JH		 2642#ifdef MACOS_TRADITIONAL
2643 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2644 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2645 "maintained by Chris Nandor\n");
eae9c151 2646#endif
79072805 2647#ifdef MSDOS
b0e47665
GS		 2648 PerlIO_printf(PerlIO_stdout(),
2649 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2650#endif
2651#ifdef DJGPP
b0e47665
GS		 2652 PerlIO_printf(PerlIO_stdout(),
2653 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2654 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2655#endif
79072805 2656#ifdef OS2
b0e47665
GS		 2657 PerlIO_printf(PerlIO_stdout(),
2658 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2659 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2660#endif
79072805 2661#ifdef atarist
b0e47665
GS		 2662 PerlIO_printf(PerlIO_stdout(),
2663 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2664#endif
a3f9223b 2665#ifdef __BEOS__
b0e47665
GS		 2666 PerlIO_printf(PerlIO_stdout(),
2667 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2668#endif
1d84e8df 2669#ifdef MPE
b0e47665 2670 PerlIO_printf(PerlIO_stdout(),
e583a879 2671 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 2672#endif
9d116dd7 2673#ifdef OEMVS
b0e47665
GS		 2674 PerlIO_printf(PerlIO_stdout(),
2675 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2676#endif
495c5fdc 2677#ifdef __VOS__
b0e47665 2678 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2679 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2680#endif
092bebab 2681#ifdef __OPEN_VM
b0e47665
GS		 2682 PerlIO_printf(PerlIO_stdout(),
2683 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2684#endif
a1a0e61e 2685#ifdef POSIX_BC
b0e47665
GS		 2686 PerlIO_printf(PerlIO_stdout(),
2687 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2688#endif
61ae2fbf 2689#ifdef __MINT__
b0e47665
GS		 2690 PerlIO_printf(PerlIO_stdout(),
2691 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2692#endif
f83d2536 2693#ifdef EPOC
b0e47665 2694 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2695 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2696#endif
e1caacb4 2697#ifdef UNDER_CE
b475b3e6
JH		 2698 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2699 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2700 wce_hitreturn();
2701#endif
baed7233
DL		 2702#ifdef BINARY_BUILD_NOTICE
2703 BINARY_BUILD_NOTICE;
2704#endif
b0e47665
GS		 2705 PerlIO_printf(PerlIO_stdout(),
2706 "\n\
79072805 2707Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2708GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2709Complete documentation for Perl, including FAQ lists, should be found on\n\
2710this system using `man perl' or `perldoc perl'. If you have access to the\n\
2711Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
7ca617d0 2712 my_exit(0);
79072805 2713 case 'w':
599cee73 2714 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2715 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2716 s++;
2717 return s;
2718 case 'W':
ac27b0f5 2719 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2720 if (!specialWARN(PL_compiling.cop_warnings))
2721 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2722 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2723 s++;
2724 return s;
2725 case 'X':
ac27b0f5 2726 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2727 if (!specialWARN(PL_compiling.cop_warnings))
2728 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2729 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2730 s++;
2731 return s;
a0d0e21e 2732 case '*':
79072805
LW		 2733 case ' ':
2734 if (s[1] == '-') /* Additional switches on #! line. */
2735 return s+2;
2736 break;
a0d0e21e 2737 case '-':
79072805 2738 case 0:
51882d45 2739#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2740 case '\r':
2741#endif
79072805
LW		 2742 case '\n':
2743 case '\t':
2744 break;
aa689395 2745#ifdef ALTERNATE_SHEBANG
2746 case 'S': /* OS/2 needs -S on "extproc" line. */
2747 break;
2748#endif
a0d0e21e 2749 case 'P':
3280af22 2750 if (PL_preprocess)
a0d0e21e
LW		 2751 return s+1;
2752 /* FALL THROUGH */
79072805 2753 default:
cea2e8a9 2754 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2755 }
2756 return Nullch;
2757}
2758
2759/* compliments of Tom Christiansen */
2760
2761/* unexec() can be found in the Gnu emacs distribution */
ee580363 2762/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2763
2764void
864dbfa3 2765Perl_my_unexec(pTHX)
79072805
LW		 2766{
2767#ifdef UNEXEC
46fc3d4c 2768 SV* prog;
2769 SV* file;
ee580363 2770 int status = 1;
79072805
LW		 2771 extern int etext;
2772
ee580363 2773 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2774 sv_catpv(prog, "/perl");
6b88bc9c 2775 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2776 sv_catpv(file, ".perldump");
79072805 2777
ee580363
GS		 2778 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2779 /* unexec prints msg to stderr in case of failure */
6ad3d225 2780 PerlProc_exit(status);
79072805 2781#else
a5f75d66
AD		 2782# ifdef VMS
2783# include <lib$routines.h>
2784 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2785# else
79072805 2786 ABORT(); /* for use with undump */
aa689395 2787# endif
a5f75d66 2788#endif
79072805
LW		 2789}
2790
cb68f92d
GS		 2791/* initialize curinterp */
2792STATIC void
cea2e8a9 2793S_init_interp(pTHX)
cb68f92d
GS		 2794{
2795
acfe0abc
GS		 2796#ifdef MULTIPLICITY
2797# define PERLVAR(var,type)
2798# define PERLVARA(var,n,type)
2799# if defined(PERL_IMPLICIT_CONTEXT)
2800# if defined(USE_5005THREADS)
2801# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2802# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2803# else /* !USE_5005THREADS */
2804# define PERLVARI(var,type,init) aTHX->var = init;
2805# define PERLVARIC(var,type,init) aTHX->var = init;
2806# endif /* USE_5005THREADS */
3967c732 2807# else
acfe0abc
GS		 2808# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2809# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2810# endif
acfe0abc
GS		 2811# include "intrpvar.h"
2812# ifndef USE_5005THREADS
2813# include "thrdvar.h"
2814# endif
2815# undef PERLVAR
2816# undef PERLVARA
2817# undef PERLVARI
2818# undef PERLVARIC
2819#else
2820# define PERLVAR(var,type)
2821# define PERLVARA(var,n,type)
2822# define PERLVARI(var,type,init) PL_##var = init;
2823# define PERLVARIC(var,type,init) PL_##var = init;
2824# include "intrpvar.h"
2825# ifndef USE_5005THREADS
2826# include "thrdvar.h"
2827# endif
2828# undef PERLVAR
2829# undef PERLVARA
2830# undef PERLVARI
2831# undef PERLVARIC
cb68f92d
GS		 2832#endif
2833
cb68f92d
GS		 2834}
2835
76e3520e 2836STATIC void
cea2e8a9 2837S_init_main_stash(pTHX)
79072805 2838{
463ee0b2 2839 GV *gv;
6e72f9df 2840
3280af22 2841 PL_curstash = PL_defstash = newHV();
79cb57f6 2842 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2843 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2844 SvREFCNT_dec(GvHV(gv));
3280af22 2845 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2846 SvREADONLY_on(gv);
3280af22
NIS		 2847 HvNAME(PL_defstash) = savepv("main");
2848 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2849 GvMULTI_on(PL_incgv);
2850 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2851 GvMULTI_on(PL_hintgv);
2852 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2853 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2854 GvMULTI_on(PL_errgv);
2855 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2856 GvMULTI_on(PL_replgv);
cea2e8a9 2857 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2858 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2859 sv_setpvn(ERRSV, "", 0);
3280af22 2860 PL_curstash = PL_defstash;
11faa288 2861 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2862 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2863 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2864 /* We must init $/ before switches are processed. */
864dbfa3 2865 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2866}
2867
76e3520e 2868STATIC void
cea2e8a9 2869S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2870{
1b24ed4b
MS		 2871 char *quote;
2872 char *code;
2873 char *cpp_discard_flag;
2874 char *perl;
2875
6c4ab083 2876 *fdscript = -1;
79072805 2877
3280af22
NIS		 2878 if (PL_e_script) {
2879 PL_origfilename = savepv("-e");
96436eeb 2880 }
6c4ab083
GS		 2881 else {
2882 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2883 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2884
2885 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2886 char *s = scriptname + 8;
2887 *fdscript = atoi(s);
2888 while (isDIGIT(*s))
2889 s++;
2890 if (*s) {
2891 scriptname = savepv(s + 1);
3280af22
NIS		 2892 Safefree(PL_origfilename);
2893 PL_origfilename = scriptname;
6c4ab083
GS		 2894 }
2895 }
2896 }
2897
05ec9bb3 2898 CopFILE_free(PL_curcop);
57843af0 2899 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2900 if (strEQ(PL_origfilename,"-"))
79072805 2901 scriptname = "";
01f988be 2902 if (*fdscript >= 0) {
3280af22 2903 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2904# if defined(HAS_FCNTL) && defined(F_SETFD)
2905 if (PL_rsfp)
2906 /* ensure close-on-exec */
2907 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2908# endif
96436eeb 2909 }
3280af22 2910 else if (PL_preprocess) {
46fc3d4c 2911 char *cpp_cfg = CPPSTDIN;
79cb57f6 2912 SV *cpp = newSVpvn("",0);
46fc3d4c 2913 SV *cmd = NEWSV(0,0);
2914
ae58f265
JH		 2915 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
2916 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
46fc3d4c 2917 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2918 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2919 sv_catpv(cpp, cpp_cfg);
79072805 2920
1b24ed4b
MS		 2921# ifndef VMS
2922 sv_catpvn(sv, "-I", 2);
2923 sv_catpv(sv,PRIVLIB_EXP);
2924# endif
46fc3d4c 2925
14953ddc
MB		 2926 DEBUG_P(PerlIO_printf(Perl_debug_log,
2927 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2928 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 2929
2930# if defined(MSDOS) || defined(WIN32) || defined(VMS)
2931 quote = "\"";
2932# else
2933 quote = "'";
2934# endif
2935
2936# ifdef VMS
2937 cpp_discard_flag = "";
2938# else
2939 cpp_discard_flag = "-C";
2940# endif
2941
2942# ifdef OS2
2943 perl = os2_execname(aTHX);
2944# else
2945 perl = PL_origargv[0];
2946# endif
2947
2948
2949 /* This strips off Perl comments which might interfere with
62375a60
NIS		 2950 the C pre-processor, including #!. #line directives are
2951 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 2952 of #line. FWP played some golf with it so it will fit
2953 into VMS's 255 character buffer.
2954 */
2955 if( PL_doextract )
2956 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2957 else
2958 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2959
2960 Perl_sv_setpvf(aTHX_ cmd, "\
2961%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 2962 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 2963 cpp_discard_flag, sv, CPPMINUS);
2964
3280af22 2965 PL_doextract = FALSE;
1b24ed4b
MS		 2966# ifdef IAMSUID /* actually, this is caught earlier */
2967 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2968# ifdef HAS_SETEUID
2969 (void)seteuid(PL_uid); /* musn't stay setuid root */
2970# else
2971# ifdef HAS_SETREUID
2972 (void)setreuid((Uid_t)-1, PL_uid);
2973# else
2974# ifdef HAS_SETRESUID
2975 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2976# else
2977 PerlProc_setuid(PL_uid);
2978# endif
2979# endif
2980# endif
b28d0864 2981 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2982 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805 2983 }
1b24ed4b 2984# endif /* IAMSUID */
0a6c758d 2985
62375a60
NIS		 2986 DEBUG_P(PerlIO_printf(Perl_debug_log,
2987 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 2988 SvPVX(cmd)));
2989
3280af22 2990 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2991 SvREFCNT_dec(cmd);
2992 SvREFCNT_dec(cpp);
79072805
LW		 2993 }
2994 else if (!*scriptname) {
bbce6d69 2995 forbid_setid("program input from stdin");
3280af22 2996 PL_rsfp = PerlIO_stdin();
79072805 2997 }
96436eeb 2998 else {
3280af22 2999 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3000# if defined(HAS_FCNTL) && defined(F_SETFD)
3001 if (PL_rsfp)
3002 /* ensure close-on-exec */
3003 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3004# endif
96436eeb 3005 }
3280af22 3006 if (!PL_rsfp) {
1b24ed4b
MS		 3007# ifdef DOSUID
3008# ifndef IAMSUID /* in case script is not readable before setuid */
3009 if (PL_euid &&
3010 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
3011 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
3012 {
3013 /* try again */
b35112e7 3014 PERL_FPU_PRE_EXEC
62375a60
NIS		 3015 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
3016 BIN_EXP, (int)PERL_REVISION,
1b24ed4b
MS		 3017 (int)PERL_VERSION,
3018 (int)PERL_SUBVERSION), PL_origargv);
b35112e7 3019 PERL_FPU_POST_EXEC
1b24ed4b
MS		 3020 Perl_croak(aTHX_ "Can't do setuid\n");
3021 }
3022# endif
3023# endif
3024# ifdef IAMSUID
3025 errno = EPERM;
2b8ca739 3026 Perl_croak(aTHX_ "Permission denied\n");
1b24ed4b
MS		 3027# else
3028 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3029 CopFILE(PL_curcop), Strerror(errno));
3030# endif
13281fa4 3031 }
79072805 3032}
8d063cd8 3033
7b89560d
JH		 3034/* Mention
3035 * I_SYSSTATVFS HAS_FSTATVFS
3036 * I_SYSMOUNT
c890dc6c 3037 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3038 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3039 * here so that metaconfig picks them up. */
3040
104d25b7 3041#ifdef IAMSUID
864dbfa3 3042STATIC int
e688b231 3043S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 3044{
0545a864
JH		 3045 int check_okay = 0; /* able to do all the required sys/libcalls */
3046 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 3047/*
ad27e871 3048 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 3049 * fstatvfs() is UNIX98.
0545a864 3050 * fstatfs() is 4.3 BSD.
ad27e871 3051 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 3052 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3053 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 3054 */
3055
6439433f
JH		 3056#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3057
3058# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3059 defined(HAS_FSTATVFS)
3060# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 3061 struct statvfs stfs;
6439433f 3062
104d25b7
JH		 3063 check_okay = fstatvfs(fd, &stfs) == 0;
3064 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
6439433f 3065# endif /* fstatvfs */
ac27b0f5 3066
6439433f
JH		 3067# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3068 defined(PERL_MOUNT_NOSUID) && \
3069 defined(HAS_FSTATFS) && \
3070 defined(HAS_STRUCT_STATFS) && \
3071 defined(HAS_STRUCT_STATFS_F_FLAGS)
3072# define FD_ON_NOSUID_CHECK_OKAY
e688b231 3073 struct statfs stfs;
6439433f 3074
104d25b7 3075 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 3076 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
6439433f
JH		 3077# endif /* fstatfs */
3078
3079# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3080 defined(PERL_MOUNT_NOSUID) && \
3081 defined(HAS_FSTAT) && \
3082 defined(HAS_USTAT) && \
3083 defined(HAS_GETMNT) && \
3084 defined(HAS_STRUCT_FS_DATA) && \
3085 defined(NOSTAT_ONE)
3086# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 3087 Stat_t fdst;
6439433f 3088
0545a864 3089 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 3090 struct ustat us;
3091 if (ustat(fdst.st_dev, &us) == 0) {
3092 struct fs_data fsd;
3093 /* NOSTAT_ONE here because we're not examining fields which
3094 * vary between that case and STAT_ONE. */
ad27e871 3095 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3096 size_t cmplen = sizeof(us.f_fname);
3097 if (sizeof(fsd.fd_req.path) < cmplen)
3098 cmplen = sizeof(fsd.fd_req.path);
3099 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3100 fdst.st_dev == fsd.fd_req.dev) {
3101 check_okay = 1;
3102 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3103 }
3104 }
3105 }
3106 }
0545a864 3107 }
6439433f
JH		 3108# endif /* fstat+ustat+getmnt */
3109
3110# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3111 defined(HAS_GETMNTENT) && \
3112 defined(HAS_HASMNTOPT) && \
3113 defined(MNTOPT_NOSUID)
3114# define FD_ON_NOSUID_CHECK_OKAY
3115 FILE *mtab = fopen("/etc/mtab", "r");
3116 struct mntent *entry;
c623ac67 3117 Stat_t stb, fsb;
104d25b7
JH		 3118
3119 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3120 while (entry = getmntent(mtab)) {
3121 if (stat(entry->mnt_dir, &fsb) == 0
3122 && fsb.st_dev == stb.st_dev)
3123 {
3124 /* found the filesystem */
3125 check_okay = 1;
3126 if (hasmntopt(entry, MNTOPT_NOSUID))
3127 on_nosuid = 1;
3128 break;
3129 } /* A single fs may well fail its stat(). */
3130 }
104d25b7
JH		 3131 }
3132 if (mtab)
6439433f
JH		 3133 fclose(mtab);
3134# endif /* getmntent+hasmntopt */
0545a864 3135
ac27b0f5 3136 if (!check_okay)
0545a864 3137 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 3138 return on_nosuid;
3139}
3140#endif /* IAMSUID */
3141
76e3520e 3142STATIC void
cea2e8a9 3143S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 3144{
155aba94 3145#ifdef IAMSUID
96436eeb 3146 int which;
155aba94 3147#endif
96436eeb 3148
13281fa4
LW		 3149 /* do we need to emulate setuid on scripts? */
3150
3151 /* This code is for those BSD systems that have setuid #! scripts disabled
3152 * in the kernel because of a security problem. Merely defining DOSUID
3153 * in perl will not fix that problem, but if you have disabled setuid
3154 * scripts in the kernel, this will attempt to emulate setuid and setgid
3155 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3156 * root version must be called suidperl or sperlN.NNN. If regular perl
3157 * discovers that it has opened a setuid script, it calls suidperl with
3158 * the same argv that it had. If suidperl finds that the script it has
3159 * just opened is NOT setuid root, it sets the effective uid back to the
3160 * uid. We don't just make perl setuid root because that loses the
3161 * effective uid we had before invoking perl, if it was different from the
3162 * uid.
13281fa4
LW		 3163 *
3164 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3165 * be defined in suidperl only. suidperl must be setuid root. The
3166 * Configure script will set this up for you if you want it.
3167 */
a687059c 3168
13281fa4 3169#ifdef DOSUID
6e72f9df 3170 char *s, *s2;
a0d0e21e 3171
b28d0864 3172 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3173 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 3174 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3175 I32 len;
2d8e6c8d 3176 STRLEN n_a;
13281fa4 3177
a687059c 3178#ifdef IAMSUID
fe14fcc3 3179#ifndef HAS_SETREUID
a687059c
LW		 3180 /* On this access check to make sure the directories are readable,
3181 * there is actually a small window that the user could use to make
3182 * filename point to an accessible directory. So there is a faint
3183 * chance that someone could execute a setuid script down in a
3184 * non-accessible directory. I don't know what to do about that.
3185 * But I don't think it's too important. The manual lies when
3186 * it says access() is useful in setuid programs.
3187 */
e57400b1
BD		 3188 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3189 errno = EPERM;
3190 Perl_croak(aTHX_ "Permission denied\n");
3191 }
a687059c
LW		 3192#else
3193 /* If we can swap euid and uid, then we can determine access rights
3194 * with a simple stat of the file, and then compare device and
3195 * inode to make sure we did stat() on the same file we opened.
3196 * Then we just have to make sure he or she can execute it.
3197 */
3198 {
c623ac67 3199 Stat_t tmpstatbuf;
a687059c 3200
85e6fe83
LW		 3201 if (
3202#ifdef HAS_SETREUID
b28d0864 3203 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 3204#else
3205# if HAS_SETRESUID
b28d0864 3206 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 3207# endif
85e6fe83 3208#endif
b28d0864 3209 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 3210 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
e57400b1
BD		 3211 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0) {
3212 errno = EPERM;
3213 Perl_croak(aTHX_ "Permission denied\n"); /* testing full pathname here */
3214 }
2bb3463c 3215#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e57400b1
BD		 3216 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3217 errno = EPERM;
3218 Perl_croak(aTHX_ "Permission denied\n");
3219 }
104d25b7 3220#endif
b28d0864
NIS		 3221 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3222 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3223 (void)PerlIO_close(PL_rsfp);
e57400b1 3224 errno = EPERM;
cea2e8a9 3225 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3226 }
85e6fe83
LW		 3227 if (
3228#ifdef HAS_SETREUID
b28d0864 3229 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 3230#else
3231# if defined(HAS_SETRESUID)
b28d0864 3232 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 3233# endif
85e6fe83 3234#endif
b28d0864 3235 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 3236 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 3237 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 3238 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3239 }
fe14fcc3 3240#endif /* HAS_SETREUID */
a687059c
LW		 3241#endif /* IAMSUID */
3242
e57400b1
BD		 3243 if (!S_ISREG(PL_statbuf.st_mode)) {
3244 errno = EPERM;
3245 Perl_croak(aTHX_ "Permission denied\n");
3246 }
b28d0864 3247 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3248 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3249 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 3250 CopLINE_inc(PL_curcop);
6b88bc9c 3251 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3252 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3253 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3254 s = SvPV(PL_linestr,n_a)+2;
663a0e37 3255 if (*s == ' ') s++;
45d8adaa 3256 while (!isSPACE(*s)) s++;
2d8e6c8d 3257 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3258 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3259 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 3260 Perl_croak(aTHX_ "Not a perl script");
a687059c 3261 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3262 /*
3263 * #! arg must be what we saw above. They can invoke it by
3264 * mentioning suidperl explicitly, but they may not add any strange
3265 * arguments beyond what #! says if they do invoke suidperl that way.
3266 */
3267 len = strlen(validarg);
3268 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 3269 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 3270 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3271
3272#ifndef IAMSUID
b28d0864
NIS		 3273 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3274 PL_euid == PL_statbuf.st_uid)
3275 if (!PL_do_undump)
cea2e8a9 3276 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
11fb1898 3277FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
a687059c 3278#endif /* IAMSUID */
13281fa4 3279
b28d0864
NIS		 3280 if (PL_euid) { /* oops, we're not the setuid root perl */
3281 (void)PerlIO_close(PL_rsfp);
13281fa4 3282#ifndef IAMSUID
46fc3d4c 3283 /* try again */
b35112e7 3284 PERL_FPU_PRE_EXEC
a7cb1f99 3285 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3286 (int)PERL_REVISION, (int)PERL_VERSION,
3287 (int)PERL_SUBVERSION), PL_origargv);
b35112e7 3288 PERL_FPU_POST_EXEC
13281fa4 3289#endif
cea2e8a9 3290 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 3291 }
3292
b28d0864 3293 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 3294#ifdef HAS_SETEGID
b28d0864 3295 (void)setegid(PL_statbuf.st_gid);
a687059c 3296#else
fe14fcc3 3297#ifdef HAS_SETREGID
b28d0864 3298 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3299#else
3300#ifdef HAS_SETRESGID
b28d0864 3301 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3302#else
b28d0864 3303 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3304#endif
3305#endif
85e6fe83 3306#endif
b28d0864 3307 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3308 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3309 }
b28d0864
NIS		 3310 if (PL_statbuf.st_mode & S_ISUID) {
3311 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3312#ifdef HAS_SETEUID
b28d0864 3313 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3314#else
fe14fcc3 3315#ifdef HAS_SETREUID
b28d0864 3316 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3317#else
3318#ifdef HAS_SETRESUID
b28d0864 3319 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3320#else
b28d0864 3321 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3322#endif
3323#endif
85e6fe83 3324#endif
b28d0864 3325 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3326 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3327 }
b28d0864 3328 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3329#ifdef HAS_SETEUID
b28d0864 3330 (void)seteuid((Uid_t)PL_uid);
a687059c 3331#else
fe14fcc3 3332#ifdef HAS_SETREUID
b28d0864 3333 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3334#else
85e6fe83 3335#ifdef HAS_SETRESUID
b28d0864 3336 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3337#else
b28d0864 3338 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3339#endif
a687059c
LW		 3340#endif
3341#endif
b28d0864 3342 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3343 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3344 }
748a9306 3345 init_ids();
b28d0864 3346 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 3347 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 3348 }
3349#ifdef IAMSUID
6b88bc9c 3350 else if (PL_preprocess)
cea2e8a9 3351 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 3352 else if (fdscript >= 0)
cea2e8a9 3353 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
e57400b1
BD		 3354 else {
3355 errno = EPERM;
2b8ca739 3356 Perl_croak(aTHX_ "Permission denied\n");
e57400b1 3357 }
96436eeb 3358
3359 /* We absolutely must clear out any saved ids here, so we */
3360 /* exec the real perl, substituting fd script for scriptname. */
3361 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 3362 PerlIO_rewind(PL_rsfp);
3363 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c 3364 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
e57400b1
BD		 3365 if (!PL_origargv[which]) {
3366 errno = EPERM;
3367 Perl_croak(aTHX_ "Permission denied\n");
3368 }
cea2e8a9 3369 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 3370 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 3371#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3372 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3373#endif
b35112e7 3374 PERL_FPU_PRE_EXEC
a7cb1f99 3375 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3376 (int)PERL_REVISION, (int)PERL_VERSION,
3377 (int)PERL_SUBVERSION), PL_origargv);/* try again */
b35112e7 3378 PERL_FPU_POST_EXEC
cea2e8a9 3379 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 3380#endif /* IAMSUID */
a687059c 3381#else /* !DOSUID */
3280af22 3382 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3383#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3384 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3385 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3386 ||
b28d0864 3387 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3388 )
b28d0864 3389 if (!PL_do_undump)
cea2e8a9 3390 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3391FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3392#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3393 /* not set-id, must be wrapped */
a687059c 3394 }
13281fa4 3395#endif /* DOSUID */
79072805 3396}
13281fa4 3397
76e3520e 3398STATIC void
cea2e8a9 3399S_find_beginning(pTHX)
79072805 3400{
6e72f9df 3401 register char *s, *s2;
e55ac0fa
HS		 3402#ifdef MACOS_TRADITIONAL
3403 int maclines = 0;
3404#endif
33b78306
LW		 3405
3406 /* skip forward in input to the real script? */
3407
bbce6d69 3408 forbid_setid("-x");
bf4acbe4 3409#ifdef MACOS_TRADITIONAL
084592ab 3410 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3411
bf4acbe4
GS		 3412 while (PL_doextract || gMacPerl_AlwaysExtract) {
3413 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3414 if (!gMacPerl_AlwaysExtract)
3415 Perl_croak(aTHX_ "No Perl script found in input\n");
e55ac0fa 3416
bf4acbe4
GS		 3417 if (PL_doextract) /* require explicit override ? */
3418 if (!OverrideExtract(PL_origfilename))
3419 Perl_croak(aTHX_ "User aborted script\n");
3420 else
3421 PL_doextract = FALSE;
e55ac0fa 3422
bf4acbe4
GS		 3423 /* Pater peccavi, file does not have #! */
3424 PerlIO_rewind(PL_rsfp);
e55ac0fa 3425
bf4acbe4
GS		 3426 break;
3427 }
3428#else
3280af22
NIS		 3429 while (PL_doextract) {
3430 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3431 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3432#endif
4f0c37ba
IZ		 3433 s2 = s;
3434 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3435 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3436 PL_doextract = FALSE;
6e72f9df 3437 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3438 s2 = s;
3439 while (*s == ' ' || *s == '\t') s++;
3440 if (*s++ == '-') {
3441 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3442 if (strnEQ(s2-4,"perl",4))
3443 /*SUPPRESS 530*/
155aba94
GS		 3444 while ((s = moreswitches(s)))
3445 ;
33b78306 3446 }
95e8664e 3447#ifdef MACOS_TRADITIONAL
e55ac0fa
HS		 3448 /* We are always searching for the #!perl line in MacPerl,
3449 * so if we find it, still keep the line count correct
3450 * by counting lines we already skipped over
3451 */
3452 for (; maclines > 0 ; maclines--)
3453 PerlIO_ungetc(PL_rsfp, '\n');
3454
95e8664e 3455 break;
e55ac0fa
HS		 3456
3457 /* gMacPerl_AlwaysExtract is false in MPW tool */
3458 } else if (gMacPerl_AlwaysExtract) {
3459 ++maclines;
95e8664e 3460#endif
83025b21
LW		 3461 }
3462 }
3463}
3464
afe37c7d 3465
76e3520e 3466STATIC void
cea2e8a9 3467S_init_ids(pTHX)
352d5a3a 3468{
d8eceb89
JH		 3469 PL_uid = PerlProc_getuid();
3470 PL_euid = PerlProc_geteuid();
3471 PL_gid = PerlProc_getgid();
3472 PL_egid = PerlProc_getegid();
748a9306 3473#ifdef VMS
b28d0864
NIS		 3474 PL_uid |= PL_gid << 16;
3475 PL_euid |= PL_egid << 16;
748a9306 3476#endif
22f7c9c9
JH		 3477 /* Should not happen: */
3478 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3280af22 3479 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 3480}
79072805 3481
a0643315
JH		 3482/* This is used very early in the lifetime of the program,
3483 * before even the options are parsed, so PL_tainting has
b0891165 3484 * not been initialized properly. */
af419de7 3485bool
22f7c9c9
JH		 3486Perl_doing_taint(int argc, char *argv[], char *envp[])
3487{
c3446a78
JH		 3488#ifndef PERL_IMPLICIT_SYS
3489 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3490 * before we have an interpreter-- and the whole point of this
3491 * function is to be called at such an early stage. If you are on
3492 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3493 * "tainted because running with altered effective ids', you'll
3494 * have to add your own checks somewhere in here. The two most
3495 * known samples of 'implicitness' are Win32 and NetWare, neither
3496 * of which has much of concept of 'uids'. */
af419de7 3497 int uid = PerlProc_getuid();
22f7c9c9 3498 int euid = PerlProc_geteuid();
af419de7 3499 int gid = PerlProc_getgid();
22f7c9c9
JH		 3500 int egid = PerlProc_getegid();
3501
3502#ifdef VMS
af419de7 3503 uid |= gid << 16;
22f7c9c9
JH		 3504 euid |= egid << 16;
3505#endif
3506 if (uid && (euid != uid || egid != gid))
3507 return 1;
c3446a78 3508#endif /* !PERL_IMPLICIT_SYS */
af419de7
JH		 3509 /* This is a really primitive check; environment gets ignored only