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