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