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
Add an option for the grok_xxx() to silently ignore bad digits.
[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 {
53305cf1
NC		 2174 I32 flags = 0;
2175 numlen = 4;
2176 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
8bfdd7d9 2177 SvREFCNT_dec(PL_rs);
c07a80fd 2178 if (rschar & ~((U8)~0))
8bfdd7d9 2179 PL_rs = &PL_sv_undef;
c07a80fd 2180 else if (!rschar && numlen >= 2)
8bfdd7d9 2181 PL_rs = newSVpvn("", 0);
c07a80fd 2182 else {
eb160463 2183 char ch = (char)rschar;
8bfdd7d9 2184 PL_rs = newSVpvn(&ch, 1);
79072805
LW		 2185 }
2186 return s + numlen;
a863c7d1 2187 }
46487f74 2188 case 'C':
a05d7ebb
JH		 2189 s++;
2190 PL_unicode = parse_unicode_opts(&s);
46487f74 2191 return s;
2304df62 2192 case 'F':
3280af22 2193 PL_minus_F = TRUE;
ebce5377
RGS		 2194 PL_splitstr = ++s;
2195 while (*s && !isSPACE(*s)) ++s;
2196 *s = '\0';
2197 PL_splitstr = savepv(PL_splitstr);
2304df62 2198 return s;
79072805 2199 case 'a':
3280af22 2200 PL_minus_a = TRUE;
79072805
LW		 2201 s++;
2202 return s;
2203 case 'c':
3280af22 2204 PL_minus_c = TRUE;
79072805
LW		 2205 s++;
2206 return s;
2207 case 'd':
bbce6d69 2208 forbid_setid("-d");
4633a7c4 2209 s++;
70c94a19
RR		 2210 /* The following permits -d:Mod to accepts arguments following an =
2211 in the fashion that -MSome::Mod does. */
2212 if (*s == ':' || *s == '=') {
2213 char *start;
2214 SV *sv;
2215 sv = newSVpv("use Devel::", 0);
2216 start = ++s;
2217 /* We now allow -d:Module=Foo,Bar */
2218 while(isALNUM(*s) || *s==':') ++s;
2219 if (*s != '=')
2220 sv_catpv(sv, start);
2221 else {
2222 sv_catpvn(sv, start, s-start);
2223 sv_catpv(sv, " split(/,/,q{");
2224 sv_catpv(sv, ++s);
2225 sv_catpv(sv, "})");
2226 }
4633a7c4 2227 s += strlen(s);
70c94a19 2228 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2229 }
ed094faf 2230 if (!PL_perldb) {
3280af22 2231 PL_perldb = PERLDB_ALL;
a0d0e21e 2232 init_debugger();
ed094faf 2233 }
79072805
LW		 2234 return s;
2235 case 'D':
0453d815 2236 {
79072805 2237#ifdef DEBUGGING
bbce6d69 2238 forbid_setid("-D");
79072805 2239 if (isALPHA(s[1])) {
04932ac8 2240 /* if adding extra options, remember to update DEBUG_MASK */
7bab3ede 2241 static char debopts[] = "psltocPmfrxu HXDSTRJvC";
79072805
LW		 2242 char *d;
2243
93a17b20 2244 for (s++; *s && (d = strchr(debopts,*s)); s++)
3280af22 2245 PL_debug |= 1 << (d - debopts);
79072805
LW		 2246 }
2247 else {
3280af22 2248 PL_debug = atoi(s+1);
79072805
LW		 2249 for (s++; isDIGIT(*s); s++) ;
2250 }
2ac72d6e 2251#ifdef EBCDIC
12a43e32
JH		 2252 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2253 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2254 "-Dp not implemented on this platform\n");
2255#endif
aea4f609 2256 PL_debug |= DEBUG_TOP_FLAG;
12a43e32 2257#else /* !DEBUGGING */
0453d815 2258 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2259 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
0453d815 2260 "Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 2261 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2262#endif
2263 /*SUPPRESS 530*/
2264 return s;
0453d815 2265 }
4633a7c4 2266 case 'h':
ac27b0f5 2267 usage(PL_origargv[0]);
7ca617d0 2268 my_exit(0);
79072805 2269 case 'i':
3280af22
NIS		 2270 if (PL_inplace)
2271 Safefree(PL_inplace);
c030f24b
GH		 2272#if defined(__CYGWIN__) /* do backup extension automagically */
2273 if (*(s+1) == '\0') {
2274 PL_inplace = savepv(".bak");
2275 return s+1;
2276 }
2277#endif /* __CYGWIN__ */
3280af22 2278 PL_inplace = savepv(s+1);
79072805 2279 /*SUPPRESS 530*/
3280af22 2280 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2281 if (*s) {
fb73857a 2282 *s++ = '\0';
7b8d334a
GS		 2283 if (*s == '-') /* Additional switches on #! line. */
2284 s++;
2285 }
fb73857a 2286 return s;
4e49a025 2287 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2288 forbid_setid("-I");
fb73857a 2289 ++s;
2290 while (*s && isSPACE(*s))
2291 ++s;
2292 if (*s) {
774d564b 2293 char *e, *p;
0df16ed7
GS		 2294 p = s;
2295 /* ignore trailing spaces (possibly followed by other switches) */
2296 do {
2297 for (e = p; *e && !isSPACE(*e); e++) ;
2298 p = e;
2299 while (isSPACE(*p))
2300 p++;
2301 } while (*p && *p != '-');
2302 e = savepvn(s, e-s);
574c798a 2303 incpush(e, TRUE, TRUE, FALSE);
0df16ed7
GS		 2304 Safefree(e);
2305 s = p;
2306 if (*s == '-')
2307 s++;
79072805
LW		 2308 }
2309 else
a67e862a 2310 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2311 return s;
79072805 2312 case 'l':
3280af22 2313 PL_minus_l = TRUE;
79072805 2314 s++;
7889fe52
NIS		 2315 if (PL_ors_sv) {
2316 SvREFCNT_dec(PL_ors_sv);
2317 PL_ors_sv = Nullsv;
2318 }
79072805 2319 if (isDIGIT(*s)) {
53305cf1 2320 I32 flags = 0;
7889fe52 2321 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2322 numlen = 3 + (*s == '0');
2323 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2324 s += numlen;
2325 }
2326 else {
8bfdd7d9 2327 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2328 PL_ors_sv = newSVpvn("\n\n",2);
2329 }
2330 else {
8bfdd7d9 2331 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2332 }
79072805
LW		 2333 }
2334 return s;
06492da6
SF		 2335 case 'A':
2336 forbid_setid("-A");
930366bd
RGS		 2337 if (!PL_preambleav)
2338 PL_preambleav = newAV();
06492da6 2339 if (*++s) {
930366bd 2340 SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37);
06492da6
SF		 2341 sv_catpv(sv,s);
2342 sv_catpv(sv,"})");
2343 s+=strlen(s);
06492da6
SF		 2344 av_push(PL_preambleav, sv);
2345 }
2346 else
930366bd 2347 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
06492da6 2348 return s;
1a30305b 2349 case 'M':
bbce6d69 2350 forbid_setid("-M"); /* XXX ? */
1a30305b 2351 /* FALL THROUGH */
2352 case 'm':
bbce6d69 2353 forbid_setid("-m"); /* XXX ? */
1a30305b 2354 if (*++s) {
a5f75d66 2355 char *start;
11343788 2356 SV *sv;
a5f75d66
AD		 2357 char *use = "use ";
2358 /* -M-foo == 'no foo' */
2359 if (*s == '-') { use = "no "; ++s; }
11343788 2360 sv = newSVpv(use,0);
a5f75d66 2361 start = s;
1a30305b 2362 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2363 while(isALNUM(*s) || *s==':') ++s;
2364 if (*s != '=') {
11343788 2365 sv_catpv(sv, start);
c07a80fd 2366 if (*(start-1) == 'm') {
2367 if (*s != '\0')
cea2e8a9 2368 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2369 sv_catpv( sv, " ()");
c07a80fd 2370 }
2371 } else {
6df41af2 2372 if (s == start)
be98fb35
GS		 2373 Perl_croak(aTHX_ "Module name required with -%c option",
2374 s[-1]);
11343788
MB		 2375 sv_catpvn(sv, start, s-start);
2376 sv_catpv(sv, " split(/,/,q{");
2377 sv_catpv(sv, ++s);
2378 sv_catpv(sv, "})");
c07a80fd 2379 }
1a30305b 2380 s += strlen(s);
5c831c24 2381 if (!PL_preambleav)
3280af22
NIS		 2382 PL_preambleav = newAV();
2383 av_push(PL_preambleav, sv);
1a30305b 2384 }
2385 else
cea2e8a9 2386 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2387 return s;
79072805 2388 case 'n':
3280af22 2389 PL_minus_n = TRUE;
79072805
LW		 2390 s++;
2391 return s;
2392 case 'p':
3280af22 2393 PL_minus_p = TRUE;
79072805
LW		 2394 s++;
2395 return s;
2396 case 's':
bbce6d69 2397 forbid_setid("-s");
3280af22 2398 PL_doswitches = TRUE;
79072805
LW		 2399 s++;
2400 return s;
6537fe72
MS		 2401 case 't':
2402 if (!PL_tainting)
2403 Perl_croak(aTHX_ "Too late for \"-t\" option");
2404 s++;
2405 return s;
463ee0b2 2406 case 'T':
3280af22 2407 if (!PL_tainting)
cea2e8a9 2408 Perl_croak(aTHX_ "Too late for \"-T\" option");
463ee0b2
LW		 2409 s++;
2410 return s;
79072805 2411 case 'u':
bf4acbe4
GS		 2412#ifdef MACOS_TRADITIONAL
2413 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2414#endif
3280af22 2415 PL_do_undump = TRUE;
79072805
LW		 2416 s++;
2417 return s;
2418 case 'U':
3280af22 2419 PL_unsafe = TRUE;
79072805
LW		 2420 s++;
2421 return s;
2422 case 'v':
8e9464f1 2423#if !defined(DGUX)
b0e47665 2424 PerlIO_printf(PerlIO_stdout(),
d2560b70 2425 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
b0e47665 2426 PL_patchlevel, ARCHNAME));
8e9464f1
JH		 2427#else /* DGUX */
2428/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2429 PerlIO_printf(PerlIO_stdout(),
2430 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2431 PerlIO_printf(PerlIO_stdout(),
2432 Perl_form(aTHX_ " built under %s at %s %s\n",
2433 OSNAME, __DATE__, __TIME__));
2434 PerlIO_printf(PerlIO_stdout(),
2435 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2436 OSVERS));
8e9464f1
JH		 2437#endif /* !DGUX */
2438
fb73857a 2439#if defined(LOCAL_PATCH_COUNT)
2440 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2441 PerlIO_printf(PerlIO_stdout(),
2442 "\n(with %d registered patch%s, "
2443 "see perl -V for more detail)",
2444 (int)LOCAL_PATCH_COUNT,
2445 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2446#endif
1a30305b 2447
b0e47665 2448 PerlIO_printf(PerlIO_stdout(),
4c79ee7a 2449 "\n\nCopyright 1987-2003, Larry Wall\n");
eae9c151
JH		 2450#ifdef MACOS_TRADITIONAL
2451 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2452 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2453 "maintained by Chris Nandor\n");
eae9c151 2454#endif
79072805 2455#ifdef MSDOS
b0e47665
GS		 2456 PerlIO_printf(PerlIO_stdout(),
2457 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2458#endif
2459#ifdef DJGPP
b0e47665
GS		 2460 PerlIO_printf(PerlIO_stdout(),
2461 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2462 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2463#endif
79072805 2464#ifdef OS2
b0e47665
GS		 2465 PerlIO_printf(PerlIO_stdout(),
2466 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2467 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2468#endif
79072805 2469#ifdef atarist
b0e47665
GS		 2470 PerlIO_printf(PerlIO_stdout(),
2471 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2472#endif
a3f9223b 2473#ifdef __BEOS__
b0e47665
GS		 2474 PerlIO_printf(PerlIO_stdout(),
2475 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2476#endif
1d84e8df 2477#ifdef MPE
b0e47665 2478 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2479 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
1d84e8df 2480#endif
9d116dd7 2481#ifdef OEMVS
b0e47665
GS		 2482 PerlIO_printf(PerlIO_stdout(),
2483 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2484#endif
495c5fdc 2485#ifdef __VOS__
b0e47665 2486 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2487 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2488#endif
092bebab 2489#ifdef __OPEN_VM
b0e47665
GS		 2490 PerlIO_printf(PerlIO_stdout(),
2491 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2492#endif
a1a0e61e 2493#ifdef POSIX_BC
b0e47665
GS		 2494 PerlIO_printf(PerlIO_stdout(),
2495 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2496#endif
61ae2fbf 2497#ifdef __MINT__
b0e47665
GS		 2498 PerlIO_printf(PerlIO_stdout(),
2499 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2500#endif
f83d2536 2501#ifdef EPOC
b0e47665 2502 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2503 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2504#endif
e1caacb4 2505#ifdef UNDER_CE
b475b3e6
JH		 2506 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2507 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2508 wce_hitreturn();
2509#endif
baed7233
DL		 2510#ifdef BINARY_BUILD_NOTICE
2511 BINARY_BUILD_NOTICE;
2512#endif
b0e47665
GS		 2513 PerlIO_printf(PerlIO_stdout(),
2514 "\n\
79072805 2515Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2516GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2517Complete documentation for Perl, including FAQ lists, should be found on\n\
2518this system using `man perl' or `perldoc perl'. If you have access to the\n\
2519Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
7ca617d0 2520 my_exit(0);
79072805 2521 case 'w':
599cee73 2522 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2523 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2524 s++;
2525 return s;
2526 case 'W':
ac27b0f5 2527 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2528 if (!specialWARN(PL_compiling.cop_warnings))
2529 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2530 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2531 s++;
2532 return s;
2533 case 'X':
ac27b0f5 2534 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2535 if (!specialWARN(PL_compiling.cop_warnings))
2536 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2537 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2538 s++;
2539 return s;
a0d0e21e 2540 case '*':
79072805
LW		 2541 case ' ':
2542 if (s[1] == '-') /* Additional switches on #! line. */
2543 return s+2;
2544 break;
a0d0e21e 2545 case '-':
79072805 2546 case 0:
51882d45 2547#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2548 case '\r':
2549#endif
79072805
LW		 2550 case '\n':
2551 case '\t':
2552 break;
aa689395 2553#ifdef ALTERNATE_SHEBANG
2554 case 'S': /* OS/2 needs -S on "extproc" line. */
2555 break;
2556#endif
a0d0e21e 2557 case 'P':
3280af22 2558 if (PL_preprocess)
a0d0e21e
LW		 2559 return s+1;
2560 /* FALL THROUGH */
79072805 2561 default:
cea2e8a9 2562 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2563 }
2564 return Nullch;
2565}
2566
2567/* compliments of Tom Christiansen */
2568
2569/* unexec() can be found in the Gnu emacs distribution */
ee580363 2570/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2571
2572void
864dbfa3 2573Perl_my_unexec(pTHX)
79072805
LW		 2574{
2575#ifdef UNEXEC
46fc3d4c 2576 SV* prog;
2577 SV* file;
ee580363 2578 int status = 1;
79072805
LW		 2579 extern int etext;
2580
ee580363 2581 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2582 sv_catpv(prog, "/perl");
6b88bc9c 2583 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2584 sv_catpv(file, ".perldump");
79072805 2585
ee580363
GS		 2586 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2587 /* unexec prints msg to stderr in case of failure */
6ad3d225 2588 PerlProc_exit(status);
79072805 2589#else
a5f75d66
AD		 2590# ifdef VMS
2591# include <lib$routines.h>
2592 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2593# else
79072805 2594 ABORT(); /* for use with undump */
aa689395 2595# endif
a5f75d66 2596#endif
79072805
LW		 2597}
2598
cb68f92d
GS		 2599/* initialize curinterp */
2600STATIC void
cea2e8a9 2601S_init_interp(pTHX)
cb68f92d
GS		 2602{
2603
acfe0abc
GS		 2604#ifdef MULTIPLICITY
2605# define PERLVAR(var,type)
2606# define PERLVARA(var,n,type)
2607# if defined(PERL_IMPLICIT_CONTEXT)
2608# if defined(USE_5005THREADS)
2609# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2610# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2611# else /* !USE_5005THREADS */
2612# define PERLVARI(var,type,init) aTHX->var = init;
2613# define PERLVARIC(var,type,init) aTHX->var = init;
2614# endif /* USE_5005THREADS */
3967c732 2615# else
acfe0abc
GS		 2616# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2617# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2618# endif
acfe0abc
GS		 2619# include "intrpvar.h"
2620# ifndef USE_5005THREADS
2621# include "thrdvar.h"
2622# endif
2623# undef PERLVAR
2624# undef PERLVARA
2625# undef PERLVARI
2626# undef PERLVARIC
2627#else
2628# define PERLVAR(var,type)
2629# define PERLVARA(var,n,type)
2630# define PERLVARI(var,type,init) PL_##var = init;
2631# define PERLVARIC(var,type,init) PL_##var = init;
2632# include "intrpvar.h"
2633# ifndef USE_5005THREADS
2634# include "thrdvar.h"
2635# endif
2636# undef PERLVAR
2637# undef PERLVARA
2638# undef PERLVARI
2639# undef PERLVARIC
cb68f92d
GS		 2640#endif
2641
cb68f92d
GS		 2642}
2643
76e3520e 2644STATIC void
cea2e8a9 2645S_init_main_stash(pTHX)
79072805 2646{
463ee0b2 2647 GV *gv;
6e72f9df 2648
3280af22 2649 PL_curstash = PL_defstash = newHV();
79cb57f6 2650 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2651 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2652 SvREFCNT_dec(GvHV(gv));
3280af22 2653 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2654 SvREADONLY_on(gv);
3280af22
NIS		 2655 HvNAME(PL_defstash) = savepv("main");
2656 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2657 GvMULTI_on(PL_incgv);
2658 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2659 GvMULTI_on(PL_hintgv);
2660 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2661 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2662 GvMULTI_on(PL_errgv);
2663 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2664 GvMULTI_on(PL_replgv);
cea2e8a9 2665 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2666 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2667 sv_setpvn(ERRSV, "", 0);
3280af22 2668 PL_curstash = PL_defstash;
11faa288 2669 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2670 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2671 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2672 /* We must init $/ before switches are processed. */
864dbfa3 2673 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2674}
2675
76e3520e 2676STATIC void
cea2e8a9 2677S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2678{
1b24ed4b
MS		 2679 char *quote;
2680 char *code;
2681 char *cpp_discard_flag;
2682 char *perl;
2683
6c4ab083 2684 *fdscript = -1;
79072805 2685
3280af22
NIS		 2686 if (PL_e_script) {
2687 PL_origfilename = savepv("-e");
96436eeb 2688 }
6c4ab083
GS		 2689 else {
2690 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2691 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2692
2693 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2694 char *s = scriptname + 8;
2695 *fdscript = atoi(s);
2696 while (isDIGIT(*s))
2697 s++;
2698 if (*s) {
2699 scriptname = savepv(s + 1);
3280af22
NIS		 2700 Safefree(PL_origfilename);
2701 PL_origfilename = scriptname;
6c4ab083
GS		 2702 }
2703 }
2704 }
2705
05ec9bb3 2706 CopFILE_free(PL_curcop);
57843af0 2707 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2708 if (strEQ(PL_origfilename,"-"))
79072805 2709 scriptname = "";
01f988be 2710 if (*fdscript >= 0) {
3280af22 2711 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2712# if defined(HAS_FCNTL) && defined(F_SETFD)
2713 if (PL_rsfp)
2714 /* ensure close-on-exec */
2715 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2716# endif
96436eeb 2717 }
3280af22 2718 else if (PL_preprocess) {
46fc3d4c 2719 char *cpp_cfg = CPPSTDIN;
79cb57f6 2720 SV *cpp = newSVpvn("",0);
46fc3d4c 2721 SV *cmd = NEWSV(0,0);
2722
2723 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2724 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2725 sv_catpv(cpp, cpp_cfg);
79072805 2726
1b24ed4b
MS		 2727# ifndef VMS
2728 sv_catpvn(sv, "-I", 2);
2729 sv_catpv(sv,PRIVLIB_EXP);
2730# endif
46fc3d4c 2731
14953ddc
MB		 2732 DEBUG_P(PerlIO_printf(Perl_debug_log,
2733 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2734 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 2735
2736# if defined(MSDOS) || defined(WIN32) || defined(VMS)
2737 quote = "\"";
2738# else
2739 quote = "'";
2740# endif
2741
2742# ifdef VMS
2743 cpp_discard_flag = "";
2744# else
2745 cpp_discard_flag = "-C";
2746# endif
2747
2748# ifdef OS2
2749 perl = os2_execname(aTHX);
2750# else
2751 perl = PL_origargv[0];
2752# endif
2753
2754
2755 /* This strips off Perl comments which might interfere with
62375a60
NIS		 2756 the C pre-processor, including #!. #line directives are
2757 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 2758 of #line. FWP played some golf with it so it will fit
2759 into VMS's 255 character buffer.
2760 */
2761 if( PL_doextract )
2762 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2763 else
2764 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2765
2766 Perl_sv_setpvf(aTHX_ cmd, "\
2767%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 2768 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 2769 cpp_discard_flag, sv, CPPMINUS);
2770
3280af22 2771 PL_doextract = FALSE;
1b24ed4b
MS		 2772# ifdef IAMSUID /* actually, this is caught earlier */
2773 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2774# ifdef HAS_SETEUID
2775 (void)seteuid(PL_uid); /* musn't stay setuid root */
2776# else
2777# ifdef HAS_SETREUID
2778 (void)setreuid((Uid_t)-1, PL_uid);
2779# else
2780# ifdef HAS_SETRESUID
2781 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2782# else
2783 PerlProc_setuid(PL_uid);
2784# endif
2785# endif
2786# endif
b28d0864 2787 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2788 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805 2789 }
1b24ed4b 2790# endif /* IAMSUID */
0a6c758d 2791
62375a60
NIS		 2792 DEBUG_P(PerlIO_printf(Perl_debug_log,
2793 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 2794 SvPVX(cmd)));
2795
3280af22 2796 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2797 SvREFCNT_dec(cmd);
2798 SvREFCNT_dec(cpp);
79072805
LW		 2799 }
2800 else if (!*scriptname) {
bbce6d69 2801 forbid_setid("program input from stdin");
3280af22 2802 PL_rsfp = PerlIO_stdin();
79072805 2803 }
96436eeb 2804 else {
3280af22 2805 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2806# if defined(HAS_FCNTL) && defined(F_SETFD)
2807 if (PL_rsfp)
2808 /* ensure close-on-exec */
2809 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2810# endif
96436eeb 2811 }
3280af22 2812 if (!PL_rsfp) {
1b24ed4b
MS		 2813# ifdef DOSUID
2814# ifndef IAMSUID /* in case script is not readable before setuid */
2815 if (PL_euid &&
2816 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2817 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2818 {
2819 /* try again */
62375a60
NIS		 2820 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2821 BIN_EXP, (int)PERL_REVISION,
1b24ed4b
MS		 2822 (int)PERL_VERSION,
2823 (int)PERL_SUBVERSION), PL_origargv);
2824 Perl_croak(aTHX_ "Can't do setuid\n");
2825 }
2826# endif
2827# endif
2828# ifdef IAMSUID
2829 errno = EPERM;
2830 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2831 Strerror(errno));
2832# else
2833 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2834 CopFILE(PL_curcop), Strerror(errno));
2835# endif
13281fa4 2836 }
79072805 2837}
8d063cd8 2838
7b89560d
JH		 2839/* Mention
2840 * I_SYSSTATVFS HAS_FSTATVFS
2841 * I_SYSMOUNT
c890dc6c 2842 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 2843 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2844 * here so that metaconfig picks them up. */
2845
104d25b7 2846#ifdef IAMSUID
864dbfa3 2847STATIC int
e688b231 2848S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 2849{
0545a864
JH		 2850 int check_okay = 0; /* able to do all the required sys/libcalls */
2851 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 2852/*
ad27e871 2853 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 2854 * fstatvfs() is UNIX98.
0545a864 2855 * fstatfs() is 4.3 BSD.
ad27e871 2856 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 2857 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2858 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 2859 */
2860
6439433f
JH		 2861#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2862
2863# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2864 defined(HAS_FSTATVFS)
2865# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 2866 struct statvfs stfs;
6439433f 2867
104d25b7
JH		 2868 check_okay = fstatvfs(fd, &stfs) == 0;
2869 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
6439433f 2870# endif /* fstatvfs */
ac27b0f5 2871
6439433f
JH		 2872# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2873 defined(PERL_MOUNT_NOSUID) && \
2874 defined(HAS_FSTATFS) && \
2875 defined(HAS_STRUCT_STATFS) && \
2876 defined(HAS_STRUCT_STATFS_F_FLAGS)
2877# define FD_ON_NOSUID_CHECK_OKAY
e688b231 2878 struct statfs stfs;
6439433f 2879
104d25b7 2880 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 2881 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
6439433f
JH		 2882# endif /* fstatfs */
2883
2884# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2885 defined(PERL_MOUNT_NOSUID) && \
2886 defined(HAS_FSTAT) && \
2887 defined(HAS_USTAT) && \
2888 defined(HAS_GETMNT) && \
2889 defined(HAS_STRUCT_FS_DATA) && \
2890 defined(NOSTAT_ONE)
2891# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 2892 Stat_t fdst;
6439433f 2893
0545a864 2894 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 2895 struct ustat us;
2896 if (ustat(fdst.st_dev, &us) == 0) {
2897 struct fs_data fsd;
2898 /* NOSTAT_ONE here because we're not examining fields which
2899 * vary between that case and STAT_ONE. */
ad27e871 2900 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 2901 size_t cmplen = sizeof(us.f_fname);
2902 if (sizeof(fsd.fd_req.path) < cmplen)
2903 cmplen = sizeof(fsd.fd_req.path);
2904 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2905 fdst.st_dev == fsd.fd_req.dev) {
2906 check_okay = 1;
2907 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2908 }
2909 }
2910 }
2911 }
0545a864 2912 }
6439433f
JH		 2913# endif /* fstat+ustat+getmnt */
2914
2915# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2916 defined(HAS_GETMNTENT) && \
2917 defined(HAS_HASMNTOPT) && \
2918 defined(MNTOPT_NOSUID)
2919# define FD_ON_NOSUID_CHECK_OKAY
2920 FILE *mtab = fopen("/etc/mtab", "r");
2921 struct mntent *entry;
c623ac67 2922 Stat_t stb, fsb;
104d25b7
JH		 2923
2924 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 2925 while (entry = getmntent(mtab)) {
2926 if (stat(entry->mnt_dir, &fsb) == 0
2927 && fsb.st_dev == stb.st_dev)
2928 {
2929 /* found the filesystem */
2930 check_okay = 1;
2931 if (hasmntopt(entry, MNTOPT_NOSUID))
2932 on_nosuid = 1;
2933 break;
2934 } /* A single fs may well fail its stat(). */
2935 }
104d25b7
JH		 2936 }
2937 if (mtab)
6439433f
JH		 2938 fclose(mtab);
2939# endif /* getmntent+hasmntopt */
0545a864 2940
ac27b0f5 2941 if (!check_okay)
0545a864 2942 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 2943 return on_nosuid;
2944}
2945#endif /* IAMSUID */
2946
76e3520e 2947STATIC void
cea2e8a9 2948S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 2949{
155aba94 2950#ifdef IAMSUID
96436eeb 2951 int which;
155aba94 2952#endif
96436eeb 2953
13281fa4
LW		 2954 /* do we need to emulate setuid on scripts? */
2955
2956 /* This code is for those BSD systems that have setuid #! scripts disabled
2957 * in the kernel because of a security problem. Merely defining DOSUID
2958 * in perl will not fix that problem, but if you have disabled setuid
2959 * scripts in the kernel, this will attempt to emulate setuid and setgid
2960 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 2961 * root version must be called suidperl or sperlN.NNN. If regular perl
2962 * discovers that it has opened a setuid script, it calls suidperl with
2963 * the same argv that it had. If suidperl finds that the script it has
2964 * just opened is NOT setuid root, it sets the effective uid back to the
2965 * uid. We don't just make perl setuid root because that loses the
2966 * effective uid we had before invoking perl, if it was different from the
2967 * uid.
13281fa4
LW		 2968 *
2969 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2970 * be defined in suidperl only. suidperl must be setuid root. The
2971 * Configure script will set this up for you if you want it.
2972 */
a687059c 2973
13281fa4 2974#ifdef DOSUID
6e72f9df 2975 char *s, *s2;
a0d0e21e 2976
b28d0864 2977 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 2978 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 2979 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2980 I32 len;
2d8e6c8d 2981 STRLEN n_a;
13281fa4 2982
a687059c 2983#ifdef IAMSUID
fe14fcc3 2984#ifndef HAS_SETREUID
a687059c
LW		 2985 /* On this access check to make sure the directories are readable,
2986 * there is actually a small window that the user could use to make
2987 * filename point to an accessible directory. So there is a faint
2988 * chance that someone could execute a setuid script down in a
2989 * non-accessible directory. I don't know what to do about that.
2990 * But I don't think it's too important. The manual lies when
2991 * it says access() is useful in setuid programs.
2992 */
cc49e20b 2993 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 2994 Perl_croak(aTHX_ "Permission denied");
a687059c
LW		 2995#else
2996 /* If we can swap euid and uid, then we can determine access rights
2997 * with a simple stat of the file, and then compare device and
2998 * inode to make sure we did stat() on the same file we opened.
2999 * Then we just have to make sure he or she can execute it.
3000 */
3001 {
c623ac67 3002 Stat_t tmpstatbuf;
a687059c 3003
85e6fe83
LW		 3004 if (
3005#ifdef HAS_SETREUID
b28d0864 3006 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 3007#else
3008# if HAS_SETRESUID
b28d0864 3009 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 3010# endif
85e6fe83 3011#endif
b28d0864 3012 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 3013 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 3014 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 3015 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 3016#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 3017 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 3018 Perl_croak(aTHX_ "Permission denied");
104d25b7 3019#endif
b28d0864
NIS		 3020 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3021 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3022 (void)PerlIO_close(PL_rsfp);
cea2e8a9 3023 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3024 }
85e6fe83
LW		 3025 if (
3026#ifdef HAS_SETREUID
b28d0864 3027 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 3028#else
3029# if defined(HAS_SETRESUID)
b28d0864 3030 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 3031# endif
85e6fe83 3032#endif
b28d0864 3033 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 3034 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 3035 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 3036 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3037 }
fe14fcc3 3038#endif /* HAS_SETREUID */
a687059c
LW		 3039#endif /* IAMSUID */
3040
b28d0864 3041 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 3042 Perl_croak(aTHX_ "Permission denied");
b28d0864 3043 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3044 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3045 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 3046 CopLINE_inc(PL_curcop);
6b88bc9c 3047 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3048 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3049 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3050 s = SvPV(PL_linestr,n_a)+2;
663a0e37 3051 if (*s == ' ') s++;
45d8adaa 3052 while (!isSPACE(*s)) s++;
2d8e6c8d 3053 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3054 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3055 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 3056 Perl_croak(aTHX_ "Not a perl script");
a687059c 3057 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3058 /*
3059 * #! arg must be what we saw above. They can invoke it by
3060 * mentioning suidperl explicitly, but they may not add any strange
3061 * arguments beyond what #! says if they do invoke suidperl that way.
3062 */
3063 len = strlen(validarg);
3064 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 3065 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 3066 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3067
3068#ifndef IAMSUID
b28d0864
NIS		 3069 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3070 PL_euid == PL_statbuf.st_uid)
3071 if (!PL_do_undump)
cea2e8a9 3072 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3073FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3074#endif /* IAMSUID */
13281fa4 3075
b28d0864
NIS		 3076 if (PL_euid) { /* oops, we're not the setuid root perl */
3077 (void)PerlIO_close(PL_rsfp);
13281fa4 3078#ifndef IAMSUID
46fc3d4c 3079 /* try again */
a7cb1f99 3080 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3081 (int)PERL_REVISION, (int)PERL_VERSION,
3082 (int)PERL_SUBVERSION), PL_origargv);
13281fa4 3083#endif
cea2e8a9 3084 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 3085 }
3086
b28d0864 3087 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 3088#ifdef HAS_SETEGID
b28d0864 3089 (void)setegid(PL_statbuf.st_gid);
a687059c 3090#else
fe14fcc3 3091#ifdef HAS_SETREGID
b28d0864 3092 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3093#else
3094#ifdef HAS_SETRESGID
b28d0864 3095 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3096#else
b28d0864 3097 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3098#endif
3099#endif
85e6fe83 3100#endif
b28d0864 3101 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3102 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3103 }
b28d0864
NIS		 3104 if (PL_statbuf.st_mode & S_ISUID) {
3105 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3106#ifdef HAS_SETEUID
b28d0864 3107 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3108#else
fe14fcc3 3109#ifdef HAS_SETREUID
b28d0864 3110 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3111#else
3112#ifdef HAS_SETRESUID
b28d0864 3113 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3114#else
b28d0864 3115 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3116#endif
3117#endif
85e6fe83 3118#endif
b28d0864 3119 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3120 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3121 }
b28d0864 3122 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3123#ifdef HAS_SETEUID
b28d0864 3124 (void)seteuid((Uid_t)PL_uid);
a687059c 3125#else
fe14fcc3 3126#ifdef HAS_SETREUID
b28d0864 3127 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3128#else
85e6fe83 3129#ifdef HAS_SETRESUID
b28d0864 3130 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3131#else
b28d0864 3132 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3133#endif
a687059c
LW		 3134#endif
3135#endif
b28d0864 3136 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3137 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3138 }
748a9306 3139 init_ids();
b28d0864 3140 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 3141 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 3142 }
3143#ifdef IAMSUID
6b88bc9c 3144 else if (PL_preprocess)
cea2e8a9 3145 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 3146 else if (fdscript >= 0)
cea2e8a9 3147 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 3148 else
cea2e8a9 3149 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb 3150
3151 /* We absolutely must clear out any saved ids here, so we */
3152 /* exec the real perl, substituting fd script for scriptname. */
3153 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 3154 PerlIO_rewind(PL_rsfp);
3155 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS		 3156 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3157 if (!PL_origargv[which])
cea2e8a9
GS		 3158 Perl_croak(aTHX_ "Permission denied");
3159 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 3160 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 3161#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3162 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3163#endif
a7cb1f99 3164 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3165 (int)PERL_REVISION, (int)PERL_VERSION,
3166 (int)PERL_SUBVERSION), PL_origargv);/* try again */
cea2e8a9 3167 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 3168#endif /* IAMSUID */
a687059c 3169#else /* !DOSUID */
3280af22 3170 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3171#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3172 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3173 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3174 ||
b28d0864 3175 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3176 )
b28d0864 3177 if (!PL_do_undump)
cea2e8a9 3178 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3179FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3180#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3181 /* not set-id, must be wrapped */
a687059c 3182 }
13281fa4 3183#endif /* DOSUID */
79072805 3184}
13281fa4 3185
76e3520e 3186STATIC void
cea2e8a9 3187S_find_beginning(pTHX)
79072805 3188{
6e72f9df 3189 register char *s, *s2;
e55ac0fa
HS		 3190#ifdef MACOS_TRADITIONAL
3191 int maclines = 0;
3192#endif
33b78306
LW		 3193
3194 /* skip forward in input to the real script? */
3195
bbce6d69 3196 forbid_setid("-x");
bf4acbe4 3197#ifdef MACOS_TRADITIONAL
084592ab 3198 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3199
bf4acbe4
GS		 3200 while (PL_doextract || gMacPerl_AlwaysExtract) {
3201 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3202 if (!gMacPerl_AlwaysExtract)
3203 Perl_croak(aTHX_ "No Perl script found in input\n");
e55ac0fa 3204
bf4acbe4
GS		 3205 if (PL_doextract) /* require explicit override ? */
3206 if (!OverrideExtract(PL_origfilename))
3207 Perl_croak(aTHX_ "User aborted script\n");
3208 else
3209 PL_doextract = FALSE;
e55ac0fa 3210
bf4acbe4
GS		 3211 /* Pater peccavi, file does not have #! */
3212 PerlIO_rewind(PL_rsfp);
e55ac0fa 3213
bf4acbe4
GS		 3214 break;
3215 }
3216#else
3280af22
NIS		 3217 while (PL_doextract) {
3218 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3219 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3220#endif
4f0c37ba
IZ		 3221 s2 = s;
3222 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3223 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3224 PL_doextract = FALSE;
6e72f9df 3225 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3226 s2 = s;
3227 while (*s == ' ' || *s == '\t') s++;
3228 if (*s++ == '-') {
3229 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3230 if (strnEQ(s2-4,"perl",4))
3231 /*SUPPRESS 530*/
155aba94
GS		 3232 while ((s = moreswitches(s)))
3233 ;
33b78306 3234 }
95e8664e 3235#ifdef MACOS_TRADITIONAL
e55ac0fa
HS		 3236 /* We are always searching for the #!perl line in MacPerl,
3237 * so if we find it, still keep the line count correct
3238 * by counting lines we already skipped over
3239 */
3240 for (; maclines > 0 ; maclines--)
3241 PerlIO_ungetc(PL_rsfp, '\n');
3242
95e8664e 3243 break;
e55ac0fa
HS		 3244
3245 /* gMacPerl_AlwaysExtract is false in MPW tool */
3246 } else if (gMacPerl_AlwaysExtract) {
3247 ++maclines;
95e8664e 3248#endif
83025b21
LW		 3249 }
3250 }
3251}
3252
afe37c7d 3253
76e3520e 3254STATIC void
cea2e8a9 3255S_init_ids(pTHX)
352d5a3a 3256{
d8eceb89
JH		 3257 PL_uid = PerlProc_getuid();
3258 PL_euid = PerlProc_geteuid();
3259 PL_gid = PerlProc_getgid();
3260 PL_egid = PerlProc_getegid();
748a9306 3261#ifdef VMS
b28d0864
NIS		 3262 PL_uid |= PL_gid << 16;
3263 PL_euid |= PL_egid << 16;
748a9306 3264#endif
3280af22 3265 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 3266}
79072805 3267
76e3520e 3268STATIC void
cea2e8a9 3269S_forbid_setid(pTHX_ char *s)
bbce6d69 3270{
3280af22 3271 if (PL_euid != PL_uid)
cea2e8a9 3272 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 3273 if (PL_egid != PL_gid)
cea2e8a9 3274 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69 3275}
3276
1ee4443e
IZ		 3277void
3278Perl_init_debugger(pTHX)
748a9306 3279{
1ee4443e
IZ		 3280 HV *ostash = PL_curstash;
3281
3280af22
NIS		 3282 PL_curstash = PL_debstash;
3283 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3284 AvREAL_off(PL_dbargs);
3285 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3286 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3287 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 3288 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22 3289 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3290 sv_setiv(PL_DBsingle, 0);
3280af22 3291 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3292 sv_setiv(PL_DBtrace, 0);
3280af22 3293 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3294 sv_setiv(PL_DBsignal, 0);
06492da6
SF		 3295 PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
3296 sv_setiv(PL_DBassertion, 0);
1ee4443e 3297 PL_curstash = ostash;
352d5a3a
LW		 3298}
3299
2ce36478
SM		 3300#ifndef STRESS_REALLOC
3301#define REASONABLE(size) (size)
3302#else
3303#define REASONABLE(size) (1) /* unreasonable */
3304#endif
3305
11343788 3306void
cea2e8a9 3307Perl_init_stacks(pTHX)
79072805 3308{
e336de0d 3309 /* start with 128-item stack and 8K cxstack */
3280af22 3310 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 3311 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 3312 PL_curstackinfo->si_type = PERLSI_MAIN;
3313 PL_curstack = PL_curstackinfo->si_stack;
3314 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 3315
3280af22
NIS		 3316 PL_stack_base = AvARRAY(PL_curstack);
3317 PL_stack_sp = PL_stack_base;
3318 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 3319
3280af22
NIS		 3320 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3321 PL_tmps_floor = -1;
3322 PL_tmps_ix = -1;
3323 PL_tmps_max = REASONABLE(128);
8990e307 3324
3280af22
NIS		 3325 New(54,PL_markstack,REASONABLE(32),I32);
3326 PL_markstack_ptr = PL_markstack;
3327 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 3328
ce2f7c3b 3329 SET_MARK_OFFSET;
e336de0d 3330
3280af22
NIS		 3331 New(54,PL_scopestack,REASONABLE(32),I32);
3332 PL_scopestack_ix = 0;
3333 PL_scopestack_max = REASONABLE(32);
79072805 3334
3280af22
NIS		 3335 New(54,PL_savestack,REASONABLE(128),ANY);
3336 PL_savestack_ix = 0;
3337 PL_savestack_max = REASONABLE(128);
79072805 3338
3280af22
NIS		 3339 New(54,PL_retstack,REASONABLE(16),OP*);
3340 PL_retstack_ix = 0;
3341 PL_retstack_max = REASONABLE(16);
378cc40b 3342}
33b78306 3343
2ce36478
SM		 3344#undef REASONABLE
3345
76e3520e 3346STATIC void
cea2e8a9 3347S_nuke_stacks(pTHX)
6e72f9df 3348{
3280af22
NIS		 3349 while (PL_curstackinfo->si_next)
3350 PL_curstackinfo = PL_curstackinfo->si_next;
3351 while (PL_curstackinfo) {
3352 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 3353 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 3354 Safefree(PL_curstackinfo->si_cxstack);
3355 Safefree(PL_curstackinfo);
3356 PL_curstackinfo = p;
e336de0d 3357 }
3280af22
NIS		 3358 Safefree(PL_tmps_stack);
3359 Safefree(PL_markstack);
3360 Safefree(PL_scopestack);
3361 Safefree(PL_savestack);
3362 Safefree(PL_retstack);
378cc40b 3363}
33b78306 3364
76e3520e 3365STATIC void
cea2e8a9 3366S_init_lexer(pTHX)
8990e307 3367{
06039172 3368 PerlIO *tmpfp;
3280af22
NIS		 3369 tmpfp = PL_rsfp;
3370 PL_rsfp = Nullfp;
3371 lex_start(PL_linestr);
3372 PL_rsfp = tmpfp;
79cb57f6 3373 PL_subname = newSVpvn("main",4);
8990e307
LW		 3374}
3375
76e3520e 3376STATIC void
cea2e8a9 3377S_init_predump_symbols(pTHX)
45d8adaa 3378{
93a17b20 3379 GV *tmpgv;
af8c498a 3380 IO *io;
79072805 3381
864dbfa3 3382 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 3383 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3384 GvMULTI_on(PL_stdingv);
af8c498a 3385 io = GvIOp(PL_stdingv);
a04651f4 3386 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 3387 IoIFP(io) = PerlIO_stdin();
adbc6bb1 3388 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 3389 GvMULTI_on(tmpgv);
af8c498a 3390 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3391
85e6fe83 3392 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 3393 GvMULTI_on(tmpgv);
af8c498a 3394 io = GvIOp(tmpgv);
a04651f4 3395 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3396 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 3397 setdefout(tmpgv);
adbc6bb1 3398 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 3399 GvMULTI_on(tmpgv);
af8c498a 3400 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3401
bf49b057
GS		 3402 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3403 GvMULTI_on(PL_stderrgv);
3404 io = GvIOp(PL_stderrgv);
a04651f4 3405 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3406 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 3407 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 3408 GvMULTI_on(tmpgv);
af8c498a 3409 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3410
3280af22 3411 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 3412
bf4acbe4
GS		 3413 if (PL_osname)
3414 Safefree(PL_osname);
3415 PL_osname = savepv(OSNAME);
79072805 3416}
33b78306 3417
a11ec5a9
RGS		 3418void
3419Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
33b78306 3420{
79072805 3421 char *s;
79072805 3422 argc--,argv++; /* skip name of script */
3280af22 3423 if (PL_doswitches) {
79072805
LW		 3424 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3425 if (!argv[0][1])
3426 break;
379d538a 3427 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 3428 argc--,argv++;
3429 break;
3430 }
155aba94 3431 if ((s = strchr(argv[0], '='))) {
79072805 3432 *s++ = '\0';
85e6fe83 3433 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 3434 }
3435 else
85e6fe83 3436 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 3437 }
79072805 3438 }
a11ec5a9
RGS		 3439 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3440 GvMULTI_on(PL_argvgv);
3441 (void)gv_AVadd(PL_argvgv);
3442 av_clear(GvAVn(PL_argvgv));
3443 for (; argc > 0; argc--,argv++) {
3444 SV *sv = newSVpv(argv[0],0);
3445 av_push(GvAVn(PL_argvgv),sv);
ce81ff12
JH		 3446 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
3447 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
3448 SvUTF8_on(sv);
3449 }
a05d7ebb
JH		 3450 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
3451 (void)sv_utf8_decode(sv);
a11ec5a9
RGS		 3452 }
3453 }
3454}
3455
04fee9b5
NIS		 3456#ifdef HAS_PROCSELFEXE
3457/* This is a function so that we don't hold on to MAXPATHLEN
8338e367 3458 bytes of stack longer than necessary
04fee9b5
NIS		 3459 */
3460STATIC void
3461S_procself_val(pTHX_ SV *sv, char *arg0)
3462{
3463 char buf[MAXPATHLEN];
d13a6521 3464 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
75745e22
TJ		 3465
3466 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3467 includes a spurious NUL which will cause $^X to fail in system
3468 or backticks (this will prevent extensions from being built and
3469 many tests from working). readlink is not meant to add a NUL.
3470 Normal readlink works fine.
3471 */
3472 if (len > 0 && buf[len-1] == '\0') {
3473 len--;
3474 }
3475
d103ec31
JH		 3476 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3477 returning the text "unknown" from the readlink rather than the path
78cb7c00 3478 to the executable (or returning an error from the readlink). Any valid
d103ec31
JH		 3479 path has a '/' in it somewhere, so use that to validate the result.
3480 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3481 */
78cb7c00 3482 if (len > 0 && memchr(buf, '/', len)) {
04fee9b5
NIS		 3483 sv_setpvn(sv,buf,len);
3484 }
3485 else {
3486 sv_setpv(sv,arg0);
3487 }
3488}
3489#endif /* HAS_PROCSELFEXE */
3490
a11ec5a9
RGS		 3491STATIC void
3492S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3493{
3494 char *s;
3495 SV *sv;
3496 GV* tmpgv;
a11ec5a9 3497
3280af22
NIS		 3498 PL_toptarget = NEWSV(0,0);
3499 sv_upgrade(PL_toptarget, SVt_PVFM);
3500 sv_setpvn(PL_toptarget, "", 0);
3501 PL_bodytarget = NEWSV(0,0);
3502 sv_upgrade(PL_bodytarget, SVt_PVFM);
3503 sv_setpvn(PL_bodytarget, "", 0);
3504 PL_formtarget = PL_bodytarget;
79072805 3505
bbce6d69 3506 TAINT;
a11ec5a9
RGS		 3507
3508 init_argv_symbols(argc,argv);
3509
155aba94 3510 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
bf4acbe4
GS		 3511#ifdef MACOS_TRADITIONAL
3512 /* $0 is not majick on a Mac */
3513 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3514#else
3280af22 3515 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 3516 magicname("0", "0", 1);
bf4acbe4 3517#endif
79072805 3518 }
04fee9b5
NIS		 3519 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3520#ifdef HAS_PROCSELFEXE
3521 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3522#else
8338e367 3523#ifdef OS2
23da6c43 3524 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
8338e367
JH		 3525#else
3526 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3527#endif
04fee9b5
NIS		 3528#endif
3529 }
155aba94 3530 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
79072805 3531 HV *hv;
3280af22
NIS		 3532 GvMULTI_on(PL_envgv);
3533 hv = GvHVn(PL_envgv);
14befaf4 3534 hv_magic(hv, Nullgv, PERL_MAGIC_env);
fa6a1c44 3535#ifdef USE_ENVIRON_ARRAY
4633a7c4
LW		 3536 /* Note that if the supplied env parameter is actually a copy
3537 of the global environ then it may now point to free'd memory
3538 if the environment has been modified since. To avoid this
3539 problem we treat env==NULL as meaning 'use the default'
3540 */
3541 if (!env)
3542 env = environ;
4efc5df6
GS		 3543 if (env != environ
3544# ifdef USE_ITHREADS
3545 && PL_curinterp == aTHX
3546# endif
3547 )
3548 {
79072805 3549 environ[0] = Nullch;
4efc5df6 3550 }
764df951
IZ		 3551 if (env)
3552 for (; *env; env++) {
93a17b20 3553 if (!(s = strchr(*env,'=')))
79072805 3554 continue;
60ce6247 3555#if defined(MSDOS)
61968511 3556 *s = '\0';
137443ea 3557 (void)strupr(*env);
61968511 3558 *s = '=';
137443ea 3559#endif
61968511 3560 sv = newSVpv(s+1, 0);
79072805 3561 (void)hv_store(hv, *env, s - *env, sv, 0);
61968511
GA		 3562 if (env != environ)
3563 mg_set(sv);
764df951 3564 }
103a7189 3565#endif /* USE_ENVIRON_ARRAY */
79072805 3566 }
bbce6d69 3567 TAINT_NOT;
306196c3
MS		 3568 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3569 SvREADONLY_off(GvSV(tmpgv));
7766f137 3570 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
306196c3
MS		 3571 SvREADONLY_on(GvSV(tmpgv));
3572 }
4d76a344
RGS		 3573#ifdef THREADS_HAVE_PIDS
3574 PL_ppid = (IV)getppid();
3575#endif
2710853f
MJD		 3576
3577 /* touch @F array to prevent spurious warnings 20020415 MJD */
3578 if (PL_minus_a) {
3579 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3580 }
3581 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3582 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3583 (void) get_av("main::+", TRUE | GV_ADDMULTI);
33b78306 3584}
34de22dd 3585
76e3520e 3586STATIC void
cea2e8a9 3587S_init_perllib(pTHX)
34de22dd 3588{
85e6fe83 3589 char *s;
3280af22 3590 if (!PL_tainting) {
552a7a9b 3591#ifndef VMS
76e3520e 3592 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 3593 if (s)
574c798a 3594 incpush(s, TRUE, TRUE, TRUE);
85e6fe83 3595 else
574c798a 3596 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
552a7a9b 3597#else /* VMS */
3598 /* Treat PERL5?LIB as a possible search list logical name -- the
3599 * "natural" VMS idiom for a Unix path string. We allow each
3600 * element to be a set of |-separated directories for compatibility.
3601 */
3602 char buf[256];
3603 int idx = 0;
3604 if (my_trnlnm("PERL5LIB",buf,0))
574c798a 3605 do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 3606 else
574c798a 3607 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
552a7a9b 3608#endif /* VMS */
85e6fe83 3609 }
34de22dd 3610
c90c0ff4 3611/* Use the ~-expanded versions of APPLLIB (undocumented),
65f19062 3612 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
df5cef82 3613*/
4633a7c4 3614#ifdef APPLLIB_EXP
574c798a 3615 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
16d20bd9 3616#endif
4633a7c4 3617
fed7345c 3618#ifdef ARCHLIB_EXP
574c798a 3619 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
a0d0e21e 3620#endif
bf4acbe4
GS		 3621#ifdef MACOS_TRADITIONAL
3622 {
c623ac67 3623 Stat_t tmpstatbuf;
bf4acbe4
GS		 3624 SV * privdir = NEWSV(55, 0);
3625 char * macperl = PerlEnv_getenv("MACPERL");
3626
3627 if (!macperl)
3628 macperl = "";
3629
3630 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3631 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
574c798a 3632 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
bf4acbe4
GS		 3633 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3634 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
574c798a 3635 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
ac27b0f5 3636
bf4acbe4
GS		 3637 SvREFCNT_dec(privdir);
3638 }
3639 if (!PL_tainting)
574c798a 3640 incpush(":", FALSE, FALSE, TRUE);
bf4acbe4 3641#else
fed7345c 3642#ifndef PRIVLIB_EXP
65f19062 3643# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 3644#endif
ac27b0f5 3645#if defined(WIN32)
574c798a 3646 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
00dc2f4f 3647#else
574c798a 3648 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
00dc2f4f 3649#endif
4633a7c4 3650
65f19062 3651#ifdef SITEARCH_EXP
3b290362
GS		 3652 /* sitearch is always relative to sitelib on Windows for
3653 * DLL-based path intuition to work correctly */
3654# if !defined(WIN32)
574c798a 3655 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
65f19062
GS		 3656# endif
3657#endif
3658
4633a7c4 3659#ifdef SITELIB_EXP
65f19062 3660# if defined(WIN32)
574c798a
SR		 3661 /* this picks up sitearch as well */
3662 incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
65f19062 3663# else
574c798a 3664 incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
65f19062
GS		 3665# endif
3666#endif
189d1e8d 3667
65f19062 3668#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
574c798a 3669 incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
81c6dfba 3670#endif
65f19062
GS		 3671
3672#ifdef PERL_VENDORARCH_EXP
4ea817c6 3673 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS		 3674 * DLL-based path intuition to work correctly */
3675# if !defined(WIN32)
574c798a 3676 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
65f19062 3677# endif
4b03c463 3678#endif
65f19062
GS		 3679
3680#ifdef PERL_VENDORLIB_EXP
3681# if defined(WIN32)
574c798a 3682 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
65f19062 3683# else
574c798a 3684 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
65f19062 3685# endif
a3635516 3686#endif
65f19062
GS		 3687
3688#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
574c798a 3689 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
00dc2f4f 3690#endif
65f19062 3691
3b777bb4 3692#ifdef PERL_OTHERLIBDIRS
574c798a 3693 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
3b777bb4
GS		 3694#endif
3695
3280af22 3696 if (!PL_tainting)
574c798a 3697 incpush(".", FALSE, FALSE, TRUE);
bf4acbe4 3698#endif /* MACOS_TRADITIONAL */
774d564b 3699}
3700
ed79a026 3701#if defined(DOSISH) || defined(EPOC)
774d564b 3702# define PERLLIB_SEP ';'
3703#else
3704# if defined(VMS)
3705# define PERLLIB_SEP '|'
3706# else
bf4acbe4
GS		 3707# if defined(MACOS_TRADITIONAL)
3708# define PERLLIB_SEP ','
3709# else
3710# define PERLLIB_SEP ':'
3711# endif
774d564b 3712# endif
3713#endif
3714#ifndef PERLLIB_MANGLE
3715# define PERLLIB_MANGLE(s,n) (s)
ac27b0f5 3716#endif
774d564b 3717
76e3520e 3718STATIC void
574c798a 3719S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
774d564b 3720{
3721 SV *subdir = Nullsv;
774d564b 3722
3b290362 3723 if (!p || !*p)
774d564b 3724 return;
3725
9c8a64f0 3726 if (addsubdirs || addoldvers) {
00db4c45 3727 subdir = sv_newmortal();
774d564b 3728 }
3729
3730 /* Break at all separators */
3731 while (p && *p) {
8c52afec 3732 SV *libdir = NEWSV(55,0);
774d564b 3733 char *s;
3734
3735 /* skip any consecutive separators */
574c798a
SR		 3736 if (usesep) {
3737 while ( *p == PERLLIB_SEP ) {
3738 /* Uncomment the next line for PATH semantics */
3739 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3740 p++;
3741 }
774d564b 3742 }
3743
574c798a 3744 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
774d564b 3745 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3746 (STRLEN)(s - p));
3747 p = s + 1;
3748 }
3749 else {
3750 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3751 p = Nullch; /* break out */
3752 }
bf4acbe4 3753#ifdef MACOS_TRADITIONAL
e69a2255
JH		 3754 if (!strchr(SvPVX(libdir), ':')) {
3755 char buf[256];
3756
3757 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3758 }
bf4acbe4
GS		 3759 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3760 sv_catpv(libdir, ":");
3761#endif
774d564b 3762
3763 /*
3764 * BEFORE pushing libdir onto @INC we may first push version- and
3765 * archname-specific sub-directories.
3766 */
9c8a64f0 3767 if (addsubdirs || addoldvers) {
29d82f8d 3768#ifdef PERL_INC_VERSION_LIST
8353b874
GS		 3769 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3770 const char *incverlist[] = { PERL_INC_VERSION_LIST };
29d82f8d
GS		 3771 const char **incver;
3772#endif
c623ac67 3773 Stat_t tmpstatbuf;
aa689395 3774#ifdef VMS
3775 char *unix;
3776 STRLEN len;
774d564b 3777
2d8e6c8d 3778 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 3779 len = strlen(unix);
3780 while (unix[len-1] == '/') len--; /* Cosmetic */
3781 sv_usepvn(libdir,unix,len);
3782 }
3783 else
bf49b057 3784 PerlIO_printf(Perl_error_log,
aa689395 3785 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 3786 SvPV(libdir,len));
aa689395 3787#endif
9c8a64f0 3788 if (addsubdirs) {
bf4acbe4
GS		 3789#ifdef MACOS_TRADITIONAL
3790#define PERL_AV_SUFFIX_FMT ""
084592ab
CN		 3791#define PERL_ARCH_FMT "%s:"
3792#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
bf4acbe4
GS		 3793#else
3794#define PERL_AV_SUFFIX_FMT "/"
3795#define PERL_ARCH_FMT "/%s"
084592ab 3796#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
bf4acbe4 3797#endif
9c8a64f0 3798 /* .../version/archname if -d .../version/archname */
084592ab 3799 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
9c8a64f0
GS		 3800 libdir,
3801 (int)PERL_REVISION, (int)PERL_VERSION,
3802 (int)PERL_SUBVERSION, ARCHNAME);
3803 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3804 S_ISDIR(tmpstatbuf.st_mode))
3805 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4b03c463 3806
9c8a64f0 3807 /* .../version if -d .../version */
084592ab 3808 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
9c8a64f0
GS		 3809 (int)PERL_REVISION, (int)PERL_VERSION,
3810 (int)PERL_SUBVERSION);
3811 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3812 S_ISDIR(tmpstatbuf.st_mode))
3813 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3814
3815 /* .../archname if -d .../archname */
bf4acbe4 3816 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
29d82f8d
GS		 3817 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3818 S_ISDIR(tmpstatbuf.st_mode))
3819 av_push(GvAVn(PL_incgv), newSVsv(subdir));
29d82f8d 3820 }
9c8a64f0 3821
9c8a64f0 3822#ifdef PERL_INC_VERSION_LIST
ccc2aad8 3823 if (addoldvers) {
9c8a64f0
GS		 3824 for (incver = incverlist; *incver; incver++) {
3825 /* .../xxx if -d .../xxx */
bf4acbe4 3826 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
9c8a64f0
GS		 3827 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3828 S_ISDIR(tmpstatbuf.st_mode))
3829 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3830 }
3831 }
29d82f8d 3832#endif
774d564b 3833 }
3834
3835 /* finally push this lib directory on the end of @INC */
3280af22 3836 av_push(GvAVn(PL_incgv), libdir);
774d564b 3837 }
34de22dd 3838}
93a17b20 3839
4d1ff10f 3840#ifdef USE_5005THREADS
76e3520e 3841STATIC struct perl_thread *
cea2e8a9 3842S_init_main_thread(pTHX)
199100c8 3843{
c5be433b 3844#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 3845 struct perl_thread *thr;
cea2e8a9 3846#endif
199100c8
MB		 3847 XPV *xpv;
3848
52e1cb5e 3849 Newz(53, thr, 1, struct perl_thread);
533c011a 3850 PL_curcop = &PL_compiling;
c5be433b 3851 thr->interp = PERL_GET_INTERP;
199100c8 3852 thr->cvcache = newHV();
54b9620d 3853 thr->threadsv = newAV();
940cb80d 3854 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 3855 thr->specific = newAV();
3856 thr->flags = THRf_R_JOINABLE;
3857 MUTEX_INIT(&thr->mutex);
3858 /* Handcraft thrsv similarly to mess_sv */
533c011a 3859 New(53, PL_thrsv, 1, SV);
199100c8 3860 Newz(53, xpv, 1, XPV);
533c011a
NIS		 3861 SvFLAGS(PL_thrsv) = SVt_PV;
3862 SvANY(PL_thrsv) = (void*)xpv;
3863 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3864 SvPVX(PL_thrsv) = (char*)thr;
3865 SvCUR_set(PL_thrsv, sizeof(thr));
3866 SvLEN_set(PL_thrsv, sizeof(thr));
3867 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3868 thr->oursv = PL_thrsv;
3869 PL_chopset = " \n-";
3967c732 3870 PL_dumpindent = 4;
533c011a
NIS		 3871
3872 MUTEX_LOCK(&PL_threads_mutex);
3873 PL_nthreads++;
199100c8
MB		 3874 thr->tid = 0;
3875 thr->next = thr;
3876 thr->prev = thr;
8dcd6f7b 3877 thr->thr_done = 0;
533c011a 3878 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 3879
4b026b9e 3880#ifdef HAVE_THREAD_INTERN
4f63d024 3881 Perl_init_thread_intern(thr);
235db74f
GS		 3882#endif
3883
3884#ifdef SET_THREAD_SELF
3885 SET_THREAD_SELF(thr);
199100c8
MB		 3886#else
3887 thr->self = pthread_self();
235db74f 3888#endif /* SET_THREAD_SELF */
06d86050 3889 PERL_SET_THX(thr);
199100c8
MB		 3890
3891 /*
411caa50
JH		 3892 * These must come after the thread self setting
3893 * because sv_setpvn does SvTAINT and the taint
3894 * fields thread selfness being set.
199100c8 3895 */
533c011a
NIS		 3896 PL_toptarget = NEWSV(0,0);
3897 sv_upgrade(PL_toptarget, SVt_PVFM);
3898 sv_setpvn(PL_toptarget, "", 0);
3899 PL_bodytarget = NEWSV(0,0);
3900 sv_upgrade(PL_bodytarget, SVt_PVFM);
3901 sv_setpvn(PL_bodytarget, "", 0);
3902 PL_formtarget = PL_bodytarget;
79cb57f6 3903 thr->errsv = newSVpvn("", 0);
78857c3c 3904 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 3905
533c011a 3906 PL_maxscream = -1;
a2efc822 3907 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
0b94c7bb
GS		 3908 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3909 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3910 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3911 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3912 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 3913 PL_regindent = 0;
3914 PL_reginterp_cnt = 0;
5c0ca799 3915
199100c8
MB		 3916 return thr;
3917}
4d1ff10f 3918#endif /* USE_5005THREADS */
199100c8 3919
93a17b20 3920void
864dbfa3 3921Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 3922{
971a9dd3 3923 SV *atsv;
57843af0 3924 line_t oldline = CopLINE(PL_curcop);
312caa8e 3925 CV *cv;
22921e25 3926 STRLEN len;
6224f72b 3927 int ret;
db36c5a1 3928 dJMPENV;
93a17b20 3929
76e3520e 3930 while (AvFILL(paramList) >= 0) {
312caa8e 3931 cv = (CV*)av_shift(paramList);
ece599bd
RGS		 3932 if (PL_savebegin) {
3933 if (paramList == PL_beginav) {
059a8bb7 3934 /* save PL_beginav for compiler */
ece599bd
RGS		 3935 if (! PL_beginav_save)
3936 PL_beginav_save = newAV();
3937 av_push(PL_beginav_save, (SV*)cv);
3938 }
3939 else if (paramList == PL_checkav) {
3940 /* save PL_checkav for compiler */
3941 if (! PL_checkav_save)
3942 PL_checkav_save = newAV();
3943 av_push(PL_checkav_save, (SV*)cv);
3944 }
059a8bb7
JH		 3945 } else {
3946 SAVEFREESV(cv);
3947 }
14dd3ad8
GS		 3948#ifdef PERL_FLEXIBLE_EXCEPTIONS
3949 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3950#else
3951 JMPENV_PUSH(ret);
3952#endif
6224f72b 3953 switch (ret) {
312caa8e 3954 case 0:
14dd3ad8
GS		 3955#ifndef PERL_FLEXIBLE_EXCEPTIONS
3956 call_list_body(cv);
3957#endif
971a9dd3 3958 atsv = ERRSV;
312caa8e
CS		 3959 (void)SvPV(atsv, len);
3960 if (len) {
3961 PL_curcop = &PL_compiling;
57843af0 3962 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 3963 if (paramList == PL_beginav)
3964 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3965 else
4f25aa18
GS		 3966 Perl_sv_catpvf(aTHX_ atsv,
3967 "%s failed--call queue aborted",
7d30b5c4 3968 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 3969 : paramList == PL_initav ? "INIT"
3970 : "END");
312caa8e
CS		 3971 while (PL_scopestack_ix > oldscope)
3972 LEAVE;
14dd3ad8 3973 JMPENV_POP;
35c1215d 3974 Perl_croak(aTHX_ "%"SVf"", atsv);
a0d0e21e 3975 }
85e6fe83 3976 break;
6224f72b 3977 case 1:
f86702cc 3978 STATUS_ALL_FAILURE;
85e6fe83 3979 /* FALL THROUGH */
6224f72b 3980 case 2:
85e6fe83 3981 /* my_exit() was called */
3280af22 3982 while (PL_scopestack_ix > oldscope)
2ae324a7 3983 LEAVE;
84902520 3984 FREETMPS;
3280af22 3985 PL_curstash = PL_defstash;
3280af22 3986 PL_curcop = &PL_compiling;
57843af0 3987 CopLINE_set(PL_curcop, oldline);
14dd3ad8 3988 JMPENV_POP;
cc3604b1 3989 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 3990 if (paramList == PL_beginav)
cea2e8a9 3991 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 3992 else
4f25aa18 3993 Perl_croak(aTHX_ "%s failed--call queue aborted",
7d30b5c4 3994 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 3995 : paramList == PL_initav ? "INIT"
3996 : "END");
85e6fe83 3997 }
f86702cc 3998 my_exit_jump();
85e6fe83 3999 /* NOTREACHED */
6224f72b 4000 case 3:
312caa8e
CS		 4001 if (PL_restartop) {
4002 PL_curcop = &PL_compiling;
57843af0 4003 CopLINE_set(PL_curcop, oldline);
312caa8e 4004 JMPENV_JUMP(3);
85e6fe83 4005 }
bf49b057 4006 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 4007 FREETMPS;
4008 break;
8990e307 4009 }
14dd3ad8 4010 JMPENV_POP;
93a17b20 4011 }
93a17b20 4012}
93a17b20 4013
14dd3ad8 4014#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 4015STATIC void *
14dd3ad8 4016S_vcall_list_body(pTHX_ va_list args)
312caa8e 4017{
312caa8e 4018 CV *cv = va_arg(args, CV*);
14dd3ad8
GS		 4019 return call_list_body(cv);
4020}
4021#endif
312caa8e 4022
14dd3ad8
GS		 4023STATIC void *
4024S_call_list_body(pTHX_ CV *cv)
4025{
312caa8e 4026 PUSHMARK(PL_stack_sp);
864dbfa3 4027 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 4028 return NULL;
4029}
4030
f86702cc 4031void
864dbfa3 4032Perl_my_exit(pTHX_ U32 status)
f86702cc 4033{
8b73bbec 4034 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 4035 thr, (unsigned long) status));
f86702cc 4036 switch (status) {
4037 case 0:
4038 STATUS_ALL_SUCCESS;
4039 break;
4040 case 1:
4041 STATUS_ALL_FAILURE;
4042 break;
4043 default:
4044 STATUS_NATIVE_SET(status);
4045 break;
4046 }
4047 my_exit_jump();
4048}
4049
4050void
864dbfa3 4051Perl_my_failure_exit(pTHX)
f86702cc 4052{
4053#ifdef VMS
4054 if (vaxc$errno & 1) {
4fdae800 4055 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4056 STATUS_NATIVE_SET(44);
f86702cc 4057 }
4058 else {
ff0cee69 4059 if (!vaxc$errno && errno) /* unlikely */
4fdae800 4060 STATUS_NATIVE_SET(44);
f86702cc 4061 else
4fdae800 4062 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 4063 }
4064#else
9b599b2a 4065 int exitstatus;
f86702cc 4066 if (errno & 255)
4067 STATUS_POSIX_SET(errno);
9b599b2a 4068 else {
ac27b0f5 4069 exitstatus = STATUS_POSIX >> 8;
9b599b2a
GS		 4070 if (exitstatus & 255)
4071 STATUS_POSIX_SET(exitstatus);
4072 else
4073 STATUS_POSIX_SET(255);
4074 }
f86702cc 4075#endif
4076 my_exit_jump();
93a17b20
LW		 4077}
4078
76e3520e 4079STATIC void
cea2e8a9 4080S_my_exit_jump(pTHX)
f86702cc 4081{
c09156bb 4082 register PERL_CONTEXT *cx;
f86702cc 4083 I32 gimme;
4084 SV **newsp;
4085
3280af22
NIS		 4086 if (PL_e_script) {
4087 SvREFCNT_dec(PL_e_script);
4088 PL_e_script = Nullsv;
f86702cc 4089 }
4090
3280af22 4091 POPSTACK_TO(PL_mainstack);
f86702cc 4092 if (cxstack_ix >= 0) {
4093 if (cxstack_ix > 0)
4094 dounwind(0);
3280af22 4095 POPBLOCK(cx,PL_curpm);
f86702cc 4096 LEAVE;
4097 }
ff0cee69 4098
6224f72b 4099 JMPENV_JUMP(2);
f86702cc 4100}
873ef191 4101
0cb96387 4102static I32
acfe0abc 4103read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
873ef191
GS		 4104{
4105 char *p, *nl;
3280af22 4106 p = SvPVX(PL_e_script);
873ef191 4107 nl = strchr(p, '\n');
3280af22 4108 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 4109 if (nl-p == 0) {
0cb96387 4110 filter_del(read_e_script);
873ef191 4111 return 0;
7dfe3f66 4112 }
873ef191 4113 sv_catpvn(buf_sv, p, nl-p);
3280af22 4114 sv_chop(PL_e_script, nl);
873ef191
GS		 4115 return 1;
4116}
Unnamed repository; edit this file 'description' to name the repository.