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