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