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