This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fix Archive-Tar tests on Win32
[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 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 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 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 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 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 563 /* loosen bonds of global variables */
564
3280af22
NIS		 565 if(PL_rsfp) {
566 (void)PerlIO_close(PL_rsfp);
567 PL_rsfp = Nullfp;
8ebc5c01 568 }
569
570 /* Filters for program text */
3280af22
NIS		 571 SvREFCNT_dec(PL_rsfp_filters);
572 PL_rsfp_filters = Nullav;
8ebc5c01 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 594 }
595
bf9cdc68
RG		 596 PL_perldb = 0;
597
8ebc5c01 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 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 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.
806 */
807 I32 riter;
808 I32 max;
809 HE *hent;
810 HE **array;
811
812 riter = 0;
3280af22
NIS		 813 max = HvMAX(PL_strtab);
814 array = HvARRAY(PL_strtab);
6e72f9df 815 hent = array[0];
816 for (;;) {
0453d815 817 if (hent && ckWARN_d(WARN_INTERNAL)) {
9014280d 818 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 819 "Unbalanced string table refcount: (%d) for \"%s\"",
6e72f9df 820 HeVAL(hent) - Nullsv, HeKEY(hent));
821 HeVAL(hent) = Nullsv;
822 hent = HeNEXT(hent);
823 }
824 if (!hent) {
825 if (++riter > max)
826 break;
827 hent = array[riter];
828 }
829 }
830 }
3280af22 831 SvREFCNT_dec(PL_strtab);
6e72f9df 832
e652bb2f 833#ifdef USE_ITHREADS
c21d1a0f 834 /* free the pointer tables used for cloning */
a0739874 835 ptr_table_free(PL_ptr_table);
bf9cdc68 836 PL_ptr_table = (PTR_TBL_t*)NULL;
53186e96 837#endif
a0739874 838
d33b2eba
GS		 839 /* free special SVs */
840
841 SvREFCNT(&PL_sv_yes) = 0;
842 sv_clear(&PL_sv_yes);
843 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 844 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS		 845
846 SvREFCNT(&PL_sv_no) = 0;
847 sv_clear(&PL_sv_no);
848 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 849 SvFLAGS(&PL_sv_no) = 0;
01724ea0 850
9f375a43
DM		 851 {
852 int i;
853 for (i=0; i<=2; i++) {
854 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
855 sv_clear(PERL_DEBUG_PAD(i));
856 SvANY(PERL_DEBUG_PAD(i)) = NULL;
857 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
858 }
859 }
860
0453d815 861 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
9014280d 862 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 863
eba0f806
DM		 864#ifdef DEBUG_LEAKING_SCALARS
865 if (PL_sv_count != 0) {
866 SV* sva;
867 SV* sv;
868 register SV* svend;
869
870 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
871 svend = &sva[SvREFCNT(sva)];
872 for (sv = sva + 1; sv < svend; ++sv) {
873 if (SvTYPE(sv) != SVTYPEMASK) {
a548cda8 874 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
61b61456 875 " flags=0x%"UVxf
fd0854ff
DM		 876 " refcnt=%"UVuf pTHX__FORMAT "\n"
877 "\tallocated at %s:%d %s %s%s\n",
878 sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
879 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
880 sv->sv_debug_line,
881 sv->sv_debug_inpad ? "for" : "by",
882 sv->sv_debug_optype ?
883 PL_op_name[sv->sv_debug_optype]: "(none)",
884 sv->sv_debug_cloned ? " (cloned)" : ""
885 );
eba0f806
DM		 886 }
887 }
888 }
889 }
890#endif
bf9cdc68 891 PL_sv_count = 0;
eba0f806
DM		 892
893
56a2bab7 894#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS		 895 /* No more IO - including error messages ! */
896 PerlIO_cleanup(aTHX);
897#endif
898
9f4bd222
NIS		 899 /* sv_undef needs to stay immortal until after PerlIO_cleanup
900 as currently layers use it rather than Nullsv as a marker
901 for no arg - and will try and SvREFCNT_dec it.
902 */
903 SvREFCNT(&PL_sv_undef) = 0;
904 SvREADONLY_off(&PL_sv_undef);
905
3280af22 906 Safefree(PL_origfilename);
bf9cdc68 907 PL_origfilename = Nullch;
3280af22 908 Safefree(PL_reg_start_tmp);
bf9cdc68
RG		 909 PL_reg_start_tmp = (char**)NULL;
910 PL_reg_start_tmpl = 0;
5c5e4c24
IZ		 911 if (PL_reg_curpm)
912 Safefree(PL_reg_curpm);
82ba1be6 913 Safefree(PL_reg_poscache);
dd28f7bb 914 free_tied_hv_pool();
3280af22 915 Safefree(PL_op_mask);
cf36064f 916 Safefree(PL_psig_ptr);
bf9cdc68 917 PL_psig_ptr = (SV**)NULL;
cf36064f 918 Safefree(PL_psig_name);
bf9cdc68 919 PL_psig_name = (SV**)NULL;
2c2666fc 920 Safefree(PL_bitcount);
bf9cdc68 921 PL_bitcount = Nullch;
ce08f86c 922 Safefree(PL_psig_pend);
bf9cdc68
RG		 923 PL_psig_pend = (int*)NULL;
924 PL_formfeed = Nullsv;
6e72f9df 925 nuke_stacks();
bf9cdc68
RG		 926 PL_tainting = FALSE;
927 PL_taint_warn = FALSE;
3280af22 928 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
bf9cdc68 929 PL_debug = 0;
ac27b0f5 930
a0d0e21e 931 DEBUG_P(debprofdump());
d33b2eba 932
e5dd39fc 933#ifdef USE_REENTRANT_API
10bc17b6 934 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 935#endif
936
612f20c3
GS		 937 sv_free_arenas();
938
fc36a67e 939 /* As the absolutely last thing, free the non-arena SV for mess() */
940
3280af22 941 if (PL_mess_sv) {
f350b448
NC		 942 /* we know that type == SVt_PVMG */
943
9c63abab 944 /* it could have accumulated taint magic */
f350b448
NC		 945 MAGIC* mg;
946 MAGIC* moremagic;
947 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
948 moremagic = mg->mg_moremagic;
949 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
950 && mg->mg_len >= 0)
951 Safefree(mg->mg_ptr);
952 Safefree(mg);
9c63abab 953 }
f350b448 954
fc36a67e 955 /* we know that type >= SVt_PV */
8bd4d4c5 956 SvPV_free(PL_mess_sv);
3280af22
NIS		 957 Safefree(SvANY(PL_mess_sv));
958 Safefree(PL_mess_sv);
959 PL_mess_sv = Nullsv;
fc36a67e 960 }
31d77e54 961 return STATUS_NATIVE_EXPORT;
79072805
LW		 962}
963
954c1994
GS		 964/*
965=for apidoc perl_free
966
967Releases a Perl interpreter. See L<perlembed>.
968
969=cut
970*/
971
79072805 972void
0cb96387 973perl_free(pTHXx)
79072805 974{
acfe0abc 975#if defined(WIN32) || defined(NETWARE)
ce3e5b80 976# if defined(PERL_IMPLICIT_SYS)
acfe0abc
GS		 977# ifdef NETWARE
978 void *host = nw_internal_host;
979# else
980 void *host = w32_internal_host;
981# endif
ce3e5b80 982 PerlMem_free(aTHXx);
acfe0abc 983# ifdef NETWARE
011f1a1a 984 nw_delete_internal_host(host);
acfe0abc
GS		 985# else
986 win32_delete_internal_host(host);
987# endif
1c0ca838
GS		 988# else
989 PerlMem_free(aTHXx);
990# endif
acfe0abc
GS		 991#else
992 PerlMem_free(aTHXx);
76e3520e 993#endif
79072805
LW		 994}
995
aebd1ac7
GA		 996#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
997/* provide destructors to clean up the thread key when libperl is unloaded */
998#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
999
110d3f98 1000#if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
aebd1ac7
GA		 1001#pragma fini "perl_fini"
1002#endif
1003
0dbb1585
AL		 1004static void
1005#if defined(__GNUC__)
1006__attribute__((destructor))
aebd1ac7 1007#endif
de009b76 1008perl_fini(void)
aebd1ac7 1009{
27da23d5 1010 dVAR;
aebd1ac7
GA		 1011 if (PL_curinterp)
1012 FREE_THREAD_KEY;
1013}
1014
1015#endif /* WIN32 */
1016#endif /* THREADS */
1017
4b556e6c 1018void
864dbfa3 1019Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 1020{
3280af22
NIS		 1021 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1022 PL_exitlist[PL_exitlistlen].fn = fn;
1023 PL_exitlist[PL_exitlistlen].ptr = ptr;
1024 ++PL_exitlistlen;
4b556e6c
JD		 1025}
1026
56cf6df8
RGS		 1027#ifdef HAS_PROCSELFEXE
1028/* This is a function so that we don't hold on to MAXPATHLEN
1029 bytes of stack longer than necessary
1030 */
1031STATIC void
e1ec3a88 1032S_procself_val(pTHX_ SV *sv, const char *arg0)
56cf6df8
RGS		 1033{
1034 char buf[MAXPATHLEN];
1035 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1036
1037 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1038 includes a spurious NUL which will cause $^X to fail in system
1039 or backticks (this will prevent extensions from being built and
1040 many tests from working). readlink is not meant to add a NUL.
1041 Normal readlink works fine.
1042 */
1043 if (len > 0 && buf[len-1] == '\0') {
1044 len--;
1045 }
1046
1047 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1048 returning the text "unknown" from the readlink rather than the path
1049 to the executable (or returning an error from the readlink). Any valid
1050 path has a '/' in it somewhere, so use that to validate the result.
1051 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1052 */
1053 if (len > 0 && memchr(buf, '/', len)) {
1054 sv_setpvn(sv,buf,len);
1055 }
1056 else {
1057 sv_setpv(sv,arg0);
1058 }
1059}
1060#endif /* HAS_PROCSELFEXE */
b7975bdd
NC		 1061
1062STATIC void
1063S_set_caret_X(pTHX) {
1064 GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
1065 if (tmpgv) {
1066#ifdef HAS_PROCSELFEXE
1067 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1068#else
1069#ifdef OS2
1070 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
1071#else
1072 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
1073#endif
1074#endif
1075 }
1076}
1077
954c1994
GS		 1078/*
1079=for apidoc perl_parse
1080
1081Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1082
1083=cut
1084*/
1085
79072805 1086int
0cb96387 1087perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 1088{
27da23d5 1089 dVAR;
6224f72b 1090 I32 oldscope;
6224f72b 1091 int ret;
db36c5a1 1092 dJMPENV;
8d063cd8 1093
a687059c
LW		 1094#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1095#ifdef IAMSUID
1096#undef IAMSUID
cea2e8a9 1097 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c 1098setuid perl scripts securely.\n");
ae3f3efd 1099#endif /* IAMSUID */
a687059c
LW		 1100#endif
1101
b0891165
JH		 1102#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1103 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
103dd899 1104 * This MUST be done before any hash stores or fetches take place.
008fb0c0
NC		 1105 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1106 * yourself, it is your responsibility to provide a good random seed!
830b38bd 1107 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
008fb0c0
NC		 1108 if (!PL_rehash_seed_set)
1109 PL_rehash_seed = get_hash_seed();
b0891165 1110 {
bed60192
JH		 1111 char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1112
1113 if (s) {
1114 int i = atoi(s);
1115
1116 if (i == 1)
1117 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
008fb0c0 1118 PL_rehash_seed);
bed60192 1119 }
b0891165
JH		 1120 }
1121#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1122
3280af22 1123 PL_origargc = argc;
e2975953 1124 PL_origargv = argv;
a0d0e21e 1125
54bfe034 1126 {
3cb9023d
JH		 1127 /* Set PL_origalen be the sum of the contiguous argv[]
1128 * elements plus the size of the env in case that it is
e9137a8e 1129 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
3cb9023d
JH		 1130 * as the maximum modifiable length of $0. In the worst case
1131 * the area we are able to modify is limited to the size of
43c32782 1132 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d 1133 * --jhi */
e1ec3a88 1134 const char *s = NULL;
54bfe034 1135 int i;
7d8e7db3
JH		 1136 UV mask =
1137 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
43c32782
JH		 1138 /* Do the mask check only if the args seem like aligned. */
1139 UV aligned =
1140 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1141
1142 /* See if all the arguments are contiguous in memory. Note
1143 * that 'contiguous' is a loose term because some platforms
1144 * align the argv[] and the envp[]. If the arguments look
1145 * like non-aligned, assume that they are 'strictly' or
1146 * 'traditionally' contiguous. If the arguments look like
1147 * aligned, we just check that they are within aligned
1148 * PTRSIZE bytes. As long as no system has something bizarre
1149 * like the argv[] interleaved with some other data, we are
1150 * fine. (Did I just evoke Murphy's Law?) --jhi */
c8941eeb
JH		 1151 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1152 while (*s) s++;
1153 for (i = 1; i < PL_origargc; i++) {
1154 if ((PL_origargv[i] == s + 1
43c32782 1155#ifdef OS2
c8941eeb 1156 || PL_origargv[i] == s + 2
43c32782 1157#endif
c8941eeb
JH		 1158 )
1159 ||
1160 (aligned &&
1161 (PL_origargv[i] > s &&
1162 PL_origargv[i] <=
1163 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1164 )
1165 {
1166 s = PL_origargv[i];
1167 while (*s) s++;
1168 }
1169 else
1170 break;
54bfe034 1171 }
54bfe034 1172 }
3cb9023d 1173 /* Can we grab env area too to be used as the area for $0? */
43c32782
JH		 1174 if (PL_origenviron) {
1175 if ((PL_origenviron[0] == s + 1
1176#ifdef OS2
1177 || (PL_origenviron[0] == s + 9 && (s += 8))
1178#endif
1179 )
1180 ||
1181 (aligned &&
1182 (PL_origenviron[0] > s &&
1183 PL_origenviron[0] <=
1184 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1185 )
1186 {
1187#ifndef OS2
1188 s = PL_origenviron[0];
1189 while (*s) s++;
1190#endif
1191 my_setenv("NoNe SuCh", Nullch);
1192 /* Force copy of environment. */
1193 for (i = 1; PL_origenviron[i]; i++) {
1194 if (PL_origenviron[i] == s + 1
1195 ||
1196 (aligned &&
1197 (PL_origenviron[i] > s &&
1198 PL_origenviron[i] <=
1199 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1200 )
1201 {
1202 s = PL_origenviron[i];
1203 while (*s) s++;
1204 }
1205 else
1206 break;
54bfe034 1207 }
43c32782 1208 }
54bfe034 1209 }
284e1220 1210 PL_origalen = s - PL_origargv[0] + 1;
54bfe034
JH		 1211 }
1212
3280af22 1213 if (PL_do_undump) {
a0d0e21e
LW		 1214
1215 /* Come here if running an undumped a.out. */
1216
3280af22
NIS		 1217 PL_origfilename = savepv(argv[0]);
1218 PL_do_undump = FALSE;
a0d0e21e 1219 cxstack_ix = -1; /* start label stack again */
748a9306 1220 init_ids();
b7975bdd
NC		 1221 assert (!PL_tainted);
1222 TAINT;
1223 S_set_caret_X(aTHX);
1224 TAINT_NOT;
a0d0e21e
LW		 1225 init_postdump_symbols(argc,argv,env);
1226 return 0;
1227 }
1228
3280af22 1229 if (PL_main_root) {
3280af22
NIS		 1230 op_free(PL_main_root);
1231 PL_main_root = Nullop;
ff0cee69 1232 }
3280af22
NIS		 1233 PL_main_start = Nullop;
1234 SvREFCNT_dec(PL_main_cv);
1235 PL_main_cv = Nullcv;
79072805 1236
3280af22
NIS		 1237 time(&PL_basetime);
1238 oldscope = PL_scopestack_ix;
599cee73 1239 PL_dowarn = G_WARN_OFF;
f86702cc 1240
14dd3ad8 1241 JMPENV_PUSH(ret);
6224f72b 1242 switch (ret) {
312caa8e 1243 case 0:
14dd3ad8 1244 parse_body(env,xsinit);
7d30b5c4
GS		 1245 if (PL_checkav)
1246 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1247 ret = 0;
1248 break;
6224f72b
GS		 1249 case 1:
1250 STATUS_ALL_FAILURE;
1251 /* FALL THROUGH */
1252 case 2:
1253 /* my_exit() was called */
3280af22 1254 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1255 LEAVE;
1256 FREETMPS;
3280af22 1257 PL_curstash = PL_defstash;
7d30b5c4
GS		 1258 if (PL_checkav)
1259 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1260 ret = STATUS_NATIVE_EXPORT;
1261 break;
6224f72b 1262 case 3:
bf49b057 1263 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1264 ret = 1;
1265 break;
6224f72b 1266 }
14dd3ad8
GS		 1267 JMPENV_POP;
1268 return ret;
1269}
1270
312caa8e 1271STATIC void *
14dd3ad8 1272S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1273{
27da23d5 1274 dVAR;
312caa8e 1275 int argc = PL_origargc;
8f42b153 1276 char **argv = PL_origargv;
e1ec3a88 1277 const char *scriptname = NULL;
312caa8e 1278 VOL bool dosearch = FALSE;
e1ec3a88 1279 const char *validarg = "";
312caa8e
CS		 1280 register SV *sv;
1281 register char *s;
e1ec3a88 1282 const char *cddir = Nullch;
ab019eaa 1283#ifdef USE_SITECUSTOMIZE
20ef40cf 1284 bool minus_f = FALSE;
ab019eaa 1285#endif
312caa8e 1286
ae3f3efd
PS		 1287 PL_fdscript = -1;
1288 PL_suidscript = -1;
3280af22 1289 sv_setpvn(PL_linestr,"",0);
79cb57f6 1290 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 1291 SAVEFREESV(sv);
1292 init_main_stash();
54310121 1293
6224f72b
GS		 1294 for (argc--,argv++; argc > 0; argc--,argv++) {
1295 if (argv[0][0] != '-' || !argv[0][1])
1296 break;
1297#ifdef DOSUID
1298 if (*validarg)
1299 validarg = " PHOOEY ";
1300 else
1301 validarg = argv[0];
ae3f3efd
PS		 1302 /*
1303 * Can we rely on the kernel to start scripts with argv[1] set to
1304 * contain all #! line switches (the whole line)? (argv[0] is set to
1305 * the interpreter name, argv[2] to the script name; argv[3] and
1306 * above may contain other arguments.)
1307 */
13281fa4 1308#endif
6224f72b
GS		 1309 s = argv[0]+1;
1310 reswitch:
1311 switch (*s) {
729a02f2 1312 case 'C':
1d5472a9
GS		 1313#ifndef PERL_STRICT_CR
1314 case '\r':
1315#endif
6224f72b
GS		 1316 case ' ':
1317 case '0':
1318 case 'F':
1319 case 'a':
1320 case 'c':
1321 case 'd':
1322 case 'D':
1323 case 'h':
1324 case 'i':
1325 case 'l':
1326 case 'M':
1327 case 'm':
1328 case 'n':
1329 case 'p':
1330 case 's':
1331 case 'u':
1332 case 'U':
1333 case 'v':
599cee73
PM		 1334 case 'W':
1335 case 'X':
6224f72b 1336 case 'w':
06492da6 1337 case 'A':
155aba94 1338 if ((s = moreswitches(s)))
6224f72b
GS		 1339 goto reswitch;
1340 break;
33b78306 1341
1dbad523 1342 case 't':
22f7c9c9 1343 CHECK_MALLOC_TOO_LATE_FOR('t');
317ea90d
MS		 1344 if( !PL_tainting ) {
1345 PL_taint_warn = TRUE;
1346 PL_tainting = TRUE;
1347 }
1348 s++;
1349 goto reswitch;
6224f72b 1350 case 'T':
22f7c9c9 1351 CHECK_MALLOC_TOO_LATE_FOR('T');
3280af22 1352 PL_tainting = TRUE;
317ea90d 1353 PL_taint_warn = FALSE;
6224f72b
GS		 1354 s++;
1355 goto reswitch;
f86702cc 1356
6224f72b 1357 case 'e':
bf4acbe4
GS		 1358#ifdef MACOS_TRADITIONAL
1359 /* ignore -e for Dev:Pseudo argument */
1360 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1361 break;
bf4acbe4 1362#endif
ae3f3efd 1363 forbid_setid("-e");
3280af22 1364 if (!PL_e_script) {
79cb57f6 1365 PL_e_script = newSVpvn("",0);
0cb96387 1366 filter_add(read_e_script, NULL);
6224f72b
GS		 1367 }
1368 if (*++s)
3280af22 1369 sv_catpv(PL_e_script, s);
6224f72b 1370 else if (argv[1]) {
3280af22 1371 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1372 argc--,argv++;
1373 }
1374 else
cea2e8a9 1375 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1376 sv_catpv(PL_e_script, "\n");
6224f72b 1377 break;
afe37c7d 1378
20ef40cf 1379 case 'f':
f5542d3a 1380#ifdef USE_SITECUSTOMIZE
20ef40cf 1381 minus_f = TRUE;
f5542d3a 1382#endif
20ef40cf
GA		 1383 s++;
1384 goto reswitch;
1385
6224f72b
GS		 1386 case 'I': /* -I handled both here and in moreswitches() */
1387 forbid_setid("-I");
1388 if (!*++s && (s=argv[1]) != Nullch) {
1389 argc--,argv++;
1390 }
6224f72b 1391 if (s && *s) {
0df16ed7
GS		 1392 char *p;
1393 STRLEN len = strlen(s);
1394 p = savepvn(s, len);
88fe16b2 1395 incpush(p, TRUE, TRUE, FALSE, FALSE);
0df16ed7
GS		 1396 sv_catpvn(sv, "-I", 2);
1397 sv_catpvn(sv, p, len);
1398 sv_catpvn(sv, " ", 1);
6224f72b 1399 Safefree(p);
0df16ed7
GS		 1400 }
1401 else
a67e862a 1402 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1403 break;
1404 case 'P':
1405 forbid_setid("-P");
3280af22 1406 PL_preprocess = TRUE;
6224f72b
GS		 1407 s++;
1408 goto reswitch;
1409 case 'S':
1410 forbid_setid("-S");
1411 dosearch = TRUE;
1412 s++;
1413 goto reswitch;
1414 case 'V':
3280af22
NIS		 1415 if (!PL_preambleav)
1416 PL_preambleav = newAV();
1417 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1418 if (*++s != ':') {
efcaa95b
YST		 1419 STRLEN opts;
1420
3280af22 1421 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1422#ifdef VMS
6b88bc9c 1423 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1424#else
3280af22 1425 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1426#endif
efcaa95b
YST		 1427 opts = SvCUR(PL_Sv);
1428
3280af22 1429 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1430# ifdef DEBUGGING
3280af22 1431 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1432# endif
6224f72b 1433# ifdef MULTIPLICITY
8f872242 1434 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1435# endif
4d1ff10f
AB		 1436# ifdef USE_5005THREADS
1437 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1438# endif
ac5e8965
JH		 1439# ifdef USE_ITHREADS
1440 sv_catpv(PL_Sv," USE_ITHREADS");
1441# endif
10cc9d2a
JH		 1442# ifdef USE_64_BIT_INT
1443 sv_catpv(PL_Sv," USE_64_BIT_INT");
1444# endif
1445# ifdef USE_64_BIT_ALL
1446 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1447# endif
1448# ifdef USE_LONG_DOUBLE
1449 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1450# endif
53430762
JH		 1451# ifdef USE_LARGE_FILES
1452 sv_catpv(PL_Sv," USE_LARGE_FILES");
1453# endif
ac5e8965
JH		 1454# ifdef USE_SOCKS
1455 sv_catpv(PL_Sv," USE_SOCKS");
1456# endif
20ef40cf
GA		 1457# ifdef USE_SITECUSTOMIZE
1458 sv_catpv(PL_Sv," USE_SITECUSTOMIZE");
1459# endif
b363f7ed
GS		 1460# ifdef PERL_IMPLICIT_CONTEXT
1461 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1462# endif
1463# ifdef PERL_IMPLICIT_SYS
1464 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1465# endif
efcaa95b
YST		 1466
1467 while (SvCUR(PL_Sv) > opts+76) {
1468 /* find last space after "options: " and before col 76 */
1469
dd374669
AL		 1470 const char *space;
1471 char *pv = SvPV_nolen(PL_Sv);
1472 const char c = pv[opts+76];
efcaa95b
YST		 1473 pv[opts+76] = '\0';
1474 space = strrchr(pv+opts+26, ' ');
1475 pv[opts+76] = c;
1476 if (!space) break; /* "Can't happen" */
1477
1478 /* break the line before that space */
1479
1480 opts = space - pv;
1481 sv_insert(PL_Sv, opts, 0,
1482 "\\n ", 25);
1483 }
1484
3280af22 1485 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1486
6224f72b
GS		 1487#if defined(LOCAL_PATCH_COUNT)
1488 if (LOCAL_PATCH_COUNT > 0) {
1489 int i;
3280af22 1490 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1491 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1492 if (PL_localpatches[i])
acb03d05
AB		 1493 Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
1494 0, PL_localpatches[i], 0);
6224f72b
GS		 1495 }
1496 }
1497#endif
cea2e8a9 1498 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1499#ifdef __DATE__
1500# ifdef __TIME__
cea2e8a9 1501 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1502# else
cea2e8a9 1503 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1504# endif
1505#endif
3280af22 1506 sv_catpv(PL_Sv, "; \
6224f72b 1507$\"=\"\\n \"; \
69fcd688
JH		 1508@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1509#ifdef __CYGWIN__
1510 sv_catpv(PL_Sv,"\
1511push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1512#endif
1513 sv_catpv(PL_Sv, "\
6224f72b
GS		 1514print \" \\%ENV:\\n @env\\n\" if @env; \
1515print \" \\@INC:\\n @INC\\n\";");
1516 }
1517 else {
3280af22
NIS		 1518 PL_Sv = newSVpv("config_vars(qw(",0);
1519 sv_catpv(PL_Sv, ++s);
1520 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1521 s += strlen(s);
1522 }
3280af22 1523 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1524 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1525 goto reswitch;
1526 case 'x':
3280af22 1527 PL_doextract = TRUE;
6224f72b
GS		 1528 s++;
1529 if (*s)
f4c556ac 1530 cddir = s;
6224f72b
GS		 1531 break;
1532 case 0:
1533 break;
1534 case '-':
1535 if (!*++s || isSPACE(*s)) {
1536 argc--,argv++;
1537 goto switch_end;
1538 }
1539 /* catch use of gnu style long options */
1540 if (strEQ(s, "version")) {
dd374669 1541 s = (char *)"v";
6224f72b
GS		 1542 goto reswitch;
1543 }
1544 if (strEQ(s, "help")) {
dd374669 1545 s = (char *)"h";
6224f72b
GS		 1546 goto reswitch;
1547 }
1548 s--;
1549 /* FALL THROUGH */
1550 default:
cea2e8a9 1551 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1552 }
1553 }
6224f72b 1554 switch_end:
54310121 1555
f675dbe5
CB		 1556 if (
1557#ifndef SECURE_INTERNAL_GETENV
1558 !PL_tainting &&
1559#endif
cf756827 1560 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1561 {
e1ec3a88 1562 const char *popt = s;
74288ac8
GS		 1563 while (isSPACE(*s))
1564 s++;
317ea90d 1565 if (*s == '-' && *(s+1) == 'T') {
22f7c9c9 1566 CHECK_MALLOC_TOO_LATE_FOR('T');
74288ac8 1567 PL_tainting = TRUE;
317ea90d
MS		 1568 PL_taint_warn = FALSE;
1569 }
74288ac8 1570 else {
cf756827 1571 char *popt_copy = Nullch;
74288ac8 1572 while (s && *s) {
4ea8f8fb 1573 char *d;
74288ac8
GS		 1574 while (isSPACE(*s))
1575 s++;
1576 if (*s == '-') {
1577 s++;
1578 if (isSPACE(*s))
1579 continue;
1580 }
4ea8f8fb 1581 d = s;
74288ac8
GS		 1582 if (!*s)
1583 break;
06492da6 1584 if (!strchr("DIMUdmtwA", *s))
cea2e8a9 1585 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1586 while (++s && *s) {
1587 if (isSPACE(*s)) {
cf756827
GS		 1588 if (!popt_copy) {
1589 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1590 s = popt_copy + (s - popt);
1591 d = popt_copy + (d - popt);
1592 }
4ea8f8fb
MS		 1593 *s++ = '\0';
1594 break;
1595 }
1596 }
1c4db469 1597 if (*d == 't') {
317ea90d
MS		 1598 if( !PL_tainting ) {
1599 PL_taint_warn = TRUE;
1600 PL_tainting = TRUE;
1601 }
1c4db469
RGS		 1602 } else {
1603 moreswitches(d);
1604 }
6224f72b 1605 }
6224f72b
GS		 1606 }
1607 }
a0d0e21e 1608
20ef40cf
GA		 1609#ifdef USE_SITECUSTOMIZE
1610 if (!minus_f) {
1611 if (!PL_preambleav)
1612 PL_preambleav = newAV();
1613 av_unshift(PL_preambleav, 1);
1614 (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
1615 }
1616#endif
1617
317ea90d
MS		 1618 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1619 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1620 }
1621
6224f72b
GS		 1622 if (!scriptname)
1623 scriptname = argv[0];
3280af22 1624 if (PL_e_script) {
6224f72b
GS		 1625 argc++,argv--;
1626 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1627 }
1628 else if (scriptname == Nullch) {
1629#ifdef MSDOS
1630 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1631 moreswitches("h");
1632#endif
1633 scriptname = "-";
1634 }
1635
b7975bdd
NC		 1636 /* Set $^X early so that it can be used for relocatable paths in @INC */
1637 assert (!PL_tainted);
1638 TAINT;
1639 S_set_caret_X(aTHX);
1640 TAINT_NOT;
6224f72b
GS		 1641 init_perllib();
1642
c5cccb17 1643 open_script(scriptname,dosearch,sv);
6224f72b 1644
c5cccb17 1645 validate_suid(validarg, scriptname);
6224f72b 1646
64ca3a65 1647#ifndef PERL_MICRO
0b5b802d
GS		 1648#if defined(SIGCHLD) || defined(SIGCLD)
1649 {
1650#ifndef SIGCHLD
1651# define SIGCHLD SIGCLD
1652#endif
1653 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1654 if (sigstate == SIG_IGN) {
1655 if (ckWARN(WARN_SIGNAL))
9014280d 1656 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1657 "Can't ignore signal CHLD, forcing to default");
1658 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1659 }
1660 }
1661#endif
64ca3a65 1662#endif
0b5b802d 1663
bf4acbe4
GS		 1664#ifdef MACOS_TRADITIONAL
1665 if (PL_doextract || gMacPerl_AlwaysExtract) {
1666#else
f4c556ac 1667 if (PL_doextract) {
bf4acbe4 1668#endif
6224f72b 1669 find_beginning();
dd374669 1670 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
f4c556ac
GS		 1671 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1672
1673 }
6224f72b 1674
3280af22
NIS		 1675 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1676 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1677 CvUNIQUE_on(PL_compcv);
1678
dd2155a4 1679 CvPADLIST(PL_compcv) = pad_new(0);
4d1ff10f 1680#ifdef USE_5005THREADS
533c011a
NIS		 1681 CvOWNER(PL_compcv) = 0;
1682 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1683 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1684#endif /* USE_5005THREADS */
6224f72b 1685
0c4f7ff0 1686 boot_core_PerlIO();
6224f72b 1687 boot_core_UNIVERSAL();
09bef843 1688 boot_core_xsutils();
6224f72b
GS		 1689
1690 if (xsinit)
acfe0abc 1691 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1692#ifndef PERL_MICRO
ed79a026 1693#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1694 init_os_extras();
6224f72b 1695#endif
64ca3a65 1696#endif
6224f72b 1697
29209bc5 1698#ifdef USE_SOCKS
1b9c9cf5
DH		 1699# ifdef HAS_SOCKS5_INIT
1700 socks5_init(argv[0]);
1701# else
29209bc5 1702 SOCKSinit(argv[0]);
1b9c9cf5 1703# endif
ac27b0f5 1704#endif
29209bc5 1705
6224f72b
GS		 1706 init_predump_symbols();
1707 /* init_postdump_symbols not currently designed to be called */
1708 /* more than once (ENV isn't cleared first, for example) */
1709 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1710 if (!PL_do_undump)
6224f72b
GS		 1711 init_postdump_symbols(argc,argv,env);
1712
27da23d5
JH		 1713 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
1714 * or explicitly in some platforms.
085a54d9 1715 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 1716 * look like the user wants to use UTF-8. */
27da23d5
JH		 1717#if defined(SYMBIAN)
1718 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
1719#endif
06e66572
JH		 1720 if (PL_unicode) {
1721 /* Requires init_predump_symbols(). */
a05d7ebb 1722 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH		 1723 IO* io;
1724 PerlIO* fp;
1725 SV* sv;
1726
a05d7ebb 1727 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 1728 * and the default open disciplines. */
a05d7ebb
JH		 1729 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1730 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1731 (fp = IoIFP(io)))
1732 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1733 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1734 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1735 (fp = IoOFP(io)))
1736 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1737 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1738 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1739 (fp = IoOFP(io)))
1740 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1741 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1742 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1743 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1744 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1745 if (in) {
1746 if (out)
1747 sv_setpvn(sv, ":utf8\0:utf8", 11);
1748 else
1749 sv_setpvn(sv, ":utf8\0", 6);
1750 }
1751 else if (out)
1752 sv_setpvn(sv, "\0:utf8", 6);
1753 SvSETMAGIC(sv);
1754 }
b310b053
JH		 1755 }
1756 }
1757
4ffa73a3
JH		 1758 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1759 if (strEQ(s, "unsafe"))
1760 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1761 else if (strEQ(s, "safe"))
1762 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1763 else
1764 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1765 }
1766
6224f72b
GS		 1767 init_lexer();
1768
1769 /* now parse the script */
1770
93189314 1771 SETERRNO(0,SS_NORMAL);
3280af22 1772 PL_error_count = 0;
bf4acbe4
GS		 1773#ifdef MACOS_TRADITIONAL
1774 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1775 if (PL_minus_c)
1776 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1777 else {
1778 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1779 MacPerl_MPWFileName(PL_origfilename));
1780 }
1781 }
1782#else
3280af22
NIS		 1783 if (yyparse() || PL_error_count) {
1784 if (PL_minus_c)
cea2e8a9 1785 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1786 else {
cea2e8a9 1787 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1788 PL_origfilename);
6224f72b
GS		 1789 }
1790 }
bf4acbe4 1791#endif
57843af0 1792 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1793 PL_curstash = PL_defstash;
1794 PL_preprocess = FALSE;
1795 if (PL_e_script) {
1796 SvREFCNT_dec(PL_e_script);
1797 PL_e_script = Nullsv;
6224f72b
GS		 1798 }
1799
3280af22 1800 if (PL_do_undump)
6224f72b
GS		 1801 my_unexec();
1802
57843af0
GS		 1803 if (isWARN_ONCE) {
1804 SAVECOPFILE(PL_curcop);
1805 SAVECOPLINE(PL_curcop);
3280af22 1806 gv_check(PL_defstash);
57843af0 1807 }
6224f72b
GS		 1808
1809 LEAVE;
1810 FREETMPS;
1811
1812#ifdef MYMALLOC
1813 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1814 dump_mstats("after compilation:");
1815#endif
1816
1817 ENTER;
3280af22 1818 PL_restartop = 0;
312caa8e 1819 return NULL;
6224f72b
GS		 1820}
1821
954c1994
GS		 1822/*
1823=for apidoc perl_run
1824
1825Tells a Perl interpreter to run. See L<perlembed>.
1826
1827=cut
1828*/
1829
6224f72b 1830int
0cb96387 1831perl_run(pTHXx)
6224f72b 1832{
6224f72b 1833 I32 oldscope;
14dd3ad8 1834 int ret = 0;
db36c5a1 1835 dJMPENV;
6224f72b 1836
3280af22 1837 oldscope = PL_scopestack_ix;
96e176bf
CL		 1838#ifdef VMS
1839 VMSISH_HUSHED = 0;
1840#endif
6224f72b 1841
14dd3ad8 1842 JMPENV_PUSH(ret);
6224f72b
GS		 1843 switch (ret) {
1844 case 1:
1845 cxstack_ix = -1; /* start context stack again */
312caa8e 1846 goto redo_body;
14dd3ad8 1847 case 0: /* normal completion */
14dd3ad8
GS		 1848 redo_body:
1849 run_body(oldscope);
14dd3ad8
GS		 1850 /* FALL THROUGH */
1851 case 2: /* my_exit() */
3280af22 1852 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1853 LEAVE;
1854 FREETMPS;
3280af22 1855 PL_curstash = PL_defstash;
3a1ee7e8 1856 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1857 PL_endav && !PL_minus_c)
1858 call_list(oldscope, PL_endav);
6224f72b
GS		 1859#ifdef MYMALLOC
1860 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1861 dump_mstats("after execution: ");
1862#endif
14dd3ad8
GS		 1863 ret = STATUS_NATIVE_EXPORT;
1864 break;
6224f72b 1865 case 3:
312caa8e
CS		 1866 if (PL_restartop) {
1867 POPSTACK_TO(PL_mainstack);
1868 goto redo_body;
6224f72b 1869 }
bf49b057 1870 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1871 FREETMPS;
14dd3ad8
GS		 1872 ret = 1;
1873 break;
6224f72b
GS		 1874 }
1875
14dd3ad8
GS		 1876 JMPENV_POP;
1877 return ret;
312caa8e
CS		 1878}
1879
14dd3ad8 1880
dd374669 1881STATIC void
14dd3ad8
GS		 1882S_run_body(pTHX_ I32 oldscope)
1883{
6224f72b 1884 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1885 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1886
3280af22 1887 if (!PL_restartop) {
6224f72b 1888 DEBUG_x(dump_all());
ecae49c0
NC		 1889 if (!DEBUG_q_TEST)
1890 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1891 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1892 PTR2UV(thr)));
6224f72b 1893
3280af22 1894 if (PL_minus_c) {
bf4acbe4 1895#ifdef MACOS_TRADITIONAL
e69a2255
JH		 1896 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1897 (gMacPerl_ErrorFormat ? "# " : ""),
1898 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1899#else
bf49b057 1900 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1901#endif
6224f72b
GS		 1902 my_exit(0);
1903 }
3280af22 1904 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1905 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1906 if (PL_initav)
1907 call_list(oldscope, PL_initav);
6224f72b
GS		 1908 }
1909
1910 /* do it */
1911
3280af22 1912 if (PL_restartop) {
533c011a 1913 PL_op = PL_restartop;
3280af22 1914 PL_restartop = 0;
cea2e8a9 1915 CALLRUNOPS(aTHX);
6224f72b 1916 }
3280af22
NIS		 1917 else if (PL_main_start) {
1918 CvDEPTH(PL_main_cv) = 1;
533c011a 1919 PL_op = PL_main_start;
cea2e8a9 1920 CALLRUNOPS(aTHX);
6224f72b 1921 }
f6b3007c
JH		 1922 my_exit(0);
1923 /* NOTREACHED */
6224f72b
GS		 1924}
1925
954c1994 1926/*
ccfc67b7
JH		 1927=head1 SV Manipulation Functions
1928
954c1994
GS		 1929=for apidoc p||get_sv
1930
1931Returns the SV of the specified Perl scalar. If C<create> is set and the
1932Perl variable does not exist then it will be created. If C<create> is not
1933set and the variable does not exist then NULL is returned.
1934
1935=cut
1936*/
1937
6224f72b 1938SV*
864dbfa3 1939Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1940{
1941 GV *gv;
4d1ff10f 1942#ifdef USE_5005THREADS
6224f72b
GS		 1943 if (name[1] == '\0' && !isALPHA(name[0])) {
1944 PADOFFSET tmp = find_threadsv(name);
411caa50 1945 if (tmp != NOT_IN_PAD)
6224f72b 1946 return THREADSV(tmp);
6224f72b 1947 }
4d1ff10f 1948#endif /* USE_5005THREADS */
6224f72b
GS		 1949 gv = gv_fetchpv(name, create, SVt_PV);
1950 if (gv)
1951 return GvSV(gv);
1952 return Nullsv;
1953}
1954
954c1994 1955/*
ccfc67b7
JH		 1956=head1 Array Manipulation Functions
1957
954c1994
GS		 1958=for apidoc p||get_av
1959
1960Returns the AV of the specified Perl array. If C<create> is set and the
1961Perl variable does not exist then it will be created. If C<create> is not
1962set and the variable does not exist then NULL is returned.
1963
1964=cut
1965*/
1966
6224f72b 1967AV*
864dbfa3 1968Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1969{
1970 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1971 if (create)
1972 return GvAVn(gv);
1973 if (gv)
1974 return GvAV(gv);
1975 return Nullav;
1976}
1977
954c1994 1978/*
ccfc67b7
JH		 1979=head1 Hash Manipulation Functions
1980
954c1994
GS		 1981=for apidoc p||get_hv
1982
1983Returns the HV of the specified Perl hash. If C<create> is set and the
1984Perl variable does not exist then it will be created. If C<create> is not
1985set and the variable does not exist then NULL is returned.
1986
1987=cut
1988*/
1989
6224f72b 1990HV*
864dbfa3 1991Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1992{
a0d0e21e
LW		 1993 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1994 if (create)
1995 return GvHVn(gv);
1996 if (gv)
1997 return GvHV(gv);
1998 return Nullhv;
1999}
2000
954c1994 2001/*
ccfc67b7
JH		 2002=head1 CV Manipulation Functions
2003
954c1994
GS		 2004=for apidoc p||get_cv
2005
2006Returns the CV of the specified Perl subroutine. If C<create> is set and
2007the Perl subroutine does not exist then it will be declared (which has the
2008same effect as saying C<sub name;>). If C<create> is not set and the
2009subroutine does not exist then NULL is returned.
2010
2011=cut
2012*/
2013
a0d0e21e 2014CV*
864dbfa3 2015Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 2016{
2017 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 2018 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 2019 /* XXX this is probably not what they think they're getting.
2020 * It has the same effect as "sub name;", i.e. just a forward
2021 * declaration! */
8ebc5c01 2022 if (create && !GvCVu(gv))
774d564b 2023 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 2024 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 2025 Nullop,
a0d0e21e
LW		 2026 Nullop);
2027 if (gv)
8ebc5c01 2028 return GvCVu(gv);
a0d0e21e
LW		 2029 return Nullcv;
2030}
2031
79072805
LW		 2032/* Be sure to refetch the stack pointer after calling these routines. */
2033
954c1994 2034/*
ccfc67b7
JH		 2035
2036=head1 Callback Functions
2037
954c1994
GS		 2038=for apidoc p||call_argv
2039
2040Performs a callback to the specified Perl sub. See L<perlcall>.
2041
2042=cut
2043*/
2044
a0d0e21e 2045I32
8f42b153 2046Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 2047
8ac85365
NIS		 2048 /* See G_* flags in cop.h */
2049 /* null terminated arg list */
8990e307 2050{
a0d0e21e 2051 dSP;
8990e307 2052
924508f0 2053 PUSHMARK(SP);
a0d0e21e 2054 if (argv) {
8990e307 2055 while (*argv) {
a0d0e21e 2056 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 2057 argv++;
2058 }
a0d0e21e 2059 PUTBACK;
8990e307 2060 }
864dbfa3 2061 return call_pv(sub_name, flags);
8990e307
LW		 2062}
2063
954c1994
GS		 2064/*
2065=for apidoc p||call_pv
2066
2067Performs a callback to the specified Perl sub. See L<perlcall>.
2068
2069=cut
2070*/
2071
a0d0e21e 2072I32
864dbfa3 2073Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 2074 /* name of the subroutine */
2075 /* See G_* flags in cop.h */
a0d0e21e 2076{
864dbfa3 2077 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 2078}
2079
954c1994
GS		 2080/*
2081=for apidoc p||call_method
2082
2083Performs a callback to the specified Perl method. The blessed object must
2084be on the stack. See L<perlcall>.
2085
2086=cut
2087*/
2088
a0d0e21e 2089I32
864dbfa3 2090Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 2091 /* name of the subroutine */
2092 /* See G_* flags in cop.h */
a0d0e21e 2093{
968b3946 2094 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 2095}
2096
2097/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 2098/*
2099=for apidoc p||call_sv
2100
2101Performs a callback to the Perl sub whose name is in the SV. See
2102L<perlcall>.
2103
2104=cut
2105*/
2106
a0d0e21e 2107I32
864dbfa3 2108Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 2109 /* See G_* flags in cop.h */
a0d0e21e 2110{
27da23d5 2111 dVAR; dSP;
a0d0e21e 2112 LOGOP myop; /* fake syntax tree node */
968b3946 2113 UNOP method_op;
aa689395 2114 I32 oldmark;
13689cfe 2115 volatile I32 retval = 0;
a0d0e21e 2116 I32 oldscope;
54310121 2117 bool oldcatch = CATCH_GET;
6224f72b 2118 int ret;
533c011a 2119 OP* oldop = PL_op;
db36c5a1 2120 dJMPENV;
1e422769 2121
a0d0e21e
LW		 2122 if (flags & G_DISCARD) {
2123 ENTER;
2124 SAVETMPS;
2125 }
2126
aa689395 2127 Zero(&myop, 1, LOGOP);
54310121 2128 myop.op_next = Nullop;
f51d4af5 2129 if (!(flags & G_NOARGS))
aa689395 2130 myop.op_flags |= OPf_STACKED;
54310121 2131 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2132 (flags & G_ARRAY) ? OPf_WANT_LIST :
2133 OPf_WANT_SCALAR);
462e5cf6 2134 SAVEOP();
533c011a 2135 PL_op = (OP*)&myop;
aa689395 2136
3280af22
NIS		 2137 EXTEND(PL_stack_sp, 1);
2138 *++PL_stack_sp = sv;
aa689395 2139 oldmark = TOPMARK;
3280af22 2140 oldscope = PL_scopestack_ix;
a0d0e21e 2141
3280af22 2142 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 2143 /* Handle first BEGIN of -d. */
3280af22 2144 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 2145 /* Try harder, since this may have been a sighandler, thus
2146 * curstash may be meaningless. */
3280af22 2147 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 2148 && !(flags & G_NODEBUG))
533c011a 2149 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2150
968b3946
GS		 2151 if (flags & G_METHOD) {
2152 Zero(&method_op, 1, UNOP);
2153 method_op.op_next = PL_op;
2154 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2155 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 2156 PL_op = (OP*)&method_op;
968b3946
GS		 2157 }
2158
312caa8e 2159 if (!(flags & G_EVAL)) {
0cdb2077 2160 CATCH_SET(TRUE);
14dd3ad8 2161 call_body((OP*)&myop, FALSE);
312caa8e 2162 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 2163 CATCH_SET(oldcatch);
312caa8e
CS		 2164 }
2165 else {
d78bda3d 2166 myop.op_other = (OP*)&myop;
3280af22 2167 PL_markstack_ptr--;
4633a7c4
LW		 2168 /* we're trying to emulate pp_entertry() here */
2169 {
c09156bb 2170 register PERL_CONTEXT *cx;
f54cb97a 2171 const I32 gimme = GIMME_V;
ac27b0f5 2172
4633a7c4
LW		 2173 ENTER;
2174 SAVETMPS;
ac27b0f5 2175
1d76a5c3 2176 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 2177 PUSHEVAL(cx, 0, 0);
533c011a 2178 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 2179
faef0170 2180 PL_in_eval = EVAL_INEVAL;
4633a7c4 2181 if (flags & G_KEEPERR)
faef0170 2182 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 2183 else
c69006e4 2184 sv_setpvn(ERRSV,"",0);
4633a7c4 2185 }
3280af22 2186 PL_markstack_ptr++;
a0d0e21e 2187
14dd3ad8 2188 JMPENV_PUSH(ret);
6224f72b
GS		 2189 switch (ret) {
2190 case 0:
14dd3ad8
GS		 2191 redo_body:
2192 call_body((OP*)&myop, FALSE);
312caa8e
CS		 2193 retval = PL_stack_sp - (PL_stack_base + oldmark);
2194 if (!(flags & G_KEEPERR))
c69006e4 2195 sv_setpvn(ERRSV,"",0);
a0d0e21e 2196 break;
6224f72b 2197 case 1:
f86702cc 2198 STATUS_ALL_FAILURE;
a0d0e21e 2199 /* FALL THROUGH */
6224f72b 2200 case 2:
a0d0e21e 2201 /* my_exit() was called */
3280af22 2202 PL_curstash = PL_defstash;
a0d0e21e 2203 FREETMPS;
14dd3ad8 2204 JMPENV_POP;
cc3604b1 2205 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2206 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2207 my_exit_jump();
a0d0e21e 2208 /* NOTREACHED */
6224f72b 2209 case 3:
3280af22 2210 if (PL_restartop) {
533c011a 2211 PL_op = PL_restartop;
3280af22 2212 PL_restartop = 0;
312caa8e 2213 goto redo_body;
a0d0e21e 2214 }
3280af22 2215 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2216 if (flags & G_ARRAY)
2217 retval = 0;
2218 else {
2219 retval = 1;
3280af22 2220 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2221 }
312caa8e 2222 break;
a0d0e21e 2223 }
a0d0e21e 2224
3280af22 2225 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 2226 SV **newsp;
2227 PMOP *newpm;
2228 I32 gimme;
c09156bb 2229 register PERL_CONTEXT *cx;
a0a2876f
LW		 2230 I32 optype;
2231
2232 POPBLOCK(cx,newpm);
2233 POPEVAL(cx);
3280af22 2234 PL_curpm = newpm;
a0a2876f 2235 LEAVE;
a0d0e21e 2236 }
14dd3ad8 2237 JMPENV_POP;
a0d0e21e 2238 }
1e422769 2239
a0d0e21e 2240 if (flags & G_DISCARD) {
3280af22 2241 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2242 retval = 0;
2243 FREETMPS;
2244 LEAVE;
2245 }
533c011a 2246 PL_op = oldop;
a0d0e21e
LW		 2247 return retval;
2248}
2249
312caa8e 2250STATIC void
dd374669 2251S_call_body(pTHX_ const OP *myop, bool is_eval)
312caa8e 2252{
312caa8e
CS		 2253 if (PL_op == myop) {
2254 if (is_eval)
f807eda9 2255 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 2256 else
f807eda9 2257 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 2258 }
2259 if (PL_op)
cea2e8a9 2260 CALLRUNOPS(aTHX);
312caa8e
CS		 2261}
2262
6e72f9df 2263/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2264
954c1994
GS		 2265/*
2266=for apidoc p||eval_sv
2267
2268Tells Perl to C<eval> the string in the SV.
2269
2270=cut
2271*/
2272
a0d0e21e 2273I32
864dbfa3 2274Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2275
8ac85365 2276 /* See G_* flags in cop.h */
a0d0e21e 2277{
924508f0 2278 dSP;
a0d0e21e 2279 UNOP myop; /* fake syntax tree node */
8fa7f367 2280 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2281 volatile I32 retval = 0;
6224f72b 2282 int ret;
533c011a 2283 OP* oldop = PL_op;
db36c5a1 2284 dJMPENV;
84902520 2285
4633a7c4
LW		 2286 if (flags & G_DISCARD) {
2287 ENTER;
2288 SAVETMPS;
2289 }
2290
462e5cf6 2291 SAVEOP();
533c011a
NIS		 2292 PL_op = (OP*)&myop;
2293 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2294 EXTEND(PL_stack_sp, 1);
2295 *++PL_stack_sp = sv;
79072805 2296
4633a7c4
LW		 2297 if (!(flags & G_NOARGS))
2298 myop.op_flags = OPf_STACKED;
79072805 2299 myop.op_next = Nullop;
6e72f9df 2300 myop.op_type = OP_ENTEREVAL;
54310121 2301 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2302 (flags & G_ARRAY) ? OPf_WANT_LIST :
2303 OPf_WANT_SCALAR);
6e72f9df 2304 if (flags & G_KEEPERR)
2305 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2306
dedbcade
DM		 2307 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2308 * before a PUSHEVAL, which corrupts the stack after a croak */
2309 TAINT_PROPER("eval_sv()");
2310
14dd3ad8 2311 JMPENV_PUSH(ret);
6224f72b
GS		 2312 switch (ret) {
2313 case 0:
14dd3ad8
GS		 2314 redo_body:
2315 call_body((OP*)&myop,TRUE);
312caa8e
CS		 2316 retval = PL_stack_sp - (PL_stack_base + oldmark);
2317 if (!(flags & G_KEEPERR))
c69006e4 2318 sv_setpvn(ERRSV,"",0);
4633a7c4 2319 break;
6224f72b 2320 case 1:
f86702cc 2321 STATUS_ALL_FAILURE;
4633a7c4 2322 /* FALL THROUGH */
6224f72b 2323 case 2:
4633a7c4 2324 /* my_exit() was called */
3280af22 2325 PL_curstash = PL_defstash;
4633a7c4 2326 FREETMPS;
14dd3ad8 2327 JMPENV_POP;
cc3604b1 2328 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2329 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2330 my_exit_jump();
4633a7c4 2331 /* NOTREACHED */
6224f72b 2332 case 3:
3280af22 2333 if (PL_restartop) {
533c011a 2334 PL_op = PL_restartop;
3280af22 2335 PL_restartop = 0;
312caa8e 2336 goto redo_body;
4633a7c4 2337 }
3280af22 2338 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2339 if (flags & G_ARRAY)
2340 retval = 0;
2341 else {
2342 retval = 1;
3280af22 2343 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2344 }
312caa8e 2345 break;
4633a7c4
LW		 2346 }
2347
14dd3ad8 2348 JMPENV_POP;
4633a7c4 2349 if (flags & G_DISCARD) {
3280af22 2350 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2351 retval = 0;
2352 FREETMPS;
2353 LEAVE;
2354 }
533c011a 2355 PL_op = oldop;
4633a7c4
LW		 2356 return retval;
2357}
2358
954c1994
GS		 2359/*
2360=for apidoc p||eval_pv
2361
2362Tells Perl to C<eval> the given string and return an SV* result.
2363
2364=cut
2365*/
2366
137443ea 2367SV*
864dbfa3 2368Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2369{
2370 dSP;
2371 SV* sv = newSVpv(p, 0);
2372
864dbfa3 2373 eval_sv(sv, G_SCALAR);
137443ea 2374 SvREFCNT_dec(sv);
2375
2376 SPAGAIN;
2377 sv = POPs;
2378 PUTBACK;
2379
2d8e6c8d 2380 if (croak_on_error && SvTRUE(ERRSV)) {
0510663f 2381 Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2d8e6c8d 2382 }
137443ea 2383
2384 return sv;
2385}
2386
4633a7c4
LW		 2387/* Require a module. */
2388
954c1994 2389/*
ccfc67b7
JH		 2390=head1 Embedding Functions
2391
954c1994
GS		 2392=for apidoc p||require_pv
2393
7d3fb230
BS		 2394Tells Perl to C<require> the file named by the string argument. It is
2395analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2396implemented that way; consider using load_module instead.
954c1994 2397
7d3fb230 2398=cut */
954c1994 2399
4633a7c4 2400void
864dbfa3 2401Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2402{
d3acc0f7
JP		 2403 SV* sv;
2404 dSP;
e788e7d3 2405 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2406 PUTBACK;
2407 sv = sv_newmortal();
4633a7c4
LW		 2408 sv_setpv(sv, "require '");
2409 sv_catpv(sv, pv);
2410 sv_catpv(sv, "'");
864dbfa3 2411 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2412 SPAGAIN;
2413 POPSTACK;
79072805
LW		 2414}
2415
79072805 2416void
e1ec3a88 2417Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
79072805
LW		 2418{
2419 register GV *gv;
2420
155aba94 2421 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2422 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2423}
2424
76e3520e 2425STATIC void
e1ec3a88 2426S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
4633a7c4 2427{
ab821d7f 2428 /* This message really ought to be max 23 lines.
75c72d73 2429 * Removed -h because the user already knows that option. Others? */
fb73857a 2430
27da23d5 2431 static const char * const usage_msg[] = {
aefc56c5
SF		 2432"-0[octal] specify record separator (\\0, if no argument)",
2433"-A[mod][=pattern] activate all/given assertions",
2434"-a autosplit mode with -n or -p (splits $_ into @F)",
2435"-C[number/list] enables the listed Unicode features",
2436"-c check syntax only (runs BEGIN and CHECK blocks)",
2437"-d[:debugger] run program under debugger",
2438"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2439"-e program one line of program (several -e's allowed, omit programfile)",
aefc56c5 2440"-f don't do $sitelib/sitecustomize.pl at startup",
aefc56c5
SF		 2441"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2442"-i[extension] edit <> files in place (makes backup if extension supplied)",
2443"-Idirectory specify @INC/#include directory (several -I's allowed)",
2444"-l[octal] enable line ending processing, specifies line terminator",
2445"-[mM][-]module execute \"use/no module...\" before executing program",
2446"-n assume \"while (<>) { ... }\" loop around program",
2447"-p assume loop like -n but print line also, like sed",
2448"-P run program through C preprocessor before compilation",
2449"-s enable rudimentary parsing for switches after programfile",
2450"-S look for programfile using PATH environment variable",
2451"-t enable tainting warnings",
2452"-T enable tainting checks",
2453"-u dump core after parsing program",
2454"-U allow unsafe operations",
2455"-v print version, subversion (includes VERY IMPORTANT perl info)",
2456"-V[:variable] print configuration summary (or a single Config.pm variable)",
2457"-w enable many useful warnings (RECOMMENDED)",
2458"-W enable all warnings",
2459"-x[directory] strip off text before #!perl line and perhaps cd to directory",
2460"-X disable all warnings",
fb73857a 2461"\n",
2462NULL
2463};
27da23d5 2464 const char * const *p = usage_msg;
fb73857a 2465
b0e47665
GS		 2466 PerlIO_printf(PerlIO_stdout(),
2467 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2468 name);
fb73857a 2469 while (*p)
b0e47665 2470 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2471}
2472
b4ab917c
DM		 2473/* convert a string of -D options (or digits) into an int.
2474 * sets *s to point to the char after the options */
2475
2476#ifdef DEBUGGING
2477int
e1ec3a88 2478Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
b4ab917c 2479{
27da23d5 2480 static const char * const usage_msgd[] = {
e6e64d9b
JC		 2481 " Debugging flag values: (see also -d)",
2482 " p Tokenizing and parsing (with v, displays parse stack)",
3679267a 2483 " s Stack snapshots (with v, displays all stacks)",
e6e64d9b
JC		 2484 " l Context (loop) stack processing",
2485 " t Trace execution",
2486 " o Method and overloading resolution",
2487 " c String/numeric conversions",
2488 " P Print profiling info, preprocessor command for -P, source file input state",
2489 " m Memory allocation",
2490 " f Format processing",
2491 " r Regular expression parsing and execution",
2492 " x Syntax tree dump",
3679267a 2493 " u Tainting checks",
e6e64d9b
JC		 2494 " H Hash dump -- usurps values()",
2495 " X Scratchpad allocation",
2496 " D Cleaning up",
2497 " S Thread synchronization",
2498 " T Tokenising",
2499 " R Include reference counts of dumped variables (eg when using -Ds)",
2500 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2501 " v Verbose: use in conjunction with other flags",
2502 " C Copy On Write",
2503 " A Consistency checks on internal structures",
3679267a 2504 " q quiet - currently only suppresses the 'EXECUTING' message",
e6e64d9b
JC		 2505 NULL
2506 };
b4ab917c
DM		 2507 int i = 0;
2508 if (isALPHA(**s)) {
2509 /* if adding extra options, remember to update DEBUG_MASK */
bfed75c6 2510 static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
b4ab917c
DM		 2511
2512 for (; isALNUM(**s); (*s)++) {
e1ec3a88 2513 const char *d = strchr(debopts,**s);
b4ab917c
DM		 2514 if (d)
2515 i |= 1 << (d - debopts);
2516 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC		 2517 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2518 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM		 2519 }
2520 }
e6e64d9b 2521 else if (isDIGIT(**s)) {
b4ab917c
DM		 2522 i = atoi(*s);
2523 for (; isALNUM(**s); (*s)++) ;
2524 }
ddcf8bc1 2525 else if (givehelp) {
aadb217d 2526 char **p = (char **)usage_msgd;
e6e64d9b
JC		 2527 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2528 }
b4ab917c
DM		 2529# ifdef EBCDIC
2530 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2531 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2532 "-Dp not implemented on this platform\n");
2533# endif
2534 return i;
2535}
2536#endif
2537
79072805
LW		 2538/* This routine handles any switches that can be given during run */
2539
2540char *
864dbfa3 2541Perl_moreswitches(pTHX_ char *s)
79072805 2542{
27da23d5 2543 dVAR;
84c133a0 2544 UV rschar;
79072805
LW		 2545
2546 switch (*s) {
2547 case '0':
a863c7d1 2548 {
f2095865 2549 I32 flags = 0;
a3b680e6 2550 STRLEN numlen;
f2095865
JH		 2551
2552 SvREFCNT_dec(PL_rs);
2553 if (s[1] == 'x' && s[2]) {
a3b680e6 2554 const char *e = s+=2;
f2095865
JH		 2555 U8 *tmps;
2556
a3b680e6
AL		 2557 while (*e)
2558 e++;
f2095865
JH		 2559 numlen = e - s;
2560 flags = PERL_SCAN_SILENT_ILLDIGIT;
2561 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2562 if (s + numlen < e) {
2563 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2564 numlen = 0;
2565 s--;
2566 }
2567 PL_rs = newSVpvn("", 0);
c5661c80 2568 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 2569 tmps = (U8*)SvPVX(PL_rs);
2570 uvchr_to_utf8(tmps, rschar);
2571 SvCUR_set(PL_rs, UNISKIP(rschar));
2572 SvUTF8_on(PL_rs);
2573 }
2574 else {
2575 numlen = 4;
2576 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2577 if (rschar & ~((U8)~0))
2578 PL_rs = &PL_sv_undef;
2579 else if (!rschar && numlen >= 2)
2580 PL_rs = newSVpvn("", 0);
2581 else {
2582 char ch = (char)rschar;
2583 PL_rs = newSVpvn(&ch, 1);
2584 }
2585 }
800633c3 2586 sv_setsv(get_sv("/", TRUE), PL_rs);
f2095865 2587 return s + numlen;
a863c7d1 2588 }
46487f74 2589 case 'C':
a05d7ebb 2590 s++;
dd374669 2591 PL_unicode = parse_unicode_opts( (const char **)&s );
46487f74 2592 return s;
2304df62 2593 case 'F':
3280af22 2594 PL_minus_F = TRUE;
ebce5377
RGS		 2595 PL_splitstr = ++s;
2596 while (*s && !isSPACE(*s)) ++s;
2597 *s = '\0';
2598 PL_splitstr = savepv(PL_splitstr);
2304df62 2599 return s;
79072805 2600 case 'a':
3280af22 2601 PL_minus_a = TRUE;
79072805
LW		 2602 s++;
2603 return s;
2604 case 'c':
3280af22 2605 PL_minus_c = TRUE;
79072805
LW		 2606 s++;
2607 return s;
2608 case 'd':
bbce6d69 2609 forbid_setid("-d");
4633a7c4 2610 s++;
2cbb2ee1
RGS		 2611
2612 /* -dt indicates to the debugger that threads will be used */
2613 if (*s == 't' && !isALNUM(s[1])) {
2614 ++s;
2615 my_setenv("PERL5DB_THREADED", "1");
2616 }
2617
70c94a19
RR		 2618 /* The following permits -d:Mod to accepts arguments following an =
2619 in the fashion that -MSome::Mod does. */
2620 if (*s == ':' || *s == '=') {
06b5626a 2621 const char *start;
70c94a19
RR		 2622 SV *sv;
2623 sv = newSVpv("use Devel::", 0);
2624 start = ++s;
2625 /* We now allow -d:Module=Foo,Bar */
2626 while(isALNUM(*s) || *s==':') ++s;
2627 if (*s != '=')
2628 sv_catpv(sv, start);
2629 else {
2630 sv_catpvn(sv, start, s-start);
2631 sv_catpv(sv, " split(/,/,q{");
2632 sv_catpv(sv, ++s);
3d27e215 2633 sv_catpv(sv, "})");
70c94a19 2634 }
4633a7c4 2635 s += strlen(s);
70c94a19 2636 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2637 }
ed094faf 2638 if (!PL_perldb) {
3280af22 2639 PL_perldb = PERLDB_ALL;
a0d0e21e 2640 init_debugger();
ed094faf 2641 }
79072805
LW		 2642 return s;
2643 case 'D':
0453d815 2644 {
79072805 2645#ifdef DEBUGGING
bbce6d69 2646 forbid_setid("-D");
b4ab917c 2647 s++;
dd374669 2648 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
12a43e32 2649#else /* !DEBUGGING */
0453d815 2650 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2651 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
e6e64d9b 2652 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
a0d0e21e 2653 for (s++; isALNUM(*s); s++) ;
79072805 2654#endif
79072805 2655 return s;
0453d815 2656 }
4633a7c4 2657 case 'h':
ac27b0f5 2658 usage(PL_origargv[0]);
7ca617d0 2659 my_exit(0);
79072805 2660 case 'i':
3280af22
NIS		 2661 if (PL_inplace)
2662 Safefree(PL_inplace);
c030f24b
GH		 2663#if defined(__CYGWIN__) /* do backup extension automagically */
2664 if (*(s+1) == '\0') {
2665 PL_inplace = savepv(".bak");
2666 return s+1;
2667 }
2668#endif /* __CYGWIN__ */
3280af22 2669 PL_inplace = savepv(s+1);
a6e20a40
AL		 2670 for (s = PL_inplace; *s && !isSPACE(*s); s++)
2671 ;
7b8d334a 2672 if (*s) {
fb73857a 2673 *s++ = '\0';
7b8d334a
GS		 2674 if (*s == '-') /* Additional switches on #! line. */
2675 s++;
2676 }
fb73857a 2677 return s;
4e49a025 2678 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2679 forbid_setid("-I");
fb73857a 2680 ++s;
2681 while (*s && isSPACE(*s))
2682 ++s;
2683 if (*s) {
774d564b 2684 char *e, *p;
0df16ed7
GS		 2685 p = s;
2686 /* ignore trailing spaces (possibly followed by other switches) */
2687 do {
2688 for (e = p; *e && !isSPACE(*e); e++) ;
2689 p = e;
2690 while (isSPACE(*p))
2691 p++;
2692 } while (*p && *p != '-');
2693 e = savepvn(s, e-s);
88fe16b2 2694 incpush(e, TRUE, TRUE, FALSE, FALSE);
0df16ed7
GS		 2695 Safefree(e);
2696 s = p;
2697 if (*s == '-')
2698 s++;
79072805
LW		 2699 }
2700 else
a67e862a 2701 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2702 return s;
79072805 2703 case 'l':
3280af22 2704 PL_minus_l = TRUE;
79072805 2705 s++;
7889fe52
NIS		 2706 if (PL_ors_sv) {
2707 SvREFCNT_dec(PL_ors_sv);
2708 PL_ors_sv = Nullsv;
2709 }
79072805 2710 if (isDIGIT(*s)) {
53305cf1 2711 I32 flags = 0;
a3b680e6 2712 STRLEN numlen;
7889fe52 2713 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2714 numlen = 3 + (*s == '0');
2715 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2716 s += numlen;
2717 }
2718 else {
8bfdd7d9 2719 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2720 PL_ors_sv = newSVpvn("\n\n",2);
2721 }
2722 else {
8bfdd7d9 2723 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2724 }
79072805
LW		 2725 }
2726 return s;
06492da6
SF		 2727 case 'A':
2728 forbid_setid("-A");
930366bd
RGS		 2729 if (!PL_preambleav)
2730 PL_preambleav = newAV();
aefc56c5
SF		 2731 s++;
2732 {
2733 char *start = s;
2734 SV *sv = newSVpv("use assertions::activate", 24);
2735 while(isALNUM(*s) || *s == ':') ++s;
2736 if (s != start) {
2737 sv_catpvn(sv, "::", 2);
2738 sv_catpvn(sv, start, s-start);
2739 }
2740 if (*s == '=') {
2741 sv_catpvn(sv, " split(/,/,q\0", 13);
2742 sv_catpv(sv, s+1);
2743 sv_catpvn(sv, "\0)", 2);
2744 s+=strlen(s);
2745 }
2746 else if (*s != '\0') {
2747 Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start);
2748 }
06492da6 2749 av_push(PL_preambleav, sv);
aefc56c5 2750 return s;
06492da6 2751 }
1a30305b 2752 case 'M':
bbce6d69 2753 forbid_setid("-M"); /* XXX ? */
1a30305b 2754 /* FALL THROUGH */
2755 case 'm':
bbce6d69 2756 forbid_setid("-m"); /* XXX ? */
1a30305b 2757 if (*++s) {
a5f75d66 2758 char *start;
11343788 2759 SV *sv;
e1ec3a88 2760 const char *use = "use ";
a5f75d66
AD		 2761 /* -M-foo == 'no foo' */
2762 if (*s == '-') { use = "no "; ++s; }
11343788 2763 sv = newSVpv(use,0);
a5f75d66 2764 start = s;
1a30305b 2765 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2766 while(isALNUM(*s) || *s==':') ++s;
2767 if (*s != '=') {
11343788 2768 sv_catpv(sv, start);
c07a80fd 2769 if (*(start-1) == 'm') {
2770 if (*s != '\0')
cea2e8a9 2771 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2772 sv_catpv( sv, " ()");
c07a80fd 2773 }
2774 } else {
6df41af2 2775 if (s == start)
be98fb35
GS		 2776 Perl_croak(aTHX_ "Module name required with -%c option",
2777 s[-1]);
11343788 2778 sv_catpvn(sv, start, s-start);
3d27e215
LM		 2779 sv_catpv(sv, " split(/,/,q");
2780 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
11343788 2781 sv_catpv(sv, ++s);
3d27e215 2782 sv_catpvn(sv, "\0)", 2);
c07a80fd 2783 }
1a30305b 2784 s += strlen(s);
5c831c24 2785 if (!PL_preambleav)
3280af22
NIS		 2786 PL_preambleav = newAV();
2787 av_push(PL_preambleav, sv);
1a30305b 2788 }
2789 else
9e81e6a1 2790 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
1a30305b 2791 return s;
79072805 2792 case 'n':
3280af22 2793 PL_minus_n = TRUE;
79072805
LW		 2794 s++;
2795 return s;
2796 case 'p':
3280af22 2797 PL_minus_p = TRUE;
79072805
LW		 2798 s++;
2799 return s;
2800 case 's':
bbce6d69 2801 forbid_setid("-s");
3280af22 2802 PL_doswitches = TRUE;
79072805
LW		 2803 s++;
2804 return s;
6537fe72
MS		 2805 case 't':
2806 if (!PL_tainting)
22f7c9c9 2807 TOO_LATE_FOR('t');
6537fe72
MS		 2808 s++;
2809 return s;
463ee0b2 2810 case 'T':
3280af22 2811 if (!PL_tainting)
22f7c9c9 2812 TOO_LATE_FOR('T');
463ee0b2
LW		 2813 s++;
2814 return s;
79072805 2815 case 'u':
bf4acbe4
GS		 2816#ifdef MACOS_TRADITIONAL
2817 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2818#endif
3280af22 2819 PL_do_undump = TRUE;
79072805
LW		 2820 s++;
2821 return s;
2822 case 'U':
3280af22 2823 PL_unsafe = TRUE;
79072805
LW		 2824 s++;
2825 return s;
2826 case 'v':
d7aa5382
JP		 2827 if (!sv_derived_from(PL_patchlevel, "version"))
2828 (void *)upg_version(PL_patchlevel);
8e9464f1 2829#if !defined(DGUX)
b0e47665 2830 PerlIO_printf(PerlIO_stdout(),
52ea0aec 2831 Perl_form(aTHX_ "\nThis is perl, %"SVf" built for %s",
d7aa5382
JP		 2832 vstringify(PL_patchlevel),
2833 ARCHNAME));
8e9464f1
JH		 2834#else /* DGUX */
2835/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2836 PerlIO_printf(PerlIO_stdout(),
52ea0aec 2837 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
d7aa5382 2838 vstringify(PL_patchlevel)));
8e9464f1
JH		 2839 PerlIO_printf(PerlIO_stdout(),
2840 Perl_form(aTHX_ " built under %s at %s %s\n",
2841 OSNAME, __DATE__, __TIME__));
2842 PerlIO_printf(PerlIO_stdout(),
2843 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2844 OSVERS));
8e9464f1
JH		 2845#endif /* !DGUX */
2846
fb73857a 2847#if defined(LOCAL_PATCH_COUNT)
2848 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2849 PerlIO_printf(PerlIO_stdout(),
2850 "\n(with %d registered patch%s, "
2851 "see perl -V for more detail)",
2852 (int)LOCAL_PATCH_COUNT,
2853 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2854#endif
1a30305b 2855
b0e47665 2856 PerlIO_printf(PerlIO_stdout(),
359b00fe 2857 "\n\nCopyright 1987-2005, Larry Wall\n");
eae9c151
JH		 2858#ifdef MACOS_TRADITIONAL
2859 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2860 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2861 "maintained by Chris Nandor\n");
eae9c151 2862#endif
79072805 2863#ifdef MSDOS
b0e47665
GS		 2864 PerlIO_printf(PerlIO_stdout(),
2865 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2866#endif
2867#ifdef DJGPP
b0e47665
GS		 2868 PerlIO_printf(PerlIO_stdout(),
2869 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2870 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2871#endif
79072805 2872#ifdef OS2
b0e47665
GS		 2873 PerlIO_printf(PerlIO_stdout(),
2874 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2875 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2876#endif
79072805 2877#ifdef atarist
b0e47665
GS		 2878 PerlIO_printf(PerlIO_stdout(),
2879 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2880#endif
a3f9223b 2881#ifdef __BEOS__
b0e47665
GS		 2882 PerlIO_printf(PerlIO_stdout(),
2883 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2884#endif
1d84e8df 2885#ifdef MPE
b0e47665 2886 PerlIO_printf(PerlIO_stdout(),
e583a879 2887 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 2888#endif
9d116dd7 2889#ifdef OEMVS
b0e47665
GS		 2890 PerlIO_printf(PerlIO_stdout(),
2891 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2892#endif
495c5fdc 2893#ifdef __VOS__
b0e47665 2894 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2895 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2896#endif
092bebab 2897#ifdef __OPEN_VM
b0e47665
GS		 2898 PerlIO_printf(PerlIO_stdout(),
2899 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2900#endif
a1a0e61e 2901#ifdef POSIX_BC
b0e47665
GS		 2902 PerlIO_printf(PerlIO_stdout(),
2903 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2904#endif
61ae2fbf 2905#ifdef __MINT__
b0e47665
GS		 2906 PerlIO_printf(PerlIO_stdout(),
2907 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2908#endif
f83d2536 2909#ifdef EPOC
b0e47665 2910 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2911 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2912#endif
e1caacb4 2913#ifdef UNDER_CE
b475b3e6
JH		 2914 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2915 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2916 wce_hitreturn();
2917#endif
27da23d5
JH		 2918#ifdef SYMBIAN
2919 PerlIO_printf(PerlIO_stdout(),
2920 "Symbian port by Nokia, 2004-2005\n");
2921#endif
baed7233
DL		 2922#ifdef BINARY_BUILD_NOTICE
2923 BINARY_BUILD_NOTICE;
2924#endif
b0e47665
GS		 2925 PerlIO_printf(PerlIO_stdout(),
2926 "\n\
79072805 2927Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2928GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687 2929Complete documentation for Perl, including FAQ lists, should be found on\n\
a0288114 2930this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
c9e30dd8 2931Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
7ca617d0 2932 my_exit(0);
79072805 2933 case 'w':
599cee73 2934 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2935 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2936 s++;
2937 return s;
2938 case 'W':
ac27b0f5 2939 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2940 if (!specialWARN(PL_compiling.cop_warnings))
2941 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2942 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2943 s++;
2944 return s;
2945 case 'X':
ac27b0f5 2946 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2947 if (!specialWARN(PL_compiling.cop_warnings))
2948 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2949 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2950 s++;
2951 return s;
a0d0e21e 2952 case '*':
79072805
LW		 2953 case ' ':
2954 if (s[1] == '-') /* Additional switches on #! line. */
2955 return s+2;
2956 break;
a0d0e21e 2957 case '-':
79072805 2958 case 0:
51882d45 2959#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2960 case '\r':
2961#endif
79072805
LW		 2962 case '\n':
2963 case '\t':
2964 break;
aa689395 2965#ifdef ALTERNATE_SHEBANG
2966 case 'S': /* OS/2 needs -S on "extproc" line. */
2967 break;
2968#endif
a0d0e21e 2969 case 'P':
3280af22 2970 if (PL_preprocess)
a0d0e21e
LW		 2971 return s+1;
2972 /* FALL THROUGH */
79072805 2973 default:
cea2e8a9 2974 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2975 }
2976 return Nullch;
2977}
2978
2979/* compliments of Tom Christiansen */
2980
2981/* unexec() can be found in the Gnu emacs distribution */
ee580363 2982/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2983
2984void
864dbfa3 2985Perl_my_unexec(pTHX)
79072805
LW		 2986{
2987#ifdef UNEXEC
46fc3d4c 2988 SV* prog;
2989 SV* file;
ee580363 2990 int status = 1;
79072805
LW		 2991 extern int etext;
2992
ee580363 2993 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2994 sv_catpv(prog, "/perl");
6b88bc9c 2995 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2996 sv_catpv(file, ".perldump");
79072805 2997
ee580363
GS		 2998 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2999 /* unexec prints msg to stderr in case of failure */
6ad3d225 3000 PerlProc_exit(status);
79072805 3001#else
a5f75d66
AD		 3002# ifdef VMS
3003# include <lib$routines.h>
3004 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 3005# else
79072805 3006 ABORT(); /* for use with undump */
aa689395 3007# endif
a5f75d66 3008#endif
79072805
LW		 3009}
3010
cb68f92d
GS		 3011/* initialize curinterp */
3012STATIC void
cea2e8a9 3013S_init_interp(pTHX)
cb68f92d
GS		 3014{
3015
acfe0abc
GS		 3016#ifdef MULTIPLICITY
3017# define PERLVAR(var,type)
3018# define PERLVARA(var,n,type)
3019# if defined(PERL_IMPLICIT_CONTEXT)
3020# if defined(USE_5005THREADS)
3021# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
27da23d5 3022# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 3023# else /* !USE_5005THREADS */
3024# define PERLVARI(var,type,init) aTHX->var = init;
3025# define PERLVARIC(var,type,init) aTHX->var = init;
3026# endif /* USE_5005THREADS */
3967c732 3027# else
acfe0abc
GS		 3028# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3029# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 3030# endif
acfe0abc
GS		 3031# include "intrpvar.h"
3032# ifndef USE_5005THREADS
3033# include "thrdvar.h"
3034# endif
3035# undef PERLVAR
3036# undef PERLVARA
3037# undef PERLVARI
3038# undef PERLVARIC
3039#else
3040# define PERLVAR(var,type)
3041# define PERLVARA(var,n,type)
3042# define PERLVARI(var,type,init) PL_##var = init;
3043# define PERLVARIC(var,type,init) PL_##var = init;
3044# include "intrpvar.h"
3045# ifndef USE_5005THREADS
3046# include "thrdvar.h"
3047# endif
3048# undef PERLVAR
3049# undef PERLVARA
3050# undef PERLVARI
3051# undef PERLVARIC
cb68f92d
GS		 3052#endif
3053
cb68f92d
GS		 3054}
3055
76e3520e 3056STATIC void
cea2e8a9 3057S_init_main_stash(pTHX)
79072805 3058{
463ee0b2 3059 GV *gv;
6e72f9df 3060
3280af22 3061 PL_curstash = PL_defstash = newHV();
79cb57f6 3062 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 3063 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
3064 SvREFCNT_dec(GvHV(gv));
3280af22 3065 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 3066 SvREADONLY_on(gv);
bfcb3514 3067 Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0);
3280af22
NIS		 3068 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
3069 GvMULTI_on(PL_incgv);
3070 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
3071 GvMULTI_on(PL_hintgv);
3072 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
3073 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
3074 GvMULTI_on(PL_errgv);
3075 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
3076 GvMULTI_on(PL_replgv);
cea2e8a9 3077 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 3078 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3079 sv_setpvn(ERRSV, "", 0);
3280af22 3080 PL_curstash = PL_defstash;
11faa288 3081 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 3082 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 3083 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 3084 /* We must init $/ before switches are processed. */
864dbfa3 3085 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 3086}
3087
ae3f3efd 3088/* PSz 18 Nov 03 fdscript now global but do not change prototype */
76e3520e 3089STATIC void
dd374669 3090S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
79072805 3091{
ae3f3efd 3092#ifndef IAMSUID
e1ec3a88
AL		 3093 const char *quote;
3094 const char *code;
3095 const char *cpp_discard_flag;
3096 const char *perl;
ae3f3efd 3097#endif
27da23d5 3098 dVAR;
1b24ed4b 3099
ae3f3efd
PS		 3100 PL_fdscript = -1;
3101 PL_suidscript = -1;
79072805 3102
3280af22 3103 if (PL_e_script) {
ff5bdd37 3104 PL_origfilename = savepvn("-e", 2);
96436eeb 3105 }
6c4ab083
GS		 3106 else {
3107 /* if find_script() returns, it returns a malloc()-ed value */
dd374669 3108 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 3109
3110 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
e1ec3a88 3111 const char *s = scriptname + 8;
ae3f3efd 3112 PL_fdscript = atoi(s);
6c4ab083
GS		 3113 while (isDIGIT(*s))
3114 s++;
3115 if (*s) {
ae3f3efd
PS		 3116 /* PSz 18 Feb 04
3117 * Tell apart "normal" usage of fdscript, e.g.
3118 * with bash on FreeBSD:
3119 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3120 * from usage in suidperl.
3121 * Does any "normal" usage leave garbage after the number???
3122 * Is it a mistake to use a similar /dev/fd/ construct for
3123 * suidperl?
3124 */
3125 PL_suidscript = 1;
3126 /* PSz 20 Feb 04
3127 * Be supersafe and do some sanity-checks.
3128 * Still, can we be sure we got the right thing?
3129 */
3130 if (*s != '/') {
3131 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3132 }
3133 if (! *(s+1)) {
3134 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3135 }
6c4ab083 3136 scriptname = savepv(s + 1);
3280af22 3137 Safefree(PL_origfilename);
dd374669 3138 PL_origfilename = (char *)scriptname;
6c4ab083
GS		 3139 }
3140 }
3141 }
3142
05ec9bb3 3143 CopFILE_free(PL_curcop);
57843af0 3144 CopFILE_set(PL_curcop, PL_origfilename);
770526c1 3145 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
dd374669 3146 scriptname = (char *)"";
ae3f3efd
PS		 3147 if (PL_fdscript >= 0) {
3148 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3149# if defined(HAS_FCNTL) && defined(F_SETFD)
3150 if (PL_rsfp)
3151 /* ensure close-on-exec */
3152 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3153# endif
96436eeb 3154 }
ae3f3efd
PS		 3155#ifdef IAMSUID
3156 else {
86207487
NC		 3157 Perl_croak(aTHX_ "sperl needs fd script\n"
3158 "You should not call sperl directly; do you need to "
3159 "change a #! line\nfrom sperl to perl?\n");
3160
ae3f3efd
PS		 3161/* PSz 11 Nov 03
3162 * Do not open (or do other fancy stuff) while setuid.
3163 * Perl does the open, and hands script to suidperl on a fd;
3164 * suidperl only does some checks, sets up UIDs and re-execs
3165 * perl with that fd as it has always done.
3166 */
3167 }
3168 if (PL_suidscript != 1) {
3169 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3170 }
3171#else /* IAMSUID */
3280af22 3172 else if (PL_preprocess) {
dd374669 3173 const char *cpp_cfg = CPPSTDIN;
79cb57f6 3174 SV *cpp = newSVpvn("",0);
46fc3d4c 3175 SV *cmd = NEWSV(0,0);
3176
ae58f265
JH		 3177 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3178 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
46fc3d4c 3179 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 3180 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 3181 sv_catpv(cpp, cpp_cfg);
79072805 3182
1b24ed4b
MS		 3183# ifndef VMS
3184 sv_catpvn(sv, "-I", 2);
3185 sv_catpv(sv,PRIVLIB_EXP);
3186# endif
46fc3d4c 3187
14953ddc
MB		 3188 DEBUG_P(PerlIO_printf(Perl_debug_log,
3189 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
848ef955
NC		 3190 scriptname, SvPVX_const (cpp), SvPVX_const (sv),
3191 CPPMINUS));
1b24ed4b
MS		 3192
3193# if defined(MSDOS) || defined(WIN32) || defined(VMS)
3194 quote = "\"";
3195# else
3196 quote = "'";
3197# endif
3198
3199# ifdef VMS
3200 cpp_discard_flag = "";
3201# else
3202 cpp_discard_flag = "-C";
3203# endif
3204
3205# ifdef OS2
3206 perl = os2_execname(aTHX);
3207# else
3208 perl = PL_origargv[0];
3209# endif
3210
3211
3212 /* This strips off Perl comments which might interfere with
62375a60
NIS		 3213 the C pre-processor, including #!. #line directives are
3214 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 3215 of #line. FWP played some golf with it so it will fit
3216 into VMS's 255 character buffer.
3217 */
3218 if( PL_doextract )
3219 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3220 else
3221 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3222
3223 Perl_sv_setpvf(aTHX_ cmd, "\
3224%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 3225 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 3226 cpp_discard_flag, sv, CPPMINUS);
3227
3280af22 3228 PL_doextract = FALSE;
0a6c758d 3229
62375a60
NIS		 3230 DEBUG_P(PerlIO_printf(Perl_debug_log,
3231 "PL_preprocess: cmd=\"%s\"\n",
848ef955 3232 SvPVX_const(cmd)));
0a6c758d 3233
848ef955 3234 PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
46fc3d4c 3235 SvREFCNT_dec(cmd);
3236 SvREFCNT_dec(cpp);
79072805
LW		 3237 }
3238 else if (!*scriptname) {
bbce6d69 3239 forbid_setid("program input from stdin");
3280af22 3240 PL_rsfp = PerlIO_stdin();
79072805 3241 }
96436eeb 3242 else {
3280af22 3243 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3244# if defined(HAS_FCNTL) && defined(F_SETFD)
3245 if (PL_rsfp)
3246 /* ensure close-on-exec */
3247 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3248# endif
96436eeb 3249 }
ae3f3efd 3250#endif /* IAMSUID */
3280af22 3251 if (!PL_rsfp) {
447218f8 3252 /* PSz 16 Sep 03 Keep neat error message */
fa3aa65a
JC		 3253 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3254 CopFILE(PL_curcop), Strerror(errno));
13281fa4 3255 }
79072805 3256}
8d063cd8 3257
7b89560d
JH		 3258/* Mention
3259 * I_SYSSTATVFS HAS_FSTATVFS
3260 * I_SYSMOUNT
c890dc6c 3261 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3262 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3263 * here so that metaconfig picks them up. */
3264
104d25b7 3265#ifdef IAMSUID
864dbfa3 3266STATIC int
e688b231 3267S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 3268{
ae3f3efd
PS		 3269/* PSz 27 Feb 04
3270 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3271 * but is needed also on machines without setreuid.
3272 * Seems safe enough to run as root.
3273 */
0545a864
JH		 3274 int check_okay = 0; /* able to do all the required sys/libcalls */
3275 int on_nosuid = 0; /* the fd is on a nosuid fs */
ae3f3efd
PS		 3276 /* PSz 12 Nov 03
3277 * Need to check noexec also: nosuid might not be set, the average
3278 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3279 */
3280 int on_noexec = 0; /* the fd is on a noexec fs */
3281
104d25b7 3282/*
ad27e871 3283 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 3284 * fstatvfs() is UNIX98.
0545a864 3285 * fstatfs() is 4.3 BSD.
ad27e871 3286 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 3287 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3288 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 3289 */
3290
6439433f
JH		 3291#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3292
3293# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3294 defined(HAS_FSTATVFS)
3295# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 3296 struct statvfs stfs;
6439433f 3297
104d25b7
JH		 3298 check_okay = fstatvfs(fd, &stfs) == 0;
3299 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
ae3f3efd
PS		 3300#ifdef ST_NOEXEC
3301 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3302 on platforms where it is present. */
3303 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3304#endif
6439433f 3305# endif /* fstatvfs */
ac27b0f5 3306
6439433f
JH		 3307# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3308 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3309 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3310 defined(HAS_FSTATFS) && \
3311 defined(HAS_STRUCT_STATFS) && \
3312 defined(HAS_STRUCT_STATFS_F_FLAGS)
3313# define FD_ON_NOSUID_CHECK_OKAY
e688b231 3314 struct statfs stfs;
6439433f 3315
104d25b7 3316 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 3317 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
ae3f3efd 3318 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
6439433f
JH		 3319# endif /* fstatfs */
3320
3321# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3322 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3323 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3324 defined(HAS_FSTAT) && \
3325 defined(HAS_USTAT) && \
3326 defined(HAS_GETMNT) && \
3327 defined(HAS_STRUCT_FS_DATA) && \
3328 defined(NOSTAT_ONE)
3329# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 3330 Stat_t fdst;
6439433f 3331
0545a864 3332 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 3333 struct ustat us;
3334 if (ustat(fdst.st_dev, &us) == 0) {
3335 struct fs_data fsd;
3336 /* NOSTAT_ONE here because we're not examining fields which
3337 * vary between that case and STAT_ONE. */
ad27e871 3338 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3339 size_t cmplen = sizeof(us.f_fname);
3340 if (sizeof(fsd.fd_req.path) < cmplen)
3341 cmplen = sizeof(fsd.fd_req.path);
3342 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3343 fdst.st_dev == fsd.fd_req.dev) {
3344 check_okay = 1;
3345 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
ae3f3efd 3346 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
6439433f
JH		 3347 }
3348 }
3349 }
3350 }
0545a864 3351 }
6439433f
JH		 3352# endif /* fstat+ustat+getmnt */
3353
3354# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3355 defined(HAS_GETMNTENT) && \
3356 defined(HAS_HASMNTOPT) && \
ae3f3efd
PS		 3357 defined(MNTOPT_NOSUID) && \
3358 defined(MNTOPT_NOEXEC)
6439433f
JH		 3359# define FD_ON_NOSUID_CHECK_OKAY
3360 FILE *mtab = fopen("/etc/mtab", "r");
3361 struct mntent *entry;
c623ac67 3362 Stat_t stb, fsb;
104d25b7
JH		 3363
3364 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3365 while (entry = getmntent(mtab)) {
3366 if (stat(entry->mnt_dir, &fsb) == 0
3367 && fsb.st_dev == stb.st_dev)
3368 {
3369 /* found the filesystem */
3370 check_okay = 1;
3371 if (hasmntopt(entry, MNTOPT_NOSUID))
3372 on_nosuid = 1;
ae3f3efd
PS		 3373 if (hasmntopt(entry, MNTOPT_NOEXEC))
3374 on_noexec = 1;
6439433f
JH		 3375 break;
3376 } /* A single fs may well fail its stat(). */
3377 }
104d25b7
JH		 3378 }
3379 if (mtab)
6439433f
JH		 3380 fclose(mtab);
3381# endif /* getmntent+hasmntopt */
0545a864 3382
ac27b0f5 3383 if (!check_okay)
ae3f3efd
PS		 3384 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3385 if (on_nosuid)
3386 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3387 if (on_noexec)
3388 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3389 return ((!check_okay) || on_nosuid || on_noexec);
104d25b7
JH		 3390}
3391#endif /* IAMSUID */
3392
76e3520e 3393STATIC void
e1ec3a88 3394S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
79072805 3395{
27da23d5 3396 dVAR;
155aba94 3397#ifdef IAMSUID
ae3f3efd
PS		 3398 /* int which; */
3399#endif /* IAMSUID */
96436eeb 3400
13281fa4
LW		 3401 /* do we need to emulate setuid on scripts? */
3402
3403 /* This code is for those BSD systems that have setuid #! scripts disabled
3404 * in the kernel because of a security problem. Merely defining DOSUID
3405 * in perl will not fix that problem, but if you have disabled setuid
3406 * scripts in the kernel, this will attempt to emulate setuid and setgid
3407 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3408 * root version must be called suidperl or sperlN.NNN. If regular perl
3409 * discovers that it has opened a setuid script, it calls suidperl with
3410 * the same argv that it had. If suidperl finds that the script it has
3411 * just opened is NOT setuid root, it sets the effective uid back to the
3412 * uid. We don't just make perl setuid root because that loses the
3413 * effective uid we had before invoking perl, if it was different from the
3414 * uid.
ae3f3efd
PS		 3415 * PSz 27 Feb 04
3416 * Description/comments above do not match current workings:
3417 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3418 * suidperl called with script open and name changed to /dev/fd/N/X;
3419 * suidperl croaks if script is not setuid;
3420 * making perl setuid would be a huge security risk (and yes, that
3421 * would lose any euid we might have had).
13281fa4
LW		 3422 *
3423 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3424 * be defined in suidperl only. suidperl must be setuid root. The
3425 * Configure script will set this up for you if you want it.
3426 */
a687059c 3427
13281fa4 3428#ifdef DOSUID
dd720ed5 3429 const char *s, *s2;
a0d0e21e 3430
b28d0864 3431 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3432 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
ae3f3efd 3433 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3434 I32 len;
dd720ed5 3435 const char *linestr;
13281fa4 3436
a687059c 3437#ifdef IAMSUID
ae3f3efd
PS		 3438 if (PL_fdscript < 0 || PL_suidscript != 1)
3439 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3440 /* PSz 11 Nov 03
3441 * Since the script is opened by perl, not suidperl, some of these
3442 * checks are superfluous. Leaving them in probably does not lower
3443 * security(?!).
3444 */
3445 /* PSz 27 Feb 04
3446 * Do checks even for systems with no HAS_SETREUID.
3447 * We used to swap, then re-swap UIDs with
3448#ifdef HAS_SETREUID
3449 if (setreuid(PL_euid,PL_uid) < 0
3450 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3451 Perl_croak(aTHX_ "Can't swap uid and euid");
3452#endif
3453#ifdef HAS_SETREUID
3454 if (setreuid(PL_uid,PL_euid) < 0
3455 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3456 Perl_croak(aTHX_ "Can't reswap uid and euid");
3457#endif
3458 */
3459
a687059c
LW		 3460 /* On this access check to make sure the directories are readable,
3461 * there is actually a small window that the user could use to make
3462 * filename point to an accessible directory. So there is a faint
3463 * chance that someone could execute a setuid script down in a
3464 * non-accessible directory. I don't know what to do about that.
3465 * But I don't think it's too important. The manual lies when
3466 * it says access() is useful in setuid programs.
ae3f3efd
PS		 3467 *
3468 * So, access() is pretty useless... but not harmful... do anyway.
a687059c 3469 */
e57400b1 3470 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
ae3f3efd 3471 Perl_croak(aTHX_ "Can't access() script\n");
e57400b1 3472 }
ae3f3efd 3473
a687059c
LW		 3474 /* If we can swap euid and uid, then we can determine access rights
3475 * with a simple stat of the file, and then compare device and
3476 * inode to make sure we did stat() on the same file we opened.
3477 * Then we just have to make sure he or she can execute it.
ae3f3efd
PS		 3478 *
3479 * PSz 24 Feb 04
3480 * As the script is opened by perl, not suidperl, we do not need to
3481 * care much about access rights.
3482 *
3483 * The 'script changed' check is needed, or we can get lied to
3484 * about $0 with e.g.
3485 * suidperl /dev/fd/4//bin/x 4<setuidscript
3486 * Without HAS_SETREUID, is it safe to stat() as root?
3487 *
3488 * Are there any operating systems that pass /dev/fd/xxx for setuid
3489 * scripts, as suggested/described in perlsec(1)? Surely they do not
3490 * pass the script name as we do, so the "script changed" test would
3491 * fail for them... but we never get here with
3492 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3493 *
3494 * This is one place where we must "lie" about return status: not
3495 * say if the stat() failed. We are doing this as root, and could
3496 * be tricked into reporting existence or not of files that the
3497 * "plain" user cannot even see.
a687059c
LW		 3498 */
3499 {
c623ac67 3500 Stat_t tmpstatbuf;
ae3f3efd
PS		 3501 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3502 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
b28d0864 3503 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
ae3f3efd 3504 Perl_croak(aTHX_ "Setuid script changed\n");
a687059c 3505 }
ae3f3efd 3506
a687059c 3507 }
ae3f3efd
PS		 3508 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3509 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3510
3511 /* PSz 27 Feb 04
3512 * We used to do this check as the "plain" user (after swapping
3513 * UIDs). But the check for nosuid and noexec filesystem is needed,
3514 * and should be done even without HAS_SETREUID. (Maybe those
3515 * operating systems do not have such mount options anyway...)
3516 * Seems safe enough to do as root.
3517 */
3518#if !defined(NO_NOSUID_CHECK)
3519 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3520 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3521 }
3522#endif
a687059c
LW		 3523#endif /* IAMSUID */
3524
e57400b1 3525 if (!S_ISREG(PL_statbuf.st_mode)) {
ae3f3efd 3526 Perl_croak(aTHX_ "Setuid script not plain file\n");
e57400b1 3527 }
b28d0864 3528 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3529 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3530 PL_doswitches = FALSE; /* -s is insecure in suid */
ae3f3efd 3531 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
57843af0 3532 CopLINE_inc(PL_curcop);
dd720ed5 3533 linestr = SvPV_nolen_const(PL_linestr);
6b88bc9c 3534 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
dd720ed5 3535 strnNE(linestr,"#!",2) ) /* required even on Sys V */
cea2e8a9 3536 Perl_croak(aTHX_ "No #! line");
dd720ed5
NC		 3537 linestr+=2;
3538 s = linestr;
ae3f3efd
PS		 3539 /* PSz 27 Feb 04 */
3540 /* Sanity check on line length */
3541 if (strlen(s) < 1 || strlen(s) > 4000)
3542 Perl_croak(aTHX_ "Very long #! line");
3543 /* Allow more than a single space after #! */
3544 while (isSPACE(*s)) s++;
3545 /* Sanity check on buffer end */
3546 while ((*s) && !isSPACE(*s)) s++;
dd720ed5 3547 for (s2 = s; (s2 > linestr &&
3792a11b
NC		 3548 (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
3549 || s2[-1] == '-')); s2--) ;
ae3f3efd 3550 /* Sanity check on buffer start */
dd720ed5
NC		 3551 if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
3552 (s-9 < linestr || strnNE(s-9,"perl",4)) )
cea2e8a9 3553 Perl_croak(aTHX_ "Not a perl script");
a687059c 3554 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3555 /*
3556 * #! arg must be what we saw above. They can invoke it by
3557 * mentioning suidperl explicitly, but they may not add any strange
3558 * arguments beyond what #! says if they do invoke suidperl that way.
3559 */
ae3f3efd
PS		 3560 /*
3561 * The way validarg was set up, we rely on the kernel to start
3562 * scripts with argv[1] set to contain all #