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