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