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