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