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