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