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 #! line switches (the
3563 * whole line).
3564 */
3565 /*
3566 * Check that we got all the arguments listed in the #! line (not
3567 * just that there are no extraneous arguments). Might not matter
3568 * much, as switches from #! line seem to be acted upon (also), and
3569 * so may be checked and trapped in perl. But, security checks must
3570 * be done in suidperl and not deferred to perl. Note that suidperl
3571 * does not get around to parsing (and checking) the switches on
3572 * the #! line (but execs perl sooner).
3573 * Allow (require) a trailing newline (which may be of two
3574 * characters on some architectures?) (but no other trailing
3575 * whitespace).
3576 */
13281fa4
LW		 3577 len = strlen(validarg);
3578 if (strEQ(validarg," PHOOEY ") ||
ae3f3efd
PS		 3579 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3580 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
cea2e8a9 3581 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3582
3583#ifndef IAMSUID
ae3f3efd
PS		 3584 if (PL_fdscript < 0 &&
3585 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
b28d0864
NIS		 3586 PL_euid == PL_statbuf.st_uid)
3587 if (!PL_do_undump)
cea2e8a9 3588 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
11fb1898 3589FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
a687059c 3590#endif /* IAMSUID */
13281fa4 3591
ae3f3efd
PS		 3592 if (PL_fdscript < 0 &&
3593 PL_euid) { /* oops, we're not the setuid root perl */
3594 /* PSz 18 Feb 04
3595 * When root runs a setuid script, we do not go through the same
3596 * steps of execing sperl and then perl with fd scripts, but
3597 * simply set up UIDs within the same perl invocation; so do
3598 * not have the same checks (on options, whatever) that we have
3599 * for plain users. No problem really: would have to be a script
3600 * that does not actually work for plain users; and if root is
3601 * foolish and can be persuaded to run such an unsafe script, he
3602 * might run also non-setuid ones, and deserves what he gets.
3603 *
3604 * Or, we might drop the PL_euid check above (and rely just on
3605 * PL_fdscript to avoid loops), and do the execs
3606 * even for root.
3607 */
13281fa4 3608#ifndef IAMSUID
ae3f3efd
PS		 3609 int which;
3610 /* PSz 11 Nov 03
3611 * Pass fd script to suidperl.
3612 * Exec suidperl, substituting fd script for scriptname.
3613 * Pass script name as "subdir" of fd, which perl will grok;
3614 * in fact will use that to distinguish this from "normal"
3615 * usage, see comments above.
3616 */
3617 PerlIO_rewind(PL_rsfp);
3618 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3619 /* PSz 27 Feb 04 Sanity checks on scriptname */
3620 if ((!scriptname) || (!*scriptname) ) {
3621 Perl_croak(aTHX_ "No setuid script name\n");
3622 }
3623 if (*scriptname == '-') {
3624 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3625 /* Or we might confuse it with an option when replacing
3626 * name in argument list, below (though we do pointer, not
3627 * string, comparisons).
3628 */
3629 }
3630 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3631 if (!PL_origargv[which]) {
3632 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3633 }
3634 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3635 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3636#if defined(HAS_FCNTL) && defined(F_SETFD)
3637 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3638#endif
b35112e7 3639 PERL_FPU_PRE_EXEC
a7cb1f99 3640 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3641 (int)PERL_REVISION, (int)PERL_VERSION,
3642 (int)PERL_SUBVERSION), PL_origargv);
b35112e7 3643 PERL_FPU_POST_EXEC
ae3f3efd
PS		 3644#endif /* IAMSUID */
3645 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
13281fa4
LW		 3646 }
3647
b28d0864 3648 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
ae3f3efd
PS		 3649/* PSz 26 Feb 04
3650 * This seems back to front: we try HAS_SETEGID first; if not available
3651 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3652 * in the sense that we only want to set EGID; but are there any machines
3653 * with either of the latter, but not the former? Same with UID, later.
3654 */
fe14fcc3 3655#ifdef HAS_SETEGID
b28d0864 3656 (void)setegid(PL_statbuf.st_gid);
a687059c 3657#else
fe14fcc3 3658#ifdef HAS_SETREGID
b28d0864 3659 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3660#else
3661#ifdef HAS_SETRESGID
b28d0864 3662 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3663#else
b28d0864 3664 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3665#endif
3666#endif
85e6fe83 3667#endif
b28d0864 3668 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3669 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3670 }
b28d0864
NIS		 3671 if (PL_statbuf.st_mode & S_ISUID) {
3672 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3673#ifdef HAS_SETEUID
b28d0864 3674 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3675#else
fe14fcc3 3676#ifdef HAS_SETREUID
b28d0864 3677 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3678#else
3679#ifdef HAS_SETRESUID
b28d0864 3680 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3681#else
b28d0864 3682 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3683#endif
3684#endif
85e6fe83 3685#endif
b28d0864 3686 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3687 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3688 }
b28d0864 3689 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3690#ifdef HAS_SETEUID
b28d0864 3691 (void)seteuid((Uid_t)PL_uid);
a687059c 3692#else
fe14fcc3 3693#ifdef HAS_SETREUID
b28d0864 3694 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3695#else
85e6fe83 3696#ifdef HAS_SETRESUID
b28d0864 3697 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3698#else
b28d0864 3699 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3700#endif
a687059c
LW		 3701#endif
3702#endif
b28d0864 3703 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3704 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3705 }
748a9306 3706 init_ids();
b28d0864 3707 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
ae3f3efd 3708 Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
13281fa4
LW		 3709 }
3710#ifdef IAMSUID
ae3f3efd 3711 else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
cea2e8a9 3712 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
ae3f3efd
PS		 3713 else if (PL_fdscript < 0 || PL_suidscript != 1)
3714 /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
3715 Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
e57400b1 3716 else {
ae3f3efd
PS		 3717/* PSz 16 Sep 03 Keep neat error message */
3718 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
e57400b1 3719 }
96436eeb 3720
3721 /* We absolutely must clear out any saved ids here, so we */
3722 /* exec the real perl, substituting fd script for scriptname. */
3723 /* (We pass script name as "subdir" of fd, which perl will grok.) */
ae3f3efd
PS		 3724 /*
3725 * It might be thought that using setresgid and/or setresuid (changed to
3726 * set the saved IDs) above might obviate the need to exec, and we could
3727 * go on to "do the perl thing".
3728 *
3729 * Is there such a thing as "saved GID", and is that set for setuid (but
3730 * not setgid) execution like suidperl? Without exec, it would not be
3731 * cleared for setuid (but not setgid) scripts (or might need a dummy
3732 * setresgid).
3733 *
3734 * We need suidperl to do the exact same argument checking that perl
3735 * does. Thus it cannot be very small; while it could be significantly
3736 * smaller, it is safer (simpler?) to make it essentially the same
3737 * binary as perl (but they are not identical). - Maybe could defer that
3738 * check to the invoked perl, and suidperl be a tiny wrapper instead;
3739 * but prefer to do thorough checks in suidperl itself. Such deferral
3740 * would make suidperl security rely on perl, a design no-no.
3741 *
3742 * Setuid things should be short and simple, thus easy to understand and
3743 * verify. They should do their "own thing", without influence by
3744 * attackers. It may help if their internal execution flow is fixed,
3745 * regardless of platform: it may be best to exec anyway.
3746 *
3747 * Suidperl should at least be conceptually simple: a wrapper only,
3748 * never to do any real perl. Maybe we should put
3749 * #ifdef IAMSUID
3750 * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
3751 * #endif
3752 * into the perly bits.
3753 */
b28d0864
NIS		 3754 PerlIO_rewind(PL_rsfp);
3755 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
ae3f3efd
PS		 3756 /* PSz 11 Nov 03
3757 * Keep original arguments: suidperl already has fd script.
3758 */
3759/* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
3760/* if (!PL_origargv[which]) { */
3761/* errno = EPERM; */
3762/* Perl_croak(aTHX_ "Permission denied\n"); */
3763/* } */
3764/* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */
3765/* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
96436eeb 3766#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3767 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3768#endif
b35112e7 3769 PERL_FPU_PRE_EXEC
a7cb1f99 3770 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3771 (int)PERL_REVISION, (int)PERL_VERSION,
3772 (int)PERL_SUBVERSION), PL_origargv);/* try again */
b35112e7 3773 PERL_FPU_POST_EXEC
ae3f3efd 3774 Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
13281fa4 3775#endif /* IAMSUID */
a687059c 3776#else /* !DOSUID */
3280af22 3777 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3778#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3779 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3780 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3781 ||
b28d0864 3782 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3783 )
b28d0864 3784 if (!PL_do_undump)
cea2e8a9 3785 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3786FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3787#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3788 /* not set-id, must be wrapped */
a687059c 3789 }
13281fa4 3790#endif /* DOSUID */
dd374669
AL		 3791 (void)validarg;
3792 (void)scriptname;
79072805 3793}
13281fa4 3794
76e3520e 3795STATIC void
cea2e8a9 3796S_find_beginning(pTHX)
79072805 3797{
dd374669
AL		 3798 register char *s;
3799 register const char *s2;
e55ac0fa
HS		 3800#ifdef MACOS_TRADITIONAL
3801 int maclines = 0;
3802#endif
33b78306
LW		 3803
3804 /* skip forward in input to the real script? */
3805
bbce6d69 3806 forbid_setid("-x");
bf4acbe4 3807#ifdef MACOS_TRADITIONAL
084592ab 3808 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3809
bf4acbe4
GS		 3810 while (PL_doextract || gMacPerl_AlwaysExtract) {
3811 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3812 if (!gMacPerl_AlwaysExtract)
3813 Perl_croak(aTHX_ "No Perl script found in input\n");
e55ac0fa 3814
bf4acbe4
GS		 3815 if (PL_doextract) /* require explicit override ? */
3816 if (!OverrideExtract(PL_origfilename))
3817 Perl_croak(aTHX_ "User aborted script\n");
3818 else
3819 PL_doextract = FALSE;
e55ac0fa 3820
bf4acbe4
GS		 3821 /* Pater peccavi, file does not have #! */
3822 PerlIO_rewind(PL_rsfp);
e55ac0fa 3823
bf4acbe4
GS		 3824 break;
3825 }
3826#else
3280af22
NIS		 3827 while (PL_doextract) {
3828 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3829 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3830#endif
4f0c37ba
IZ		 3831 s2 = s;
3832 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3833 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3834 PL_doextract = FALSE;
6e72f9df 3835 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3836 s2 = s;
3837 while (*s == ' ' || *s == '\t') s++;
3838 if (*s++ == '-') {
3792a11b
NC		 3839 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3840 || s2[-1] == '_') s2--;
6e72f9df 3841 if (strnEQ(s2-4,"perl",4))
155aba94
GS		 3842 while ((s = moreswitches(s)))
3843 ;
33b78306 3844 }
95e8664e 3845#ifdef MACOS_TRADITIONAL
e55ac0fa
HS		 3846 /* We are always searching for the #!perl line in MacPerl,
3847 * so if we find it, still keep the line count correct
3848 * by counting lines we already skipped over
3849 */
3850 for (; maclines > 0 ; maclines--)
3851 PerlIO_ungetc(PL_rsfp, '\n');
3852
95e8664e 3853 break;
e55ac0fa
HS		 3854
3855 /* gMacPerl_AlwaysExtract is false in MPW tool */
3856 } else if (gMacPerl_AlwaysExtract) {
3857 ++maclines;
95e8664e 3858#endif
83025b21
LW		 3859 }
3860 }
3861}
3862
afe37c7d 3863
76e3520e 3864STATIC void
cea2e8a9 3865S_init_ids(pTHX)
352d5a3a 3866{
d8eceb89
JH		 3867 PL_uid = PerlProc_getuid();
3868 PL_euid = PerlProc_geteuid();
3869 PL_gid = PerlProc_getgid();
3870 PL_egid = PerlProc_getegid();
748a9306 3871#ifdef VMS
b28d0864
NIS		 3872 PL_uid |= PL_gid << 16;
3873 PL_euid |= PL_egid << 16;
748a9306 3874#endif
22f7c9c9
JH		 3875 /* Should not happen: */
3876 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3280af22 3877 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
ae3f3efd
PS		 3878 /* BUG */
3879 /* PSz 27 Feb 04
3880 * Should go by suidscript, not uid!=euid: why disallow
3881 * system("ls") in scripts run from setuid things?
3882 * Or, is this run before we check arguments and set suidscript?
3883 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3884 * (We never have suidscript, can we be sure to have fdscript?)
3885 * Or must then go by UID checks? See comments in forbid_setid also.
3886 */
748a9306 3887}
79072805 3888
a0643315
JH		 3889/* This is used very early in the lifetime of the program,
3890 * before even the options are parsed, so PL_tainting has
b0891165 3891 * not been initialized properly. */
af419de7 3892bool
8f42b153 3893Perl_doing_taint(int argc, char *argv[], char *envp[])
22f7c9c9 3894{
c3446a78
JH		 3895#ifndef PERL_IMPLICIT_SYS
3896 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3897 * before we have an interpreter-- and the whole point of this
3898 * function is to be called at such an early stage. If you are on
3899 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3900 * "tainted because running with altered effective ids', you'll
3901 * have to add your own checks somewhere in here. The two most
3902 * known samples of 'implicitness' are Win32 and NetWare, neither
3903 * of which has much of concept of 'uids'. */
af419de7 3904 int uid = PerlProc_getuid();
22f7c9c9 3905 int euid = PerlProc_geteuid();
af419de7 3906 int gid = PerlProc_getgid();
22f7c9c9 3907 int egid = PerlProc_getegid();
6867be6d 3908 (void)envp;
22f7c9c9
JH		 3909
3910#ifdef VMS
af419de7 3911 uid |= gid << 16;
22f7c9c9
JH		 3912 euid |= egid << 16;
3913#endif
3914 if (uid && (euid != uid || egid != gid))
3915 return 1;
c3446a78 3916#endif /* !PERL_IMPLICIT_SYS */
af419de7
JH		 3917 /* This is a really primitive check; environment gets ignored only
3918 * if -T are the first chars together; otherwise one gets
3919 * "Too late" message. */
22f7c9c9
JH		 3920 if ( argc > 1 && argv[1][0] == '-'
3921 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3922 return 1;
3923 return 0;
3924}
22f7c9c9 3925
76e3520e 3926STATIC void
e1ec3a88 3927S_forbid_setid(pTHX_ const char *s)
bbce6d69 3928{
ae3f3efd 3929#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3280af22 3930 if (PL_euid != PL_uid)
cea2e8a9 3931 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 3932 if (PL_egid != PL_gid)
cea2e8a9 3933 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
ae3f3efd
PS		 3934#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3935 /* PSz 29 Feb 04
3936 * Checks for UID/GID above "wrong": why disallow
3937 * perl -e 'print "Hello\n"'
3938 * from within setuid things?? Simply drop them: replaced by
3939 * fdscript/suidscript and #ifdef IAMSUID checks below.
3940 *
3941 * This may be too late for command-line switches. Will catch those on
3942 * the #! line, after finding the script name and setting up
3943 * fdscript/suidscript. Note that suidperl does not get around to
3944 * parsing (and checking) the switches on the #! line, but checks that
3945 * the two sets are identical.
3946 *
3947 * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
3948 * instead, or would that be "too late"? (We never have suidscript, can
3949 * we be sure to have fdscript?)
3950 *
3951 * Catch things with suidscript (in descendant of suidperl), even with
3952 * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
3953 * below; but I am paranoid.
3954 *
3955 * Also see comments about root running a setuid script, elsewhere.
3956 */
3957 if (PL_suidscript >= 0)
3958 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
3959#ifdef IAMSUID
3960 /* PSz 11 Nov 03 Catch it in suidperl, always! */
3961 Perl_croak(aTHX_ "No %s allowed in suidperl", s);
3962#endif /* IAMSUID */
bbce6d69 3963}
3964
1ee4443e
IZ		 3965void
3966Perl_init_debugger(pTHX)
748a9306 3967{
1ee4443e
IZ		 3968 HV *ostash = PL_curstash;
3969
3280af22 3970 PL_curstash = PL_debstash;
7619c85e 3971 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
3280af22 3972 AvREAL_off(PL_dbargs);
7619c85e
RG		 3973 PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
3974 PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3975 PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
7619c85e 3976 PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3977 sv_setiv(PL_DBsingle, 0);
7619c85e 3978 PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3979 sv_setiv(PL_DBtrace, 0);
7619c85e 3980 PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3981 sv_setiv(PL_DBsignal, 0);
bf9cdc68 3982 PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
06492da6 3983 sv_setiv(PL_DBassertion, 0);
1ee4443e 3984 PL_curstash = ostash;
352d5a3a
LW		 3985}
3986
2ce36478
SM		 3987#ifndef STRESS_REALLOC
3988#define REASONABLE(size) (size)
3989#else
3990#define REASONABLE(size) (1) /* unreasonable */
3991#endif
3992
11343788 3993void
cea2e8a9 3994Perl_init_stacks(pTHX)
79072805 3995{
e336de0d 3996 /* start with 128-item stack and 8K cxstack */
3280af22 3997 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 3998 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 3999 PL_curstackinfo->si_type = PERLSI_MAIN;
4000 PL_curstack = PL_curstackinfo->si_stack;
4001 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 4002
3280af22
NIS		 4003 PL_stack_base = AvARRAY(PL_curstack);
4004 PL_stack_sp = PL_stack_base;
4005 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 4006
3280af22
NIS		 4007 New(50,PL_tmps_stack,REASONABLE(128),SV*);
4008 PL_tmps_floor = -1;
4009 PL_tmps_ix = -1;
4010 PL_tmps_max = REASONABLE(128);
8990e307 4011
3280af22
NIS		 4012 New(54,PL_markstack,REASONABLE(32),I32);
4013 PL_markstack_ptr = PL_markstack;
4014 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 4015
ce2f7c3b 4016 SET_MARK_OFFSET;
e336de0d 4017
3280af22
NIS		 4018 New(54,PL_scopestack,REASONABLE(32),I32);
4019 PL_scopestack_ix = 0;
4020 PL_scopestack_max = REASONABLE(32);
79072805 4021
3280af22
NIS		 4022 New(54,PL_savestack,REASONABLE(128),ANY);
4023 PL_savestack_ix = 0;
4024 PL_savestack_max = REASONABLE(128);
378cc40b 4025}
33b78306 4026
2ce36478
SM		 4027#undef REASONABLE
4028
76e3520e 4029STATIC void
cea2e8a9 4030S_nuke_stacks(pTHX)
6e72f9df 4031{
3280af22
NIS		 4032 while (PL_curstackinfo->si_next)
4033 PL_curstackinfo = PL_curstackinfo->si_next;
4034 while (PL_curstackinfo) {
4035 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 4036 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 4037 Safefree(PL_curstackinfo->si_cxstack);
4038 Safefree(PL_curstackinfo);
4039 PL_curstackinfo = p;
e336de0d 4040 }
3280af22
NIS		 4041 Safefree(PL_tmps_stack);
4042 Safefree(PL_markstack);
4043 Safefree(PL_scopestack);
4044 Safefree(PL_savestack);
378cc40b 4045}
33b78306 4046
76e3520e 4047STATIC void
cea2e8a9 4048S_init_lexer(pTHX)
8990e307 4049{
06039172 4050 PerlIO *tmpfp;
3280af22
NIS		 4051 tmpfp = PL_rsfp;
4052 PL_rsfp = Nullfp;
4053 lex_start(PL_linestr);
4054 PL_rsfp = tmpfp;
79cb57f6 4055 PL_subname = newSVpvn("main",4);
8990e307
LW		 4056}
4057
76e3520e 4058STATIC void
cea2e8a9 4059S_init_predump_symbols(pTHX)
45d8adaa 4060{
93a17b20 4061 GV *tmpgv;
af8c498a 4062 IO *io;
79072805 4063
864dbfa3 4064 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 4065 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
4066 GvMULTI_on(PL_stdingv);
af8c498a 4067 io = GvIOp(PL_stdingv);
a04651f4 4068 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 4069 IoIFP(io) = PerlIO_stdin();
adbc6bb1 4070 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 4071 GvMULTI_on(tmpgv);
af8c498a 4072 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 4073
85e6fe83 4074 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 4075 GvMULTI_on(tmpgv);
af8c498a 4076 io = GvIOp(tmpgv);
a04651f4 4077 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 4078 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 4079 setdefout(tmpgv);
adbc6bb1 4080 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 4081 GvMULTI_on(tmpgv);
af8c498a 4082 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 4083
bf49b057
GS		 4084 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
4085 GvMULTI_on(PL_stderrgv);
4086 io = GvIOp(PL_stderrgv);
a04651f4 4087 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 4088 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 4089 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 4090 GvMULTI_on(tmpgv);
af8c498a 4091 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 4092
3280af22 4093 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 4094
bf4acbe4
GS		 4095 if (PL_osname)
4096 Safefree(PL_osname);
4097 PL_osname = savepv(OSNAME);
79072805 4098}
33b78306 4099
a11ec5a9 4100void
8f42b153 4101Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
33b78306 4102{
79072805 4103 char *s;
79072805 4104 argc--,argv++; /* skip name of script */
3280af22 4105 if (PL_doswitches) {
79072805
LW		 4106 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4107 if (!argv[0][1])
4108 break;
379d538a 4109 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 4110 argc--,argv++;
4111 break;
4112 }
155aba94 4113 if ((s = strchr(argv[0], '='))) {
79072805 4114 *s++ = '\0';
85e6fe83 4115 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 4116 }
4117 else
85e6fe83 4118 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 4119 }
79072805 4120 }
a11ec5a9
RGS		 4121 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4122 GvMULTI_on(PL_argvgv);
4123 (void)gv_AVadd(PL_argvgv);
4124 av_clear(GvAVn(PL_argvgv));
4125 for (; argc > 0; argc--,argv++) {
4126 SV *sv = newSVpv(argv[0],0);
4127 av_push(GvAVn(PL_argvgv),sv);
ce81ff12
JH		 4128 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4129 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4130 SvUTF8_on(sv);
4131 }
a05d7ebb
JH		 4132 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4133 (void)sv_utf8_decode(sv);
a11ec5a9
RGS		 4134 }
4135 }
4136}
4137
4138STATIC void
4139S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4140{
27da23d5 4141 dVAR;
a11ec5a9 4142 GV* tmpgv;
a11ec5a9 4143
3280af22
NIS		 4144 PL_toptarget = NEWSV(0,0);
4145 sv_upgrade(PL_toptarget, SVt_PVFM);
4146 sv_setpvn(PL_toptarget, "", 0);
4147 PL_bodytarget = NEWSV(0,0);
4148 sv_upgrade(PL_bodytarget, SVt_PVFM);
4149 sv_setpvn(PL_bodytarget, "", 0);
4150 PL_formtarget = PL_bodytarget;
79072805 4151
bbce6d69 4152 TAINT;
a11ec5a9
RGS		 4153
4154 init_argv_symbols(argc,argv);
4155
155aba94 4156 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
bf4acbe4
GS		 4157#ifdef MACOS_TRADITIONAL
4158 /* $0 is not majick on a Mac */
4159 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4160#else
3280af22 4161 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 4162 magicname("0", "0", 1);
bf4acbe4 4163#endif
79072805 4164 }
155aba94 4165 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
79072805 4166 HV *hv;
3280af22
NIS		 4167 GvMULTI_on(PL_envgv);
4168 hv = GvHVn(PL_envgv);
14befaf4 4169 hv_magic(hv, Nullgv, PERL_MAGIC_env);
2f42fcb0 4170#ifndef PERL_MICRO
fa6a1c44 4171#ifdef USE_ENVIRON_ARRAY
4633a7c4
LW		 4172 /* Note that if the supplied env parameter is actually a copy
4173 of the global environ then it may now point to free'd memory
4174 if the environment has been modified since. To avoid this
4175 problem we treat env==NULL as meaning 'use the default'
4176 */
4177 if (!env)
4178 env = environ;
4efc5df6
GS		 4179 if (env != environ
4180# ifdef USE_ITHREADS
4181 && PL_curinterp == aTHX
4182# endif
4183 )
4184 {
79072805 4185 environ[0] = Nullch;
4efc5df6 4186 }
9b4eeda5
MB		 4187 if (env) {
4188 char** origenv = environ;
27da23d5
JH		 4189 char *s;
4190 SV *sv;
764df951 4191 for (; *env; env++) {
9b4eeda5 4192 if (!(s = strchr(*env,'=')) || s == *env)
79072805 4193 continue;
7da0e383 4194#if defined(MSDOS) && !defined(DJGPP)
61968511 4195 *s = '\0';
137443ea 4196 (void)strupr(*env);
61968511 4197 *s = '=';
137443ea 4198#endif
61968511 4199 sv = newSVpv(s+1, 0);
79072805 4200 (void)hv_store(hv, *env, s - *env, sv, 0);
61968511
GA		 4201 if (env != environ)
4202 mg_set(sv);
9b4eeda5
MB		 4203 if (origenv != environ) {
4204 /* realloc has shifted us */
4205 env = (env - origenv) + environ;
4206 origenv = environ;
4207 }
764df951 4208 }
9b4eeda5 4209 }
103a7189 4210#endif /* USE_ENVIRON_ARRAY */
2f42fcb0 4211#endif /* !PERL_MICRO */
79072805 4212 }
bbce6d69 4213 TAINT_NOT;
306196c3
MS		 4214 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4215 SvREADONLY_off(GvSV(tmpgv));
7766f137 4216 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
306196c3
MS		 4217 SvREADONLY_on(GvSV(tmpgv));
4218 }
4d76a344
RGS		 4219#ifdef THREADS_HAVE_PIDS
4220 PL_ppid = (IV)getppid();
4221#endif
2710853f
MJD		 4222
4223 /* touch @F array to prevent spurious warnings 20020415 MJD */
4224 if (PL_minus_a) {
4225 (void) get_av("main::F", TRUE | GV_ADDMULTI);
4226 }
4227 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4228 (void) get_av("main::-", TRUE | GV_ADDMULTI);
4229 (void) get_av("main::+", TRUE | GV_ADDMULTI);
33b78306 4230}
34de22dd 4231
76e3520e 4232STATIC void
cea2e8a9 4233S_init_perllib(pTHX)
34de22dd 4234{
85e6fe83 4235 char *s;
3280af22 4236 if (!PL_tainting) {
552a7a9b 4237#ifndef VMS
76e3520e 4238 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 4239 if (s)
88fe16b2 4240 incpush(s, TRUE, TRUE, TRUE, FALSE);
85e6fe83 4241 else
88fe16b2 4242 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
552a7a9b 4243#else /* VMS */
4244 /* Treat PERL5?LIB as a possible search list logical name -- the
4245 * "natural" VMS idiom for a Unix path string. We allow each
4246 * element to be a set of |-separated directories for compatibility.
4247 */
4248 char buf[256];
4249 int idx = 0;
4250 if (my_trnlnm("PERL5LIB",buf,0))
88fe16b2 4251 do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 4252 else
88fe16b2 4253 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
552a7a9b 4254#endif /* VMS */
85e6fe83 4255 }
34de22dd 4256
c90c0ff4 4257/* Use the ~-expanded versions of APPLLIB (undocumented),
65f19062 4258 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
df5cef82 4259*/
4633a7c4 4260#ifdef APPLLIB_EXP
88fe16b2 4261 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
16d20bd9 4262#endif
4633a7c4 4263
fed7345c 4264#ifdef ARCHLIB_EXP
88fe16b2 4265 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
a0d0e21e 4266#endif
bf4acbe4
GS		 4267#ifdef MACOS_TRADITIONAL
4268 {
c623ac67 4269 Stat_t tmpstatbuf;
bf4acbe4
GS		 4270 SV * privdir = NEWSV(55, 0);
4271 char * macperl = PerlEnv_getenv("MACPERL");
4272
4273 if (!macperl)
4274 macperl = "";
4275
4276 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4277 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
88fe16b2 4278 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
bf4acbe4
GS		 4279 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4280 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
88fe16b2 4281 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
ac27b0f5 4282
bf4acbe4
GS		 4283 SvREFCNT_dec(privdir);
4284 }
4285 if (!PL_tainting)
88fe16b2 4286 incpush(":", FALSE, FALSE, TRUE, FALSE);
bf4acbe4 4287#else
fed7345c 4288#ifndef PRIVLIB_EXP
65f19062 4289# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 4290#endif
ac27b0f5 4291#if defined(WIN32)
88fe16b2 4292 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
00dc2f4f 4293#else
88fe16b2 4294 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
00dc2f4f 4295#endif
4633a7c4 4296
65f19062 4297#ifdef SITEARCH_EXP
3b290362
GS		 4298 /* sitearch is always relative to sitelib on Windows for
4299 * DLL-based path intuition to work correctly */
4300# if !defined(WIN32)
88fe16b2 4301 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062
GS		 4302# endif
4303#endif
4304
4633a7c4 4305#ifdef SITELIB_EXP
65f19062 4306# if defined(WIN32)
574c798a 4307 /* this picks up sitearch as well */
88fe16b2 4308 incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
65f19062 4309# else
88fe16b2 4310 incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062
GS		 4311# endif
4312#endif
189d1e8d 4313
65f19062 4314#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
88fe16b2 4315 incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
81c6dfba 4316#endif
65f19062
GS		 4317
4318#ifdef PERL_VENDORARCH_EXP
4ea817c6 4319 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS		 4320 * DLL-based path intuition to work correctly */
4321# if !defined(WIN32)
88fe16b2 4322 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062 4323# endif
4b03c463 4324#endif
65f19062
GS		 4325
4326#ifdef PERL_VENDORLIB_EXP
4327# if defined(WIN32)
88fe16b2 4328 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE); /* this picks up vendorarch as well */
65f19062 4329# else
88fe16b2 4330 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062 4331# endif
a3635516 4332#endif
65f19062
GS		 4333
4334#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
88fe16b2 4335 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
00dc2f4f 4336#endif
65f19062 4337
3b777bb4 4338#ifdef PERL_OTHERLIBDIRS
88fe16b2 4339 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
3b777bb4
GS		 4340#endif
4341
3280af22 4342 if (!PL_tainting)
88fe16b2 4343 incpush(".", FALSE, FALSE, TRUE, FALSE);
bf4acbe4 4344#endif /* MACOS_TRADITIONAL */
774d564b 4345}
4346
27da23d5 4347#if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
774d564b 4348# define PERLLIB_SEP ';'
4349#else
4350# if defined(VMS)
4351# define PERLLIB_SEP '|'
4352# else
bf4acbe4
GS		 4353# if defined(MACOS_TRADITIONAL)
4354# define PERLLIB_SEP ','
4355# else
4356# define PERLLIB_SEP ':'
4357# endif
774d564b 4358# endif
4359#endif
4360#ifndef PERLLIB_MANGLE
4361# define PERLLIB_MANGLE(s,n) (s)
ac27b0f5 4362#endif
774d564b 4363
ad17a1ae
NC		 4364/* Push a directory onto @INC if it exists.
4365 Generate a new SV if we do this, to save needing to copy the SV we push
4366 onto @INC */
4367STATIC SV *
4368S_incpush_if_exists(pTHX_ SV *dir)
4369{
4370 Stat_t tmpstatbuf;
848ef955 4371 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
ad17a1ae
NC		 4372 S_ISDIR(tmpstatbuf.st_mode)) {
4373 av_push(GvAVn(PL_incgv), dir);
4374 dir = NEWSV(0,0);
4375 }
4376 return dir;
4377}
4378
76e3520e 4379STATIC void
dd374669
AL		 4380S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
4381 bool canrelocate)
774d564b 4382{
4383 SV *subdir = Nullsv;
dd374669 4384 const char *p = dir;
774d564b 4385
3b290362 4386 if (!p || !*p)
774d564b 4387 return;
4388
9c8a64f0 4389 if (addsubdirs || addoldvers) {
ad17a1ae 4390 subdir = NEWSV(0,0);
774d564b 4391 }
4392
4393 /* Break at all separators */
4394 while (p && *p) {
8c52afec 4395 SV *libdir = NEWSV(55,0);
e1ec3a88 4396 const char *s;
774d564b 4397
4398 /* skip any consecutive separators */
574c798a
SR		 4399 if (usesep) {
4400 while ( *p == PERLLIB_SEP ) {
4401 /* Uncomment the next line for PATH semantics */
4402 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4403 p++;
4404 }
774d564b 4405 }
4406
574c798a 4407 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
774d564b 4408 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4409 (STRLEN)(s - p));
4410 p = s + 1;
4411 }
4412 else {
4413 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4414 p = Nullch; /* break out */
4415 }
bf4acbe4 4416#ifdef MACOS_TRADITIONAL
e69a2255
JH		 4417 if (!strchr(SvPVX(libdir), ':')) {
4418 char buf[256];
4419
4420 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4421 }
bf4acbe4
GS		 4422 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4423 sv_catpv(libdir, ":");
4424#endif
774d564b 4425
dd374669
AL		 4426 /* Do the if() outside the #ifdef to avoid warnings about an unused
4427 parameter. */
4428 if (canrelocate) {
88fe16b2
NC		 4429#ifdef PERL_RELOCATABLE_INC
4430 /*
4431 * Relocatable include entries are marked with a leading .../
4432 *
4433 * The algorithm is
4434 * 0: Remove that leading ".../"
4435 * 1: Remove trailing executable name (anything after the last '/')
4436 * from the perl path to give a perl prefix
4437 * Then
4438 * While the @INC element starts "../" and the prefix ends with a real
4439 * directory (ie not . or ..) chop that real directory off the prefix
4440 * and the leading "../" from the @INC element. ie a logical "../"
4441 * cleanup
4442 * Finally concatenate the prefix and the remainder of the @INC element
4443 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4444 * generates /usr/local/lib/perl5
4445 */
88fe16b2
NC		 4446 char *libpath = SvPVX(libdir);
4447 STRLEN libpath_len = SvCUR(libdir);
4448 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4449 /* Game on! */
4450 SV *caret_X = get_sv("\030", 0);
4451 /* Going to use the SV just as a scratch buffer holding a C
4452 string: */
4453 SV *prefix_sv;
4454 char *prefix;
4455 char *lastslash;
4456
4457 /* $^X is *the* source of taint if tainting is on, hence
4458 SvPOK() won't be true. */
4459 assert(caret_X);
4460 assert(SvPOKp(caret_X));
4461 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
4462 /* Firstly take off the leading .../
4463 If all else fail we'll do the paths relative to the current
4464 directory. */
4465 sv_chop(libdir, libpath + 4);
4466 /* Don't use SvPV as we're intentionally bypassing taining,
4467 mortal copies that the mg_get of tainting creates, and
4468 corruption that seems to come via the save stack.
4469 I guess that the save stack isn't correctly set up yet. */
4470 libpath = SvPVX(libdir);
4471 libpath_len = SvCUR(libdir);
4472
4473 /* This would work more efficiently with memrchr, but as it's
4474 only a GNU extension we'd need to probe for it and
4475 implement our own. Not hard, but maybe not worth it? */
4476
4477 prefix = SvPVX(prefix_sv);
4478 lastslash = strrchr(prefix, '/');
4479
4480 /* First time in with the *lastslash = '\0' we just wipe off
4481 the trailing /perl from (say) /usr/foo/bin/perl
4482 */
4483 if (lastslash) {
4484 SV *tempsv;
4485 while ((*lastslash = '\0'), /* Do that, come what may. */
4486 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4487 && (lastslash = strrchr(prefix, '/')))) {
4488 if (lastslash[1] == '\0'
4489 || (lastslash[1] == '.'
4490 && (lastslash[2] == '/' /* ends "/." */
4491 || (lastslash[2] == '/'
4492 && lastslash[3] == '/' /* or "/.." */
4493 )))) {
4494 /* Prefix ends "/" or "/." or "/..", any of which
4495 are fishy, so don't do any more logical cleanup.
4496 */
4497 break;
4498 }
4499 /* Remove leading "../" from path */
4500 libpath += 3;
4501 libpath_len -= 3;
4502 /* Next iteration round the loop removes the last
4503 directory name from prefix by writing a '\0' in
4504 the while clause. */
4505 }
4506 /* prefix has been terminated with a '\0' to the correct
4507 length. libpath points somewhere into the libdir SV.
4508 We need to join the 2 with '/' and drop the result into
4509 libdir. */
4510 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4511 SvREFCNT_dec(libdir);
4512 /* And this is the new libdir. */
4513 libdir = tempsv;
4514 if (PL_tainting &&
4515 (PL_uid != PL_euid || PL_gid != PL_egid)) {
4516 /* Need to taint reloccated paths if running set ID */
4517 SvTAINTED_on(libdir);
4518 }
4519 }
4520 SvREFCNT_dec(prefix_sv);
4521 }
88fe16b2 4522#endif
dd374669 4523 }
774d564b 4524 /*
4525 * BEFORE pushing libdir onto @INC we may first push version- and
4526 * archname-specific sub-directories.
4527 */
9c8a64f0 4528 if (addsubdirs || addoldvers) {
29d82f8d 4529#ifdef PERL_INC_VERSION_LIST
8353b874
GS		 4530 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4531 const char *incverlist[] = { PERL_INC_VERSION_LIST };
29d82f8d
GS		 4532 const char **incver;
4533#endif
aa689395 4534#ifdef VMS
4535 char *unix;
4536 STRLEN len;
774d564b 4537
2d8e6c8d 4538 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 4539 len = strlen(unix);
4540 while (unix[len-1] == '/') len--; /* Cosmetic */
4541 sv_usepvn(libdir,unix,len);
4542 }
4543 else
bf49b057 4544 PerlIO_printf(Perl_error_log,
aa689395 4545 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 4546 SvPV(libdir,len));
aa689395 4547#endif
9c8a64f0 4548 if (addsubdirs) {
bf4acbe4
GS		 4549#ifdef MACOS_TRADITIONAL
4550#define PERL_AV_SUFFIX_FMT ""
084592ab
CN		 4551#define PERL_ARCH_FMT "%s:"
4552#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
bf4acbe4
GS		 4553#else
4554#define PERL_AV_SUFFIX_FMT "/"
4555#define PERL_ARCH_FMT "/%s"
084592ab 4556#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
bf4acbe4 4557#endif
9c8a64f0 4558 /* .../version/archname if -d .../version/archname */
084592ab 4559 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
9c8a64f0
GS		 4560 libdir,
4561 (int)PERL_REVISION, (int)PERL_VERSION,
4562 (int)PERL_SUBVERSION, ARCHNAME);
ad17a1ae 4563 subdir = S_incpush_if_exists(aTHX_ subdir);
4b03c463 4564
9c8a64f0 4565 /* .../version if -d .../version */
084592ab 4566 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
9c8a64f0
GS		 4567 (int)PERL_REVISION, (int)PERL_VERSION,
4568 (int)PERL_SUBVERSION);
ad17a1ae 4569 subdir = S_incpush_if_exists(aTHX_ subdir);
9c8a64f0
GS		 4570
4571 /* .../archname if -d .../archname */
bf4acbe4 4572 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
ad17a1ae
NC		 4573 subdir = S_incpush_if_exists(aTHX_ subdir);
4574
29d82f8d 4575 }
9c8a64f0 4576
9c8a64f0 4577#ifdef PERL_INC_VERSION_LIST
ccc2aad8 4578 if (addoldvers) {
9c8a64f0
GS		 4579 for (incver = incverlist; *incver; incver++) {
4580 /* .../xxx if -d .../xxx */
bf4acbe4 4581 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
ad17a1ae 4582 subdir = S_incpush_if_exists(aTHX_ subdir);
9c8a64f0
GS		 4583 }
4584 }
29d82f8d 4585#endif
774d564b 4586 }
4587
4588 /* finally push this lib directory on the end of @INC */
3280af22 4589 av_push(GvAVn(PL_incgv), libdir);
774d564b 4590 }
ad17a1ae 4591 if (subdir) {
ef97f5b3 4592 assert (SvREFCNT(subdir) == 1);
ad17a1ae
NC		 4593 SvREFCNT_dec(subdir);
4594 }
34de22dd 4595}
93a17b20 4596
4d1ff10f 4597#ifdef USE_5005THREADS
76e3520e 4598STATIC struct perl_thread *
cea2e8a9 4599S_init_main_thread(pTHX)
199100c8 4600{
c5be433b 4601#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 4602 struct perl_thread *thr;
cea2e8a9 4603#endif
199100c8
MB		 4604 XPV *xpv;
4605
52e1cb5e 4606 Newz(53, thr, 1, struct perl_thread);
533c011a 4607 PL_curcop = &PL_compiling;
c5be433b 4608 thr->interp = PERL_GET_INTERP;
199100c8 4609 thr->cvcache = newHV();
54b9620d 4610 thr->threadsv = newAV();
940cb80d 4611 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 4612 thr->specific = newAV();
4613 thr->flags = THRf_R_JOINABLE;
4614 MUTEX_INIT(&thr->mutex);
4615 /* Handcraft thrsv similarly to mess_sv */
533c011a 4616 New(53, PL_thrsv, 1, SV);
199100c8 4617 Newz(53, xpv, 1, XPV);
533c011a
NIS		 4618 SvFLAGS(PL_thrsv) = SVt_PV;
4619 SvANY(PL_thrsv) = (void*)xpv;
4620 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
f880fe2f 4621 SvPV_set(PL_thrsvr, (char*)thr);
533c011a
NIS		 4622 SvCUR_set(PL_thrsv, sizeof(thr));
4623 SvLEN_set(PL_thrsv, sizeof(thr));
4624 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
4625 thr->oursv = PL_thrsv;
4626 PL_chopset = " \n-";
3967c732 4627 PL_dumpindent = 4;
533c011a
NIS		 4628
4629 MUTEX_LOCK(&PL_threads_mutex);
4630 PL_nthreads++;
199100c8
MB		 4631 thr->tid = 0;
4632 thr->next = thr;
4633 thr->prev = thr;
8dcd6f7b 4634 thr->thr_done = 0;
533c011a 4635 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 4636
4b026b9e 4637#ifdef HAVE_THREAD_INTERN
4f63d024 4638 Perl_init_thread_intern(thr);
235db74f
GS		 4639#endif
4640
4641#ifdef SET_THREAD_SELF
4642 SET_THREAD_SELF(thr);
199100c8
MB		 4643#else
4644 thr->self = pthread_self();
235db74f 4645#endif /* SET_THREAD_SELF */
06d86050 4646 PERL_SET_THX(thr);
199100c8
MB		 4647
4648 /*
411caa50
JH		 4649 * These must come after the thread self setting
4650 * because sv_setpvn does SvTAINT and the taint
4651 * fields thread selfness being set.
199100c8 4652 */
533c011a
NIS		 4653 PL_toptarget = NEWSV(0,0);
4654 sv_upgrade(PL_toptarget, SVt_PVFM);
4655 sv_setpvn(PL_toptarget, "", 0);
4656 PL_bodytarget = NEWSV(0,0);
4657 sv_upgrade(PL_bodytarget, SVt_PVFM);
4658 sv_setpvn(PL_bodytarget, "", 0);
4659 PL_formtarget = PL_bodytarget;
79cb57f6 4660 thr->errsv = newSVpvn("", 0);
78857c3c 4661 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 4662
533c011a 4663 PL_maxscream = -1;
a2efc822 4664 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
0b94c7bb
GS		 4665 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4666 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4667 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4668 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4669 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 4670 PL_regindent = 0;
4671 PL_reginterp_cnt = 0;
5c0ca799 4672
199100c8
MB		 4673 return thr;
4674}
4d1ff10f 4675#endif /* USE_5005THREADS */
199100c8 4676
93a17b20 4677void
864dbfa3 4678Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 4679{
27da23d5 4680 dVAR;
971a9dd3 4681 SV *atsv;
dd374669 4682 const line_t oldline = CopLINE(PL_curcop);
312caa8e 4683 CV *cv;
22921e25 4684 STRLEN len;
6224f72b 4685 int ret;
db36c5a1 4686 dJMPENV;
93a17b20 4687
e1ec3a88 4688 while (av_len(paramList) >= 0) {
312caa8e 4689 cv = (CV*)av_shift(paramList);
ece599bd
RGS		 4690 if (PL_savebegin) {
4691 if (paramList == PL_beginav) {
059a8bb7 4692 /* save PL_beginav for compiler */
ece599bd
RGS		 4693 if (! PL_beginav_save)
4694 PL_beginav_save = newAV();
4695 av_push(PL_beginav_save, (SV*)cv);
4696 }
4697 else if (paramList == PL_checkav) {
4698 /* save PL_checkav for compiler */
4699 if (! PL_checkav_save)
4700 PL_checkav_save = newAV();
4701 av_push(PL_checkav_save, (SV*)cv);
4702 }
059a8bb7
JH		 4703 } else {
4704 SAVEFREESV(cv);
4705 }
14dd3ad8 4706 JMPENV_PUSH(ret);
6224f72b 4707 switch (ret) {
312caa8e 4708 case 0:
14dd3ad8 4709 call_list_body(cv);
971a9dd3 4710 atsv = ERRSV;
10516c54 4711 (void)SvPV_const(atsv, len);
312caa8e
CS		 4712 if (len) {
4713 PL_curcop = &PL_compiling;
57843af0 4714 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 4715 if (paramList == PL_beginav)
4716 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4717 else
4f25aa18
GS		 4718 Perl_sv_catpvf(aTHX_ atsv,
4719 "%s failed--call queue aborted",
7d30b5c4 4720 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4721 : paramList == PL_initav ? "INIT"
4722 : "END");
312caa8e
CS		 4723 while (PL_scopestack_ix > oldscope)
4724 LEAVE;
14dd3ad8 4725 JMPENV_POP;
35c1215d 4726 Perl_croak(aTHX_ "%"SVf"", atsv);
a0d0e21e 4727 }
85e6fe83 4728 break;
6224f72b 4729 case 1:
f86702cc 4730 STATUS_ALL_FAILURE;
85e6fe83 4731 /* FALL THROUGH */
6224f72b 4732 case 2:
85e6fe83 4733 /* my_exit() was called */
3280af22 4734 while (PL_scopestack_ix > oldscope)
2ae324a7 4735 LEAVE;
84902520 4736 FREETMPS;
3280af22 4737 PL_curstash = PL_defstash;
3280af22 4738 PL_curcop = &PL_compiling;
57843af0 4739 CopLINE_set(PL_curcop, oldline);
14dd3ad8 4740 JMPENV_POP;
cc3604b1 4741 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 4742 if (paramList == PL_beginav)
cea2e8a9 4743 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 4744 else
4f25aa18 4745 Perl_croak(aTHX_ "%s failed--call queue aborted",
7d30b5c4 4746 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4747 : paramList == PL_initav ? "INIT"
4748 : "END");
85e6fe83 4749 }
f86702cc 4750 my_exit_jump();
85e6fe83 4751 /* NOTREACHED */
6224f72b 4752 case 3:
312caa8e
CS		 4753 if (PL_restartop) {
4754 PL_curcop = &PL_compiling;
57843af0 4755 CopLINE_set(PL_curcop, oldline);
312caa8e 4756 JMPENV_JUMP(3);
85e6fe83 4757 }
bf49b057 4758 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 4759 FREETMPS;
4760 break;
8990e307 4761 }
14dd3ad8 4762 JMPENV_POP;
93a17b20 4763 }
93a17b20 4764}
93a17b20 4765
14dd3ad8
GS		 4766STATIC void *
4767S_call_list_body(pTHX_ CV *cv)
4768{
312caa8e 4769 PUSHMARK(PL_stack_sp);
864dbfa3 4770 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 4771 return NULL;
4772}
4773
f86702cc 4774void
864dbfa3 4775Perl_my_exit(pTHX_ U32 status)
f86702cc 4776{
8b73bbec 4777 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 4778 thr, (unsigned long) status));
f86702cc 4779 switch (status) {
4780 case 0:
4781 STATUS_ALL_SUCCESS;
4782 break;
4783 case 1:
4784 STATUS_ALL_FAILURE;
4785 break;
4786 default:
4787 STATUS_NATIVE_SET(status);
4788 break;
4789 }
4790 my_exit_jump();
4791}
4792
4793void
864dbfa3 4794Perl_my_failure_exit(pTHX)
f86702cc 4795{
4796#ifdef VMS
4797 if (vaxc$errno & 1) {
4fdae800 4798 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4799 STATUS_NATIVE_SET(44);
f86702cc 4800 }
4801 else {
69232efa 4802 if (!vaxc$errno) /* unlikely */
4fdae800 4803 STATUS_NATIVE_SET(44);
f86702cc 4804 else
4fdae800 4805 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 4806 }
4807#else
9b599b2a 4808 int exitstatus;
f86702cc 4809 if (errno & 255)
e5218da5 4810 STATUS_UNIX_SET(errno);
9b599b2a 4811 else {
e5218da5 4812 exitstatus = STATUS_UNIX >> 8;
9b599b2a 4813 if (exitstatus & 255)
e5218da5 4814 STATUS_UNIX_SET(exitstatus);
9b599b2a 4815 else
e5218da5 4816 STATUS_UNIX_SET(255);
9b599b2a 4817 }
f86702cc 4818#endif
4819 my_exit_jump();
93a17b20
LW		 4820}
4821
76e3520e 4822STATIC void
cea2e8a9 4823S_my_exit_jump(pTHX)
f86702cc 4824{
27da23d5 4825 dVAR;
c09156bb 4826 register PERL_CONTEXT *cx;
f86702cc 4827 I32 gimme;
4828 SV **newsp;
4829
3280af22
NIS		 4830 if (PL_e_script) {
4831 SvREFCNT_dec(PL_e_script);
4832 PL_e_script = Nullsv;
f86702cc 4833 }
4834
3280af22 4835 POPSTACK_TO(PL_mainstack);
f86702cc 4836 if (cxstack_ix >= 0) {
4837 if (cxstack_ix > 0)
4838 dounwind(0);
3280af22 4839 POPBLOCK(cx,PL_curpm);
f86702cc 4840 LEAVE;
4841 }
ff0cee69 4842
6224f72b 4843 JMPENV_JUMP(2);
f86702cc 4844}
873ef191 4845
0cb96387 4846static I32
acfe0abc 4847read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
873ef191 4848{
848ef955 4849 const char *p, *nl;
dd374669
AL		 4850 (void)idx;
4851 (void)maxlen;
4852
848ef955 4853 p = SvPVX_const(PL_e_script);
873ef191 4854 nl = strchr(p, '\n');
3280af22 4855 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 4856 if (nl-p == 0) {
0cb96387 4857 filter_del(read_e_script);
873ef191 4858 return 0;
7dfe3f66 4859 }
873ef191 4860 sv_catpvn(buf_sv, p, nl-p);
3280af22 4861 sv_chop(PL_e_script, nl);
873ef191
GS		 4862 return 1;
4863}
66610fdd
RGS		 4864
4865/*
4866 * Local variables:
4867 * c-indentation-style: bsd
4868 * c-basic-offset: 4
4869 * indent-tabs-mode: t
4870 * End:
4871 *
37442d52
RGS		 4872 * ex: set ts=8 sts=4 sw=4 noet:
4873 */
Unnamed repository; edit this file 'description' to name the repository.