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