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