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