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