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