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