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