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