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