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