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
$0 is pain.
[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;
6e72f9df 184 }
79072805 185
cea2e8a9 186 PL_sighandlerp = Perl_sighandler;
3280af22 187 PL_pidstatus = newHV();
79072805
LW		 188 }
189
8bfdd7d9 190 PL_rs = newSVpvn("\n", 1);
dc92893f 191
cea2e8a9 192 init_stacks();
79072805 193
748a9306 194 init_ids();
3280af22 195 PL_lex_state = LEX_NOTPARSING;
a5f75d66 196
312caa8e 197 JMPENV_BOOTSTRAP;
f86702cc 198 STATUS_ALL_SUCCESS;
199
0672f40e 200 init_i18nl10n(1);
36477c24 201 SET_NUMERIC_STANDARD();
0b5b802d 202
a7cb1f99
GS		 203 {
204 U8 *s;
205 PL_patchlevel = NEWSV(0,4);
155aba94 206 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
a7cb1f99 207 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
806e7201 208 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
a7cb1f99 209 s = (U8*)SvPVX(PL_patchlevel);
9041c2e3
NIS		 210 /* Build version strings using "native" characters */
211 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
212 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
213 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
a7cb1f99
GS		 214 *s = '\0';
215 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
216 SvPOK_on(PL_patchlevel);
00d6e121
MB		 217 SvNVX(PL_patchlevel) = (NV)PERL_REVISION +
218 ((NV)PERL_VERSION / (NV)1000) +
219 ((NV)PERL_SUBVERSION / (NV)1000000);
a7cb1f99
GS		 220 SvNOK_on(PL_patchlevel); /* dual valued */
221 SvUTF8_on(PL_patchlevel);
222 SvREADONLY_on(PL_patchlevel);
223 }
79072805 224
ab821d7f 225#if defined(LOCAL_PATCH_COUNT)
3280af22 226 PL_localpatches = local_patches; /* For possible -v */
ab821d7f 227#endif
228
52853b95
GS		 229#ifdef HAVE_INTERP_INTERN
230 sys_intern_init();
231#endif
232
3a1ee7e8 233 PerlIO_init(aTHX); /* Hook to IO system */
760ac839 234
3280af22
NIS		 235 PL_fdpid = newAV(); /* for remembering popen pids by fd */
236 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
24944567 237 PL_errors = newSVpvn("",0);
48c6b404 238 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
1f483ca1
JH		 239 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
240 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
1fcf4c12 241#ifdef USE_ITHREADS
13137afc
AB		 242 PL_regex_padav = newAV();
243 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
244 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 245#endif
e5dd39fc 246#ifdef USE_REENTRANT_API
59bd0823 247 Perl_reentrant_init(aTHX);
e5dd39fc 248#endif
3d47000e
AB		 249
250 /* Note that strtab is a rather special HV. Assumptions are made
251 about not iterating on it, and not adding tie magic to it.
252 It is properly deallocated in perl_destruct() */
253 PL_strtab = newHV();
254
3d47000e
AB		 255 HvSHAREKEYS_off(PL_strtab); /* mandatory */
256 hv_ksplit(PL_strtab, 512);
257
0631ea03
AB		 258#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
259 _dyld_lookup_and_bind
260 ("__environ", (unsigned long *) &environ_pointer, NULL);
261#endif /* environ */
262
263#ifdef USE_ENVIRON_ARRAY
264 PL_origenviron = environ;
265#endif
266
5311654c
JH		 267 /* Use sysconf(_SC_CLK_TCK) if available, if not
268 * available or if the sysconf() fails, use the HZ. */
269#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
270 PL_clocktick = sysconf(_SC_CLK_TCK);
271 if (PL_clocktick <= 0)
272#endif
273 PL_clocktick = HZ;
274
081fc587
AB		 275 PL_stashcache = newHV();
276
504f80c1
JH		 277#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
278 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 */
279 {
d0d2ba8f
JH		 280 char *s = NULL;
281
ed085813 282 if (!PL_earlytaint)
d0d2ba8f 283 s = PerlEnv_getenv("PERL_HASH_SEED");
504f80c1
JH		 284 if (s)
285 while (isSPACE(*s)) s++;
286 if (s && isDIGIT(*s))
bf1e0190 287 PL_hash_seed = (UV)Atoul(s);
504f80c1
JH		 288#ifndef USE_HASH_SEED_EXPLICIT
289 else {
290 /* Compute a random seed */
291 (void)seedDrand01((Rand_seed_t)seed());
292 PL_srand_called = TRUE;
293 PL_hash_seed = (UV)(Drand01() * (NV)UV_MAX);
294#if RANDBITS < (UVSIZE * 8)
295 {
296 int skip = (UVSIZE * 8) - RANDBITS;
297 PL_hash_seed >>= skip;
298 /* The low bits might need extra help. */
299 PL_hash_seed += (UV)(Drand01() * ((1 << skip) - 1));
300 }
301#endif /* RANDBITS < (UVSIZE * 8) */
302 }
303#endif /* USE_HASH_SEED_EXPLICIT */
ed085813 304 if (!PL_earlytaint && (s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG")))
2191697e
JH		 305 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
306 PL_hash_seed);
504f80c1
JH		 307 }
308#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
309
8990e307 310 ENTER;
79072805
LW		 311}
312
954c1994 313/*
62375a60
NIS		 314=for apidoc nothreadhook
315
316Stub that provides thread hook for perl_destruct when there are
317no threads.
318
319=cut
320*/
321
322int
4e9e3734 323Perl_nothreadhook(pTHX)
62375a60
NIS		 324{
325 return 0;
326}
327
328/*
954c1994
GS		 329=for apidoc perl_destruct
330
331Shuts down a Perl interpreter. See L<perlembed>.
332
333=cut
334*/
335
31d77e54 336int
0cb96387 337perl_destruct(pTHXx)
79072805 338{
7c474504 339 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
a0d0e21e 340 HV *hv;
4d1ff10f 341#ifdef USE_5005THREADS
cea2e8a9 342 dTHX;
4d1ff10f 343#endif /* USE_5005THREADS */
8990e307 344
7766f137
GS		 345 /* wait for all pseudo-forked children to finish */
346 PERL_WAIT_FOR_CHILDREN;
347
3280af22 348 destruct_level = PL_perl_destruct_level;
4633a7c4
LW		 349#ifdef DEBUGGING
350 {
351 char *s;
155aba94 352 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
5f05dabc 353 int i = atoi(s);
354 if (destruct_level < i)
355 destruct_level = i;
356 }
4633a7c4
LW		 357 }
358#endif
359
31d77e54
AB		 360
361 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
f3faeb53
AB		 362 dJMPENV;
363 int x = 0;
364
365 JMPENV_PUSH(x);
366 if (PL_endav && !PL_minus_c)
367 call_list(PL_scopestack_ix, PL_endav);
368 JMPENV_POP;
26f423df 369 }
f3faeb53 370 LEAVE;
a0d0e21e
LW		 371 FREETMPS;
372
e00b64d4 373 /* Need to flush since END blocks can produce output */
f13a2bc0 374 my_fflush_all();
e00b64d4 375
62375a60
NIS		 376 if (CALL_FPTR(PL_threadhook)(aTHX)) {
377 /* Threads hook has vetoed further cleanup */
b47cad08 378 return STATUS_NATIVE_EXPORT;
62375a60
NIS		 379 }
380
ff0cee69 381 /* We must account for everything. */
382
383 /* Destroy the main CV and syntax tree */
3280af22 384 if (PL_main_root) {
3280af22
NIS		 385 op_free(PL_main_root);
386 PL_main_root = Nullop;
a0d0e21e 387 }
3280af22
NIS		 388 PL_curcop = &PL_compiling;
389 PL_main_start = Nullop;
390 SvREFCNT_dec(PL_main_cv);
391 PL_main_cv = Nullcv;
24d3c518 392 PL_dirty = TRUE;
ff0cee69 393
13621cfb
NIS		 394 /* Tell PerlIO we are about to tear things apart in case
395 we have layers which are using resources that should
396 be cleaned up now.
397 */
398
399 PerlIO_destruct(aTHX);
400
3280af22 401 if (PL_sv_objcount) {
a0d0e21e
LW		 402 /*
403 * Try to destruct global references. We do this first so that the
404 * destructors and destructees still exist. Some sv's might remain.
405 * Non-referenced objects are on their own.
406 */
a0d0e21e 407 sv_clean_objs();
8990e307
LW		 408 }
409
5cd24f17 410 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS		 411 SvREFCNT_dec(PL_warnhook);
412 PL_warnhook = Nullsv;
413 SvREFCNT_dec(PL_diehook);
414 PL_diehook = Nullsv;
5cd24f17 415
4b556e6c 416 /* call exit list functions */
3280af22 417 while (PL_exitlistlen-- > 0)
acfe0abc 418 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 419
3280af22 420 Safefree(PL_exitlist);
4b556e6c 421
1c4916e5
CB		 422 PL_exitlist = NULL;
423 PL_exitlistlen = 0;
424
a0d0e21e 425 if (destruct_level == 0){
8990e307 426
a0d0e21e 427 DEBUG_P(debprofdump());
ac27b0f5 428
56a2bab7
NIS		 429#if defined(PERLIO_LAYERS)
430 /* No more IO - including error messages ! */
431 PerlIO_cleanup(aTHX);
432#endif
433
a0d0e21e 434 /* The exit() function will do everything that needs doing. */
b47cad08 435 return STATUS_NATIVE_EXPORT;
a0d0e21e 436 }
5dd60ef7 437
551a8b83 438 /* jettison our possibly duplicated environment */
4b647fb0
DM		 439 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
440 * so we certainly shouldn't free it here
441 */
442#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
4efc5df6
GS		 443 if (environ != PL_origenviron
444#ifdef USE_ITHREADS
445 /* only main thread can free environ[0] contents */
446 && PL_curinterp == aTHX
447#endif
448 )
449 {
551a8b83
JH		 450 I32 i;
451
452 for (i = 0; environ[i]; i++)
4b420006 453 safesysfree(environ[i]);
0631ea03 454
4b420006
JH		 455 /* Must use safesysfree() when working with environ. */
456 safesysfree(environ);
551a8b83
JH		 457
458 environ = PL_origenviron;
459 }
460#endif
461
5f8cb046
DM		 462#ifdef USE_ITHREADS
463 /* the syntax tree is shared between clones
464 * so op_free(PL_main_root) only ReREFCNT_dec's
465 * REGEXPs in the parent interpreter
466 * we need to manually ReREFCNT_dec for the clones
467 */
468 {
469 I32 i = AvFILLp(PL_regex_padav) + 1;
470 SV **ary = AvARRAY(PL_regex_padav);
471
472 while (i) {
35061a7e 473 SV *resv = ary[--i];
ba89bb6e 474 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
35061a7e
DM		 475
476 if (SvFLAGS(resv) & SVf_BREAK) {
577e12cc 477 /* this is PL_reg_curpm, already freed
35061a7e
DM		 478 * flag is set in regexec.c:S_regtry
479 */
480 SvFLAGS(resv) &= ~SVf_BREAK;
3a1ee7e8 481 }
1cc8b4c5
AB		 482 else if(SvREPADTMP(resv)) {
483 SvREPADTMP_off(resv);
484 }
35061a7e 485 else {
5f8cb046
DM		 486 ReREFCNT_dec(re);
487 }
488 }
489 }
490 SvREFCNT_dec(PL_regex_padav);
491 PL_regex_padav = Nullav;
492 PL_regex_pad = NULL;
493#endif
494
081fc587
AB		 495 SvREFCNT_dec((SV*) PL_stashcache);
496 PL_stashcache = NULL;
497
5f05dabc 498 /* loosen bonds of global variables */
499
3280af22
NIS		 500 if(PL_rsfp) {
501 (void)PerlIO_close(PL_rsfp);
502 PL_rsfp = Nullfp;
8ebc5c01 503 }
504
505 /* Filters for program text */
3280af22
NIS		 506 SvREFCNT_dec(PL_rsfp_filters);
507 PL_rsfp_filters = Nullav;
8ebc5c01 508
509 /* switches */
3280af22
NIS		 510 PL_preprocess = FALSE;
511 PL_minus_n = FALSE;
512 PL_minus_p = FALSE;
513 PL_minus_l = FALSE;
514 PL_minus_a = FALSE;
515 PL_minus_F = FALSE;
516 PL_doswitches = FALSE;
599cee73 517 PL_dowarn = G_WARN_OFF;
3280af22
NIS		 518 PL_doextract = FALSE;
519 PL_sawampersand = FALSE; /* must save all match strings */
3280af22
NIS		 520 PL_unsafe = FALSE;
521
522 Safefree(PL_inplace);
523 PL_inplace = Nullch;
a7cb1f99 524 SvREFCNT_dec(PL_patchlevel);
3280af22
NIS		 525
526 if (PL_e_script) {
527 SvREFCNT_dec(PL_e_script);
528 PL_e_script = Nullsv;
8ebc5c01 529 }
530
531 /* magical thingies */
532
7889fe52
NIS		 533 SvREFCNT_dec(PL_ofs_sv); /* $, */
534 PL_ofs_sv = Nullsv;
5f05dabc 535
7889fe52
NIS		 536 SvREFCNT_dec(PL_ors_sv); /* $\ */
537 PL_ors_sv = Nullsv;
8ebc5c01 538
3280af22
NIS		 539 SvREFCNT_dec(PL_rs); /* $/ */
540 PL_rs = Nullsv;
dc92893f 541
d33b2eba
GS		 542 PL_multiline = 0; /* $* */
543 Safefree(PL_osname); /* $^O */
544 PL_osname = Nullch;
5f05dabc 545
3280af22
NIS		 546 SvREFCNT_dec(PL_statname);
547 PL_statname = Nullsv;
548 PL_statgv = Nullgv;
5f05dabc 549
8ebc5c01 550 /* defgv, aka *_ should be taken care of elsewhere */
551
8ebc5c01 552 /* clean up after study() */
3280af22
NIS		 553 SvREFCNT_dec(PL_lastscream);
554 PL_lastscream = Nullsv;
555 Safefree(PL_screamfirst);
556 PL_screamfirst = 0;
557 Safefree(PL_screamnext);
558 PL_screamnext = 0;
8ebc5c01 559
7d5ea4e7
GS		 560 /* float buffer */
561 Safefree(PL_efloatbuf);
562 PL_efloatbuf = Nullch;
563 PL_efloatsize = 0;
564
8ebc5c01 565 /* startup and shutdown function lists */
3280af22 566 SvREFCNT_dec(PL_beginav);
5a837c8f 567 SvREFCNT_dec(PL_beginav_save);
3280af22 568 SvREFCNT_dec(PL_endav);
7d30b5c4 569 SvREFCNT_dec(PL_checkav);
ece599bd 570 SvREFCNT_dec(PL_checkav_save);
3280af22
NIS		 571 SvREFCNT_dec(PL_initav);
572 PL_beginav = Nullav;
5a837c8f 573 PL_beginav_save = Nullav;
3280af22 574 PL_endav = Nullav;
7d30b5c4 575 PL_checkav = Nullav;
ece599bd 576 PL_checkav_save = Nullav;
3280af22 577 PL_initav = Nullav;
5618dfe8 578
8ebc5c01 579 /* shortcuts just get cleared */
3280af22 580 PL_envgv = Nullgv;
3280af22
NIS		 581 PL_incgv = Nullgv;
582 PL_hintgv = Nullgv;
583 PL_errgv = Nullgv;
584 PL_argvgv = Nullgv;
585 PL_argvoutgv = Nullgv;
586 PL_stdingv = Nullgv;
bf49b057 587 PL_stderrgv = Nullgv;
3280af22
NIS		 588 PL_last_in_gv = Nullgv;
589 PL_replgv = Nullgv;
5c831c24 590 PL_debstash = Nullhv;
8ebc5c01 591
592 /* reset so print() ends up where we expect */
593 setdefout(Nullgv);
5c831c24 594
7a1c5554
GS		 595 SvREFCNT_dec(PL_argvout_stack);
596 PL_argvout_stack = Nullav;
8ebc5c01 597
5c831c24
GS		 598 SvREFCNT_dec(PL_modglobal);
599 PL_modglobal = Nullhv;
600 SvREFCNT_dec(PL_preambleav);
601 PL_preambleav = Nullav;
602 SvREFCNT_dec(PL_subname);
603 PL_subname = Nullsv;
604 SvREFCNT_dec(PL_linestr);
605 PL_linestr = Nullsv;
606 SvREFCNT_dec(PL_pidstatus);
607 PL_pidstatus = Nullhv;
608 SvREFCNT_dec(PL_toptarget);
609 PL_toptarget = Nullsv;
610 SvREFCNT_dec(PL_bodytarget);
611 PL_bodytarget = Nullsv;
612 PL_formtarget = Nullsv;
613
d33b2eba 614 /* free locale stuff */
b9582b6a 615#ifdef USE_LOCALE_COLLATE
d33b2eba
GS		 616 Safefree(PL_collation_name);
617 PL_collation_name = Nullch;
b9582b6a 618#endif
d33b2eba 619
b9582b6a 620#ifdef USE_LOCALE_NUMERIC
d33b2eba
GS		 621 Safefree(PL_numeric_name);
622 PL_numeric_name = Nullch;
a453c169 623 SvREFCNT_dec(PL_numeric_radix_sv);
b9582b6a 624#endif
d33b2eba 625
5c831c24
GS		 626 /* clear utf8 character classes */
627 SvREFCNT_dec(PL_utf8_alnum);
628 SvREFCNT_dec(PL_utf8_alnumc);
629 SvREFCNT_dec(PL_utf8_ascii);
630 SvREFCNT_dec(PL_utf8_alpha);
631 SvREFCNT_dec(PL_utf8_space);
632 SvREFCNT_dec(PL_utf8_cntrl);
633 SvREFCNT_dec(PL_utf8_graph);
634 SvREFCNT_dec(PL_utf8_digit);
635 SvREFCNT_dec(PL_utf8_upper);
636 SvREFCNT_dec(PL_utf8_lower);
637 SvREFCNT_dec(PL_utf8_print);
638 SvREFCNT_dec(PL_utf8_punct);
639 SvREFCNT_dec(PL_utf8_xdigit);
640 SvREFCNT_dec(PL_utf8_mark);
641 SvREFCNT_dec(PL_utf8_toupper);
4dbdbdc2 642 SvREFCNT_dec(PL_utf8_totitle);
5c831c24 643 SvREFCNT_dec(PL_utf8_tolower);
b4e400f9 644 SvREFCNT_dec(PL_utf8_tofold);
82686b01
JH		 645 SvREFCNT_dec(PL_utf8_idstart);
646 SvREFCNT_dec(PL_utf8_idcont);
5c831c24
GS		 647 PL_utf8_alnum = Nullsv;
648 PL_utf8_alnumc = Nullsv;
649 PL_utf8_ascii = Nullsv;
650 PL_utf8_alpha = Nullsv;
651 PL_utf8_space = Nullsv;
652 PL_utf8_cntrl = Nullsv;
653 PL_utf8_graph = Nullsv;
654 PL_utf8_digit = Nullsv;
655 PL_utf8_upper = Nullsv;
656 PL_utf8_lower = Nullsv;
657 PL_utf8_print = Nullsv;
658 PL_utf8_punct = Nullsv;
659 PL_utf8_xdigit = Nullsv;
660 PL_utf8_mark = Nullsv;
661 PL_utf8_toupper = Nullsv;
662 PL_utf8_totitle = Nullsv;
663 PL_utf8_tolower = Nullsv;
b4e400f9 664 PL_utf8_tofold = Nullsv;
82686b01
JH		 665 PL_utf8_idstart = Nullsv;
666 PL_utf8_idcont = Nullsv;
5c831c24 667
971a9dd3
GS		 668 if (!specialWARN(PL_compiling.cop_warnings))
669 SvREFCNT_dec(PL_compiling.cop_warnings);
5c831c24 670 PL_compiling.cop_warnings = Nullsv;
ac27b0f5
NIS		 671 if (!specialCopIO(PL_compiling.cop_io))
672 SvREFCNT_dec(PL_compiling.cop_io);
673 PL_compiling.cop_io = Nullsv;
05ec9bb3
NIS		 674 CopFILE_free(&PL_compiling);
675 CopSTASH_free(&PL_compiling);
5c831c24 676
a0d0e21e 677 /* Prepare to destruct main symbol table. */
5f05dabc 678
3280af22
NIS		 679 hv = PL_defstash;
680 PL_defstash = 0;
a0d0e21e 681 SvREFCNT_dec(hv);
5c831c24
GS		 682 SvREFCNT_dec(PL_curstname);
683 PL_curstname = Nullsv;
a0d0e21e 684
5a844595
GS		 685 /* clear queued errors */
686 SvREFCNT_dec(PL_errors);
687 PL_errors = Nullsv;
688
a0d0e21e 689 FREETMPS;
0453d815 690 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
3280af22 691 if (PL_scopestack_ix != 0)
9014280d 692 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 693 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
3280af22
NIS		 694 (long)PL_scopestack_ix);
695 if (PL_savestack_ix != 0)
9014280d 696 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 697 "Unbalanced saves: %ld more saves than restores\n",
3280af22
NIS		 698 (long)PL_savestack_ix);
699 if (PL_tmps_floor != -1)
9014280d 700 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
3280af22 701 (long)PL_tmps_floor + 1);
a0d0e21e 702 if (cxstack_ix != -1)
9014280d 703 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
ff0cee69 704 (long)cxstack_ix + 1);
a0d0e21e 705 }
8990e307
LW		 706
707 /* Now absolutely destruct everything, somehow or other, loops or no. */
d33b2eba 708 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
3280af22 709 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
5226ed68
JH		 710
711 /* the 2 is for PL_fdpid and PL_strtab */
712 while (PL_sv_count > 2 && sv_clean_all())
713 ;
714
d33b2eba
GS		 715 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
716 SvFLAGS(PL_fdpid) |= SVt_PVAV;
3280af22
NIS		 717 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
718 SvFLAGS(PL_strtab) |= SVt_PVHV;
d33b2eba 719
d4777f27
GS		 720 AvREAL_off(PL_fdpid); /* no surviving entries */
721 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
d33b2eba
GS		 722 PL_fdpid = Nullav;
723
6c644e78
GS		 724#ifdef HAVE_INTERP_INTERN
725 sys_intern_clear();
726#endif
727
6e72f9df 728 /* Destruct the global string table. */
729 {
730 /* Yell and reset the HeVAL() slots that are still holding refcounts,
731 * so that sv_free() won't fail on them.
732 */
733 I32 riter;
734 I32 max;
735 HE *hent;
736 HE **array;
737
738 riter = 0;
3280af22
NIS		 739 max = HvMAX(PL_strtab);
740 array = HvARRAY(PL_strtab);
6e72f9df 741 hent = array[0];
742 for (;;) {
0453d815 743 if (hent && ckWARN_d(WARN_INTERNAL)) {
9014280d 744 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 745 "Unbalanced string table refcount: (%d) for \"%s\"",
6e72f9df 746 HeVAL(hent) - Nullsv, HeKEY(hent));
747 HeVAL(hent) = Nullsv;
748 hent = HeNEXT(hent);
749 }
750 if (!hent) {
751 if (++riter > max)
752 break;
753 hent = array[riter];
754 }
755 }
756 }
3280af22 757 SvREFCNT_dec(PL_strtab);
6e72f9df 758
e652bb2f 759#ifdef USE_ITHREADS
a0739874
DM		 760 /* free the pointer table used for cloning */
761 ptr_table_free(PL_ptr_table);
53186e96 762#endif
a0739874 763
d33b2eba
GS		 764 /* free special SVs */
765
766 SvREFCNT(&PL_sv_yes) = 0;
767 sv_clear(&PL_sv_yes);
768 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 769 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS		 770
771 SvREFCNT(&PL_sv_no) = 0;
772 sv_clear(&PL_sv_no);
773 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 774 SvFLAGS(&PL_sv_no) = 0;
01724ea0 775
9f375a43
DM		 776 {
777 int i;
778 for (i=0; i<=2; i++) {
779 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
780 sv_clear(PERL_DEBUG_PAD(i));
781 SvANY(PERL_DEBUG_PAD(i)) = NULL;
782 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
783 }
784 }
785
0453d815 786 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
9014280d 787 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 788
eba0f806
DM		 789#ifdef DEBUG_LEAKING_SCALARS
790 if (PL_sv_count != 0) {
791 SV* sva;
792 SV* sv;
793 register SV* svend;
794
795 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
796 svend = &sva[SvREFCNT(sva)];
797 for (sv = sva + 1; sv < svend; ++sv) {
798 if (SvTYPE(sv) != SVTYPEMASK) {
799 PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
800 }
801 }
802 }
803 }
804#endif
805
806
56a2bab7 807#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS		 808 /* No more IO - including error messages ! */
809 PerlIO_cleanup(aTHX);
810#endif
811
9f4bd222
NIS		 812 /* sv_undef needs to stay immortal until after PerlIO_cleanup
813 as currently layers use it rather than Nullsv as a marker
814 for no arg - and will try and SvREFCNT_dec it.
815 */
816 SvREFCNT(&PL_sv_undef) = 0;
817 SvREADONLY_off(&PL_sv_undef);
818
3280af22 819 Safefree(PL_origfilename);
3280af22 820 Safefree(PL_reg_start_tmp);
5c5e4c24
IZ		 821 if (PL_reg_curpm)
822 Safefree(PL_reg_curpm);
82ba1be6 823 Safefree(PL_reg_poscache);
dd28f7bb 824 free_tied_hv_pool();
3280af22 825 Safefree(PL_op_mask);
cf36064f
GS		 826 Safefree(PL_psig_ptr);
827 Safefree(PL_psig_name);
2c2666fc 828 Safefree(PL_bitcount);
ce08f86c 829 Safefree(PL_psig_pend);
6e72f9df 830 nuke_stacks();
3280af22 831 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
ac27b0f5 832
a0d0e21e 833 DEBUG_P(debprofdump());
d33b2eba 834
e5dd39fc 835#ifdef USE_REENTRANT_API
10bc17b6 836 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 837#endif
838
612f20c3
GS		 839 sv_free_arenas();
840
fc36a67e 841 /* As the absolutely last thing, free the non-arena SV for mess() */
842
3280af22 843 if (PL_mess_sv) {
9c63abab
GS		 844 /* it could have accumulated taint magic */
845 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
846 MAGIC* mg;
847 MAGIC* moremagic;
848 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
849 moremagic = mg->mg_moremagic;
14befaf4
DM		 850 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
851 && mg->mg_len >= 0)
9c63abab
GS		 852 Safefree(mg->mg_ptr);
853 Safefree(mg);
854 }
855 }
fc36a67e 856 /* we know that type >= SVt_PV */
155aba94 857 (void)SvOOK_off(PL_mess_sv);
3280af22
NIS		 858 Safefree(SvPVX(PL_mess_sv));
859 Safefree(SvANY(PL_mess_sv));
860 Safefree(PL_mess_sv);
861 PL_mess_sv = Nullsv;
fc36a67e 862 }
31d77e54 863 return STATUS_NATIVE_EXPORT;
79072805
LW		 864}
865
954c1994
GS		 866/*
867=for apidoc perl_free
868
869Releases a Perl interpreter. See L<perlembed>.
870
871=cut
872*/
873
79072805 874void
0cb96387 875perl_free(pTHXx)
79072805 876{
acfe0abc 877#if defined(WIN32) || defined(NETWARE)
ce3e5b80 878# if defined(PERL_IMPLICIT_SYS)
acfe0abc
GS		 879# ifdef NETWARE
880 void *host = nw_internal_host;
881# else
882 void *host = w32_internal_host;
883# endif
ce3e5b80 884 PerlMem_free(aTHXx);
acfe0abc 885# ifdef NETWARE
011f1a1a 886 nw_delete_internal_host(host);
acfe0abc
GS		 887# else
888 win32_delete_internal_host(host);
889# endif
1c0ca838
GS		 890# else
891 PerlMem_free(aTHXx);
892# endif
acfe0abc
GS		 893#else
894 PerlMem_free(aTHXx);
76e3520e 895#endif
79072805
LW		 896}
897
4b556e6c 898void
864dbfa3 899Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 900{
3280af22
NIS		 901 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
902 PL_exitlist[PL_exitlistlen].fn = fn;
903 PL_exitlist[PL_exitlistlen].ptr = ptr;
904 ++PL_exitlistlen;
4b556e6c
JD		 905}
906
954c1994
GS		 907/*
908=for apidoc perl_parse
909
910Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
911
912=cut
913*/
914
79072805 915int
0cb96387 916perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 917{
6224f72b 918 I32 oldscope;
6224f72b 919 int ret;
db36c5a1 920 dJMPENV;
4d1ff10f 921#ifdef USE_5005THREADS
cea2e8a9
GS		 922 dTHX;
923#endif
8d063cd8 924
a687059c
LW		 925#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
926#ifdef IAMSUID
927#undef IAMSUID
cea2e8a9 928 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW		 929setuid perl scripts securely.\n");
930#endif
931#endif
932
3280af22 933 PL_origargc = argc;
e2975953 934 PL_origargv = argv;
a0d0e21e 935
54bfe034 936 {
3cb9023d
JH		 937 /* Set PL_origalen be the sum of the contiguous argv[]
938 * elements plus the size of the env in case that it is
939 * contiguous with the argv[]. This is used in mg.c:mg_set()
940 * as the maximum modifiable length of $0. In the worst case
941 * the area we are able to modify is limited to the size of
43c32782 942 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d
JH		 943 * --jhi */
944 char *s;
54bfe034 945 int i;
7d8e7db3
JH		 946 UV mask =
947 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
43c32782
JH		 948 /* Do the mask check only if the args seem like aligned. */
949 UV aligned =
950 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
951
952 /* See if all the arguments are contiguous in memory. Note
953 * that 'contiguous' is a loose term because some platforms
954 * align the argv[] and the envp[]. If the arguments look
955 * like non-aligned, assume that they are 'strictly' or
956 * 'traditionally' contiguous. If the arguments look like
957 * aligned, we just check that they are within aligned
958 * PTRSIZE bytes. As long as no system has something bizarre
959 * like the argv[] interleaved with some other data, we are
960 * fine. (Did I just evoke Murphy's Law?) --jhi */
3cb9023d
JH		 961 s = PL_origargv[0];
962 while (*s) s++;
54bfe034 963 for (i = 1; i < PL_origargc; i++) {
43c32782
JH		 964 if ((PL_origargv[i] == s + 1
965#ifdef OS2
966 || PL_origargv[i] == s + 2
967#endif
968 )
969 ||
970 (aligned &&
971 (PL_origargv[i] > s &&
972 PL_origargv[i] <=
973 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
974 )
975 {
3cb9023d
JH		 976 s = PL_origargv[i];
977 while (*s) s++;
54bfe034
JH		 978 }
979 else
980 break;
981 }
3cb9023d 982 /* Can we grab env area too to be used as the area for $0? */
43c32782
JH		 983 if (PL_origenviron) {
984 if ((PL_origenviron[0] == s + 1
985#ifdef OS2
986 || (PL_origenviron[0] == s + 9 && (s += 8))
987#endif
988 )
989 ||
990 (aligned &&
991 (PL_origenviron[0] > s &&
992 PL_origenviron[0] <=
993 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
994 )
995 {
996#ifndef OS2
997 s = PL_origenviron[0];
998 while (*s) s++;
999#endif
1000 my_setenv("NoNe SuCh", Nullch);
1001 /* Force copy of environment. */
1002 for (i = 1; PL_origenviron[i]; i++) {
1003 if (PL_origenviron[i] == s + 1
1004 ||
1005 (aligned &&
1006 (PL_origenviron[i] > s &&
1007 PL_origenviron[i] <=
1008 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1009 )
1010 {
1011 s = PL_origenviron[i];
1012 while (*s) s++;
1013 }
1014 else
1015 break;
54bfe034 1016 }
43c32782 1017 }
54bfe034
JH		 1018 }
1019 PL_origalen = s - PL_origargv[0];
1020 }
1021
3280af22 1022 if (PL_do_undump) {
a0d0e21e
LW		 1023
1024 /* Come here if running an undumped a.out. */
1025
3280af22
NIS		 1026 PL_origfilename = savepv(argv[0]);
1027 PL_do_undump = FALSE;
a0d0e21e 1028 cxstack_ix = -1; /* start label stack again */
748a9306 1029 init_ids();
a0d0e21e
LW		 1030 init_postdump_symbols(argc,argv,env);
1031 return 0;
1032 }
1033
3280af22 1034 if (PL_main_root) {
3280af22
NIS		 1035 op_free(PL_main_root);
1036 PL_main_root = Nullop;
ff0cee69 1037 }
3280af22
NIS		 1038 PL_main_start = Nullop;
1039 SvREFCNT_dec(PL_main_cv);
1040 PL_main_cv = Nullcv;
79072805 1041
3280af22
NIS		 1042 time(&PL_basetime);
1043 oldscope = PL_scopestack_ix;
599cee73 1044 PL_dowarn = G_WARN_OFF;
f86702cc 1045
14dd3ad8
GS		 1046#ifdef PERL_FLEXIBLE_EXCEPTIONS
1047 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1048#else
1049 JMPENV_PUSH(ret);
1050#endif
6224f72b 1051 switch (ret) {
312caa8e 1052 case 0:
14dd3ad8
GS		 1053#ifndef PERL_FLEXIBLE_EXCEPTIONS
1054 parse_body(env,xsinit);
1055#endif
7d30b5c4
GS		 1056 if (PL_checkav)
1057 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1058 ret = 0;
1059 break;
6224f72b
GS		 1060 case 1:
1061 STATUS_ALL_FAILURE;
1062 /* FALL THROUGH */
1063 case 2:
1064 /* my_exit() was called */
3280af22 1065 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1066 LEAVE;
1067 FREETMPS;
3280af22 1068 PL_curstash = PL_defstash;
7d30b5c4
GS		 1069 if (PL_checkav)
1070 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1071 ret = STATUS_NATIVE_EXPORT;
1072 break;
6224f72b 1073 case 3:
bf49b057 1074 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1075 ret = 1;
1076 break;
6224f72b 1077 }
14dd3ad8
GS		 1078 JMPENV_POP;
1079 return ret;
1080}
1081
1082#ifdef PERL_FLEXIBLE_EXCEPTIONS
1083STATIC void *
1084S_vparse_body(pTHX_ va_list args)
1085{
1086 char **env = va_arg(args, char**);
1087 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1088
1089 return parse_body(env, xsinit);
312caa8e 1090}
14dd3ad8 1091#endif
312caa8e
CS		 1092
1093STATIC void *
14dd3ad8 1094S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1095{
312caa8e
CS		 1096 int argc = PL_origargc;
1097 char **argv = PL_origargv;
312caa8e
CS		 1098 char *scriptname = NULL;
1099 int fdscript = -1;
1100 VOL bool dosearch = FALSE;
1101 char *validarg = "";
312caa8e
CS		 1102 register SV *sv;
1103 register char *s;
cf756827 1104 char *cddir = Nullch;
312caa8e 1105
3280af22 1106 sv_setpvn(PL_linestr,"",0);
79cb57f6 1107 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 1108 SAVEFREESV(sv);
1109 init_main_stash();
54310121 1110
6224f72b
GS		 1111 for (argc--,argv++; argc > 0; argc--,argv++) {
1112 if (argv[0][0] != '-' || !argv[0][1])
1113 break;
1114#ifdef DOSUID
1115 if (*validarg)
1116 validarg = " PHOOEY ";
1117 else
1118 validarg = argv[0];
13281fa4 1119#endif
6224f72b
GS		 1120 s = argv[0]+1;
1121 reswitch:
1122 switch (*s) {
729a02f2 1123 case 'C':
1d5472a9
GS		 1124#ifndef PERL_STRICT_CR
1125 case '\r':
1126#endif
6224f72b
GS		 1127 case ' ':
1128 case '0':
1129 case 'F':
1130 case 'a':
1131 case 'c':
1132 case 'd':
1133 case 'D':
1134 case 'h':
1135 case 'i':
1136 case 'l':
1137 case 'M':
1138 case 'm':
1139 case 'n':
1140 case 'p':
1141 case 's':
1142 case 'u':
1143 case 'U':
1144 case 'v':
599cee73
PM		 1145 case 'W':
1146 case 'X':
6224f72b 1147 case 'w':
06492da6 1148 case 'A':
155aba94 1149 if ((s = moreswitches(s)))
6224f72b
GS		 1150 goto reswitch;
1151 break;
33b78306 1152
1dbad523 1153 case 't':
22f7c9c9 1154 CHECK_MALLOC_TOO_LATE_FOR('t');
317ea90d
MS		 1155 if( !PL_tainting ) {
1156 PL_taint_warn = TRUE;
1157 PL_tainting = TRUE;
1158 }
1159 s++;
1160 goto reswitch;
6224f72b 1161 case 'T':
22f7c9c9 1162 CHECK_MALLOC_TOO_LATE_FOR('T');
3280af22 1163 PL_tainting = TRUE;
317ea90d 1164 PL_taint_warn = FALSE;
6224f72b
GS		 1165 s++;
1166 goto reswitch;
f86702cc 1167
6224f72b 1168 case 'e':
bf4acbe4
GS		 1169#ifdef MACOS_TRADITIONAL
1170 /* ignore -e for Dev:Pseudo argument */
1171 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1172 break;
bf4acbe4 1173#endif
3280af22 1174 if (PL_euid != PL_uid || PL_egid != PL_gid)
cea2e8a9 1175 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
3280af22 1176 if (!PL_e_script) {
79cb57f6 1177 PL_e_script = newSVpvn("",0);
0cb96387 1178 filter_add(read_e_script, NULL);
6224f72b
GS		 1179 }
1180 if (*++s)
3280af22 1181 sv_catpv(PL_e_script, s);
6224f72b 1182 else if (argv[1]) {
3280af22 1183 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1184 argc--,argv++;
1185 }
1186 else
cea2e8a9 1187 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1188 sv_catpv(PL_e_script, "\n");
6224f72b 1189 break;
afe37c7d 1190
6224f72b
GS		 1191 case 'I': /* -I handled both here and in moreswitches() */
1192 forbid_setid("-I");
1193 if (!*++s && (s=argv[1]) != Nullch) {
1194 argc--,argv++;
1195 }
6224f72b 1196 if (s && *s) {
0df16ed7
GS		 1197 char *p;
1198 STRLEN len = strlen(s);
1199 p = savepvn(s, len);
574c798a 1200 incpush(p, TRUE, TRUE, FALSE);
0df16ed7
GS		 1201 sv_catpvn(sv, "-I", 2);
1202 sv_catpvn(sv, p, len);
1203 sv_catpvn(sv, " ", 1);
6224f72b 1204 Safefree(p);
0df16ed7
GS		 1205 }
1206 else
a67e862a 1207 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1208 break;
1209 case 'P':
1210 forbid_setid("-P");
3280af22 1211 PL_preprocess = TRUE;
6224f72b
GS		 1212 s++;
1213 goto reswitch;
1214 case 'S':
1215 forbid_setid("-S");
1216 dosearch = TRUE;
1217 s++;
1218 goto reswitch;
1219 case 'V':
3280af22
NIS		 1220 if (!PL_preambleav)
1221 PL_preambleav = newAV();
1222 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1223 if (*++s != ':') {
3280af22 1224 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1225#ifdef VMS
6b88bc9c 1226 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1227#else
3280af22 1228 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1229#endif
3280af22 1230 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1231# ifdef DEBUGGING
3280af22 1232 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1233# endif
6224f72b 1234# ifdef MULTIPLICITY
8f872242 1235 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1236# endif
4d1ff10f
AB		 1237# ifdef USE_5005THREADS
1238 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1239# endif
ac5e8965
JH		 1240# ifdef USE_ITHREADS
1241 sv_catpv(PL_Sv," USE_ITHREADS");
1242# endif
10cc9d2a
JH		 1243# ifdef USE_64_BIT_INT
1244 sv_catpv(PL_Sv," USE_64_BIT_INT");
1245# endif
1246# ifdef USE_64_BIT_ALL
1247 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1248# endif
1249# ifdef USE_LONG_DOUBLE
1250 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1251# endif
53430762
JH		 1252# ifdef USE_LARGE_FILES
1253 sv_catpv(PL_Sv," USE_LARGE_FILES");
1254# endif
ac5e8965
JH		 1255# ifdef USE_SOCKS
1256 sv_catpv(PL_Sv," USE_SOCKS");
1257# endif
b363f7ed
GS		 1258# ifdef PERL_IMPLICIT_CONTEXT
1259 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1260# endif
1261# ifdef PERL_IMPLICIT_SYS
1262 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1263# endif
3280af22 1264 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1265
6224f72b
GS		 1266#if defined(LOCAL_PATCH_COUNT)
1267 if (LOCAL_PATCH_COUNT > 0) {
1268 int i;
3280af22 1269 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1270 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1271 if (PL_localpatches[i])
cea2e8a9 1272 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS		 1273 }
1274 }
1275#endif
cea2e8a9 1276 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1277#ifdef __DATE__
1278# ifdef __TIME__
cea2e8a9 1279 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1280# else
cea2e8a9 1281 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1282# endif
1283#endif
3280af22 1284 sv_catpv(PL_Sv, "; \
6224f72b 1285$\"=\"\\n \"; \
69fcd688
JH		 1286@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1287#ifdef __CYGWIN__
1288 sv_catpv(PL_Sv,"\
1289push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1290#endif
1291 sv_catpv(PL_Sv, "\
6224f72b
GS		 1292print \" \\%ENV:\\n @env\\n\" if @env; \
1293print \" \\@INC:\\n @INC\\n\";");
1294 }
1295 else {
3280af22
NIS		 1296 PL_Sv = newSVpv("config_vars(qw(",0);
1297 sv_catpv(PL_Sv, ++s);
1298 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1299 s += strlen(s);
1300 }
3280af22 1301 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1302 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1303 goto reswitch;
1304 case 'x':
3280af22 1305 PL_doextract = TRUE;
6224f72b
GS		 1306 s++;
1307 if (*s)
f4c556ac 1308 cddir = s;
6224f72b
GS		 1309 break;
1310 case 0:
1311 break;
1312 case '-':
1313 if (!*++s || isSPACE(*s)) {
1314 argc--,argv++;
1315 goto switch_end;
1316 }
1317 /* catch use of gnu style long options */
1318 if (strEQ(s, "version")) {
1319 s = "v";
1320 goto reswitch;
1321 }
1322 if (strEQ(s, "help")) {
1323 s = "h";
1324 goto reswitch;
1325 }
1326 s--;
1327 /* FALL THROUGH */
1328 default:
cea2e8a9 1329 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1330 }
1331 }
6224f72b 1332 switch_end:
7f9e821f 1333 sv_setsv(get_sv("/", TRUE), PL_rs);
54310121 1334
f675dbe5
CB		 1335 if (
1336#ifndef SECURE_INTERNAL_GETENV
1337 !PL_tainting &&
1338#endif
cf756827 1339 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1340 {
cf756827 1341 char *popt = s;
74288ac8
GS		 1342 while (isSPACE(*s))
1343 s++;
317ea90d 1344 if (*s == '-' && *(s+1) == 'T') {
22f7c9c9 1345 CHECK_MALLOC_TOO_LATE_FOR('T');
74288ac8 1346 PL_tainting = TRUE;
317ea90d
MS		 1347 PL_taint_warn = FALSE;
1348 }
74288ac8 1349 else {
cf756827 1350 char *popt_copy = Nullch;
74288ac8 1351 while (s && *s) {
4ea8f8fb 1352 char *d;
74288ac8
GS		 1353 while (isSPACE(*s))
1354 s++;
1355 if (*s == '-') {
1356 s++;
1357 if (isSPACE(*s))
1358 continue;
1359 }
4ea8f8fb 1360 d = s;
74288ac8
GS		 1361 if (!*s)
1362 break;
06492da6 1363 if (!strchr("DIMUdmtwA", *s))
cea2e8a9 1364 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1365 while (++s && *s) {
1366 if (isSPACE(*s)) {
cf756827
GS		 1367 if (!popt_copy) {
1368 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1369 s = popt_copy + (s - popt);
1370 d = popt_copy + (d - popt);
1371 }
4ea8f8fb
MS		 1372 *s++ = '\0';
1373 break;
1374 }
1375 }
1c4db469 1376 if (*d == 't') {
317ea90d
MS		 1377 if( !PL_tainting ) {
1378 PL_taint_warn = TRUE;
1379 PL_tainting = TRUE;
1380 }
1c4db469
RGS		 1381 } else {
1382 moreswitches(d);
1383 }
6224f72b 1384 }
6224f72b
GS		 1385 }
1386 }
a0d0e21e 1387
317ea90d
MS		 1388 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1389 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1390 }
1391
6224f72b
GS		 1392 if (!scriptname)
1393 scriptname = argv[0];
3280af22 1394 if (PL_e_script) {
6224f72b
GS		 1395 argc++,argv--;
1396 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1397 }
1398 else if (scriptname == Nullch) {
1399#ifdef MSDOS
1400 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1401 moreswitches("h");
1402#endif
1403 scriptname = "-";
1404 }
1405
1406 init_perllib();
1407
1408 open_script(scriptname,dosearch,sv,&fdscript);
1409
1410 validate_suid(validarg, scriptname,fdscript);
1411
64ca3a65 1412#ifndef PERL_MICRO
0b5b802d
GS		 1413#if defined(SIGCHLD) || defined(SIGCLD)
1414 {
1415#ifndef SIGCHLD
1416# define SIGCHLD SIGCLD
1417#endif
1418 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1419 if (sigstate == SIG_IGN) {
1420 if (ckWARN(WARN_SIGNAL))
9014280d 1421 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1422 "Can't ignore signal CHLD, forcing to default");
1423 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1424 }
1425 }
1426#endif
64ca3a65 1427#endif
0b5b802d 1428
bf4acbe4
GS		 1429#ifdef MACOS_TRADITIONAL
1430 if (PL_doextract || gMacPerl_AlwaysExtract) {
1431#else
f4c556ac 1432 if (PL_doextract) {
bf4acbe4 1433#endif
6224f72b 1434 find_beginning();
f4c556ac
GS		 1435 if (cddir && PerlDir_chdir(cddir) < 0)
1436 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1437
1438 }
6224f72b 1439
3280af22
NIS		 1440 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1441 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1442 CvUNIQUE_on(PL_compcv);
1443
dd2155a4 1444 CvPADLIST(PL_compcv) = pad_new(0);
4d1ff10f 1445#ifdef USE_5005THREADS
533c011a
NIS		 1446 CvOWNER(PL_compcv) = 0;
1447 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1448 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1449#endif /* USE_5005THREADS */
6224f72b 1450
0c4f7ff0 1451 boot_core_PerlIO();
6224f72b 1452 boot_core_UNIVERSAL();
9a34ef1d 1453#ifndef PERL_MICRO
09bef843 1454 boot_core_xsutils();
9a34ef1d 1455#endif
6224f72b
GS		 1456
1457 if (xsinit)
acfe0abc 1458 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1459#ifndef PERL_MICRO
ed79a026 1460#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1461 init_os_extras();
6224f72b 1462#endif
64ca3a65 1463#endif
6224f72b 1464
29209bc5 1465#ifdef USE_SOCKS
1b9c9cf5
DH		 1466# ifdef HAS_SOCKS5_INIT
1467 socks5_init(argv[0]);
1468# else
29209bc5 1469 SOCKSinit(argv[0]);
1b9c9cf5 1470# endif
ac27b0f5 1471#endif
29209bc5 1472
6224f72b
GS		 1473 init_predump_symbols();
1474 /* init_postdump_symbols not currently designed to be called */
1475 /* more than once (ENV isn't cleared first, for example) */
1476 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1477 if (!PL_do_undump)
6224f72b
GS		 1478 init_postdump_symbols(argc,argv,env);
1479
a05d7ebb
JH		 1480 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1481 * PL_utf8locale is conditionally turned on by
085a54d9 1482 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 1483 * look like the user wants to use UTF-8. */
06e66572
JH		 1484 if (PL_unicode) {
1485 /* Requires init_predump_symbols(). */
a05d7ebb 1486 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH		 1487 IO* io;
1488 PerlIO* fp;
1489 SV* sv;
1490
a05d7ebb 1491 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 1492 * and the default open disciplines. */
a05d7ebb
JH		 1493 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1494 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1495 (fp = IoIFP(io)))
1496 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1497 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1498 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1499 (fp = IoOFP(io)))
1500 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1501 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1502 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1503 (fp = IoOFP(io)))
1504 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1505 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1506 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1507 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1508 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1509 if (in) {
1510 if (out)
1511 sv_setpvn(sv, ":utf8\0:utf8", 11);
1512 else
1513 sv_setpvn(sv, ":utf8\0", 6);
1514 }
1515 else if (out)
1516 sv_setpvn(sv, "\0:utf8", 6);
1517 SvSETMAGIC(sv);
1518 }
b310b053
JH		 1519 }
1520 }
1521
4ffa73a3
JH		 1522 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1523 if (strEQ(s, "unsafe"))
1524 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1525 else if (strEQ(s, "safe"))
1526 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1527 else
1528 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1529 }
1530
6224f72b
GS		 1531 init_lexer();
1532
1533 /* now parse the script */
1534
93189314 1535 SETERRNO(0,SS_NORMAL);
3280af22 1536 PL_error_count = 0;
bf4acbe4
GS		 1537#ifdef MACOS_TRADITIONAL
1538 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1539 if (PL_minus_c)
1540 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1541 else {
1542 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1543 MacPerl_MPWFileName(PL_origfilename));
1544 }
1545 }
1546#else
3280af22
NIS		 1547 if (yyparse() || PL_error_count) {
1548 if (PL_minus_c)
cea2e8a9 1549 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1550 else {
cea2e8a9 1551 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1552 PL_origfilename);
6224f72b
GS		 1553 }
1554 }
bf4acbe4 1555#endif
57843af0 1556 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1557 PL_curstash = PL_defstash;
1558 PL_preprocess = FALSE;
1559 if (PL_e_script) {
1560 SvREFCNT_dec(PL_e_script);
1561 PL_e_script = Nullsv;
6224f72b
GS		 1562 }
1563
3280af22 1564 if (PL_do_undump)
6224f72b
GS		 1565 my_unexec();
1566
57843af0
GS		 1567 if (isWARN_ONCE) {
1568 SAVECOPFILE(PL_curcop);
1569 SAVECOPLINE(PL_curcop);
3280af22 1570 gv_check(PL_defstash);
57843af0 1571 }
6224f72b
GS		 1572
1573 LEAVE;
1574 FREETMPS;
1575
1576#ifdef MYMALLOC
1577 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1578 dump_mstats("after compilation:");
1579#endif
1580
1581 ENTER;
3280af22 1582 PL_restartop = 0;
312caa8e 1583 return NULL;
6224f72b
GS		 1584}
1585
954c1994
GS		 1586/*
1587=for apidoc perl_run
1588
1589Tells a Perl interpreter to run. See L<perlembed>.
1590
1591=cut
1592*/
1593
6224f72b 1594int
0cb96387 1595perl_run(pTHXx)
6224f72b 1596{
6224f72b 1597 I32 oldscope;
14dd3ad8 1598 int ret = 0;
db36c5a1 1599 dJMPENV;
4d1ff10f 1600#ifdef USE_5005THREADS
cea2e8a9
GS		 1601 dTHX;
1602#endif
6224f72b 1603
3280af22 1604 oldscope = PL_scopestack_ix;
96e176bf
CL		 1605#ifdef VMS
1606 VMSISH_HUSHED = 0;
1607#endif
6224f72b 1608
14dd3ad8 1609#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1610 redo_body:
14dd3ad8
GS		 1611 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1612#else
1613 JMPENV_PUSH(ret);
1614#endif
6224f72b
GS		 1615 switch (ret) {
1616 case 1:
1617 cxstack_ix = -1; /* start context stack again */
312caa8e 1618 goto redo_body;
14dd3ad8
GS		 1619 case 0: /* normal completion */
1620#ifndef PERL_FLEXIBLE_EXCEPTIONS
1621 redo_body:
1622 run_body(oldscope);
1623#endif
1624 /* FALL THROUGH */
1625 case 2: /* my_exit() */
3280af22 1626 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1627 LEAVE;
1628 FREETMPS;
3280af22 1629 PL_curstash = PL_defstash;
3a1ee7e8 1630 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1631 PL_endav && !PL_minus_c)
1632 call_list(oldscope, PL_endav);
6224f72b
GS		 1633#ifdef MYMALLOC
1634 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1635 dump_mstats("after execution: ");
1636#endif
14dd3ad8
GS		 1637 ret = STATUS_NATIVE_EXPORT;
1638 break;
6224f72b 1639 case 3:
312caa8e
CS		 1640 if (PL_restartop) {
1641 POPSTACK_TO(PL_mainstack);
1642 goto redo_body;
6224f72b 1643 }
bf49b057 1644 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1645 FREETMPS;
14dd3ad8
GS		 1646 ret = 1;
1647 break;
6224f72b
GS		 1648 }
1649
14dd3ad8
GS		 1650 JMPENV_POP;
1651 return ret;
312caa8e
CS		 1652}
1653
14dd3ad8 1654#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1655STATIC void *
14dd3ad8 1656S_vrun_body(pTHX_ va_list args)
312caa8e 1657{
312caa8e
CS		 1658 I32 oldscope = va_arg(args, I32);
1659
14dd3ad8
GS		 1660 return run_body(oldscope);
1661}
1662#endif
1663
1664
1665STATIC void *
1666S_run_body(pTHX_ I32 oldscope)
1667{
6224f72b 1668 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1669 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1670
3280af22 1671 if (!PL_restartop) {
6224f72b
GS		 1672 DEBUG_x(dump_all());
1673 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1674 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1675 PTR2UV(thr)));
6224f72b 1676
3280af22 1677 if (PL_minus_c) {
bf4acbe4 1678#ifdef MACOS_TRADITIONAL
e69a2255
JH		 1679 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1680 (gMacPerl_ErrorFormat ? "# " : ""),
1681 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1682#else
bf49b057 1683 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1684#endif
6224f72b
GS		 1685 my_exit(0);
1686 }
3280af22 1687 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1688 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1689 if (PL_initav)
1690 call_list(oldscope, PL_initav);
6224f72b
GS		 1691 }
1692
1693 /* do it */
1694
3280af22 1695 if (PL_restartop) {
533c011a 1696 PL_op = PL_restartop;
3280af22 1697 PL_restartop = 0;
cea2e8a9 1698 CALLRUNOPS(aTHX);
6224f72b 1699 }
3280af22
NIS		 1700 else if (PL_main_start) {
1701 CvDEPTH(PL_main_cv) = 1;
533c011a 1702 PL_op = PL_main_start;
cea2e8a9 1703 CALLRUNOPS(aTHX);
6224f72b
GS		 1704 }
1705
f6b3007c
JH		 1706 my_exit(0);
1707 /* NOTREACHED */
312caa8e 1708 return NULL;
6224f72b
GS		 1709}
1710
954c1994 1711/*
ccfc67b7
JH		 1712=head1 SV Manipulation Functions
1713
954c1994
GS		 1714=for apidoc p||get_sv
1715
1716Returns the SV of the specified Perl scalar. If C<create> is set and the
1717Perl variable does not exist then it will be created. If C<create> is not
1718set and the variable does not exist then NULL is returned.
1719
1720=cut
1721*/
1722
6224f72b 1723SV*
864dbfa3 1724Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1725{
1726 GV *gv;
4d1ff10f 1727#ifdef USE_5005THREADS
6224f72b
GS		 1728 if (name[1] == '\0' && !isALPHA(name[0])) {
1729 PADOFFSET tmp = find_threadsv(name);
411caa50 1730 if (tmp != NOT_IN_PAD)
6224f72b 1731 return THREADSV(tmp);
6224f72b 1732 }
4d1ff10f 1733#endif /* USE_5005THREADS */
6224f72b
GS		 1734 gv = gv_fetchpv(name, create, SVt_PV);
1735 if (gv)
1736 return GvSV(gv);
1737 return Nullsv;
1738}
1739
954c1994 1740/*
ccfc67b7
JH		 1741=head1 Array Manipulation Functions
1742
954c1994
GS		 1743=for apidoc p||get_av
1744
1745Returns the AV of the specified Perl array. If C<create> is set and the
1746Perl variable does not exist then it will be created. If C<create> is not
1747set and the variable does not exist then NULL is returned.
1748
1749=cut
1750*/
1751
6224f72b 1752AV*
864dbfa3 1753Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1754{
1755 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1756 if (create)
1757 return GvAVn(gv);
1758 if (gv)
1759 return GvAV(gv);
1760 return Nullav;
1761}
1762
954c1994 1763/*
ccfc67b7
JH		 1764=head1 Hash Manipulation Functions
1765
954c1994
GS		 1766=for apidoc p||get_hv
1767
1768Returns the HV of the specified Perl hash. If C<create> is set and the
1769Perl variable does not exist then it will be created. If C<create> is not
1770set and the variable does not exist then NULL is returned.
1771
1772=cut
1773*/
1774
6224f72b 1775HV*
864dbfa3 1776Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1777{
a0d0e21e
LW		 1778 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1779 if (create)
1780 return GvHVn(gv);
1781 if (gv)
1782 return GvHV(gv);
1783 return Nullhv;
1784}
1785
954c1994 1786/*
ccfc67b7
JH		 1787=head1 CV Manipulation Functions
1788
954c1994
GS		 1789=for apidoc p||get_cv
1790
1791Returns the CV of the specified Perl subroutine. If C<create> is set and
1792the Perl subroutine does not exist then it will be declared (which has the
1793same effect as saying C<sub name;>). If C<create> is not set and the
1794subroutine does not exist then NULL is returned.
1795
1796=cut
1797*/
1798
a0d0e21e 1799CV*
864dbfa3 1800Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1801{
1802 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1803 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 1804 /* XXX this is probably not what they think they're getting.
1805 * It has the same effect as "sub name;", i.e. just a forward
1806 * declaration! */
8ebc5c01 1807 if (create && !GvCVu(gv))
774d564b 1808 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1809 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1810 Nullop,
a0d0e21e
LW		 1811 Nullop);
1812 if (gv)
8ebc5c01 1813 return GvCVu(gv);
a0d0e21e
LW		 1814 return Nullcv;
1815}
1816
79072805
LW		 1817/* Be sure to refetch the stack pointer after calling these routines. */
1818
954c1994 1819/*
ccfc67b7
JH		 1820
1821=head1 Callback Functions
1822
954c1994
GS		 1823=for apidoc p||call_argv
1824
1825Performs a callback to the specified Perl sub. See L<perlcall>.
1826
1827=cut
1828*/
1829
a0d0e21e 1830I32
864dbfa3 1831Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 1832
8ac85365
NIS		 1833 /* See G_* flags in cop.h */
1834 /* null terminated arg list */
8990e307 1835{
a0d0e21e 1836 dSP;
8990e307 1837
924508f0 1838 PUSHMARK(SP);
a0d0e21e 1839 if (argv) {
8990e307 1840 while (*argv) {
a0d0e21e 1841 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 1842 argv++;
1843 }
a0d0e21e 1844 PUTBACK;
8990e307 1845 }
864dbfa3 1846 return call_pv(sub_name, flags);
8990e307
LW		 1847}
1848
954c1994
GS		 1849/*
1850=for apidoc p||call_pv
1851
1852Performs a callback to the specified Perl sub. See L<perlcall>.
1853
1854=cut
1855*/
1856
a0d0e21e 1857I32
864dbfa3 1858Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 1859 /* name of the subroutine */
1860 /* See G_* flags in cop.h */
a0d0e21e 1861{
864dbfa3 1862 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 1863}
1864
954c1994
GS		 1865/*
1866=for apidoc p||call_method
1867
1868Performs a callback to the specified Perl method. The blessed object must
1869be on the stack. See L<perlcall>.
1870
1871=cut
1872*/
1873
a0d0e21e 1874I32
864dbfa3 1875Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 1876 /* name of the subroutine */
1877 /* See G_* flags in cop.h */
a0d0e21e 1878{
968b3946 1879 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 1880}
1881
1882/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 1883/*
1884=for apidoc p||call_sv
1885
1886Performs a callback to the Perl sub whose name is in the SV. See
1887L<perlcall>.
1888
1889=cut
1890*/
1891
a0d0e21e 1892I32
864dbfa3 1893Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 1894 /* See G_* flags in cop.h */
a0d0e21e 1895{
924508f0 1896 dSP;
a0d0e21e 1897 LOGOP myop; /* fake syntax tree node */
968b3946 1898 UNOP method_op;
aa689395 1899 I32 oldmark;
13689cfe 1900 volatile I32 retval = 0;
a0d0e21e 1901 I32 oldscope;
54310121 1902 bool oldcatch = CATCH_GET;
6224f72b 1903 int ret;
533c011a 1904 OP* oldop = PL_op;
db36c5a1 1905 dJMPENV;
1e422769 1906
a0d0e21e
LW		 1907 if (flags & G_DISCARD) {
1908 ENTER;
1909 SAVETMPS;
1910 }
1911
aa689395 1912 Zero(&myop, 1, LOGOP);
54310121 1913 myop.op_next = Nullop;
f51d4af5 1914 if (!(flags & G_NOARGS))
aa689395 1915 myop.op_flags |= OPf_STACKED;
54310121 1916 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1917 (flags & G_ARRAY) ? OPf_WANT_LIST :
1918 OPf_WANT_SCALAR);
462e5cf6 1919 SAVEOP();
533c011a 1920 PL_op = (OP*)&myop;
aa689395 1921
3280af22
NIS		 1922 EXTEND(PL_stack_sp, 1);
1923 *++PL_stack_sp = sv;
aa689395 1924 oldmark = TOPMARK;
3280af22 1925 oldscope = PL_scopestack_ix;
a0d0e21e 1926
3280af22 1927 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 1928 /* Handle first BEGIN of -d. */
3280af22 1929 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 1930 /* Try harder, since this may have been a sighandler, thus
1931 * curstash may be meaningless. */
3280af22 1932 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 1933 && !(flags & G_NODEBUG))
533c011a 1934 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1935
968b3946
GS		 1936 if (flags & G_METHOD) {
1937 Zero(&method_op, 1, UNOP);
1938 method_op.op_next = PL_op;
1939 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1940 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 1941 PL_op = (OP*)&method_op;
968b3946
GS		 1942 }
1943
312caa8e 1944 if (!(flags & G_EVAL)) {
0cdb2077 1945 CATCH_SET(TRUE);
14dd3ad8 1946 call_body((OP*)&myop, FALSE);
312caa8e 1947 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 1948 CATCH_SET(oldcatch);
312caa8e
CS		 1949 }
1950 else {
d78bda3d 1951 myop.op_other = (OP*)&myop;
3280af22 1952 PL_markstack_ptr--;
4633a7c4
LW		 1953 /* we're trying to emulate pp_entertry() here */
1954 {
c09156bb 1955 register PERL_CONTEXT *cx;
54310121 1956 I32 gimme = GIMME_V;
ac27b0f5 1957
4633a7c4
LW		 1958 ENTER;
1959 SAVETMPS;
ac27b0f5 1960
968b3946 1961 push_return(Nullop);
1d76a5c3 1962 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 1963 PUSHEVAL(cx, 0, 0);
533c011a 1964 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 1965
faef0170 1966 PL_in_eval = EVAL_INEVAL;
4633a7c4 1967 if (flags & G_KEEPERR)
faef0170 1968 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 1969 else
38a03e6e 1970 sv_setpv(ERRSV,"");
4633a7c4 1971 }
3280af22 1972 PL_markstack_ptr++;
a0d0e21e 1973
14dd3ad8
GS		 1974#ifdef PERL_FLEXIBLE_EXCEPTIONS
1975 redo_body:
1976 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 1977 (OP*)&myop, FALSE);
14dd3ad8
GS		 1978#else
1979 JMPENV_PUSH(ret);
1980#endif
6224f72b
GS		 1981 switch (ret) {
1982 case 0:
14dd3ad8
GS		 1983#ifndef PERL_FLEXIBLE_EXCEPTIONS
1984 redo_body:
1985 call_body((OP*)&myop, FALSE);
1986#endif
312caa8e
CS		 1987 retval = PL_stack_sp - (PL_stack_base + oldmark);
1988 if (!(flags & G_KEEPERR))
1989 sv_setpv(ERRSV,"");
a0d0e21e 1990 break;
6224f72b 1991 case 1:
f86702cc 1992 STATUS_ALL_FAILURE;
a0d0e21e 1993 /* FALL THROUGH */
6224f72b 1994 case 2:
a0d0e21e 1995 /* my_exit() was called */
3280af22 1996 PL_curstash = PL_defstash;
a0d0e21e 1997 FREETMPS;
14dd3ad8 1998 JMPENV_POP;
cc3604b1 1999 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2000 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2001 my_exit_jump();
a0d0e21e 2002 /* NOTREACHED */
6224f72b 2003 case 3:
3280af22 2004 if (PL_restartop) {
533c011a 2005 PL_op = PL_restartop;
3280af22 2006 PL_restartop = 0;
312caa8e 2007 goto redo_body;
a0d0e21e 2008 }
3280af22 2009 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2010 if (flags & G_ARRAY)
2011 retval = 0;
2012 else {
2013 retval = 1;
3280af22 2014 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2015 }
312caa8e 2016 break;
a0d0e21e 2017 }
a0d0e21e 2018
3280af22 2019 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 2020 SV **newsp;
2021 PMOP *newpm;
2022 I32 gimme;
c09156bb 2023 register PERL_CONTEXT *cx;
a0a2876f
LW		 2024 I32 optype;
2025
2026 POPBLOCK(cx,newpm);
2027 POPEVAL(cx);
2028 pop_return();
3280af22 2029 PL_curpm = newpm;
a0a2876f 2030 LEAVE;
a0d0e21e 2031 }
14dd3ad8 2032 JMPENV_POP;
a0d0e21e 2033 }
1e422769 2034
a0d0e21e 2035 if (flags & G_DISCARD) {
3280af22 2036 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2037 retval = 0;
2038 FREETMPS;
2039 LEAVE;
2040 }
533c011a 2041 PL_op = oldop;
a0d0e21e
LW		 2042 return retval;
2043}
2044
14dd3ad8 2045#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2046STATIC void *
14dd3ad8 2047S_vcall_body(pTHX_ va_list args)
312caa8e
CS		 2048{
2049 OP *myop = va_arg(args, OP*);
2050 int is_eval = va_arg(args, int);
2051
14dd3ad8 2052 call_body(myop, is_eval);
312caa8e
CS		 2053 return NULL;
2054}
14dd3ad8 2055#endif
312caa8e
CS		 2056
2057STATIC void
14dd3ad8 2058S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e 2059{
312caa8e
CS		 2060 if (PL_op == myop) {
2061 if (is_eval)
f807eda9 2062 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 2063 else
f807eda9 2064 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 2065 }
2066 if (PL_op)
cea2e8a9 2067 CALLRUNOPS(aTHX);
312caa8e
CS		 2068}
2069
6e72f9df 2070/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2071
954c1994
GS		 2072/*
2073=for apidoc p||eval_sv
2074
2075Tells Perl to C<eval> the string in the SV.
2076
2077=cut
2078*/
2079
a0d0e21e 2080I32
864dbfa3 2081Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2082
8ac85365 2083 /* See G_* flags in cop.h */
a0d0e21e 2084{
924508f0 2085 dSP;
a0d0e21e 2086 UNOP myop; /* fake syntax tree node */
8fa7f367 2087 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2088 volatile I32 retval = 0;
4633a7c4 2089 I32 oldscope;
6224f72b 2090 int ret;
533c011a 2091 OP* oldop = PL_op;
db36c5a1 2092 dJMPENV;
84902520 2093
4633a7c4
LW		 2094 if (flags & G_DISCARD) {
2095 ENTER;
2096 SAVETMPS;
2097 }
2098
462e5cf6 2099 SAVEOP();
533c011a
NIS		 2100 PL_op = (OP*)&myop;
2101 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2102 EXTEND(PL_stack_sp, 1);
2103 *++PL_stack_sp = sv;
2104 oldscope = PL_scopestack_ix;
79072805 2105
4633a7c4
LW		 2106 if (!(flags & G_NOARGS))
2107 myop.op_flags = OPf_STACKED;
79072805 2108 myop.op_next = Nullop;
6e72f9df 2109 myop.op_type = OP_ENTEREVAL;
54310121 2110 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2111 (flags & G_ARRAY) ? OPf_WANT_LIST :
2112 OPf_WANT_SCALAR);
6e72f9df 2113 if (flags & G_KEEPERR)
2114 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2115
14dd3ad8 2116#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2117 redo_body:
14dd3ad8 2118 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 2119 (OP*)&myop, TRUE);
14dd3ad8
GS		 2120#else
2121 JMPENV_PUSH(ret);
2122#endif
6224f72b
GS		 2123 switch (ret) {
2124 case 0:
14dd3ad8
GS		 2125#ifndef PERL_FLEXIBLE_EXCEPTIONS
2126 redo_body:
2127 call_body((OP*)&myop,TRUE);
2128#endif
312caa8e
CS		 2129 retval = PL_stack_sp - (PL_stack_base + oldmark);
2130 if (!(flags & G_KEEPERR))
2131 sv_setpv(ERRSV,"");
4633a7c4 2132 break;
6224f72b 2133 case 1:
f86702cc 2134 STATUS_ALL_FAILURE;
4633a7c4 2135 /* FALL THROUGH */
6224f72b 2136 case 2:
4633a7c4 2137 /* my_exit() was called */
3280af22 2138 PL_curstash = PL_defstash;
4633a7c4 2139 FREETMPS;
14dd3ad8 2140 JMPENV_POP;
cc3604b1 2141 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2142 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2143 my_exit_jump();
4633a7c4 2144 /* NOTREACHED */
6224f72b 2145 case 3:
3280af22 2146 if (PL_restartop) {
533c011a 2147 PL_op = PL_restartop;
3280af22 2148 PL_restartop = 0;
312caa8e 2149 goto redo_body;
4633a7c4 2150 }
3280af22 2151 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2152 if (flags & G_ARRAY)
2153 retval = 0;
2154 else {
2155 retval = 1;
3280af22 2156 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2157 }
312caa8e 2158 break;
4633a7c4
LW		 2159 }
2160
14dd3ad8 2161 JMPENV_POP;
4633a7c4 2162 if (flags & G_DISCARD) {
3280af22 2163 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2164 retval = 0;
2165 FREETMPS;
2166 LEAVE;
2167 }
533c011a 2168 PL_op = oldop;
4633a7c4
LW		 2169 return retval;
2170}
2171
954c1994
GS		 2172/*
2173=for apidoc p||eval_pv
2174
2175Tells Perl to C<eval> the given string and return an SV* result.
2176
2177=cut
2178*/
2179
137443ea 2180SV*
864dbfa3 2181Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2182{
2183 dSP;
2184 SV* sv = newSVpv(p, 0);
2185
864dbfa3 2186 eval_sv(sv, G_SCALAR);
137443ea 2187 SvREFCNT_dec(sv);
2188
2189 SPAGAIN;
2190 sv = POPs;
2191 PUTBACK;
2192
2d8e6c8d
GS		 2193 if (croak_on_error && SvTRUE(ERRSV)) {
2194 STRLEN n_a;
cea2e8a9 2195 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 2196 }
137443ea 2197
2198 return sv;
2199}
2200
4633a7c4
LW		 2201/* Require a module. */
2202
954c1994 2203/*
ccfc67b7
JH		 2204=head1 Embedding Functions
2205
954c1994
GS		 2206=for apidoc p||require_pv
2207
7d3fb230
BS		 2208Tells Perl to C<require> the file named by the string argument. It is
2209analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2210implemented that way; consider using load_module instead.
954c1994 2211
7d3fb230 2212=cut */
954c1994 2213
4633a7c4 2214void
864dbfa3 2215Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2216{
d3acc0f7
JP		 2217 SV* sv;
2218 dSP;
e788e7d3 2219 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2220 PUTBACK;
2221 sv = sv_newmortal();
4633a7c4
LW		 2222 sv_setpv(sv, "require '");
2223 sv_catpv(sv, pv);
2224 sv_catpv(sv, "'");
864dbfa3 2225 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2226 SPAGAIN;
2227 POPSTACK;
79072805
LW		 2228}
2229
79072805 2230void
864dbfa3 2231Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 2232{
2233 register GV *gv;
2234
155aba94 2235 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2236 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2237}
2238
76e3520e 2239STATIC void
cea2e8a9 2240S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 2241{
ab821d7f 2242 /* This message really ought to be max 23 lines.
75c72d73 2243 * Removed -h because the user already knows that option. Others? */
fb73857a 2244
76e3520e 2245 static char *usage_msg[] = {
fb73857a 2246"-0[octal] specify record separator (\\0, if no argument)",
2247"-a autosplit mode with -n or -p (splits $_ into @F)",
46487f74 2248"-C enable native wide character system interfaces",
1950ee41 2249"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS		 2250"-d[:debugger] run program under debugger",
2251"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2252"-e 'command' one line of program (several -e's allowed, omit programfile)",
2253"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2254"-i[extension] edit <> files in place (makes backup if extension supplied)",
2255"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 2256"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 2257"-[mM][-]module execute `use/no module...' before executing program",
2258"-n assume 'while (<>) { ... }' loop around program",
2259"-p assume loop like -n but print line also, like sed",
2260"-P run program through C preprocessor before compilation",
2261"-s enable rudimentary parsing for switches after programfile",
2262"-S look for programfile using PATH environment variable",
2263"-T enable tainting checks",
9cbc33e8 2264"-t enable tainting warnings",
aac3bd0d 2265"-u dump core after parsing program",
fb73857a 2266"-U allow unsafe operations",
aac3bd0d
GS		 2267"-v print version, subversion (includes VERY IMPORTANT perl info)",
2268"-V[:variable] print configuration summary (or a single Config.pm variable)",
2269"-w enable many useful warnings (RECOMMENDED)",
3c0facb2
GS		 2270"-W enable all warnings",
2271"-X disable all warnings",
fb73857a 2272"-x[directory] strip off text before #!perl line and perhaps cd to directory",
2273"\n",
2274NULL
2275};
76e3520e 2276 char **p = usage_msg;
fb73857a 2277
b0e47665
GS		 2278 PerlIO_printf(PerlIO_stdout(),
2279 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2280 name);
fb73857a 2281 while (*p)
b0e47665 2282 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2283}
2284
b4ab917c
DM		 2285/* convert a string of -D options (or digits) into an int.
2286 * sets *s to point to the char after the options */
2287
2288#ifdef DEBUGGING
2289int
2290Perl_get_debug_opts(pTHX_ char **s)
2291{
2292 int i = 0;
2293 if (isALPHA(**s)) {
2294 /* if adding extra options, remember to update DEBUG_MASK */
2295 static char debopts[] = "psltocPmfrxu HXDSTRJvC";
2296
2297 for (; isALNUM(**s); (*s)++) {
2298 char *d = strchr(debopts,**s);
2299 if (d)
2300 i |= 1 << (d - debopts);
2301 else if (ckWARN_d(WARN_DEBUGGING))
2302 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2303 "invalid option -D%c\n", **s);
2304 }
2305 }
2306 else {
2307 i = atoi(*s);
2308 for (; isALNUM(**s); (*s)++) ;
2309 }
2310# ifdef EBCDIC
2311 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2312 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2313 "-Dp not implemented on this platform\n");
2314# endif
2315 return i;
2316}
2317#endif
2318
79072805
LW		 2319/* This routine handles any switches that can be given during run */
2320
2321char *
864dbfa3 2322Perl_moreswitches(pTHX_ char *s)
79072805 2323{
ba210ebe 2324 STRLEN numlen;
84c133a0 2325 UV rschar;
79072805
LW		 2326
2327 switch (*s) {
2328 case '0':
a863c7d1 2329 {
f2095865
JH		 2330 I32 flags = 0;
2331
2332 SvREFCNT_dec(PL_rs);
2333 if (s[1] == 'x' && s[2]) {
2334 char *e;
2335 U8 *tmps;
2336
2337 for (s += 2, e = s; *e; e++);
2338 numlen = e - s;
2339 flags = PERL_SCAN_SILENT_ILLDIGIT;
2340 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2341 if (s + numlen < e) {
2342 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2343 numlen = 0;
2344 s--;
2345 }
2346 PL_rs = newSVpvn("", 0);
c5661c80 2347 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 2348 tmps = (U8*)SvPVX(PL_rs);
2349 uvchr_to_utf8(tmps, rschar);
2350 SvCUR_set(PL_rs, UNISKIP(rschar));
2351 SvUTF8_on(PL_rs);
2352 }
2353 else {
2354 numlen = 4;
2355 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2356 if (rschar & ~((U8)~0))
2357 PL_rs = &PL_sv_undef;
2358 else if (!rschar && numlen >= 2)
2359 PL_rs = newSVpvn("", 0);
2360 else {
2361 char ch = (char)rschar;
2362 PL_rs = newSVpvn(&ch, 1);
2363 }
2364 }
2365 return s + numlen;
a863c7d1 2366 }
46487f74 2367 case 'C':
a05d7ebb
JH		 2368 s++;
2369 PL_unicode = parse_unicode_opts(&s);
46487f74 2370 return s;
2304df62 2371 case 'F':
3280af22 2372 PL_minus_F = TRUE;
ebce5377
RGS		 2373 PL_splitstr = ++s;
2374 while (*s && !isSPACE(*s)) ++s;
2375 *s = '\0';
2376 PL_splitstr = savepv(PL_splitstr);
2304df62 2377 return s;
79072805 2378 case 'a':
3280af22 2379 PL_minus_a = TRUE;
79072805
LW		 2380 s++;
2381 return s;
2382 case 'c':
3280af22 2383 PL_minus_c = TRUE;
79072805
LW		 2384 s++;
2385 return s;
2386 case 'd':
bbce6d69 2387 forbid_setid("-d");
4633a7c4 2388 s++;
70c94a19
RR		 2389 /* The following permits -d:Mod to accepts arguments following an =
2390 in the fashion that -MSome::Mod does. */
2391 if (*s == ':' || *s == '=') {
2392 char *start;
2393 SV *sv;
2394 sv = newSVpv("use Devel::", 0);
2395 start = ++s;
2396 /* We now allow -d:Module=Foo,Bar */
2397 while(isALNUM(*s) || *s==':') ++s;
2398 if (*s != '=')
2399 sv_catpv(sv, start);
2400 else {
2401 sv_catpvn(sv, start, s-start);
2402 sv_catpv(sv, " split(/,/,q{");
2403 sv_catpv(sv, ++s);
2404 sv_catpv(sv, "})");
2405 }
4633a7c4 2406 s += strlen(s);
70c94a19 2407 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2408 }
ed094faf 2409 if (!PL_perldb) {
3280af22 2410 PL_perldb = PERLDB_ALL;
a0d0e21e 2411 init_debugger();
ed094faf 2412 }
79072805
LW		 2413 return s;
2414 case 'D':
0453d815 2415 {
79072805 2416#ifdef DEBUGGING
bbce6d69 2417 forbid_setid("-D");
b4ab917c
DM		 2418 s++;
2419 PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
12a43e32 2420#else /* !DEBUGGING */
0453d815 2421 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2422 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
0453d815 2423 "Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 2424 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2425#endif
2426 /*SUPPRESS 530*/
2427 return s;
0453d815 2428 }
4633a7c4 2429 case 'h':
ac27b0f5 2430 usage(PL_origargv[0]);
7ca617d0 2431 my_exit(0);
79072805 2432 case 'i':
3280af22
NIS		 2433 if (PL_inplace)
2434 Safefree(PL_inplace);
c030f24b
GH		 2435#if defined(__CYGWIN__) /* do backup extension automagically */
2436 if (*(s+1) == '\0') {
2437 PL_inplace = savepv(".bak");
2438 return s+1;
2439 }
2440#endif /* __CYGWIN__ */
3280af22 2441 PL_inplace = savepv(s+1);
79072805 2442 /*SUPPRESS 530*/
3280af22 2443 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2444 if (*s) {
fb73857a 2445 *s++ = '\0';
7b8d334a
GS		 2446 if (*s == '-') /* Additional switches on #! line. */
2447 s++;
2448 }
fb73857a 2449 return s;
4e49a025 2450 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2451 forbid_setid("-I");
fb73857a 2452 ++s;
2453 while (*s && isSPACE(*s))
2454 ++s;
2455 if (*s) {
774d564b 2456 char *e, *p;
0df16ed7
GS		 2457 p = s;
2458 /* ignore trailing spaces (possibly followed by other switches) */
2459 do {
2460 for (e = p; *e && !isSPACE(*e); e++) ;
2461 p = e;
2462 while (isSPACE(*p))
2463 p++;
2464 } while (*p && *p != '-');
2465 e = savepvn(s, e-s);
574c798a 2466 incpush(e, TRUE, TRUE, FALSE);
0df16ed7
GS		 2467 Safefree(e);
2468 s = p;
2469 if (*s == '-')
2470 s++;
79072805
LW		 2471 }
2472 else
a67e862a 2473 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2474 return s;
79072805 2475 case 'l':
3280af22 2476 PL_minus_l = TRUE;
79072805 2477 s++;
7889fe52
NIS		 2478 if (PL_ors_sv) {
2479 SvREFCNT_dec(PL_ors_sv);
2480 PL_ors_sv = Nullsv;
2481 }
79072805 2482 if (isDIGIT(*s)) {
53305cf1 2483 I32 flags = 0;
7889fe52 2484 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2485 numlen = 3 + (*s == '0');
2486 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2487 s += numlen;
2488 }
2489 else {
8bfdd7d9 2490 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2491 PL_ors_sv = newSVpvn("\n\n",2);
2492 }
2493 else {
8bfdd7d9 2494 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2495 }
79072805
LW		 2496 }
2497 return s;
06492da6
SF		 2498 case 'A':
2499 forbid_setid("-A");
930366bd
RGS		 2500 if (!PL_preambleav)
2501 PL_preambleav = newAV();
06492da6 2502 if (*++s) {
930366bd 2503 SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37);
06492da6
SF		 2504 sv_catpv(sv,s);
2505 sv_catpv(sv,"})");
2506 s+=strlen(s);
06492da6
SF		 2507 av_push(PL_preambleav, sv);
2508 }
2509 else
930366bd 2510 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
06492da6 2511 return s;
1a30305b 2512 case 'M':
bbce6d69 2513 forbid_setid("-M"); /* XXX ? */
1a30305b 2514 /* FALL THROUGH */
2515 case 'm':
bbce6d69 2516 forbid_setid("-m"); /* XXX ? */
1a30305b 2517 if (*++s) {
a5f75d66 2518 char *start;
11343788 2519 SV *sv;
a5f75d66
AD		 2520 char *use = "use ";
2521 /* -M-foo == 'no foo' */
2522 if (*s == '-') { use = "no "; ++s; }
11343788 2523 sv = newSVpv(use,0);
a5f75d66 2524 start = s;
1a30305b 2525 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2526 while(isALNUM(*s) || *s==':') ++s;
2527 if (*s != '=') {
11343788 2528 sv_catpv(sv, start);
c07a80fd 2529 if (*(start-1) == 'm') {
2530 if (*s != '\0')
cea2e8a9 2531 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2532 sv_catpv( sv, " ()");
c07a80fd 2533 }
2534 } else {
6df41af2 2535 if (s == start)
be98fb35
GS		 2536 Perl_croak(aTHX_ "Module name required with -%c option",
2537 s[-1]);
11343788
MB		 2538 sv_catpvn(sv, start, s-start);
2539 sv_catpv(sv, " split(/,/,q{");
2540 sv_catpv(sv, ++s);
2541 sv_catpv(sv, "})");
c07a80fd 2542 }
1a30305b 2543 s += strlen(s);
5c831c24 2544 if (!PL_preambleav)
3280af22
NIS		 2545 PL_preambleav = newAV();
2546 av_push(PL_preambleav, sv);
1a30305b 2547 }
2548 else
cea2e8a9 2549 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2550 return s;
79072805 2551 case 'n':
3280af22 2552 PL_minus_n = TRUE;
79072805
LW		 2553 s++;
2554 return s;
2555 case 'p':
3280af22 2556 PL_minus_p = TRUE;
79072805
LW		 2557 s++;
2558 return s;
2559 case 's':
bbce6d69 2560 forbid_setid("-s");
3280af22 2561 PL_doswitches = TRUE;
79072805
LW		 2562 s++;
2563 return s;
6537fe72
MS		 2564 case 't':
2565 if (!PL_tainting)
22f7c9c9 2566 TOO_LATE_FOR('t');
6537fe72
MS		 2567 s++;
2568 return s;
463ee0b2 2569 case 'T':
3280af22 2570 if (!PL_tainting)
22f7c9c9 2571 TOO_LATE_FOR('T');
463ee0b2
LW		 2572 s++;
2573 return s;
79072805 2574 case 'u':
bf4acbe4
GS		 2575#ifdef MACOS_TRADITIONAL
2576 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2577#endif
3280af22 2578 PL_do_undump = TRUE;
79072805
LW		 2579 s++;
2580 return s;
2581 case 'U':
3280af22 2582 PL_unsafe = TRUE;
79072805
LW		 2583 s++;
2584 return s;
2585 case 'v':
8e9464f1 2586#if !defined(DGUX)
b0e47665 2587 PerlIO_printf(PerlIO_stdout(),
d2560b70 2588 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
b0e47665 2589 PL_patchlevel, ARCHNAME));
8e9464f1
JH		 2590#else /* DGUX */
2591/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2592 PerlIO_printf(PerlIO_stdout(),
2593 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2594 PerlIO_printf(PerlIO_stdout(),
2595 Perl_form(aTHX_ " built under %s at %s %s\n",
2596 OSNAME, __DATE__, __TIME__));
2597 PerlIO_printf(PerlIO_stdout(),
2598 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2599 OSVERS));
8e9464f1
JH		 2600#endif /* !DGUX */
2601
fb73857a 2602#if defined(LOCAL_PATCH_COUNT)
2603 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2604 PerlIO_printf(PerlIO_stdout(),
2605 "\n(with %d registered patch%s, "
2606 "see perl -V for more detail)",
2607 (int)LOCAL_PATCH_COUNT,
2608 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2609#endif
1a30305b 2610
b0e47665 2611 PerlIO_printf(PerlIO_stdout(),
4c79ee7a 2612 "\n\nCopyright 1987-2003, Larry Wall\n");
eae9c151
JH		 2613#ifdef MACOS_TRADITIONAL
2614 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2615 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2616 "maintained by Chris Nandor\n");
eae9c151 2617#endif
79072805 2618#ifdef MSDOS
b0e47665
GS		 2619 PerlIO_printf(PerlIO_stdout(),
2620 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2621#endif
2622#ifdef DJGPP
b0e47665
GS		 2623 PerlIO_printf(PerlIO_stdout(),
2624 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2625 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2626#endif
79072805 2627#ifdef OS2
b0e47665
GS		 2628 PerlIO_printf(PerlIO_stdout(),
2629 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2630 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2631#endif
79072805 2632#ifdef atarist
b0e47665
GS		 2633 PerlIO_printf(PerlIO_stdout(),
2634 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2635#endif
a3f9223b 2636#ifdef __BEOS__
b0e47665
GS		 2637 PerlIO_printf(PerlIO_stdout(),
2638 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2639#endif
1d84e8df 2640#ifdef MPE
b0e47665 2641 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2642 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
1d84e8df 2643#endif
9d116dd7 2644#ifdef OEMVS
b0e47665
GS		 2645 PerlIO_printf(PerlIO_stdout(),
2646 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2647#endif
495c5fdc 2648#ifdef __VOS__
b0e47665 2649 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2650 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2651#endif
092bebab 2652#ifdef __OPEN_VM
b0e47665
GS		 2653 PerlIO_printf(PerlIO_stdout(),
2654 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2655#endif
a1a0e61e 2656#ifdef POSIX_BC
b0e47665
GS		 2657 PerlIO_printf(PerlIO_stdout(),
2658 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2659#endif
61ae2fbf 2660#ifdef __MINT__
b0e47665
GS		 2661 PerlIO_printf(PerlIO_stdout(),
2662 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2663#endif
f83d2536 2664#ifdef EPOC
b0e47665 2665 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2666 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2667#endif
e1caacb4 2668#ifdef UNDER_CE
b475b3e6
JH		 2669 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2670 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2671 wce_hitreturn();
2672#endif
baed7233
DL		 2673#ifdef BINARY_BUILD_NOTICE
2674 BINARY_BUILD_NOTICE;
2675#endif
b0e47665
GS		 2676 PerlIO_printf(PerlIO_stdout(),
2677 "\n\
79072805 2678Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2679GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2680Complete documentation for Perl, including FAQ lists, should be found on\n\
2681this system using `man perl' or `perldoc perl'. If you have access to the\n\
2682Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
7ca617d0 2683 my_exit(0);
79072805 2684 case 'w':
599cee73 2685 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2686 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2687 s++;
2688 return s;
2689 case 'W':
ac27b0f5 2690 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2691 if (!specialWARN(PL_compiling.cop_warnings))
2692 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2693 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2694 s++;
2695 return s;
2696 case 'X':
ac27b0f5 2697 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2698 if (!specialWARN(PL_compiling.cop_warnings))
2699 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2700 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2701 s++;
2702 return s;
a0d0e21e 2703 case '*':
79072805
LW		 2704 case ' ':
2705 if (s[1] == '-') /* Additional switches on #! line. */
2706 return s+2;
2707 break;
a0d0e21e 2708 case '-':
79072805 2709 case 0:
51882d45 2710#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2711 case '\r':
2712#endif
79072805
LW		 2713 case '\n':
2714 case '\t':
2715 break;
aa689395 2716#ifdef ALTERNATE_SHEBANG
2717 case 'S': /* OS/2 needs -S on "extproc" line. */
2718 break;
2719#endif
a0d0e21e 2720 case 'P':
3280af22 2721 if (PL_preprocess)
a0d0e21e
LW		 2722 return s+1;
2723 /* FALL THROUGH */
79072805 2724 default:
cea2e8a9 2725 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2726 }
2727 return Nullch;
2728}
2729
2730/* compliments of Tom Christiansen */
2731
2732/* unexec() can be found in the Gnu emacs distribution */
ee580363 2733/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2734
2735void
864dbfa3 2736Perl_my_unexec(pTHX)
79072805
LW		 2737{
2738#ifdef UNEXEC
46fc3d4c 2739 SV* prog;
2740 SV* file;
ee580363 2741 int status = 1;
79072805
LW		 2742 extern int etext;
2743
ee580363 2744 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2745 sv_catpv(prog, "/perl");
6b88bc9c 2746 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2747 sv_catpv(file, ".perldump");
79072805 2748
ee580363
GS		 2749 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2750 /* unexec prints msg to stderr in case of failure */
6ad3d225 2751 PerlProc_exit(status);
79072805 2752#else
a5f75d66
AD		 2753# ifdef VMS
2754# include <lib$routines.h>
2755 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2756# else
79072805 2757 ABORT(); /* for use with undump */
aa689395 2758# endif
a5f75d66 2759#endif
79072805
LW		 2760}
2761
cb68f92d
GS		 2762/* initialize curinterp */
2763STATIC void
cea2e8a9 2764S_init_interp(pTHX)
cb68f92d
GS		 2765{
2766
acfe0abc
GS		 2767#ifdef MULTIPLICITY
2768# define PERLVAR(var,type)
2769# define PERLVARA(var,n,type)
2770# if defined(PERL_IMPLICIT_CONTEXT)
2771# if defined(USE_5005THREADS)
2772# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2773# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2774# else /* !USE_5005THREADS */
2775# define PERLVARI(var,type,init) aTHX->var = init;
2776# define PERLVARIC(var,type,init) aTHX->var = init;
2777# endif /* USE_5005THREADS */
3967c732 2778# else
acfe0abc
GS		 2779# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2780# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2781# endif
acfe0abc
GS		 2782# include "intrpvar.h"
2783# ifndef USE_5005THREADS
2784# include "thrdvar.h"
2785# endif
2786# undef PERLVAR
2787# undef PERLVARA
2788# undef PERLVARI
2789# undef PERLVARIC
2790#else
2791# define PERLVAR(var,type)
2792# define PERLVARA(var,n,type)
2793# define PERLVARI(var,type,init) PL_##var = init;
2794# define PERLVARIC(var,type,init) PL_##var = init;
2795# include "intrpvar.h"
2796# ifndef USE_5005THREADS
2797# include "thrdvar.h"
2798# endif
2799# undef PERLVAR
2800# undef PERLVARA
2801# undef PERLVARI
2802# undef PERLVARIC
cb68f92d
GS		 2803#endif
2804
cb68f92d
GS		 2805}
2806
76e3520e 2807STATIC void
cea2e8a9 2808S_init_main_stash(pTHX)
79072805 2809{
463ee0b2 2810 GV *gv;
6e72f9df 2811
3280af22 2812 PL_curstash = PL_defstash = newHV();
79cb57f6 2813 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2814 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2815 SvREFCNT_dec(GvHV(gv));
3280af22 2816 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2817 SvREADONLY_on(gv);
3280af22
NIS		 2818 HvNAME(PL_defstash) = savepv("main");
2819 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2820 GvMULTI_on(PL_incgv);
2821 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2822 GvMULTI_on(PL_hintgv);
2823 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2824 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2825 GvMULTI_on(PL_errgv);
2826 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2827 GvMULTI_on(PL_replgv);
cea2e8a9 2828 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2829 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2830 sv_setpvn(ERRSV, "", 0);
3280af22 2831 PL_curstash = PL_defstash;
11faa288 2832 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2833 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2834 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2835 /* We must init $/ before switches are processed. */
864dbfa3 2836 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2837}
2838
76e3520e 2839STATIC void
cea2e8a9 2840S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2841{
1b24ed4b
MS		 2842 char *quote;
2843 char *code;
2844 char *cpp_discard_flag;
2845 char *perl;
2846
6c4ab083 2847 *fdscript = -1;
79072805 2848
3280af22
NIS		 2849 if (PL_e_script) {
2850 PL_origfilename = savepv("-e");
96436eeb 2851 }
6c4ab083
GS		 2852 else {
2853 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2854 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2855
2856 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2857 char *s = scriptname + 8;
2858 *fdscript = atoi(s);
2859 while (isDIGIT(*s))
2860 s++;
2861 if (*s) {
2862 scriptname = savepv(s + 1);
3280af22
NIS		 2863 Safefree(PL_origfilename);
2864 PL_origfilename = scriptname;
6c4ab083
GS		 2865 }
2866 }
2867 }
2868
05ec9bb3 2869 CopFILE_free(PL_curcop);
57843af0 2870 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2871 if (strEQ(PL_origfilename,"-"))
79072805 2872 scriptname = "";
01f988be 2873 if (*fdscript >= 0) {
3280af22 2874 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2875# if defined(HAS_FCNTL) && defined(F_SETFD)
2876 if (PL_rsfp)
2877 /* ensure close-on-exec */
2878 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2879# endif
96436eeb 2880 }
3280af22 2881 else if (PL_preprocess) {
46fc3d4c 2882 char *cpp_cfg = CPPSTDIN;
79cb57f6 2883 SV *cpp = newSVpvn("",0);
46fc3d4c 2884 SV *cmd = NEWSV(0,0);
2885
2886 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2887 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2888 sv_catpv(cpp, cpp_cfg);
79072805 2889
1b24ed4b
MS		 2890# ifndef VMS
2891 sv_catpvn(sv, "-I", 2);
2892 sv_catpv(sv,PRIVLIB_EXP);
2893# endif
46fc3d4c 2894
14953ddc
MB		 2895 DEBUG_P(PerlIO_printf(Perl_debug_log,
2896 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2897 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 2898
2899# if defined(MSDOS) || defined(WIN32) || defined(VMS)
2900 quote = "\"";
2901# else
2902 quote = "'";
2903# endif
2904
2905# ifdef VMS
2906 cpp_discard_flag = "";
2907# else
2908 cpp_discard_flag = "-C";
2909# endif
2910
2911# ifdef OS2
2912 perl = os2_execname(aTHX);
2913# else
2914 perl = PL_origargv[0];
2915# endif
2916
2917
2918 /* This strips off Perl comments which might interfere with
62375a60
NIS		 2919 the C pre-processor, including #!. #line directives are
2920 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 2921 of #line. FWP played some golf with it so it will fit
2922 into VMS's 255 character buffer.
2923 */
2924 if( PL_doextract )
2925 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2926 else
2927 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2928
2929 Perl_sv_setpvf(aTHX_ cmd, "\
2930%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 2931 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 2932 cpp_discard_flag, sv, CPPMINUS);
2933
3280af22 2934 PL_doextract = FALSE;
1b24ed4b
MS		 2935# ifdef IAMSUID /* actually, this is caught earlier */
2936 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2937# ifdef HAS_SETEUID
2938 (void)seteuid(PL_uid); /* musn't stay setuid root */
2939# else
2940# ifdef HAS_SETREUID
2941 (void)setreuid((Uid_t)-1, PL_uid);
2942# else
2943# ifdef HAS_SETRESUID
2944 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2945# else
2946 PerlProc_setuid(PL_uid);
2947# endif
2948# endif
2949# endif
b28d0864 2950 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2951 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805 2952 }
1b24ed4b 2953# endif /* IAMSUID */
0a6c758d 2954
62375a60
NIS		 2955 DEBUG_P(PerlIO_printf(Perl_debug_log,
2956 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 2957 SvPVX(cmd)));
2958
3280af22 2959 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2960 SvREFCNT_dec(cmd);
2961 SvREFCNT_dec(cpp);
79072805
LW		 2962 }
2963 else if (!*scriptname) {
bbce6d69 2964 forbid_setid("program input from stdin");
3280af22 2965 PL_rsfp = PerlIO_stdin();
79072805 2966 }
96436eeb 2967 else {
3280af22 2968 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2969# if defined(HAS_FCNTL) && defined(F_SETFD)
2970 if (PL_rsfp)
2971 /* ensure close-on-exec */
2972 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2973# endif
96436eeb 2974 }
3280af22 2975 if (!PL_rsfp) {
1b24ed4b
MS		 2976# ifdef DOSUID
2977# ifndef IAMSUID /* in case script is not readable before setuid */
2978 if (PL_euid &&
2979 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2980 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2981 {
2982 /* try again */
62375a60
NIS		 2983 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2984 BIN_EXP, (int)PERL_REVISION,
1b24ed4b
MS		 2985 (int)PERL_VERSION,
2986 (int)PERL_SUBVERSION), PL_origargv);
2987 Perl_croak(aTHX_ "Can't do setuid\n");
2988 }
2989# endif
2990# endif
2991# ifdef IAMSUID
2992 errno = EPERM;
2993 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2994 Strerror(errno));
2995# else
2996 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2997 CopFILE(PL_curcop), Strerror(errno));
2998# endif
13281fa4 2999 }
79072805 3000}
8d063cd8 3001
7b89560d
JH		 3002/* Mention
3003 * I_SYSSTATVFS HAS_FSTATVFS
3004 * I_SYSMOUNT
c890dc6c 3005 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3006 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3007 * here so that metaconfig picks them up. */
3008
104d25b7 3009#ifdef IAMSUID
864dbfa3 3010STATIC int
e688b231 3011S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 3012{
0545a864
JH		 3013 int check_okay = 0; /* able to do all the required sys/libcalls */
3014 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 3015/*
ad27e871 3016 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 3017 * fstatvfs() is UNIX98.
0545a864 3018 * fstatfs() is 4.3 BSD.
ad27e871 3019 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 3020 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3021 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 3022 */
3023
6439433f
JH		 3024#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3025
3026# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3027 defined(HAS_FSTATVFS)
3028# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 3029 struct statvfs stfs;
6439433f 3030
104d25b7
JH		 3031 check_okay = fstatvfs(fd, &stfs) == 0;
3032 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
6439433f 3033# endif /* fstatvfs */
ac27b0f5 3034
6439433f
JH		 3035# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3036 defined(PERL_MOUNT_NOSUID) && \
3037 defined(HAS_FSTATFS) && \
3038 defined(HAS_STRUCT_STATFS) && \
3039 defined(HAS_STRUCT_STATFS_F_FLAGS)
3040# define FD_ON_NOSUID_CHECK_OKAY
e688b231 3041 struct statfs stfs;
6439433f 3042
104d25b7 3043 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 3044 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
6439433f
JH		 3045# endif /* fstatfs */
3046
3047# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3048 defined(PERL_MOUNT_NOSUID) && \
3049 defined(HAS_FSTAT) && \
3050 defined(HAS_USTAT) && \
3051 defined(HAS_GETMNT) && \
3052 defined(HAS_STRUCT_FS_DATA) && \
3053 defined(NOSTAT_ONE)
3054# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 3055 Stat_t fdst;
6439433f 3056
0545a864 3057 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 3058 struct ustat us;
3059 if (ustat(fdst.st_dev, &us) == 0) {
3060 struct fs_data fsd;
3061 /* NOSTAT_ONE here because we're not examining fields which
3062 * vary between that case and STAT_ONE. */
ad27e871 3063 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3064 size_t cmplen = sizeof(us.f_fname);
3065 if (sizeof(fsd.fd_req.path) < cmplen)
3066 cmplen = sizeof(fsd.fd_req.path);
3067 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3068 fdst.st_dev == fsd.fd_req.dev) {
3069 check_okay = 1;
3070 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3071 }
3072 }
3073 }
3074 }
0545a864 3075 }
6439433f
JH		 3076# endif /* fstat+ustat+getmnt */
3077
3078# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3079 defined(HAS_GETMNTENT) && \
3080 defined(HAS_HASMNTOPT) && \
3081 defined(MNTOPT_NOSUID)
3082# define FD_ON_NOSUID_CHECK_OKAY
3083 FILE *mtab = fopen("/etc/mtab", "r");
3084 struct mntent *entry;
c623ac67 3085 Stat_t stb, fsb;
104d25b7
JH		 3086
3087 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3088 while (entry = getmntent(mtab)) {
3089 if (stat(entry->mnt_dir, &fsb) == 0
3090 && fsb.st_dev == stb.st_dev)
3091 {
3092 /* found the filesystem */
3093 check_okay = 1;
3094 if (hasmntopt(entry, MNTOPT_NOSUID))
3095 on_nosuid = 1;
3096 break;
3097 } /* A single fs may well fail its stat(). */
3098 }
104d25b7
JH		 3099 }
3100 if (mtab)
6439433f
JH		 3101 fclose(mtab);
3102# endif /* getmntent+hasmntopt */
0545a864 3103
ac27b0f5 3104 if (!check_okay)
0545a864 3105 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 3106 return on_nosuid;
3107}
3108#endif /* IAMSUID */
3109
76e3520e 3110STATIC void
cea2e8a9 3111S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 3112{
155aba94 3113#ifdef IAMSUID
96436eeb 3114 int which;
155aba94 3115#endif
96436eeb 3116
13281fa4
LW		 3117 /* do we need to emulate setuid on scripts? */
3118
3119 /* This code is for those BSD systems that have setuid #! scripts disabled
3120 * in the kernel because of a security problem. Merely defining DOSUID
3121 * in perl will not fix that problem, but if you have disabled setuid
3122 * scripts in the kernel, this will attempt to emulate setuid and setgid
3123 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3124 * root version must be called suidperl or sperlN.NNN. If regular perl
3125 * discovers that it has opened a setuid script, it calls suidperl with
3126 * the same argv that it had. If suidperl finds that the script it has
3127 * just opened is NOT setuid root, it sets the effective uid back to the
3128 * uid. We don't just make perl setuid root because that loses the
3129 * effective uid we had before invoking perl, if it was different from the
3130 * uid.
13281fa4
LW		 3131 *
3132 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3133 * be defined in suidperl only. suidperl must be setuid root. The
3134 * Configure script will set this up for you if you want it.
3135 */
a687059c 3136
13281fa4 3137#ifdef DOSUID
6e72f9df 3138 char *s, *s2;
a0d0e21e 3139
b28d0864 3140 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3141 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 3142 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3143 I32 len;
2d8e6c8d 3144 STRLEN n_a;
13281fa4 3145
a687059c 3146#ifdef IAMSUID
fe14fcc3 3147#ifndef HAS_SETREUID
a687059c
LW		 3148 /* On this access check to make sure the directories are readable,
3149 * there is actually a small window that the user could use to make
3150 * filename point to an accessible directory. So there is a faint
3151 * chance that someone could execute a setuid script down in a
3152 * non-accessible directory. I don't know what to do about that.
3153 * But I don't think it's too important. The manual lies when
3154 * it says access() is useful in setuid programs.
3155 */
cc49e20b 3156 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 3157 Perl_croak(aTHX_ "Permission denied");
a687059c
LW		 3158#else
3159 /* If we can swap euid and uid, then we can determine access rights
3160 * with a simple stat of the file, and then compare device and
3161 * inode to make sure we did stat() on the same file we opened.
3162 * Then we just have to make sure he or she can execute it.
3163 */
3164 {
c623ac67 3165 Stat_t tmpstatbuf;
a687059c 3166
85e6fe83
LW		 3167 if (
3168#ifdef HAS_SETREUID
b28d0864 3169 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 3170#else
3171# if HAS_SETRESUID
b28d0864 3172 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 3173# endif
85e6fe83 3174#endif
b28d0864 3175 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 3176 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 3177 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 3178 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 3179#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 3180 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 3181 Perl_croak(aTHX_ "Permission denied");
104d25b7 3182#endif
b28d0864
NIS		 3183 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3184 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3185 (void)PerlIO_close(PL_rsfp);
cea2e8a9 3186 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3187 }
85e6fe83
LW		 3188 if (
3189#ifdef HAS_SETREUID
b28d0864 3190 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 3191#else
3192# if defined(HAS_SETRESUID)
b28d0864 3193 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 3194# endif
85e6fe83 3195#endif
b28d0864 3196 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 3197 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 3198 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 3199 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3200 }
fe14fcc3 3201#endif /* HAS_SETREUID */
a687059c
LW		 3202#endif /* IAMSUID */
3203
b28d0864 3204 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 3205 Perl_croak(aTHX_ "Permission denied");
b28d0864 3206 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3207 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3208 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 3209 CopLINE_inc(PL_curcop);
6b88bc9c 3210 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3211 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3212 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3213 s = SvPV(PL_linestr,n_a)+2;
663a0e37 3214 if (*s == ' ') s++;
45d8adaa 3215 while (!isSPACE(*s)) s++;
2d8e6c8d 3216 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3217 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3218 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 3219 Perl_croak(aTHX_ "Not a perl script");
a687059c 3220 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3221 /*
3222 * #! arg must be what we saw above. They can invoke it by
3223 * mentioning suidperl explicitly, but they may not add any strange
3224 * arguments beyond what #! says if they do invoke suidperl that way.
3225 */
3226 len = strlen(validarg);
3227 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 3228 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 3229 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3230
3231#ifndef IAMSUID
b28d0864
NIS		 3232 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3233 PL_euid == PL_statbuf.st_uid)
3234 if (!PL_do_undump)
cea2e8a9 3235 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3236FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3237#endif /* IAMSUID */
13281fa4 3238
b28d0864
NIS		 3239 if (PL_euid) { /* oops, we're not the setuid root perl */
3240 (void)PerlIO_close(PL_rsfp);
13281fa4 3241#ifndef IAMSUID
46fc3d4c 3242 /* try again */
a7cb1f99 3243 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3244 (int)PERL_REVISION, (int)PERL_VERSION,
3245 (int)PERL_SUBVERSION), PL_origargv);
13281fa4 3246#endif
cea2e8a9 3247 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 3248 }
3249
b28d0864 3250 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 3251#ifdef HAS_SETEGID
b28d0864 3252 (void)setegid(PL_statbuf.st_gid);
a687059c 3253#else
fe14fcc3 3254#ifdef HAS_SETREGID
b28d0864 3255 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3256#else
3257#ifdef HAS_SETRESGID
b28d0864 3258 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3259#else
b28d0864 3260 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3261#endif
3262#endif
85e6fe83 3263#endif
b28d0864 3264 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3265 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3266 }
b28d0864
NIS		 3267 if (PL_statbuf.st_mode & S_ISUID) {
3268 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3269#ifdef HAS_SETEUID
b28d0864 3270 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3271#else
fe14fcc3 3272#ifdef HAS_SETREUID
b28d0864 3273 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3274#else
3275#ifdef HAS_SETRESUID
b28d0864 3276 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3277#else
b28d0864 3278 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3279#endif
3280#endif
85e6fe83 3281#endif
b28d0864 3282 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3283 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3284 }
b28d0864 3285 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3286#ifdef HAS_SETEUID
b28d0864 3287 (void)seteuid((Uid_t)PL_uid);
a687059c 3288#else
fe14fcc3 3289#ifdef HAS_SETREUID
b28d0864 3290 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3291#else
85e6fe83 3292#ifdef HAS_SETRESUID
b28d0864 3293 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3294#else
b28d0864 3295 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3296#endif
a687059c
LW		 3297#endif
3298#endif
b28d0864 3299 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3300 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3301 }
748a9306 3302 init_ids();
b28d0864 3303 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 3304 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 3305 }
3306#ifdef IAMSUID
6b88bc9c 3307 else if (PL_preprocess)
cea2e8a9 3308 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 3309 else if (fdscript >= 0)
cea2e8a9 3310 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 3311 else
cea2e8a9 3312 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb 3313
3314 /* We absolutely must clear out any saved ids here, so we */
3315 /* exec the real perl, substituting fd script for scriptname. */
3316 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 3317 PerlIO_rewind(PL_rsfp);
3318 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS		 3319 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3320 if (!PL_origargv[which])
cea2e8a9
GS		 3321 Perl_croak(aTHX_ "Permission denied");
3322 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 3323 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 3324#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3325 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3326#endif
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 */
cea2e8a9 3330 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 3331#endif /* IAMSUID */
a687059c 3332#else /* !DOSUID */
3280af22 3333 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3334#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3335 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3336 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3337 ||
b28d0864 3338 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3339 )
b28d0864 3340 if (!PL_do_undump)
cea2e8a9 3341 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3342FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3343#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3344 /* not set-id, must be wrapped */
a687059c 3345 }
13281fa4 3346#endif /* DOSUID */
79072805 3347}
13281fa4 3348
76e3520e 3349STATIC void
cea2e8a9 3350S_find_beginning(pTHX)
79072805 3351{
6e72f9df 3352 register char *s, *s2;
e55ac0fa
HS		 3353#ifdef MACOS_TRADITIONAL
3354 int maclines = 0;
3355#endif
33b78306
LW		 3356
3357 /* skip forward in input to the real script? */
3358
bbce6d69 3359 forbid_setid("-x");
bf4acbe4 3360#ifdef MACOS_TRADITIONAL
084592ab 3361 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3362
bf4acbe4
GS		 3363 while (PL_doextract || gMacPerl_AlwaysExtract) {
3364 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3365 if (!gMacPerl_AlwaysExtract)
3366 Perl_croak(aTHX_ "No Perl script found in input\n");
e55ac0fa 3367
bf4acbe4
GS		 3368 if (PL_doextract) /* require explicit override ? */
3369 if (!OverrideExtract(PL_origfilename))
3370 Perl_croak(aTHX_ "User aborted script\n");
3371 else
3372 PL_doextract = FALSE;
e55ac0fa 3373
bf4acbe4
GS		 3374 /* Pater peccavi, file does not have #! */
3375 PerlIO_rewind(PL_rsfp);
e55ac0fa 3376
bf4acbe4
GS		 3377 break;
3378 }
3379#else
3280af22
NIS		 3380 while (PL_doextract) {
3381 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3382 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3383#endif
4f0c37ba
IZ		 3384 s2 = s;
3385 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3386 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3387 PL_doextract = FALSE;
6e72f9df 3388 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3389 s2 = s;
3390 while (*s == ' ' || *s == '\t') s++;
3391 if (*s++ == '-') {
3392 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3393 if (strnEQ(s2-4,"perl",4))
3394 /*SUPPRESS 530*/
155aba94
GS		 3395 while ((s = moreswitches(s)))
3396 ;
33b78306 3397 }
95e8664e 3398#ifdef MACOS_TRADITIONAL
e55ac0fa
HS		 3399 /* We are always searching for the #!perl line in MacPerl,
3400 * so if we find it, still keep the line count correct
3401 * by counting lines we already skipped over
3402 */
3403 for (; maclines > 0 ; maclines--)
3404 PerlIO_ungetc(PL_rsfp, '\n');
3405
95e8664e 3406 break;
e55ac0fa
HS		 3407
3408 /* gMacPerl_AlwaysExtract is false in MPW tool */
3409 } else if (gMacPerl_AlwaysExtract) {
3410 ++maclines;
95e8664e 3411#endif
83025b21
LW		 3412 }
3413 }
3414}
3415
afe37c7d 3416
76e3520e 3417STATIC void
cea2e8a9 3418S_init_ids(pTHX)
352d5a3a 3419{
d8eceb89
JH		 3420 PL_uid = PerlProc_getuid();
3421 PL_euid = PerlProc_geteuid();
3422 PL_gid = PerlProc_getgid();
3423 PL_egid = PerlProc_getegid();
748a9306 3424#ifdef VMS
b28d0864
NIS		 3425 PL_uid |= PL_gid << 16;
3426 PL_euid |= PL_egid << 16;
748a9306 3427#endif
22f7c9c9
JH		 3428 /* Should not happen: */
3429 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3280af22 3430 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 3431}
79072805 3432
a0643315
JH		 3433/* This is used very early in the lifetime of the program,
3434 * before even the options are parsed, so PL_tainting has
af419de7
JH		 3435 * not been initialized properly. The variable PL_earlytaint
3436 * is set early in main() to the result of this function. */
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
NIS		 3484 PL_curstash = PL_debstash;
3485 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3486 AvREAL_off(PL_dbargs);
3487 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3488 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3489 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 3490 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22 3491 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3492 sv_setiv(PL_DBsingle, 0);
3280af22 3493 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3494 sv_setiv(PL_DBtrace, 0);
3280af22 3495 PL_DBsignal = GvSV((gv_fetchpv("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.