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
For-non-perlio places we need STDOUT back.
[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)",
46487f74 2245"-C enable native wide character system interfaces",
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)",
2249"-e 'command' one line of program (several -e's allowed, omit programfile)",
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",
2260"-T enable tainting checks",
9cbc33e8 2261"-t enable tainting warnings",
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
GS		 2267"-W enable all warnings",
2268"-X disable all warnings",
fb73857a 2269"-x[directory] strip off text before #!perl line and perhaps cd to directory",
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);
2401 sv_catpv(sv, "})");
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) {
930366bd 2500 SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37);
06492da6
SF		 2501 sv_catpv(sv,s);
2502 sv_catpv(sv,"})");
2503 s+=strlen(s);
06492da6
SF		 2504 av_push(PL_preambleav, sv);
2505 }
2506 else
930366bd 2507 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
06492da6 2508 return s;
1a30305b 2509 case 'M':
bbce6d69 2510 forbid_setid("-M"); /* XXX ? */
1a30305b 2511 /* FALL THROUGH */
2512 case 'm':
bbce6d69 2513 forbid_setid("-m"); /* XXX ? */
1a30305b 2514 if (*++s) {
a5f75d66 2515 char *start;
11343788 2516 SV *sv;
a5f75d66
AD		 2517 char *use = "use ";
2518 /* -M-foo == 'no foo' */
2519 if (*s == '-') { use = "no "; ++s; }
11343788 2520 sv = newSVpv(use,0);
a5f75d66 2521 start = s;
1a30305b 2522 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2523 while(isALNUM(*s) || *s==':') ++s;
2524 if (*s != '=') {
11343788 2525 sv_catpv(sv, start);
c07a80fd 2526 if (*(start-1) == 'm') {
2527 if (*s != '\0')
cea2e8a9 2528 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2529 sv_catpv( sv, " ()");
c07a80fd 2530 }
2531 } else {
6df41af2 2532 if (s == start)
be98fb35
GS		 2533 Perl_croak(aTHX_ "Module name required with -%c option",
2534 s[-1]);
11343788
MB		 2535 sv_catpvn(sv, start, s-start);
2536 sv_catpv(sv, " split(/,/,q{");
2537 sv_catpv(sv, ++s);
2538 sv_catpv(sv, "})");
c07a80fd 2539 }
1a30305b 2540 s += strlen(s);
5c831c24 2541 if (!PL_preambleav)
3280af22
NIS		 2542 PL_preambleav = newAV();
2543 av_push(PL_preambleav, sv);
1a30305b 2544 }
2545 else
cea2e8a9 2546 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2547 return s;
79072805 2548 case 'n':
3280af22 2549 PL_minus_n = TRUE;
79072805
LW		 2550 s++;
2551 return s;
2552 case 'p':
3280af22 2553 PL_minus_p = TRUE;
79072805
LW		 2554 s++;
2555 return s;
2556 case 's':
bbce6d69 2557 forbid_setid("-s");
3280af22 2558 PL_doswitches = TRUE;
79072805
LW		 2559 s++;
2560 return s;
6537fe72
MS		 2561 case 't':
2562 if (!PL_tainting)
22f7c9c9 2563 TOO_LATE_FOR('t');
6537fe72
MS		 2564 s++;
2565 return s;
463ee0b2 2566 case 'T':
3280af22 2567 if (!PL_tainting)
22f7c9c9 2568 TOO_LATE_FOR('T');
463ee0b2
LW		 2569 s++;
2570 return s;
79072805 2571 case 'u':
bf4acbe4
GS		 2572#ifdef MACOS_TRADITIONAL
2573 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2574#endif
3280af22 2575 PL_do_undump = TRUE;
79072805
LW		 2576 s++;
2577 return s;
2578 case 'U':
3280af22 2579 PL_unsafe = TRUE;
79072805
LW		 2580 s++;
2581 return s;
2582 case 'v':
8e9464f1 2583#if !defined(DGUX)
b0e47665 2584 PerlIO_printf(PerlIO_stdout(),
d2560b70 2585 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
b0e47665 2586 PL_patchlevel, ARCHNAME));
8e9464f1
JH		 2587#else /* DGUX */
2588/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2589 PerlIO_printf(PerlIO_stdout(),
2590 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2591 PerlIO_printf(PerlIO_stdout(),
2592 Perl_form(aTHX_ " built under %s at %s %s\n",
2593 OSNAME, __DATE__, __TIME__));
2594 PerlIO_printf(PerlIO_stdout(),
2595 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2596 OSVERS));
8e9464f1
JH		 2597#endif /* !DGUX */
2598
fb73857a 2599#if defined(LOCAL_PATCH_COUNT)
2600 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2601 PerlIO_printf(PerlIO_stdout(),
2602 "\n(with %d registered patch%s, "
2603 "see perl -V for more detail)",
2604 (int)LOCAL_PATCH_COUNT,
2605 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2606#endif
1a30305b 2607
b0e47665 2608 PerlIO_printf(PerlIO_stdout(),
4c79ee7a 2609 "\n\nCopyright 1987-2003, Larry Wall\n");
eae9c151
JH		 2610#ifdef MACOS_TRADITIONAL
2611 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2612 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2613 "maintained by Chris Nandor\n");
eae9c151 2614#endif
79072805 2615#ifdef MSDOS
b0e47665
GS		 2616 PerlIO_printf(PerlIO_stdout(),
2617 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2618#endif
2619#ifdef DJGPP
b0e47665
GS		 2620 PerlIO_printf(PerlIO_stdout(),
2621 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2622 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2623#endif
79072805 2624#ifdef OS2
b0e47665
GS		 2625 PerlIO_printf(PerlIO_stdout(),
2626 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2627 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2628#endif
79072805 2629#ifdef atarist
b0e47665
GS		 2630 PerlIO_printf(PerlIO_stdout(),
2631 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2632#endif
a3f9223b 2633#ifdef __BEOS__
b0e47665
GS		 2634 PerlIO_printf(PerlIO_stdout(),
2635 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2636#endif
1d84e8df 2637#ifdef MPE
b0e47665 2638 PerlIO_printf(PerlIO_stdout(),
e583a879 2639 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 2640#endif
9d116dd7 2641#ifdef OEMVS
b0e47665
GS		 2642 PerlIO_printf(PerlIO_stdout(),
2643 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2644#endif
495c5fdc 2645#ifdef __VOS__
b0e47665 2646 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2647 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2648#endif
092bebab 2649#ifdef __OPEN_VM
b0e47665
GS		 2650 PerlIO_printf(PerlIO_stdout(),
2651 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2652#endif
a1a0e61e 2653#ifdef POSIX_BC
b0e47665
GS		 2654 PerlIO_printf(PerlIO_stdout(),
2655 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2656#endif
61ae2fbf 2657#ifdef __MINT__
b0e47665
GS		 2658 PerlIO_printf(PerlIO_stdout(),
2659 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2660#endif
f83d2536 2661#ifdef EPOC
b0e47665 2662 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2663 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2664#endif
e1caacb4 2665#ifdef UNDER_CE
b475b3e6
JH		 2666 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2667 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2668 wce_hitreturn();
2669#endif
baed7233
DL		 2670#ifdef BINARY_BUILD_NOTICE
2671 BINARY_BUILD_NOTICE;
2672#endif
b0e47665
GS		 2673 PerlIO_printf(PerlIO_stdout(),
2674 "\n\
79072805 2675Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2676GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2677Complete documentation for Perl, including FAQ lists, should be found on\n\
2678this system using `man perl' or `perldoc perl'. If you have access to the\n\
2679Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
7ca617d0 2680 my_exit(0);
79072805 2681 case 'w':
599cee73 2682 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2683 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2684 s++;
2685 return s;
2686 case 'W':
ac27b0f5 2687 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2688 if (!specialWARN(PL_compiling.cop_warnings))
2689 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2690 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2691 s++;
2692 return s;
2693 case 'X':
ac27b0f5 2694 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2695 if (!specialWARN(PL_compiling.cop_warnings))
2696 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2697 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2698 s++;
2699 return s;
a0d0e21e 2700 case '*':
79072805
LW		 2701 case ' ':
2702 if (s[1] == '-') /* Additional switches on #! line. */
2703 return s+2;
2704 break;
a0d0e21e 2705 case '-':
79072805 2706 case 0:
51882d45 2707#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2708 case '\r':
2709#endif
79072805
LW		 2710 case '\n':
2711 case '\t':
2712 break;
aa689395 2713#ifdef ALTERNATE_SHEBANG
2714 case 'S': /* OS/2 needs -S on "extproc" line. */
2715 break;
2716#endif
a0d0e21e 2717 case 'P':
3280af22 2718 if (PL_preprocess)
a0d0e21e
LW		 2719 return s+1;
2720 /* FALL THROUGH */
79072805 2721 default:
cea2e8a9 2722 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2723 }
2724 return Nullch;
2725}
2726
2727/* compliments of Tom Christiansen */
2728
2729/* unexec() can be found in the Gnu emacs distribution */
ee580363 2730/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2731
2732void
864dbfa3 2733Perl_my_unexec(pTHX)
79072805
LW		 2734{
2735#ifdef UNEXEC
46fc3d4c 2736 SV* prog;
2737 SV* file;
ee580363 2738 int status = 1;
79072805
LW		 2739 extern int etext;
2740
ee580363 2741 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2742 sv_catpv(prog, "/perl");
6b88bc9c 2743 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2744 sv_catpv(file, ".perldump");
79072805 2745
ee580363
GS		 2746 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2747 /* unexec prints msg to stderr in case of failure */
6ad3d225 2748 PerlProc_exit(status);
79072805 2749#else
a5f75d66
AD		 2750# ifdef VMS
2751# include <lib$routines.h>
2752 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2753# else
79072805 2754 ABORT(); /* for use with undump */
aa689395 2755# endif
a5f75d66 2756#endif
79072805
LW		 2757}
2758
cb68f92d
GS		 2759/* initialize curinterp */
2760STATIC void
cea2e8a9 2761S_init_interp(pTHX)
cb68f92d
GS		 2762{
2763
acfe0abc
GS		 2764#ifdef MULTIPLICITY
2765# define PERLVAR(var,type)
2766# define PERLVARA(var,n,type)
2767# if defined(PERL_IMPLICIT_CONTEXT)
2768# if defined(USE_5005THREADS)
2769# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2770# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2771# else /* !USE_5005THREADS */
2772# define PERLVARI(var,type,init) aTHX->var = init;
2773# define PERLVARIC(var,type,init) aTHX->var = init;
2774# endif /* USE_5005THREADS */
3967c732 2775# else
acfe0abc
GS		 2776# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2777# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2778# endif
acfe0abc
GS		 2779# include "intrpvar.h"
2780# ifndef USE_5005THREADS
2781# include "thrdvar.h"
2782# endif
2783# undef PERLVAR
2784# undef PERLVARA
2785# undef PERLVARI
2786# undef PERLVARIC
2787#else
2788# define PERLVAR(var,type)
2789# define PERLVARA(var,n,type)
2790# define PERLVARI(var,type,init) PL_##var = init;
2791# define PERLVARIC(var,type,init) PL_##var = init;
2792# include "intrpvar.h"
2793# ifndef USE_5005THREADS
2794# include "thrdvar.h"
2795# endif
2796# undef PERLVAR
2797# undef PERLVARA
2798# undef PERLVARI
2799# undef PERLVARIC
cb68f92d
GS		 2800#endif
2801
cb68f92d
GS		 2802}
2803
76e3520e 2804STATIC void
cea2e8a9 2805S_init_main_stash(pTHX)
79072805 2806{
463ee0b2 2807 GV *gv;
6e72f9df 2808
3280af22 2809 PL_curstash = PL_defstash = newHV();
79cb57f6 2810 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2811 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2812 SvREFCNT_dec(GvHV(gv));
3280af22 2813 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2814 SvREADONLY_on(gv);
3280af22
NIS		 2815 HvNAME(PL_defstash) = savepv("main");
2816 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2817 GvMULTI_on(PL_incgv);
2818 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2819 GvMULTI_on(PL_hintgv);
2820 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2821 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2822 GvMULTI_on(PL_errgv);
2823 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2824 GvMULTI_on(PL_replgv);
cea2e8a9 2825 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2826 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2827 sv_setpvn(ERRSV, "", 0);
3280af22 2828 PL_curstash = PL_defstash;
11faa288 2829 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2830 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2831 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2832 /* We must init $/ before switches are processed. */
864dbfa3 2833 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2834}
2835
76e3520e 2836STATIC void
cea2e8a9 2837S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2838{
1b24ed4b
MS		 2839 char *quote;
2840 char *code;
2841 char *cpp_discard_flag;
2842 char *perl;
2843
6c4ab083 2844 *fdscript = -1;
79072805 2845
3280af22
NIS		 2846 if (PL_e_script) {
2847 PL_origfilename = savepv("-e");
96436eeb 2848 }
6c4ab083
GS		 2849 else {
2850 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2851 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2852
2853 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2854 char *s = scriptname + 8;
2855 *fdscript = atoi(s);
2856 while (isDIGIT(*s))
2857 s++;
2858 if (*s) {
2859 scriptname = savepv(s + 1);
3280af22
NIS		 2860 Safefree(PL_origfilename);
2861 PL_origfilename = scriptname;
6c4ab083
GS		 2862 }
2863 }
2864 }
2865
05ec9bb3 2866 CopFILE_free(PL_curcop);
57843af0 2867 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2868 if (strEQ(PL_origfilename,"-"))
79072805 2869 scriptname = "";
01f988be 2870 if (*fdscript >= 0) {
3280af22 2871 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2872# if defined(HAS_FCNTL) && defined(F_SETFD)
2873 if (PL_rsfp)
2874 /* ensure close-on-exec */
2875 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2876# endif
96436eeb 2877 }
3280af22 2878 else if (PL_preprocess) {
46fc3d4c 2879 char *cpp_cfg = CPPSTDIN;
79cb57f6 2880 SV *cpp = newSVpvn("",0);
46fc3d4c 2881 SV *cmd = NEWSV(0,0);
2882
ae58f265
JH		 2883 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
2884 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
46fc3d4c 2885 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2886 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2887 sv_catpv(cpp, cpp_cfg);
79072805 2888
1b24ed4b
MS		 2889# ifndef VMS
2890 sv_catpvn(sv, "-I", 2);
2891 sv_catpv(sv,PRIVLIB_EXP);
2892# endif
46fc3d4c 2893
14953ddc
MB		 2894 DEBUG_P(PerlIO_printf(Perl_debug_log,
2895 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2896 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 2897
2898# if defined(MSDOS) || defined(WIN32) || defined(VMS)
2899 quote = "\"";
2900# else
2901 quote = "'";
2902# endif
2903
2904# ifdef VMS
2905 cpp_discard_flag = "";
2906# else
2907 cpp_discard_flag = "-C";
2908# endif
2909
2910# ifdef OS2
2911 perl = os2_execname(aTHX);
2912# else
2913 perl = PL_origargv[0];
2914# endif
2915
2916
2917 /* This strips off Perl comments which might interfere with
62375a60
NIS		 2918 the C pre-processor, including #!. #line directives are
2919 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 2920 of #line. FWP played some golf with it so it will fit
2921 into VMS's 255 character buffer.
2922 */
2923 if( PL_doextract )
2924 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2925 else
2926 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2927
2928 Perl_sv_setpvf(aTHX_ cmd, "\
2929%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 2930 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 2931 cpp_discard_flag, sv, CPPMINUS);
2932
3280af22 2933 PL_doextract = FALSE;
1b24ed4b
MS		 2934# ifdef IAMSUID /* actually, this is caught earlier */
2935 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2936# ifdef HAS_SETEUID
2937 (void)seteuid(PL_uid); /* musn't stay setuid root */
2938# else
2939# ifdef HAS_SETREUID
2940 (void)setreuid((Uid_t)-1, PL_uid);
2941# else
2942# ifdef HAS_SETRESUID
2943 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2944# else
2945 PerlProc_setuid(PL_uid);
2946# endif
2947# endif
2948# endif
b28d0864 2949 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2950 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805 2951 }
1b24ed4b 2952# endif /* IAMSUID */
0a6c758d 2953
62375a60
NIS		 2954 DEBUG_P(PerlIO_printf(Perl_debug_log,
2955 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 2956 SvPVX(cmd)));
2957
3280af22 2958 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2959 SvREFCNT_dec(cmd);
2960 SvREFCNT_dec(cpp);
79072805
LW		 2961 }
2962 else if (!*scriptname) {
bbce6d69 2963 forbid_setid("program input from stdin");
3280af22 2964 PL_rsfp = PerlIO_stdin();
79072805 2965 }
96436eeb 2966 else {
3280af22 2967 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2968# if defined(HAS_FCNTL) && defined(F_SETFD)
2969 if (PL_rsfp)
2970 /* ensure close-on-exec */
2971 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2972# endif
96436eeb 2973 }
3280af22 2974 if (!PL_rsfp) {
1b24ed4b
MS		 2975# ifdef DOSUID
2976# ifndef IAMSUID /* in case script is not readable before setuid */
2977 if (PL_euid &&
2978 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2979 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2980 {
2981 /* try again */
b35112e7 2982 PERL_FPU_PRE_EXEC
62375a60
NIS		 2983 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2984 BIN_EXP, (int)PERL_REVISION,
1b24ed4b
MS		 2985 (int)PERL_VERSION,
2986 (int)PERL_SUBVERSION), PL_origargv);
b35112e7 2987 PERL_FPU_POST_EXEC
1b24ed4b
MS		 2988 Perl_croak(aTHX_ "Can't do setuid\n");
2989 }
2990# endif
2991# endif
2992# ifdef IAMSUID
2993 errno = EPERM;
2b8ca739 2994 Perl_croak(aTHX_ "Permission denied\n");
1b24ed4b
MS		 2995# else
2996 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2997 CopFILE(PL_curcop), Strerror(errno));
2998# endif
13281fa4 2999 }
79072805 3000}
8d063cd8 3001
7b89560d
JH		 3002/* Mention
3003 * I_SYSSTATVFS HAS_FSTATVFS
3004 * I_SYSMOUNT
c890dc6c 3005 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3006 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3007 * here so that metaconfig picks them up. */
3008
104d25b7 3009#ifdef IAMSUID
864dbfa3 3010STATIC int
e688b231 3011S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 3012{
0545a864
JH		 3013 int check_okay = 0; /* able to do all the required sys/libcalls */
3014 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 3015/*
ad27e871 3016 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 3017 * fstatvfs() is UNIX98.
0545a864 3018 * fstatfs() is 4.3 BSD.
ad27e871 3019 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 3020 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3021 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 3022 */
3023
6439433f
JH		 3024#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3025
3026# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3027 defined(HAS_FSTATVFS)
3028# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 3029 struct statvfs stfs;
6439433f 3030
104d25b7
JH		 3031 check_okay = fstatvfs(fd, &stfs) == 0;
3032 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
6439433f 3033# endif /* fstatvfs */
ac27b0f5 3034
6439433f
JH		 3035# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3036 defined(PERL_MOUNT_NOSUID) && \
3037 defined(HAS_FSTATFS) && \
3038 defined(HAS_STRUCT_STATFS) && \
3039 defined(HAS_STRUCT_STATFS_F_FLAGS)
3040# define FD_ON_NOSUID_CHECK_OKAY
e688b231 3041 struct statfs stfs;
6439433f 3042
104d25b7 3043 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 3044 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
6439433f
JH		 3045# endif /* fstatfs */
3046
3047# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3048 defined(PERL_MOUNT_NOSUID) && \
3049 defined(HAS_FSTAT) && \
3050 defined(HAS_USTAT) && \
3051 defined(HAS_GETMNT) && \
3052 defined(HAS_STRUCT_FS_DATA) && \
3053 defined(NOSTAT_ONE)
3054# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 3055 Stat_t fdst;
6439433f 3056
0545a864 3057 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 3058 struct ustat us;
3059 if (ustat(fdst.st_dev, &us) == 0) {
3060 struct fs_data fsd;
3061 /* NOSTAT_ONE here because we're not examining fields which
3062 * vary between that case and STAT_ONE. */
ad27e871 3063 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3064 size_t cmplen = sizeof(us.f_fname);
3065 if (sizeof(fsd.fd_req.path) < cmplen)
3066 cmplen = sizeof(fsd.fd_req.path);
3067 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3068 fdst.st_dev == fsd.fd_req.dev) {
3069 check_okay = 1;
3070 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3071 }
3072 }
3073 }
3074 }
0545a864 3075 }
6439433f
JH		 3076# endif /* fstat+ustat+getmnt */
3077
3078# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3079 defined(HAS_GETMNTENT) && \
3080 defined(HAS_HASMNTOPT) && \
3081 defined(MNTOPT_NOSUID)
3082# define FD_ON_NOSUID_CHECK_OKAY
3083 FILE *mtab = fopen("/etc/mtab", "r");
3084 struct mntent *entry;
c623ac67 3085 Stat_t stb, fsb;
104d25b7
JH		 3086
3087 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3088 while (entry = getmntent(mtab)) {
3089 if (stat(entry->mnt_dir, &fsb) == 0
3090 && fsb.st_dev == stb.st_dev)
3091 {
3092 /* found the filesystem */
3093 check_okay = 1;
3094 if (hasmntopt(entry, MNTOPT_NOSUID))
3095 on_nosuid = 1;
3096 break;
3097 } /* A single fs may well fail its stat(). */
3098 }
104d25b7
JH		 3099 }
3100 if (mtab)
6439433f
JH		 3101 fclose(mtab);
3102# endif /* getmntent+hasmntopt */
0545a864 3103
ac27b0f5 3104 if (!check_okay)
0545a864 3105 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 3106 return on_nosuid;
3107}
3108#endif /* IAMSUID */
3109
76e3520e 3110STATIC void
cea2e8a9 3111S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 3112{
155aba94 3113#ifdef IAMSUID
96436eeb 3114 int which;
155aba94 3115#endif
96436eeb 3116
13281fa4
LW		 3117 /* do we need to emulate setuid on scripts? */
3118
3119 /* This code is for those BSD systems that have setuid #! scripts disabled
3120 * in the kernel because of a security problem. Merely defining DOSUID
3121 * in perl will not fix that problem, but if you have disabled setuid
3122 * scripts in the kernel, this will attempt to emulate setuid and setgid
3123 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3124 * root version must be called suidperl or sperlN.NNN. If regular perl
3125 * discovers that it has opened a setuid script, it calls suidperl with
3126 * the same argv that it had. If suidperl finds that the script it has
3127 * just opened is NOT setuid root, it sets the effective uid back to the
3128 * uid. We don't just make perl setuid root because that loses the
3129 * effective uid we had before invoking perl, if it was different from the
3130 * uid.
13281fa4
LW		 3131 *
3132 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3133 * be defined in suidperl only. suidperl must be setuid root. The
3134 * Configure script will set this up for you if you want it.
3135 */
a687059c 3136
13281fa4 3137#ifdef DOSUID
6e72f9df 3138 char *s, *s2;
a0d0e21e 3139
b28d0864 3140 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3141 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 3142 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3143 I32 len;
2d8e6c8d 3144 STRLEN n_a;
13281fa4 3145
a687059c 3146#ifdef IAMSUID
fe14fcc3 3147#ifndef HAS_SETREUID
a687059c
LW		 3148 /* On this access check to make sure the directories are readable,
3149 * there is actually a small window that the user could use to make
3150 * filename point to an accessible directory. So there is a faint
3151 * chance that someone could execute a setuid script down in a
3152 * non-accessible directory. I don't know what to do about that.
3153 * But I don't think it's too important. The manual lies when
3154 * it says access() is useful in setuid programs.
3155 */
e57400b1
BD		 3156 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3157 errno = EPERM;
3158 Perl_croak(aTHX_ "Permission denied\n");
3159 }
a687059c
LW		 3160#else
3161 /* If we can swap euid and uid, then we can determine access rights
3162 * with a simple stat of the file, and then compare device and
3163 * inode to make sure we did stat() on the same file we opened.
3164 * Then we just have to make sure he or she can execute it.
3165 */
3166 {
c623ac67 3167 Stat_t tmpstatbuf;
a687059c 3168
85e6fe83
LW		 3169 if (
3170#ifdef HAS_SETREUID
b28d0864 3171 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 3172#else
3173# if HAS_SETRESUID
b28d0864 3174 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 3175# endif
85e6fe83 3176#endif
b28d0864 3177 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 3178 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
e57400b1
BD		 3179 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0) {
3180 errno = EPERM;
3181 Perl_croak(aTHX_ "Permission denied\n"); /* testing full pathname here */
3182 }
2bb3463c 3183#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e57400b1
BD		 3184 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3185 errno = EPERM;
3186 Perl_croak(aTHX_ "Permission denied\n");
3187 }
104d25b7 3188#endif
b28d0864
NIS		 3189 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3190 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3191 (void)PerlIO_close(PL_rsfp);
e57400b1 3192 errno = EPERM;
cea2e8a9 3193 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3194 }
85e6fe83
LW		 3195 if (
3196#ifdef HAS_SETREUID
b28d0864 3197 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 3198#else
3199# if defined(HAS_SETRESUID)
b28d0864 3200 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 3201# endif
85e6fe83 3202#endif
b28d0864 3203 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 3204 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 3205 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 3206 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3207 }
fe14fcc3 3208#endif /* HAS_SETREUID */
a687059c
LW		 3209#endif /* IAMSUID */
3210
e57400b1
BD		 3211 if (!S_ISREG(PL_statbuf.st_mode)) {
3212 errno = EPERM;
3213 Perl_croak(aTHX_ "Permission denied\n");
3214 }
b28d0864 3215 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3216 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3217 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 3218 CopLINE_inc(PL_curcop);
6b88bc9c 3219 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3220 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3221 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3222 s = SvPV(PL_linestr,n_a)+2;
663a0e37 3223 if (*s == ' ') s++;
45d8adaa 3224 while (!isSPACE(*s)) s++;
2d8e6c8d 3225 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3226 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3227 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 3228 Perl_croak(aTHX_ "Not a perl script");
a687059c 3229 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3230 /*
3231 * #! arg must be what we saw above. They can invoke it by
3232 * mentioning suidperl explicitly, but they may not add any strange
3233 * arguments beyond what #! says if they do invoke suidperl that way.
3234 */
3235 len = strlen(validarg);
3236 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 3237 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 3238 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3239
3240#ifndef IAMSUID
b28d0864
NIS		 3241 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3242 PL_euid == PL_statbuf.st_uid)
3243 if (!PL_do_undump)
cea2e8a9 3244 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3245FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3246#endif /* IAMSUID */
13281fa4 3247
b28d0864
NIS		 3248 if (PL_euid) { /* oops, we're not the setuid root perl */
3249 (void)PerlIO_close(PL_rsfp);
13281fa4 3250#ifndef IAMSUID
46fc3d4c 3251 /* try again */
b35112e7 3252 PERL_FPU_PRE_EXEC
a7cb1f99 3253 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3254 (int)PERL_REVISION, (int)PERL_VERSION,
3255 (int)PERL_SUBVERSION), PL_origargv);
b35112e7 3256 PERL_FPU_POST_EXEC
13281fa4 3257#endif
cea2e8a9 3258 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 3259 }
3260
b28d0864 3261 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 3262#ifdef HAS_SETEGID
b28d0864 3263 (void)setegid(PL_statbuf.st_gid);
a687059c 3264#else
fe14fcc3 3265#ifdef HAS_SETREGID
b28d0864 3266 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3267#else
3268#ifdef HAS_SETRESGID
b28d0864 3269 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3270#else
b28d0864 3271 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3272#endif
3273#endif
85e6fe83 3274#endif
b28d0864 3275 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3276 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3277 }
b28d0864
NIS		 3278 if (PL_statbuf.st_mode & S_ISUID) {
3279 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3280#ifdef HAS_SETEUID
b28d0864 3281 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3282#else
fe14fcc3 3283#ifdef HAS_SETREUID
b28d0864 3284 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3285#else
3286#ifdef HAS_SETRESUID
b28d0864 3287 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3288#else
b28d0864 3289 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3290#endif
3291#endif
85e6fe83 3292#endif
b28d0864 3293 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3294 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3295 }
b28d0864 3296 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3297#ifdef HAS_SETEUID
b28d0864 3298 (void)seteuid((Uid_t)PL_uid);
a687059c 3299#else
fe14fcc3 3300#ifdef HAS_SETREUID
b28d0864 3301 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3302#else
85e6fe83 3303#ifdef HAS_SETRESUID
b28d0864 3304 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3305#else
b28d0864 3306 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3307#endif
a687059c
LW		 3308#endif
3309#endif
b28d0864 3310 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3311 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3312 }
748a9306 3313 init_ids();
b28d0864 3314 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 3315 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 3316 }
3317#ifdef IAMSUID
6b88bc9c 3318 else if (PL_preprocess)
cea2e8a9 3319 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 3320 else if (fdscript >= 0)
cea2e8a9 3321 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
e57400b1
BD		 3322 else {
3323 errno = EPERM;
2b8ca739 3324 Perl_croak(aTHX_ "Permission denied\n");
e57400b1 3325 }
96436eeb 3326
3327 /* We absolutely must clear out any saved ids here, so we */
3328 /* exec the real perl, substituting fd script for scriptname. */
3329 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 3330 PerlIO_rewind(PL_rsfp);
3331 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c 3332 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
e57400b1
BD		 3333 if (!PL_origargv[which]) {
3334 errno = EPERM;
3335 Perl_croak(aTHX_ "Permission denied\n");
3336 }
cea2e8a9 3337 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 3338 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 3339#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3340 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3341#endif
b35112e7 3342 PERL_FPU_PRE_EXEC
a7cb1f99 3343 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3344 (int)PERL_REVISION, (int)PERL_VERSION,
3345 (int)PERL_SUBVERSION), PL_origargv);/* try again */
b35112e7 3346 PERL_FPU_POST_EXEC
cea2e8a9 3347 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 3348#endif /* IAMSUID */
a687059c 3349#else /* !DOSUID */
3280af22 3350 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3351#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3352 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3353 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3354 ||
b28d0864 3355 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3356 )
b28d0864 3357 if (!PL_do_undump)
cea2e8a9 3358 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3359FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3360#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3361 /* not set-id, must be wrapped */
a687059c 3362 }
13281fa4 3363#endif /* DOSUID */
79072805 3364}
13281fa4 3365
76e3520e 3366STATIC void
cea2e8a9 3367S_find_beginning(pTHX)
79072805 3368{
6e72f9df 3369 register char *s, *s2;
e55ac0fa
HS		 3370#ifdef MACOS_TRADITIONAL
3371 int maclines = 0;
3372#endif
33b78306
LW		 3373
3374 /* skip forward in input to the real script? */
3375
bbce6d69 3376 forbid_setid("-x");
bf4acbe4 3377#ifdef MACOS_TRADITIONAL
084592ab 3378 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3379
bf4acbe4
GS		 3380 while (PL_doextract || gMacPerl_AlwaysExtract) {
3381 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3382 if (!gMacPerl_AlwaysExtract)
3383 Perl_croak(aTHX_ "No Perl script found in input\n");
e55ac0fa 3384
bf4acbe4
GS		 3385 if (PL_doextract) /* require explicit override ? */
3386 if (!OverrideExtract(PL_origfilename))
3387 Perl_croak(aTHX_ "User aborted script\n");
3388 else
3389 PL_doextract = FALSE;
e55ac0fa 3390
bf4acbe4
GS		 3391 /* Pater peccavi, file does not have #! */
3392 PerlIO_rewind(PL_rsfp);
e55ac0fa 3393
bf4acbe4
GS		 3394 break;
3395 }
3396#else
3280af22
NIS		 3397 while (PL_doextract) {
3398 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3399 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3400#endif
4f0c37ba
IZ		 3401 s2 = s;
3402 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3403 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3404 PL_doextract = FALSE;
6e72f9df 3405 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3406 s2 = s;
3407 while (*s == ' ' || *s == '\t') s++;
3408 if (*s++ == '-') {
3409 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3410 if (strnEQ(s2-4,"perl",4))
3411 /*SUPPRESS 530*/
155aba94
GS		 3412 while ((s = moreswitches(s)))
3413 ;
33b78306 3414 }
95e8664e 3415#ifdef MACOS_TRADITIONAL
e55ac0fa
HS		 3416 /* We are always searching for the #!perl line in MacPerl,
3417 * so if we find it, still keep the line count correct
3418 * by counting lines we already skipped over
3419 */
3420 for (; maclines > 0 ; maclines--)
3421 PerlIO_ungetc(PL_rsfp, '\n');
3422
95e8664e 3423 break;
e55ac0fa
HS		 3424
3425 /* gMacPerl_AlwaysExtract is false in MPW tool */
3426 } else if (gMacPerl_AlwaysExtract) {
3427 ++maclines;
95e8664e 3428#endif
83025b21
LW		 3429 }
3430 }
3431}
3432
afe37c7d 3433
76e3520e 3434STATIC void
cea2e8a9 3435S_init_ids(pTHX)
352d5a3a 3436{
d8eceb89
JH		 3437 PL_uid = PerlProc_getuid();
3438 PL_euid = PerlProc_geteuid();
3439 PL_gid = PerlProc_getgid();
3440 PL_egid = PerlProc_getegid();
748a9306 3441#ifdef VMS
b28d0864
NIS		 3442 PL_uid |= PL_gid << 16;
3443 PL_euid |= PL_egid << 16;
748a9306 3444#endif
22f7c9c9
JH		 3445 /* Should not happen: */
3446 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3280af22 3447 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 3448}
79072805 3449
a0643315
JH		 3450/* This is used very early in the lifetime of the program,
3451 * before even the options are parsed, so PL_tainting has
b0891165 3452 * not been initialized properly. */
af419de7 3453bool
22f7c9c9
JH		 3454Perl_doing_taint(int argc, char *argv[], char *envp[])
3455{
c3446a78
JH		 3456#ifndef PERL_IMPLICIT_SYS
3457 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3458 * before we have an interpreter-- and the whole point of this
3459 * function is to be called at such an early stage. If you are on
3460 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3461 * "tainted because running with altered effective ids', you'll
3462 * have to add your own checks somewhere in here. The two most
3463 * known samples of 'implicitness' are Win32 and NetWare, neither
3464 * of which has much of concept of 'uids'. */
af419de7 3465 int uid = PerlProc_getuid();
22f7c9c9 3466 int euid = PerlProc_geteuid();
af419de7 3467 int gid = PerlProc_getgid();
22f7c9c9
JH		 3468 int egid = PerlProc_getegid();
3469
3470#ifdef VMS
af419de7 3471 uid |= gid << 16;
22f7c9c9
JH		 3472 euid |= egid << 16;
3473#endif
3474 if (uid && (euid != uid || egid != gid))
3475 return 1;
c3446a78 3476#endif /* !PERL_IMPLICIT_SYS */
af419de7
JH		 3477 /* This is a really primitive check; environment gets ignored only
3478 * if -T are the first chars together; otherwise one gets
3479 * "Too late" message. */
22f7c9c9
JH		 3480 if ( argc > 1 && argv[1][0] == '-'
3481 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3482 return 1;
3483 return 0;
3484}
22f7c9c9 3485
76e3520e 3486STATIC void
cea2e8a9 3487S_forbid_setid(pTHX_ char *s)
bbce6d69 3488{
3280af22 3489 if (PL_euid != PL_uid)
cea2e8a9 3490 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 3491 if (PL_egid != PL_gid)
cea2e8a9 3492 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69 3493}
3494
1ee4443e
IZ		 3495void
3496Perl_init_debugger(pTHX)
748a9306 3497{
1ee4443e
IZ		 3498 HV *ostash = PL_curstash;
3499
3280af22 3500 PL_curstash = PL_debstash;
7619c85e 3501 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
3280af22 3502 AvREAL_off(PL_dbargs);
7619c85e
RG		 3503 PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
3504 PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3505 PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 3506 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
7619c85e 3507 PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3508 sv_setiv(PL_DBsingle, 0);
7619c85e 3509 PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3510 sv_setiv(PL_DBtrace, 0);
7619c85e 3511 PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3512 sv_setiv(PL_DBsignal, 0);
06492da6
SF		 3513 PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
3514 sv_setiv(PL_DBassertion, 0);
1ee4443e 3515 PL_curstash = ostash;
352d5a3a
LW		 3516}
3517
2ce36478
SM		 3518#ifndef STRESS_REALLOC
3519#define REASONABLE(size) (size)
3520#else
3521#define REASONABLE(size) (1) /* unreasonable */
3522#endif
3523
11343788 3524void
cea2e8a9 3525Perl_init_stacks(pTHX)
79072805 3526{
e336de0d 3527 /* start with 128-item stack and 8K cxstack */
3280af22 3528 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 3529 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 3530 PL_curstackinfo->si_type = PERLSI_MAIN;
3531 PL_curstack = PL_curstackinfo->si_stack;
3532 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 3533
3280af22
NIS		 3534 PL_stack_base = AvARRAY(PL_curstack);
3535 PL_stack_sp = PL_stack_base;
3536 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 3537
3280af22
NIS		 3538 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3539 PL_tmps_floor = -1;
3540 PL_tmps_ix = -1;
3541 PL_tmps_max = REASONABLE(128);
8990e307 3542
3280af22
NIS		 3543 New(54,PL_markstack,REASONABLE(32),I32);
3544 PL_markstack_ptr = PL_markstack;
3545 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 3546
ce2f7c3b 3547 SET_MARK_OFFSET;
e336de0d 3548
3280af22
NIS		 3549 New(54,PL_scopestack,REASONABLE(32),I32);
3550 PL_scopestack_ix = 0;
3551 PL_scopestack_max = REASONABLE(32);
79072805 3552
3280af22
NIS		 3553 New(54,PL_savestack,REASONABLE(128),ANY);
3554 PL_savestack_ix = 0;
3555 PL_savestack_max = REASONABLE(128);
79072805 3556
3280af22
NIS		 3557 New(54,PL_retstack,REASONABLE(16),OP*);
3558 PL_retstack_ix = 0;
3559 PL_retstack_max = REASONABLE(16);
378cc40b 3560}
33b78306 3561
2ce36478
SM		 3562#undef REASONABLE
3563
76e3520e 3564STATIC void
cea2e8a9 3565S_nuke_stacks(pTHX)
6e72f9df 3566{
3280af22
NIS		 3567 while (PL_curstackinfo->si_next)
3568 PL_curstackinfo = PL_curstackinfo->si_next;
3569 while (PL_curstackinfo) {
3570 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 3571 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 3572 Safefree(PL_curstackinfo->si_cxstack);
3573 Safefree(PL_curstackinfo);
3574 PL_curstackinfo = p;
e336de0d 3575 }
3280af22
NIS		 3576 Safefree(PL_tmps_stack);
3577 Safefree(PL_markstack);
3578 Safefree(PL_scopestack);
3579 Safefree(PL_savestack);
3580 Safefree(PL_retstack);
378cc40b 3581}
33b78306 3582
76e3520e 3583STATIC void
cea2e8a9 3584S_init_lexer(pTHX)
8990e307 3585{
06039172 3586 PerlIO *tmpfp;
3280af22
NIS		 3587 tmpfp = PL_rsfp;
3588 PL_rsfp = Nullfp;
3589 lex_start(PL_linestr);
3590 PL_rsfp = tmpfp;
79cb57f6 3591 PL_subname = newSVpvn("main",4);
8990e307
LW		 3592}
3593
76e3520e 3594STATIC void
cea2e8a9 3595S_init_predump_symbols(pTHX)
45d8adaa 3596{
93a17b20 3597 GV *tmpgv;
af8c498a 3598 IO *io;
79072805 3599
864dbfa3 3600 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 3601 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3602 GvMULTI_on(PL_stdingv);
af8c498a 3603 io = GvIOp(PL_stdingv);
a04651f4 3604 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 3605 IoIFP(io) = PerlIO_stdin();
adbc6bb1 3606 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 3607 GvMULTI_on(tmpgv);
af8c498a 3608 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3609
85e6fe83 3610 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 3611 GvMULTI_on(tmpgv);
af8c498a 3612 io = GvIOp(tmpgv);
a04651f4 3613 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3614 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 3615 setdefout(tmpgv);
adbc6bb1 3616 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 3617 GvMULTI_on(tmpgv);
af8c498a 3618 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3619
bf49b057
GS		 3620 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3621 GvMULTI_on(PL_stderrgv);
3622 io = GvIOp(PL_stderrgv);
a04651f4 3623 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3624 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 3625 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 3626 GvMULTI_on(tmpgv);
af8c498a 3627 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3628
3280af22 3629 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 3630
bf4acbe4
GS		 3631 if (PL_osname)
3632 Safefree(PL_osname);
3633 PL_osname = savepv(OSNAME);
79072805 3634}
33b78306 3635
a11ec5a9
RGS		 3636void
3637Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
33b78306 3638{
79072805 3639 char *s;
79072805 3640 argc--,argv++; /* skip name of script */
3280af22 3641 if (PL_doswitches) {
79072805
LW		 3642 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3643 if (!argv[0][1])
3644 break;
379d538a 3645 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 3646 argc--,argv++;
3647 break;
3648 }
155aba94 3649 if ((s = strchr(argv[0], '='))) {
79072805 3650 *s++ = '\0';
85e6fe83 3651 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 3652 }
3653 else
85e6fe83 3654 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 3655 }
79072805 3656 }
a11ec5a9
RGS		 3657 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3658 GvMULTI_on(PL_argvgv);
3659 (void)gv_AVadd(PL_argvgv);
3660 av_clear(GvAVn(PL_argvgv));
3661 for (; argc > 0; argc--,argv++) {
3662 SV *sv = newSVpv(argv[0],0);
3663 av_push(GvAVn(PL_argvgv),sv);
ce81ff12
JH		 3664 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
3665 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
3666 SvUTF8_on(sv);
3667 }
a05d7ebb
JH		 3668 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
3669 (void)sv_utf8_decode(sv);
a11ec5a9
RGS		 3670 }
3671 }
3672}
3673
04fee9b5
NIS		 3674#ifdef HAS_PROCSELFEXE
3675/* This is a function so that we don't hold on to MAXPATHLEN
8338e367 3676 bytes of stack longer than necessary
04fee9b5
NIS		 3677 */
3678STATIC void
3679S_procself_val(pTHX_ SV *sv, char *arg0)
3680{
3681 char buf[MAXPATHLEN];
d13a6521 3682 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
75745e22
TJ		 3683
3684 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3685 includes a spurious NUL which will cause $^X to fail in system
3686 or backticks (this will prevent extensions from being built and
3687 many tests from working). readlink is not meant to add a NUL.
3688 Normal readlink works fine.
3689 */
3690 if (len > 0 && buf[len-1] == '\0') {
3691 len--;
3692 }
3693
d103ec31
JH		 3694 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3695 returning the text "unknown" from the readlink rather than the path
78cb7c00 3696 to the executable (or returning an error from the readlink). Any valid
d103ec31
JH		 3697 path has a '/' in it somewhere, so use that to validate the result.
3698 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3699 */
78cb7c00 3700 if (len > 0 && memchr(buf, '/', len)) {
04fee9b5
NIS		 3701 sv_setpvn(sv,buf,len);
3702 }
3703 else {
3704 sv_setpv(sv,arg0);
3705 }
3706}
3707#endif /* HAS_PROCSELFEXE */
3708
a11ec5a9
RGS		 3709STATIC void
3710S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3711{
3712 char *s;
3713 SV *sv;
3714 GV* tmpgv;
a11ec5a9 3715
3280af22
NIS		 3716 PL_toptarget = NEWSV(0,0);
3717 sv_upgrade(PL_toptarget, SVt_PVFM);
3718 sv_setpvn(PL_toptarget, "", 0);
3719 PL_bodytarget = NEWSV(0,0);
3720 sv_upgrade(PL_bodytarget, SVt_PVFM);
3721 sv_setpvn(PL_bodytarget, "", 0);
3722 PL_formtarget = PL_bodytarget;
79072805 3723
bbce6d69 3724 TAINT;
a11ec5a9
RGS		 3725
3726 init_argv_symbols(argc,argv);
3727
155aba94 3728 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
bf4acbe4
GS		 3729#ifdef MACOS_TRADITIONAL
3730 /* $0 is not majick on a Mac */
3731 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3732#else
3280af22 3733 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 3734 magicname("0", "0", 1);
bf4acbe4 3735#endif
79072805 3736 }
04fee9b5
NIS		 3737 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3738#ifdef HAS_PROCSELFEXE
3739 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3740#else
8338e367 3741#ifdef OS2
23da6c43 3742 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
8338e367
JH		 3743#else
3744 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3745#endif
04fee9b5
NIS		 3746#endif
3747 }
155aba94 3748 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
79072805 3749 HV *hv;
3280af22
NIS		 3750 GvMULTI_on(PL_envgv);
3751 hv = GvHVn(PL_envgv);
14befaf4 3752 hv_magic(hv, Nullgv, PERL_MAGIC_env);
2f42fcb0 3753#ifndef PERL_MICRO
fa6a1c44 3754#ifdef USE_ENVIRON_ARRAY
4633a7c4
LW		 3755 /* Note that if the supplied env parameter is actually a copy
3756 of the global environ then it may now point to free'd memory
3757 if the environment has been modified since. To avoid this
3758 problem we treat env==NULL as meaning 'use the default'
3759 */
3760 if (!env)
3761 env = environ;
4efc5df6
GS		 3762 if (env != environ
3763# ifdef USE_ITHREADS
3764 && PL_curinterp == aTHX
3765# endif
3766 )
3767 {
79072805 3768 environ[0] = Nullch;
4efc5df6 3769 }
764df951
IZ		 3770 if (env)
3771 for (; *env; env++) {
93a17b20 3772 if (!(s = strchr(*env,'=')))
79072805 3773 continue;
7da0e383 3774#if defined(MSDOS) && !defined(DJGPP)
61968511 3775 *s = '\0';
137443ea 3776 (void)strupr(*env);
61968511 3777 *s = '=';
137443ea 3778#endif
61968511 3779 sv = newSVpv(s+1, 0);
79072805 3780 (void)hv_store(hv, *env, s - *env, sv, 0);
61968511
GA		 3781 if (env != environ)
3782 mg_set(sv);
764df951 3783 }
103a7189 3784#endif /* USE_ENVIRON_ARRAY */
2f42fcb0 3785#endif /* !PERL_MICRO */
79072805 3786 }
bbce6d69 3787 TAINT_NOT;
306196c3
MS		 3788 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3789 SvREADONLY_off(GvSV(tmpgv));
7766f137 3790 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
306196c3
MS		 3791 SvREADONLY_on(GvSV(tmpgv));
3792 }
4d76a344
RGS		 3793#ifdef THREADS_HAVE_PIDS
3794 PL_ppid = (IV)getppid();
3795#endif
2710853f
MJD		 3796
3797 /* touch @F array to prevent spurious warnings 20020415 MJD */
3798 if (PL_minus_a) {
3799 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3800 }
3801 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3802 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3803 (void) get_av("main::+", TRUE | GV_ADDMULTI);
33b78306 3804}
34de22dd 3805
76e3520e 3806STATIC void
cea2e8a9 3807S_init_perllib(pTHX)
34de22dd 3808{
85e6fe83 3809 char *s;
3280af22 3810 if (!PL_tainting) {
552a7a9b 3811#ifndef VMS
76e3520e 3812 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 3813 if (s)
574c798a 3814 incpush(s, TRUE, TRUE, TRUE);
85e6fe83 3815 else
574c798a 3816 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
552a7a9b 3817#else /* VMS */
3818 /* Treat PERL5?LIB as a possible search list logical name -- the
3819 * "natural" VMS idiom for a Unix path string. We allow each
3820 * element to be a set of |-separated directories for compatibility.
3821 */
3822 char buf[256];
3823 int idx = 0;
3824 if (my_trnlnm("PERL5LIB",buf,0))
574c798a 3825 do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 3826 else
574c798a 3827 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
552a7a9b 3828#endif /* VMS */
85e6fe83 3829 }
34de22dd 3830
c90c0ff4 3831/* Use the ~-expanded versions of APPLLIB (undocumented),
65f19062 3832 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
df5cef82 3833*/
4633a7c4 3834#ifdef APPLLIB_EXP
574c798a 3835 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
16d20bd9 3836#endif
4633a7c4 3837
fed7345c 3838#ifdef ARCHLIB_EXP
574c798a 3839 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
a0d0e21e 3840#endif
bf4acbe4
GS		 3841#ifdef MACOS_TRADITIONAL
3842 {
c623ac67 3843 Stat_t tmpstatbuf;
bf4acbe4
GS		 3844 SV * privdir = NEWSV(55, 0);
3845 char * macperl = PerlEnv_getenv("MACPERL");
3846
3847 if (!macperl)
3848 macperl = "";
3849
3850 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3851 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
574c798a 3852 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
bf4acbe4
GS		 3853 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3854 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
574c798a 3855 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
ac27b0f5 3856
bf4acbe4
GS		 3857 SvREFCNT_dec(privdir);
3858 }
3859 if (!PL_tainting)
574c798a 3860 incpush(":", FALSE, FALSE, TRUE);
bf4acbe4 3861#else
fed7345c 3862#ifndef PRIVLIB_EXP
65f19062 3863# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 3864#endif
ac27b0f5 3865#if defined(WIN32)
574c798a 3866 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
00dc2f4f 3867#else
574c798a 3868 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
00dc2f4f 3869#endif
4633a7c4 3870
65f19062 3871#ifdef SITEARCH_EXP
3b290362
GS		 3872 /* sitearch is always relative to sitelib on Windows for
3873 * DLL-based path intuition to work correctly */
3874# if !defined(WIN32)
574c798a 3875 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
65f19062
GS		 3876# endif
3877#endif
3878
4633a7c4 3879#ifdef SITELIB_EXP
65f19062 3880# if defined(WIN32)
574c798a
SR		 3881 /* this picks up sitearch as well */
3882 incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
65f19062 3883# else
574c798a 3884 incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
65f19062
GS		 3885# endif
3886#endif
189d1e8d 3887
65f19062 3888#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
574c798a 3889 incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
81c6dfba 3890#endif
65f19062
GS		 3891
3892#ifdef PERL_VENDORARCH_EXP
4ea817c6 3893 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS		 3894 * DLL-based path intuition to work correctly */
3895# if !defined(WIN32)
574c798a 3896 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
65f19062 3897# endif
4b03c463 3898#endif
65f19062
GS		 3899
3900#ifdef PERL_VENDORLIB_EXP
3901# if defined(WIN32)
574c798a 3902 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
65f19062 3903# else
574c798a 3904 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
65f19062 3905# endif
a3635516 3906#endif
65f19062
GS		 3907
3908#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
574c798a 3909 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
00dc2f4f 3910#endif
65f19062 3911
3b777bb4 3912#ifdef PERL_OTHERLIBDIRS
574c798a 3913 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
3b777bb4
GS		 3914#endif
3915
3280af22 3916 if (!PL_tainting)
574c798a 3917 incpush(".", FALSE, FALSE, TRUE);
bf4acbe4 3918#endif /* MACOS_TRADITIONAL */
774d564b 3919}
3920
ed79a026 3921#if defined(DOSISH) || defined(EPOC)
774d564b 3922# define PERLLIB_SEP ';'
3923#else
3924# if defined(VMS)
3925# define PERLLIB_SEP '|'
3926# else
bf4acbe4
GS		 3927# if defined(MACOS_TRADITIONAL)
3928# define PERLLIB_SEP ','
3929# else
3930# define PERLLIB_SEP ':'
3931# endif
774d564b 3932# endif
3933#endif
3934#ifndef PERLLIB_MANGLE
3935# define PERLLIB_MANGLE(s,n) (s)
ac27b0f5 3936#endif
774d564b 3937
76e3520e 3938STATIC void
574c798a 3939S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
774d564b 3940{
3941 SV *subdir = Nullsv;
774d564b 3942
3b290362 3943 if (!p || !*p)
774d564b 3944 return;
3945
9c8a64f0 3946 if (addsubdirs || addoldvers) {
00db4c45 3947 subdir = sv_newmortal();
774d564b 3948 }
3949
3950 /* Break at all separators */
3951 while (p && *p) {
8c52afec 3952 SV *libdir = NEWSV(55,0);
774d564b 3953 char *s;
3954
3955 /* skip any consecutive separators */
574c798a
SR		 3956 if (usesep) {
3957 while ( *p == PERLLIB_SEP ) {
3958 /* Uncomment the next line for PATH semantics */
3959 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3960 p++;
3961 }
774d564b 3962 }
3963
574c798a 3964 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
774d564b 3965 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3966 (STRLEN)(s - p));
3967 p = s + 1;
3968 }
3969 else {
3970 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3971 p = Nullch; /* break out */
3972 }
bf4acbe4 3973#ifdef MACOS_TRADITIONAL
e69a2255
JH		 3974 if (!strchr(SvPVX(libdir), ':')) {
3975 char buf[256];
3976
3977 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3978 }
bf4acbe4
GS		 3979 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3980 sv_catpv(libdir, ":");
3981#endif
774d564b 3982
3983 /*
3984 * BEFORE pushing libdir onto @INC we may first push version- and
3985 * archname-specific sub-directories.
3986 */
9c8a64f0 3987 if (addsubdirs || addoldvers) {
29d82f8d 3988#ifdef PERL_INC_VERSION_LIST
8353b874
GS		 3989 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3990 const char *incverlist[] = { PERL_INC_VERSION_LIST };
29d82f8d
GS		 3991 const char **incver;
3992#endif
c623ac67 3993 Stat_t tmpstatbuf;
aa689395 3994#ifdef VMS
3995 char *unix;
3996 STRLEN len;
774d564b 3997
2d8e6c8d 3998 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 3999 len = strlen(unix);
4000 while (unix[len-1] == '/') len--; /* Cosmetic */
4001 sv_usepvn(libdir,unix,len);
4002 }
4003 else
bf49b057 4004 PerlIO_printf(Perl_error_log,
aa689395 4005 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 4006 SvPV(libdir,len));
aa689395 4007#endif
9c8a64f0 4008 if (addsubdirs) {
bf4acbe4
GS		 4009#ifdef MACOS_TRADITIONAL
4010#define PERL_AV_SUFFIX_FMT ""
084592ab
CN		 4011#define PERL_ARCH_FMT "%s:"
4012#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
bf4acbe4
GS		 4013#else
4014#define PERL_AV_SUFFIX_FMT "/"
4015#define PERL_ARCH_FMT "/%s"
084592ab 4016#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
bf4acbe4 4017#endif
9c8a64f0 4018 /* .../version/archname if -d .../version/archname */
084592ab 4019 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
9c8a64f0
GS		 4020 libdir,
4021 (int)PERL_REVISION, (int)PERL_VERSION,
4022 (int)PERL_SUBVERSION, ARCHNAME);
4023 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4024 S_ISDIR(tmpstatbuf.st_mode))
4025 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4b03c463 4026
9c8a64f0 4027 /* .../version if -d .../version */
084592ab 4028 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
9c8a64f0
GS		 4029 (int)PERL_REVISION, (int)PERL_VERSION,
4030 (int)PERL_SUBVERSION);
4031 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4032 S_ISDIR(tmpstatbuf.st_mode))
4033 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4034
4035 /* .../archname if -d .../archname */
bf4acbe4 4036 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
29d82f8d
GS		 4037 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4038 S_ISDIR(tmpstatbuf.st_mode))
4039 av_push(GvAVn(PL_incgv), newSVsv(subdir));
29d82f8d 4040 }
9c8a64f0 4041
9c8a64f0 4042#ifdef PERL_INC_VERSION_LIST
ccc2aad8 4043 if (addoldvers) {
9c8a64f0
GS		 4044 for (incver = incverlist; *incver; incver++) {
4045 /* .../xxx if -d .../xxx */
bf4acbe4 4046 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
9c8a64f0
GS		 4047 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4048 S_ISDIR(tmpstatbuf.st_mode))
4049 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4050 }
4051 }
29d82f8d 4052#endif
774d564b 4053 }
4054
4055 /* finally push this lib directory on the end of @INC */
3280af22 4056 av_push(GvAVn(PL_incgv), libdir);
774d564b 4057 }
34de22dd 4058}
93a17b20 4059
4d1ff10f 4060#ifdef USE_5005THREADS
76e3520e 4061STATIC struct perl_thread *
cea2e8a9 4062S_init_main_thread(pTHX)
199100c8 4063{
c5be433b 4064#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 4065 struct perl_thread *thr;
cea2e8a9 4066#endif
199100c8
MB		 4067 XPV *xpv;
4068
52e1cb5e 4069 Newz(53, thr, 1, struct perl_thread);
533c011a 4070 PL_curcop = &PL_compiling;
c5be433b 4071 thr->interp = PERL_GET_INTERP;
199100c8 4072 thr->cvcache = newHV();
54b9620d 4073 thr->threadsv = newAV();
940cb80d 4074 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 4075 thr->specific = newAV();
4076 thr->flags = THRf_R_JOINABLE;
4077 MUTEX_INIT(&thr->mutex);
4078 /* Handcraft thrsv similarly to mess_sv */
533c011a 4079 New(53, PL_thrsv, 1, SV);
199100c8 4080 Newz(53, xpv, 1, XPV);
533c011a
NIS		 4081 SvFLAGS(PL_thrsv) = SVt_PV;
4082 SvANY(PL_thrsv) = (void*)xpv;
4083 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
4084 SvPVX(PL_thrsv) = (char*)thr;
4085 SvCUR_set(PL_thrsv, sizeof(thr));
4086 SvLEN_set(PL_thrsv, sizeof(thr));
4087 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
4088 thr->oursv = PL_thrsv;
4089 PL_chopset = " \n-";
3967c732 4090 PL_dumpindent = 4;
533c011a
NIS		 4091
4092 MUTEX_LOCK(&PL_threads_mutex);
4093 PL_nthreads++;
199100c8
MB		 4094 thr->tid = 0;
4095 thr->next = thr;
4096 thr->prev = thr;
8dcd6f7b 4097 thr->thr_done = 0;
533c011a 4098 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 4099
4b026b9e 4100#ifdef HAVE_THREAD_INTERN
4f63d024 4101 Perl_init_thread_intern(thr);
235db74f
GS		 4102#endif
4103
4104#ifdef SET_THREAD_SELF
4105 SET_THREAD_SELF(thr);
199100c8
MB		 4106#else
4107 thr->self = pthread_self();
235db74f 4108#endif /* SET_THREAD_SELF */
06d86050 4109 PERL_SET_THX(thr);
199100c8
MB		 4110
4111 /*
411caa50
JH		 4112 * These must come after the thread self setting
4113 * because sv_setpvn does SvTAINT and the taint
4114 * fields thread selfness being set.
199100c8 4115 */
533c011a
NIS		 4116 PL_toptarget = NEWSV(0,0);
4117 sv_upgrade(PL_toptarget, SVt_PVFM);
4118 sv_setpvn(PL_toptarget, "", 0);
4119 PL_bodytarget = NEWSV(0,0);
4120 sv_upgrade(PL_bodytarget, SVt_PVFM);
4121 sv_setpvn(PL_bodytarget, "", 0);
4122 PL_formtarget = PL_bodytarget;
79cb57f6 4123 thr->errsv = newSVpvn("", 0);
78857c3c 4124 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 4125
533c011a 4126 PL_maxscream = -1;
a2efc822 4127 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
0b94c7bb
GS		 4128 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4129 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4130 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4131 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4132 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 4133 PL_regindent = 0;
4134 PL_reginterp_cnt = 0;
5c0ca799 4135
199100c8
MB		 4136 return thr;
4137}
4d1ff10f 4138#endif /* USE_5005THREADS */
199100c8 4139
93a17b20 4140void
864dbfa3 4141Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 4142{
971a9dd3 4143 SV *atsv;
57843af0 4144 line_t oldline = CopLINE(PL_curcop);
312caa8e 4145 CV *cv;
22921e25 4146 STRLEN len;
6224f72b 4147 int ret;
db36c5a1 4148 dJMPENV;
93a17b20 4149
76e3520e 4150 while (AvFILL(paramList) >= 0) {
312caa8e 4151 cv = (CV*)av_shift(paramList);
ece599bd
RGS		 4152 if (PL_savebegin) {
4153 if (paramList == PL_beginav) {
059a8bb7 4154 /* save PL_beginav for compiler */
ece599bd
RGS		 4155 if (! PL_beginav_save)
4156 PL_beginav_save = newAV();
4157 av_push(PL_beginav_save, (SV*)cv);
4158 }
4159 else if (paramList == PL_checkav) {
4160 /* save PL_checkav for compiler */
4161 if (! PL_checkav_save)
4162 PL_checkav_save = newAV();
4163 av_push(PL_checkav_save, (SV*)cv);
4164 }
059a8bb7
JH		 4165 } else {
4166 SAVEFREESV(cv);
4167 }
14dd3ad8
GS		 4168#ifdef PERL_FLEXIBLE_EXCEPTIONS
4169 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
4170#else
4171 JMPENV_PUSH(ret);
4172#endif
6224f72b 4173 switch (ret) {
312caa8e 4174 case 0:
14dd3ad8
GS		 4175#ifndef PERL_FLEXIBLE_EXCEPTIONS
4176 call_list_body(cv);
4177#endif
971a9dd3 4178 atsv = ERRSV;
312caa8e
CS		 4179 (void)SvPV(atsv, len);
4180 if (len) {
4181 PL_curcop = &PL_compiling;
57843af0 4182 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 4183 if (paramList == PL_beginav)
4184 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4185 else
4f25aa18
GS		 4186 Perl_sv_catpvf(aTHX_ atsv,
4187 "%s failed--call queue aborted",
7d30b5c4 4188 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4189 : paramList == PL_initav ? "INIT"
4190 : "END");
312caa8e
CS		 4191 while (PL_scopestack_ix > oldscope)
4192 LEAVE;
14dd3ad8 4193 JMPENV_POP;
35c1215d 4194 Perl_croak(aTHX_ "%"SVf"", atsv);
a0d0e21e 4195 }
85e6fe83 4196 break;
6224f72b 4197 case 1:
f86702cc 4198 STATUS_ALL_FAILURE;
85e6fe83 4199 /* FALL THROUGH */
6224f72b 4200 case 2:
85e6fe83 4201 /* my_exit() was called */
3280af22 4202 while (PL_scopestack_ix > oldscope)
2ae324a7 4203 LEAVE;
84902520 4204 FREETMPS;
3280af22 4205 PL_curstash = PL_defstash;
3280af22 4206 PL_curcop = &PL_compiling;
57843af0 4207 CopLINE_set(PL_curcop, oldline);
14dd3ad8 4208 JMPENV_POP;
cc3604b1 4209 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 4210 if (paramList == PL_beginav)
cea2e8a9 4211 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 4212 else
4f25aa18 4213 Perl_croak(aTHX_ "%s failed--call queue aborted",
7d30b5c4 4214 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4215 : paramList == PL_initav ? "INIT"
4216 : "END");
85e6fe83 4217 }
f86702cc 4218 my_exit_jump();
85e6fe83 4219 /* NOTREACHED */
6224f72b 4220 case 3:
312caa8e
CS		 4221 if (PL_restartop) {
4222 PL_curcop = &PL_compiling;
57843af0 4223 CopLINE_set(PL_curcop, oldline);
312caa8e 4224 JMPENV_JUMP(3);
85e6fe83 4225 }
bf49b057 4226 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 4227 FREETMPS;
4228 break;
8990e307 4229 }
14dd3ad8 4230 JMPENV_POP;
93a17b20 4231 }
93a17b20 4232}
93a17b20 4233
14dd3ad8 4234#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 4235STATIC void *
14dd3ad8 4236S_vcall_list_body(pTHX_ va_list args)
312caa8e 4237{
312caa8e 4238 CV *cv = va_arg(args, CV*);
14dd3ad8
GS		 4239 return call_list_body(cv);
4240}
4241#endif
312caa8e 4242
14dd3ad8
GS		 4243STATIC void *
4244S_call_list_body(pTHX_ CV *cv)
4245{
312caa8e 4246 PUSHMARK(PL_stack_sp);
864dbfa3 4247 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 4248 return NULL;
4249}
4250
f86702cc 4251void
864dbfa3 4252Perl_my_exit(pTHX_ U32 status)
f86702cc 4253{
8b73bbec 4254 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 4255 thr, (unsigned long) status));
f86702cc 4256 switch (status) {
4257 case 0:
4258 STATUS_ALL_SUCCESS;
4259 break;
4260 case 1:
4261 STATUS_ALL_FAILURE;
4262 break;
4263 default:
4264 STATUS_NATIVE_SET(status);
4265 break;
4266 }
4267 my_exit_jump();
4268}
4269
4270void
864dbfa3 4271Perl_my_failure_exit(pTHX)
f86702cc 4272{
4273#ifdef VMS
4274 if (vaxc$errno & 1) {
4fdae800 4275 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4276 STATUS_NATIVE_SET(44);
f86702cc 4277 }
4278 else {
ff0cee69 4279 if (!vaxc$errno && errno) /* unlikely */
4fdae800 4280 STATUS_NATIVE_SET(44);
f86702cc 4281 else
4fdae800 4282 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 4283 }
4284#else
9b599b2a 4285 int exitstatus;
f86702cc 4286 if (errno & 255)
4287 STATUS_POSIX_SET(errno);
9b599b2a 4288 else {
ac27b0f5 4289 exitstatus = STATUS_POSIX >> 8;
9b599b2a
GS		 4290 if (exitstatus & 255)
4291 STATUS_POSIX_SET(exitstatus);
4292 else
4293 STATUS_POSIX_SET(255);
4294 }
f86702cc 4295#endif
4296 my_exit_jump();
93a17b20
LW		 4297}
4298
76e3520e 4299STATIC void
cea2e8a9 4300S_my_exit_jump(pTHX)
f86702cc 4301{
c09156bb 4302 register PERL_CONTEXT *cx;
f86702cc 4303 I32 gimme;
4304 SV **newsp;
4305
3280af22
NIS		 4306 if (PL_e_script) {
4307 SvREFCNT_dec(PL_e_script);
4308 PL_e_script = Nullsv;
f86702cc 4309 }
4310
3280af22 4311 POPSTACK_TO(PL_mainstack);
f86702cc 4312 if (cxstack_ix >= 0) {
4313 if (cxstack_ix > 0)
4314 dounwind(0);
3280af22 4315 POPBLOCK(cx,PL_curpm);
f86702cc 4316 LEAVE;
4317 }
ff0cee69 4318
6224f72b 4319 JMPENV_JUMP(2);
f86702cc 4320}
873ef191 4321
0cb96387 4322static I32
acfe0abc 4323read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
873ef191
GS		 4324{
4325 char *p, *nl;
3280af22 4326 p = SvPVX(PL_e_script);
873ef191 4327 nl = strchr(p, '\n');
3280af22 4328 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 4329 if (nl-p == 0) {
0cb96387 4330 filter_del(read_e_script);
873ef191 4331 return 0;
7dfe3f66 4332 }
873ef191 4333 sv_catpvn(buf_sv, p, nl-p);
3280af22 4334 sv_chop(PL_e_script, nl);
873ef191
GS		 4335 return 1;
4336}
Unnamed repository; edit this file 'description' to name the repository.