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
Don't export Perl_stashpv_hvname_match when !USE_ITHREADS
[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;
925 Safefree(PL_ofmt);
926 PL_ofmt = Nullch;
6e72f9df 927 nuke_stacks();
bf9cdc68
RG		 928 PL_tainting = FALSE;
929 PL_taint_warn = FALSE;
3280af22 930 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
bf9cdc68 931 PL_debug = 0;
ac27b0f5 932
a0d0e21e 933 DEBUG_P(debprofdump());
d33b2eba 934
e5dd39fc 935#ifdef USE_REENTRANT_API
10bc17b6 936 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 937#endif
938
612f20c3
GS		 939 sv_free_arenas();
940
fc36a67e 941 /* As the absolutely last thing, free the non-arena SV for mess() */
942
3280af22 943 if (PL_mess_sv) {
f350b448
NC		 944 /* we know that type == SVt_PVMG */
945
9c63abab 946 /* it could have accumulated taint magic */
f350b448
NC		 947 MAGIC* mg;
948 MAGIC* moremagic;
949 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
950 moremagic = mg->mg_moremagic;
951 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
952 && mg->mg_len >= 0)
953 Safefree(mg->mg_ptr);
954 Safefree(mg);
9c63abab 955 }
f350b448 956
fc36a67e 957 /* we know that type >= SVt_PV */
8bd4d4c5 958 SvPV_free(PL_mess_sv);
3280af22
NIS		 959 Safefree(SvANY(PL_mess_sv));
960 Safefree(PL_mess_sv);
961 PL_mess_sv = Nullsv;
fc36a67e 962 }
31d77e54 963 return STATUS_NATIVE_EXPORT;
79072805
LW		 964}
965
954c1994
GS		 966/*
967=for apidoc perl_free
968
969Releases a Perl interpreter. See L<perlembed>.
970
971=cut
972*/
973
79072805 974void
0cb96387 975perl_free(pTHXx)
79072805 976{
acfe0abc 977#if defined(WIN32) || defined(NETWARE)
ce3e5b80 978# if defined(PERL_IMPLICIT_SYS)
acfe0abc
GS		 979# ifdef NETWARE
980 void *host = nw_internal_host;
981# else
982 void *host = w32_internal_host;
983# endif
ce3e5b80 984 PerlMem_free(aTHXx);
acfe0abc 985# ifdef NETWARE
011f1a1a 986 nw_delete_internal_host(host);
acfe0abc
GS		 987# else
988 win32_delete_internal_host(host);
989# endif
1c0ca838
GS		 990# else
991 PerlMem_free(aTHXx);
992# endif
acfe0abc
GS		 993#else
994 PerlMem_free(aTHXx);
76e3520e 995#endif
79072805
LW		 996}
997
aebd1ac7
GA		 998#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
999/* provide destructors to clean up the thread key when libperl is unloaded */
1000#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1001
110d3f98 1002#if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
aebd1ac7
GA		 1003#pragma fini "perl_fini"
1004#endif
1005
0dbb1585
AL		 1006static void
1007#if defined(__GNUC__)
1008__attribute__((destructor))
aebd1ac7 1009#endif
de009b76 1010perl_fini(void)
aebd1ac7 1011{
27da23d5 1012 dVAR;
aebd1ac7
GA		 1013 if (PL_curinterp)
1014 FREE_THREAD_KEY;
1015}
1016
1017#endif /* WIN32 */
1018#endif /* THREADS */
1019
4b556e6c 1020void
864dbfa3 1021Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 1022{
3280af22
NIS		 1023 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1024 PL_exitlist[PL_exitlistlen].fn = fn;
1025 PL_exitlist[PL_exitlistlen].ptr = ptr;
1026 ++PL_exitlistlen;
4b556e6c
JD		 1027}
1028
56cf6df8
RGS		 1029#ifdef HAS_PROCSELFEXE
1030/* This is a function so that we don't hold on to MAXPATHLEN
1031 bytes of stack longer than necessary
1032 */
1033STATIC void
e1ec3a88 1034S_procself_val(pTHX_ SV *sv, const char *arg0)
56cf6df8
RGS		 1035{
1036 char buf[MAXPATHLEN];
1037 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1038
1039 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1040 includes a spurious NUL which will cause $^X to fail in system
1041 or backticks (this will prevent extensions from being built and
1042 many tests from working). readlink is not meant to add a NUL.
1043 Normal readlink works fine.
1044 */
1045 if (len > 0 && buf[len-1] == '\0') {
1046 len--;
1047 }
1048
1049 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1050 returning the text "unknown" from the readlink rather than the path
1051 to the executable (or returning an error from the readlink). Any valid
1052 path has a '/' in it somewhere, so use that to validate the result.
1053 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1054 */
1055 if (len > 0 && memchr(buf, '/', len)) {
1056 sv_setpvn(sv,buf,len);
1057 }
1058 else {
1059 sv_setpv(sv,arg0);
1060 }
1061}
1062#endif /* HAS_PROCSELFEXE */
b7975bdd
NC		 1063
1064STATIC void
1065S_set_caret_X(pTHX) {
1066 GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
1067 if (tmpgv) {
1068#ifdef HAS_PROCSELFEXE
1069 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1070#else
1071#ifdef OS2
1072 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
1073#else
1074 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
1075#endif
1076#endif
1077 }
1078}
1079
954c1994
GS		 1080/*
1081=for apidoc perl_parse
1082
1083Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1084
1085=cut
1086*/
1087
79072805 1088int
0cb96387 1089perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 1090{
27da23d5 1091 dVAR;
6224f72b 1092 I32 oldscope;
6224f72b 1093 int ret;
db36c5a1 1094 dJMPENV;
8d063cd8 1095
a687059c
LW		 1096#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1097#ifdef IAMSUID
1098#undef IAMSUID
cea2e8a9 1099 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c 1100setuid perl scripts securely.\n");
ae3f3efd 1101#endif /* IAMSUID */
a687059c
LW		 1102#endif
1103
b0891165
JH		 1104#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1105 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
103dd899 1106 * This MUST be done before any hash stores or fetches take place.
008fb0c0
NC		 1107 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1108 * yourself, it is your responsibility to provide a good random seed!
830b38bd 1109 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
008fb0c0
NC		 1110 if (!PL_rehash_seed_set)
1111 PL_rehash_seed = get_hash_seed();
b0891165 1112 {
bed60192
JH		 1113 char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1114
1115 if (s) {
1116 int i = atoi(s);
1117
1118 if (i == 1)
1119 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
008fb0c0 1120 PL_rehash_seed);
bed60192 1121 }
b0891165
JH		 1122 }
1123#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1124
3280af22 1125 PL_origargc = argc;
e2975953 1126 PL_origargv = argv;
a0d0e21e 1127
54bfe034 1128 {
3cb9023d
JH		 1129 /* Set PL_origalen be the sum of the contiguous argv[]
1130 * elements plus the size of the env in case that it is
e9137a8e 1131 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
3cb9023d
JH		 1132 * as the maximum modifiable length of $0. In the worst case
1133 * the area we are able to modify is limited to the size of
43c32782 1134 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d 1135 * --jhi */
e1ec3a88 1136 const char *s = NULL;
54bfe034 1137 int i;
7d8e7db3
JH		 1138 UV mask =
1139 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
43c32782
JH		 1140 /* Do the mask check only if the args seem like aligned. */
1141 UV aligned =
1142 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1143
1144 /* See if all the arguments are contiguous in memory. Note
1145 * that 'contiguous' is a loose term because some platforms
1146 * align the argv[] and the envp[]. If the arguments look
1147 * like non-aligned, assume that they are 'strictly' or
1148 * 'traditionally' contiguous. If the arguments look like
1149 * aligned, we just check that they are within aligned
1150 * PTRSIZE bytes. As long as no system has something bizarre
1151 * like the argv[] interleaved with some other data, we are
1152 * fine. (Did I just evoke Murphy's Law?) --jhi */
c8941eeb
JH		 1153 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1154 while (*s) s++;
1155 for (i = 1; i < PL_origargc; i++) {
1156 if ((PL_origargv[i] == s + 1
43c32782 1157#ifdef OS2
c8941eeb 1158 || PL_origargv[i] == s + 2
43c32782 1159#endif
c8941eeb
JH		 1160 )
1161 ||
1162 (aligned &&
1163 (PL_origargv[i] > s &&
1164 PL_origargv[i] <=
1165 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1166 )
1167 {
1168 s = PL_origargv[i];
1169 while (*s) s++;
1170 }
1171 else
1172 break;
54bfe034 1173 }
54bfe034 1174 }
3cb9023d 1175 /* Can we grab env area too to be used as the area for $0? */
43c32782
JH		 1176 if (PL_origenviron) {
1177 if ((PL_origenviron[0] == s + 1
1178#ifdef OS2
1179 || (PL_origenviron[0] == s + 9 && (s += 8))
1180#endif
1181 )
1182 ||
1183 (aligned &&
1184 (PL_origenviron[0] > s &&
1185 PL_origenviron[0] <=
1186 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1187 )
1188 {
1189#ifndef OS2
1190 s = PL_origenviron[0];
1191 while (*s) s++;
1192#endif
1193 my_setenv("NoNe SuCh", Nullch);
1194 /* Force copy of environment. */
1195 for (i = 1; PL_origenviron[i]; i++) {
1196 if (PL_origenviron[i] == s + 1
1197 ||
1198 (aligned &&
1199 (PL_origenviron[i] > s &&
1200 PL_origenviron[i] <=
1201 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1202 )
1203 {
1204 s = PL_origenviron[i];
1205 while (*s) s++;
1206 }
1207 else
1208 break;
54bfe034 1209 }
43c32782 1210 }
54bfe034 1211 }
284e1220 1212 PL_origalen = s - PL_origargv[0] + 1;
54bfe034
JH		 1213 }
1214
3280af22 1215 if (PL_do_undump) {
a0d0e21e
LW		 1216
1217 /* Come here if running an undumped a.out. */
1218
3280af22
NIS		 1219 PL_origfilename = savepv(argv[0]);
1220 PL_do_undump = FALSE;
a0d0e21e 1221 cxstack_ix = -1; /* start label stack again */
748a9306 1222 init_ids();
b7975bdd
NC		 1223 assert (!PL_tainted);
1224 TAINT;
1225 S_set_caret_X(aTHX);
1226 TAINT_NOT;
a0d0e21e
LW		 1227 init_postdump_symbols(argc,argv,env);
1228 return 0;
1229 }
1230
3280af22 1231 if (PL_main_root) {
3280af22
NIS		 1232 op_free(PL_main_root);
1233 PL_main_root = Nullop;
ff0cee69 1234 }
3280af22
NIS		 1235 PL_main_start = Nullop;
1236 SvREFCNT_dec(PL_main_cv);
1237 PL_main_cv = Nullcv;
79072805 1238
3280af22
NIS		 1239 time(&PL_basetime);
1240 oldscope = PL_scopestack_ix;
599cee73 1241 PL_dowarn = G_WARN_OFF;
f86702cc 1242
14dd3ad8 1243 JMPENV_PUSH(ret);
6224f72b 1244 switch (ret) {
312caa8e 1245 case 0:
14dd3ad8 1246 parse_body(env,xsinit);
7d30b5c4
GS		 1247 if (PL_checkav)
1248 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1249 ret = 0;
1250 break;
6224f72b
GS		 1251 case 1:
1252 STATUS_ALL_FAILURE;
1253 /* FALL THROUGH */
1254 case 2:
1255 /* my_exit() was called */
3280af22 1256 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1257 LEAVE;
1258 FREETMPS;
3280af22 1259 PL_curstash = PL_defstash;
7d30b5c4
GS		 1260 if (PL_checkav)
1261 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1262 ret = STATUS_NATIVE_EXPORT;
1263 break;
6224f72b 1264 case 3:
bf49b057 1265 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1266 ret = 1;
1267 break;
6224f72b 1268 }
14dd3ad8
GS		 1269 JMPENV_POP;
1270 return ret;
1271}
1272
312caa8e 1273STATIC void *
14dd3ad8 1274S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1275{
27da23d5 1276 dVAR;
312caa8e 1277 int argc = PL_origargc;
8f42b153 1278 char **argv = PL_origargv;
e1ec3a88 1279 const char *scriptname = NULL;
312caa8e 1280 VOL bool dosearch = FALSE;
e1ec3a88 1281 const char *validarg = "";
312caa8e
CS		 1282 register SV *sv;
1283 register char *s;
e1ec3a88 1284 const char *cddir = Nullch;
ab019eaa 1285#ifdef USE_SITECUSTOMIZE
20ef40cf 1286 bool minus_f = FALSE;
ab019eaa 1287#endif
312caa8e 1288
ae3f3efd
PS		 1289 PL_fdscript = -1;
1290 PL_suidscript = -1;
3280af22 1291 sv_setpvn(PL_linestr,"",0);
79cb57f6 1292 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 1293 SAVEFREESV(sv);
1294 init_main_stash();
54310121 1295
6224f72b
GS		 1296 for (argc--,argv++; argc > 0; argc--,argv++) {
1297 if (argv[0][0] != '-' || !argv[0][1])
1298 break;
1299#ifdef DOSUID
1300 if (*validarg)
1301 validarg = " PHOOEY ";
1302 else
1303 validarg = argv[0];
ae3f3efd
PS		 1304 /*
1305 * Can we rely on the kernel to start scripts with argv[1] set to
1306 * contain all #! line switches (the whole line)? (argv[0] is set to
1307 * the interpreter name, argv[2] to the script name; argv[3] and
1308 * above may contain other arguments.)
1309 */
13281fa4 1310#endif
6224f72b
GS		 1311 s = argv[0]+1;
1312 reswitch:
1313 switch (*s) {
729a02f2 1314 case 'C':
1d5472a9
GS		 1315#ifndef PERL_STRICT_CR
1316 case '\r':
1317#endif
6224f72b
GS		 1318 case ' ':
1319 case '0':
1320 case 'F':
1321 case 'a':
1322 case 'c':
1323 case 'd':
1324 case 'D':
1325 case 'h':
1326 case 'i':
1327 case 'l':
1328 case 'M':
1329 case 'm':
1330 case 'n':
1331 case 'p':
1332 case 's':
1333 case 'u':
1334 case 'U':
1335 case 'v':
599cee73
PM		 1336 case 'W':
1337 case 'X':
6224f72b 1338 case 'w':
06492da6 1339 case 'A':
155aba94 1340 if ((s = moreswitches(s)))
6224f72b
GS		 1341 goto reswitch;
1342 break;
33b78306 1343
1dbad523 1344 case 't':
22f7c9c9 1345 CHECK_MALLOC_TOO_LATE_FOR('t');
317ea90d
MS		 1346 if( !PL_tainting ) {
1347 PL_taint_warn = TRUE;
1348 PL_tainting = TRUE;
1349 }
1350 s++;
1351 goto reswitch;
6224f72b 1352 case 'T':
22f7c9c9 1353 CHECK_MALLOC_TOO_LATE_FOR('T');
3280af22 1354 PL_tainting = TRUE;
317ea90d 1355 PL_taint_warn = FALSE;
6224f72b
GS		 1356 s++;
1357 goto reswitch;
f86702cc 1358
6224f72b 1359 case 'e':
bf4acbe4
GS		 1360#ifdef MACOS_TRADITIONAL
1361 /* ignore -e for Dev:Pseudo argument */
1362 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1363 break;
bf4acbe4 1364#endif
ae3f3efd 1365 forbid_setid("-e");
3280af22 1366 if (!PL_e_script) {
79cb57f6 1367 PL_e_script = newSVpvn("",0);
0cb96387 1368 filter_add(read_e_script, NULL);
6224f72b
GS		 1369 }
1370 if (*++s)
3280af22 1371 sv_catpv(PL_e_script, s);
6224f72b 1372 else if (argv[1]) {
3280af22 1373 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1374 argc--,argv++;
1375 }
1376 else
cea2e8a9 1377 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1378 sv_catpv(PL_e_script, "\n");
6224f72b 1379 break;
afe37c7d 1380
ab019eaa 1381#ifdef USE_SITECUSTOMIZE
20ef40cf
GA		 1382 case 'f':
1383 minus_f = TRUE;
1384 s++;
1385 goto reswitch;
1386
ab019eaa 1387#endif
6224f72b
GS		 1388 case 'I': /* -I handled both here and in moreswitches() */
1389 forbid_setid("-I");
1390 if (!*++s && (s=argv[1]) != Nullch) {
1391 argc--,argv++;
1392 }
6224f72b 1393 if (s && *s) {
0df16ed7
GS		 1394 char *p;
1395 STRLEN len = strlen(s);
1396 p = savepvn(s, len);
88fe16b2 1397 incpush(p, TRUE, TRUE, FALSE, FALSE);
0df16ed7
GS		 1398 sv_catpvn(sv, "-I", 2);
1399 sv_catpvn(sv, p, len);
1400 sv_catpvn(sv, " ", 1);
6224f72b 1401 Safefree(p);
0df16ed7
GS		 1402 }
1403 else
a67e862a 1404 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1405 break;
1406 case 'P':
1407 forbid_setid("-P");
3280af22 1408 PL_preprocess = TRUE;
6224f72b
GS		 1409 s++;
1410 goto reswitch;
1411 case 'S':
1412 forbid_setid("-S");
1413 dosearch = TRUE;
1414 s++;
1415 goto reswitch;
1416 case 'V':
3280af22
NIS		 1417 if (!PL_preambleav)
1418 PL_preambleav = newAV();
1419 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1420 if (*++s != ':') {
efcaa95b
YST		 1421 STRLEN opts;
1422
3280af22 1423 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1424#ifdef VMS
6b88bc9c 1425 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1426#else
3280af22 1427 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1428#endif
efcaa95b
YST		 1429 opts = SvCUR(PL_Sv);
1430
3280af22 1431 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1432# ifdef DEBUGGING
3280af22 1433 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1434# endif
6224f72b 1435# ifdef MULTIPLICITY
8f872242 1436 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1437# endif
4d1ff10f
AB		 1438# ifdef USE_5005THREADS
1439 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1440# endif
ac5e8965
JH		 1441# ifdef USE_ITHREADS
1442 sv_catpv(PL_Sv," USE_ITHREADS");
1443# endif
10cc9d2a
JH		 1444# ifdef USE_64_BIT_INT
1445 sv_catpv(PL_Sv," USE_64_BIT_INT");
1446# endif
1447# ifdef USE_64_BIT_ALL
1448 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1449# endif
1450# ifdef USE_LONG_DOUBLE
1451 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1452# endif
53430762
JH		 1453# ifdef USE_LARGE_FILES
1454 sv_catpv(PL_Sv," USE_LARGE_FILES");
1455# endif
ac5e8965
JH		 1456# ifdef USE_SOCKS
1457 sv_catpv(PL_Sv," USE_SOCKS");
1458# endif
20ef40cf
GA		 1459# ifdef USE_SITECUSTOMIZE
1460 sv_catpv(PL_Sv," USE_SITECUSTOMIZE");
1461# endif
b363f7ed
GS		 1462# ifdef PERL_IMPLICIT_CONTEXT
1463 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1464# endif
1465# ifdef PERL_IMPLICIT_SYS
1466 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1467# endif
efcaa95b
YST		 1468
1469 while (SvCUR(PL_Sv) > opts+76) {
1470 /* find last space after "options: " and before col 76 */
1471
dd374669
AL		 1472 const char *space;
1473 char *pv = SvPV_nolen(PL_Sv);
1474 const char c = pv[opts+76];
efcaa95b
YST		 1475 pv[opts+76] = '\0';
1476 space = strrchr(pv+opts+26, ' ');
1477 pv[opts+76] = c;
1478 if (!space) break; /* "Can't happen" */
1479
1480 /* break the line before that space */
1481
1482 opts = space - pv;
1483 sv_insert(PL_Sv, opts, 0,
1484 "\\n ", 25);
1485 }
1486
3280af22 1487 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1488
6224f72b
GS		 1489#if defined(LOCAL_PATCH_COUNT)
1490 if (LOCAL_PATCH_COUNT > 0) {
1491 int i;
3280af22 1492 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1493 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1494 if (PL_localpatches[i])
acb03d05
AB		 1495 Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
1496 0, PL_localpatches[i], 0);
6224f72b
GS		 1497 }
1498 }
1499#endif
cea2e8a9 1500 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1501#ifdef __DATE__
1502# ifdef __TIME__
cea2e8a9 1503 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1504# else
cea2e8a9 1505 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1506# endif
1507#endif
3280af22 1508 sv_catpv(PL_Sv, "; \
6224f72b 1509$\"=\"\\n \"; \
69fcd688
JH		 1510@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1511#ifdef __CYGWIN__
1512 sv_catpv(PL_Sv,"\
1513push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1514#endif
1515 sv_catpv(PL_Sv, "\
6224f72b
GS		 1516print \" \\%ENV:\\n @env\\n\" if @env; \
1517print \" \\@INC:\\n @INC\\n\";");
1518 }
1519 else {
3280af22
NIS		 1520 PL_Sv = newSVpv("config_vars(qw(",0);
1521 sv_catpv(PL_Sv, ++s);
1522 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1523 s += strlen(s);
1524 }
3280af22 1525 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1526 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1527 goto reswitch;
1528 case 'x':
3280af22 1529 PL_doextract = TRUE;
6224f72b
GS		 1530 s++;
1531 if (*s)
f4c556ac 1532 cddir = s;
6224f72b
GS		 1533 break;
1534 case 0:
1535 break;
1536 case '-':
1537 if (!*++s || isSPACE(*s)) {
1538 argc--,argv++;
1539 goto switch_end;
1540 }
1541 /* catch use of gnu style long options */
1542 if (strEQ(s, "version")) {
dd374669 1543 s = (char *)"v";
6224f72b
GS		 1544 goto reswitch;
1545 }
1546 if (strEQ(s, "help")) {
dd374669 1547 s = (char *)"h";
6224f72b
GS		 1548 goto reswitch;
1549 }
1550 s--;
1551 /* FALL THROUGH */
1552 default:
cea2e8a9 1553 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1554 }
1555 }
6224f72b 1556 switch_end:
54310121 1557
f675dbe5
CB		 1558 if (
1559#ifndef SECURE_INTERNAL_GETENV
1560 !PL_tainting &&
1561#endif
cf756827 1562 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1563 {
e1ec3a88 1564 const char *popt = s;
74288ac8
GS		 1565 while (isSPACE(*s))
1566 s++;
317ea90d 1567 if (*s == '-' && *(s+1) == 'T') {
22f7c9c9 1568 CHECK_MALLOC_TOO_LATE_FOR('T');
74288ac8 1569 PL_tainting = TRUE;
317ea90d
MS		 1570 PL_taint_warn = FALSE;
1571 }
74288ac8 1572 else {
cf756827 1573 char *popt_copy = Nullch;
74288ac8 1574 while (s && *s) {
4ea8f8fb 1575 char *d;
74288ac8
GS		 1576 while (isSPACE(*s))
1577 s++;
1578 if (*s == '-') {
1579 s++;
1580 if (isSPACE(*s))
1581 continue;
1582 }
4ea8f8fb 1583 d = s;
74288ac8
GS		 1584 if (!*s)
1585 break;
06492da6 1586 if (!strchr("DIMUdmtwA", *s))
cea2e8a9 1587 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1588 while (++s && *s) {
1589 if (isSPACE(*s)) {
cf756827
GS		 1590 if (!popt_copy) {
1591 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1592 s = popt_copy + (s - popt);
1593 d = popt_copy + (d - popt);
1594 }
4ea8f8fb
MS		 1595 *s++ = '\0';
1596 break;
1597 }
1598 }
1c4db469 1599 if (*d == 't') {
317ea90d
MS		 1600 if( !PL_tainting ) {
1601 PL_taint_warn = TRUE;
1602 PL_tainting = TRUE;
1603 }
1c4db469
RGS		 1604 } else {
1605 moreswitches(d);
1606 }
6224f72b 1607 }
6224f72b
GS		 1608 }
1609 }
a0d0e21e 1610
20ef40cf
GA		 1611#ifdef USE_SITECUSTOMIZE
1612 if (!minus_f) {
1613 if (!PL_preambleav)
1614 PL_preambleav = newAV();
1615 av_unshift(PL_preambleav, 1);
1616 (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
1617 }
1618#endif
1619
317ea90d
MS		 1620 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1621 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1622 }
1623
6224f72b
GS		 1624 if (!scriptname)
1625 scriptname = argv[0];
3280af22 1626 if (PL_e_script) {
6224f72b
GS		 1627 argc++,argv--;
1628 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1629 }
1630 else if (scriptname == Nullch) {
1631#ifdef MSDOS
1632 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1633 moreswitches("h");
1634#endif
1635 scriptname = "-";
1636 }
1637
b7975bdd
NC		 1638 /* Set $^X early so that it can be used for relocatable paths in @INC */
1639 assert (!PL_tainted);
1640 TAINT;
1641 S_set_caret_X(aTHX);
1642 TAINT_NOT;
6224f72b
GS		 1643 init_perllib();
1644
c5cccb17 1645 open_script(scriptname,dosearch,sv);
6224f72b 1646
c5cccb17 1647 validate_suid(validarg, scriptname);
6224f72b 1648
64ca3a65 1649#ifndef PERL_MICRO
0b5b802d
GS		 1650#if defined(SIGCHLD) || defined(SIGCLD)
1651 {
1652#ifndef SIGCHLD
1653# define SIGCHLD SIGCLD
1654#endif
1655 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1656 if (sigstate == SIG_IGN) {
1657 if (ckWARN(WARN_SIGNAL))
9014280d 1658 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1659 "Can't ignore signal CHLD, forcing to default");
1660 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1661 }
1662 }
1663#endif
64ca3a65 1664#endif
0b5b802d 1665
bf4acbe4
GS		 1666#ifdef MACOS_TRADITIONAL
1667 if (PL_doextract || gMacPerl_AlwaysExtract) {
1668#else
f4c556ac 1669 if (PL_doextract) {
bf4acbe4 1670#endif
6224f72b 1671 find_beginning();
dd374669 1672 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
f4c556ac
GS		 1673 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1674
1675 }
6224f72b 1676
3280af22
NIS		 1677 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1678 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1679 CvUNIQUE_on(PL_compcv);
1680
dd2155a4 1681 CvPADLIST(PL_compcv) = pad_new(0);
4d1ff10f 1682#ifdef USE_5005THREADS
533c011a
NIS		 1683 CvOWNER(PL_compcv) = 0;
1684 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1685 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1686#endif /* USE_5005THREADS */
6224f72b 1687
0c4f7ff0 1688 boot_core_PerlIO();
6224f72b 1689 boot_core_UNIVERSAL();
09bef843 1690 boot_core_xsutils();
6224f72b
GS		 1691
1692 if (xsinit)
acfe0abc 1693 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1694#ifndef PERL_MICRO
ed79a026 1695#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1696 init_os_extras();
6224f72b 1697#endif
64ca3a65 1698#endif
6224f72b 1699
29209bc5 1700#ifdef USE_SOCKS
1b9c9cf5
DH		 1701# ifdef HAS_SOCKS5_INIT
1702 socks5_init(argv[0]);
1703# else
29209bc5 1704 SOCKSinit(argv[0]);
1b9c9cf5 1705# endif
ac27b0f5 1706#endif
29209bc5 1707
6224f72b
GS		 1708 init_predump_symbols();
1709 /* init_postdump_symbols not currently designed to be called */
1710 /* more than once (ENV isn't cleared first, for example) */
1711 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1712 if (!PL_do_undump)
6224f72b
GS		 1713 init_postdump_symbols(argc,argv,env);
1714
27da23d5
JH		 1715 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
1716 * or explicitly in some platforms.
085a54d9 1717 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 1718 * look like the user wants to use UTF-8. */
27da23d5
JH		 1719#if defined(SYMBIAN)
1720 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
1721#endif
06e66572
JH		 1722 if (PL_unicode) {
1723 /* Requires init_predump_symbols(). */
a05d7ebb 1724 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH		 1725 IO* io;
1726 PerlIO* fp;
1727 SV* sv;
1728
a05d7ebb 1729 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 1730 * and the default open disciplines. */
a05d7ebb
JH		 1731 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1732 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1733 (fp = IoIFP(io)))
1734 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1735 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1736 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1737 (fp = IoOFP(io)))
1738 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1739 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1740 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1741 (fp = IoOFP(io)))
1742 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1743 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1744 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1745 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1746 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1747 if (in) {
1748 if (out)
1749 sv_setpvn(sv, ":utf8\0:utf8", 11);
1750 else
1751 sv_setpvn(sv, ":utf8\0", 6);
1752 }
1753 else if (out)
1754 sv_setpvn(sv, "\0:utf8", 6);
1755 SvSETMAGIC(sv);
1756 }
b310b053
JH		 1757 }
1758 }
1759
4ffa73a3
JH		 1760 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1761 if (strEQ(s, "unsafe"))
1762 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1763 else if (strEQ(s, "safe"))
1764 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1765 else
1766 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1767 }
1768
6224f72b
GS		 1769 init_lexer();
1770
1771 /* now parse the script */
1772
93189314 1773 SETERRNO(0,SS_NORMAL);
3280af22 1774 PL_error_count = 0;
bf4acbe4
GS		 1775#ifdef MACOS_TRADITIONAL
1776 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1777 if (PL_minus_c)
1778 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1779 else {
1780 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1781 MacPerl_MPWFileName(PL_origfilename));
1782 }
1783 }
1784#else
3280af22
NIS		 1785 if (yyparse() || PL_error_count) {
1786 if (PL_minus_c)
cea2e8a9 1787 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1788 else {
cea2e8a9 1789 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1790 PL_origfilename);
6224f72b
GS		 1791 }
1792 }
bf4acbe4 1793#endif
57843af0 1794 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1795 PL_curstash = PL_defstash;
1796 PL_preprocess = FALSE;
1797 if (PL_e_script) {
1798 SvREFCNT_dec(PL_e_script);
1799 PL_e_script = Nullsv;
6224f72b
GS		 1800 }
1801
3280af22 1802 if (PL_do_undump)
6224f72b
GS		 1803 my_unexec();
1804
57843af0
GS		 1805 if (isWARN_ONCE) {
1806 SAVECOPFILE(PL_curcop);
1807 SAVECOPLINE(PL_curcop);
3280af22 1808 gv_check(PL_defstash);
57843af0 1809 }
6224f72b
GS		 1810
1811 LEAVE;
1812 FREETMPS;
1813
1814#ifdef MYMALLOC
1815 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1816 dump_mstats("after compilation:");
1817#endif
1818
1819 ENTER;
3280af22 1820 PL_restartop = 0;
312caa8e 1821 return NULL;
6224f72b
GS		 1822}
1823
954c1994
GS		 1824/*
1825=for apidoc perl_run
1826
1827Tells a Perl interpreter to run. See L<perlembed>.
1828
1829=cut
1830*/
1831
6224f72b 1832int
0cb96387 1833perl_run(pTHXx)
6224f72b 1834{
6224f72b 1835 I32 oldscope;
14dd3ad8 1836 int ret = 0;
db36c5a1 1837 dJMPENV;
6224f72b 1838
3280af22 1839 oldscope = PL_scopestack_ix;
96e176bf
CL		 1840#ifdef VMS
1841 VMSISH_HUSHED = 0;
1842#endif
6224f72b 1843
14dd3ad8 1844 JMPENV_PUSH(ret);
6224f72b
GS		 1845 switch (ret) {
1846 case 1:
1847 cxstack_ix = -1; /* start context stack again */
312caa8e 1848 goto redo_body;
14dd3ad8 1849 case 0: /* normal completion */
14dd3ad8
GS		 1850 redo_body:
1851 run_body(oldscope);
14dd3ad8
GS		 1852 /* FALL THROUGH */
1853 case 2: /* my_exit() */
3280af22 1854 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1855 LEAVE;
1856 FREETMPS;
3280af22 1857 PL_curstash = PL_defstash;
3a1ee7e8 1858 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1859 PL_endav && !PL_minus_c)
1860 call_list(oldscope, PL_endav);
6224f72b
GS		 1861#ifdef MYMALLOC
1862 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1863 dump_mstats("after execution: ");
1864#endif
14dd3ad8
GS		 1865 ret = STATUS_NATIVE_EXPORT;
1866 break;
6224f72b 1867 case 3:
312caa8e
CS		 1868 if (PL_restartop) {
1869 POPSTACK_TO(PL_mainstack);
1870 goto redo_body;
6224f72b 1871 }
bf49b057 1872 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1873 FREETMPS;
14dd3ad8
GS		 1874 ret = 1;
1875 break;
6224f72b
GS		 1876 }
1877
14dd3ad8
GS		 1878 JMPENV_POP;
1879 return ret;
312caa8e
CS		 1880}
1881
14dd3ad8 1882
dd374669 1883STATIC void
14dd3ad8
GS		 1884S_run_body(pTHX_ I32 oldscope)
1885{
6224f72b 1886 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1887 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1888
3280af22 1889 if (!PL_restartop) {
6224f72b 1890 DEBUG_x(dump_all());
ecae49c0
NC		 1891 if (!DEBUG_q_TEST)
1892 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1893 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1894 PTR2UV(thr)));
6224f72b 1895
3280af22 1896 if (PL_minus_c) {
bf4acbe4 1897#ifdef MACOS_TRADITIONAL
e69a2255
JH		 1898 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1899 (gMacPerl_ErrorFormat ? "# " : ""),
1900 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1901#else
bf49b057 1902 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1903#endif
6224f72b
GS		 1904 my_exit(0);
1905 }
3280af22 1906 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1907 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1908 if (PL_initav)
1909 call_list(oldscope, PL_initav);
6224f72b
GS		 1910 }
1911
1912 /* do it */
1913
3280af22 1914 if (PL_restartop) {
533c011a 1915 PL_op = PL_restartop;
3280af22 1916 PL_restartop = 0;
cea2e8a9 1917 CALLRUNOPS(aTHX);
6224f72b 1918 }
3280af22
NIS		 1919 else if (PL_main_start) {
1920 CvDEPTH(PL_main_cv) = 1;
533c011a 1921 PL_op = PL_main_start;
cea2e8a9 1922 CALLRUNOPS(aTHX);
6224f72b 1923 }
f6b3007c
JH		 1924 my_exit(0);
1925 /* NOTREACHED */
6224f72b
GS		 1926}
1927
954c1994 1928/*
ccfc67b7
JH		 1929=head1 SV Manipulation Functions
1930
954c1994
GS		 1931=for apidoc p||get_sv
1932
1933Returns the SV of the specified Perl scalar. If C<create> is set and the
1934Perl variable does not exist then it will be created. If C<create> is not
1935set and the variable does not exist then NULL is returned.
1936
1937=cut
1938*/
1939
6224f72b 1940SV*
864dbfa3 1941Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1942{
1943 GV *gv;
4d1ff10f 1944#ifdef USE_5005THREADS
6224f72b
GS		 1945 if (name[1] == '\0' && !isALPHA(name[0])) {
1946 PADOFFSET tmp = find_threadsv(name);
411caa50 1947 if (tmp != NOT_IN_PAD)
6224f72b 1948 return THREADSV(tmp);
6224f72b 1949 }
4d1ff10f 1950#endif /* USE_5005THREADS */
6224f72b
GS		 1951 gv = gv_fetchpv(name, create, SVt_PV);
1952 if (gv)
1953 return GvSV(gv);
1954 return Nullsv;
1955}
1956
954c1994 1957/*
ccfc67b7
JH		 1958=head1 Array Manipulation Functions
1959
954c1994
GS		 1960=for apidoc p||get_av
1961
1962Returns the AV of the specified Perl array. If C<create> is set and the
1963Perl variable does not exist then it will be created. If C<create> is not
1964set and the variable does not exist then NULL is returned.
1965
1966=cut
1967*/
1968
6224f72b 1969AV*
864dbfa3 1970Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1971{
1972 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1973 if (create)
1974 return GvAVn(gv);
1975 if (gv)
1976 return GvAV(gv);
1977 return Nullav;
1978}
1979
954c1994 1980/*
ccfc67b7
JH		 1981=head1 Hash Manipulation Functions
1982
954c1994
GS		 1983=for apidoc p||get_hv
1984
1985Returns the HV of the specified Perl hash. If C<create> is set and the
1986Perl variable does not exist then it will be created. If C<create> is not
1987set and the variable does not exist then NULL is returned.
1988
1989=cut
1990*/
1991
6224f72b 1992HV*
864dbfa3 1993Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1994{
a0d0e21e
LW		 1995 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1996 if (create)
1997 return GvHVn(gv);
1998 if (gv)
1999 return GvHV(gv);
2000 return Nullhv;
2001}
2002
954c1994 2003/*
ccfc67b7
JH		 2004=head1 CV Manipulation Functions
2005
954c1994
GS		 2006=for apidoc p||get_cv
2007
2008Returns the CV of the specified Perl subroutine. If C<create> is set and
2009the Perl subroutine does not exist then it will be declared (which has the
2010same effect as saying C<sub name;>). If C<create> is not set and the
2011subroutine does not exist then NULL is returned.
2012
2013=cut
2014*/
2015
a0d0e21e 2016CV*
864dbfa3 2017Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 2018{
2019 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 2020 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 2021 /* XXX this is probably not what they think they're getting.
2022 * It has the same effect as "sub name;", i.e. just a forward
2023 * declaration! */
8ebc5c01 2024 if (create && !GvCVu(gv))
774d564b 2025 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 2026 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 2027 Nullop,
a0d0e21e
LW		 2028 Nullop);
2029 if (gv)
8ebc5c01 2030 return GvCVu(gv);
a0d0e21e
LW		 2031 return Nullcv;
2032}
2033
79072805
LW		 2034/* Be sure to refetch the stack pointer after calling these routines. */
2035
954c1994 2036/*
ccfc67b7
JH		 2037
2038=head1 Callback Functions
2039
954c1994
GS		 2040=for apidoc p||call_argv
2041
2042Performs a callback to the specified Perl sub. See L<perlcall>.
2043
2044=cut
2045*/
2046
a0d0e21e 2047I32
8f42b153 2048Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 2049
8ac85365
NIS		 2050 /* See G_* flags in cop.h */
2051 /* null terminated arg list */
8990e307 2052{
a0d0e21e 2053 dSP;
8990e307 2054
924508f0 2055 PUSHMARK(SP);
a0d0e21e 2056 if (argv) {
8990e307 2057 while (*argv) {
a0d0e21e 2058 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 2059 argv++;
2060 }
a0d0e21e 2061 PUTBACK;
8990e307 2062 }
864dbfa3 2063 return call_pv(sub_name, flags);
8990e307
LW		 2064}
2065
954c1994
GS		 2066/*
2067=for apidoc p||call_pv
2068
2069Performs a callback to the specified Perl sub. See L<perlcall>.
2070
2071=cut
2072*/
2073
a0d0e21e 2074I32
864dbfa3 2075Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 2076 /* name of the subroutine */
2077 /* See G_* flags in cop.h */
a0d0e21e 2078{
864dbfa3 2079 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 2080}
2081
954c1994
GS		 2082/*
2083=for apidoc p||call_method
2084
2085Performs a callback to the specified Perl method. The blessed object must
2086be on the stack. See L<perlcall>.
2087
2088=cut
2089*/
2090
a0d0e21e 2091I32
864dbfa3 2092Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 2093 /* name of the subroutine */
2094 /* See G_* flags in cop.h */
a0d0e21e 2095{
968b3946 2096 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 2097}
2098
2099/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 2100/*
2101=for apidoc p||call_sv
2102
2103Performs a callback to the Perl sub whose name is in the SV. See
2104L<perlcall>.
2105
2106=cut
2107*/
2108
a0d0e21e 2109I32
864dbfa3 2110Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 2111 /* See G_* flags in cop.h */
a0d0e21e 2112{
27da23d5 2113 dVAR; dSP;
a0d0e21e 2114 LOGOP myop; /* fake syntax tree node */
968b3946 2115 UNOP method_op;
aa689395 2116 I32 oldmark;
13689cfe 2117 volatile I32 retval = 0;
a0d0e21e 2118 I32 oldscope;
54310121 2119 bool oldcatch = CATCH_GET;
6224f72b 2120 int ret;
533c011a 2121 OP* oldop = PL_op;
db36c5a1 2122 dJMPENV;
1e422769 2123
a0d0e21e
LW		 2124 if (flags & G_DISCARD) {
2125 ENTER;
2126 SAVETMPS;
2127 }
2128
aa689395 2129 Zero(&myop, 1, LOGOP);
54310121 2130 myop.op_next = Nullop;
f51d4af5 2131 if (!(flags & G_NOARGS))
aa689395 2132 myop.op_flags |= OPf_STACKED;
54310121 2133 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2134 (flags & G_ARRAY) ? OPf_WANT_LIST :
2135 OPf_WANT_SCALAR);
462e5cf6 2136 SAVEOP();
533c011a 2137 PL_op = (OP*)&myop;
aa689395 2138
3280af22
NIS		 2139 EXTEND(PL_stack_sp, 1);
2140 *++PL_stack_sp = sv;
aa689395 2141 oldmark = TOPMARK;
3280af22 2142 oldscope = PL_scopestack_ix;
a0d0e21e 2143
3280af22 2144 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 2145 /* Handle first BEGIN of -d. */
3280af22 2146 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 2147 /* Try harder, since this may have been a sighandler, thus
2148 * curstash may be meaningless. */
3280af22 2149 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 2150 && !(flags & G_NODEBUG))
533c011a 2151 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2152
968b3946
GS		 2153 if (flags & G_METHOD) {
2154 Zero(&method_op, 1, UNOP);
2155 method_op.op_next = PL_op;
2156 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2157 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 2158 PL_op = (OP*)&method_op;
968b3946
GS		 2159 }
2160
312caa8e 2161 if (!(flags & G_EVAL)) {
0cdb2077 2162 CATCH_SET(TRUE);
14dd3ad8 2163 call_body((OP*)&myop, FALSE);
312caa8e 2164 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 2165 CATCH_SET(oldcatch);
312caa8e
CS		 2166 }
2167 else {
d78bda3d 2168 myop.op_other = (OP*)&myop;
3280af22 2169 PL_markstack_ptr--;
4633a7c4
LW		 2170 /* we're trying to emulate pp_entertry() here */
2171 {
c09156bb 2172 register PERL_CONTEXT *cx;
f54cb97a 2173 const I32 gimme = GIMME_V;
ac27b0f5 2174
4633a7c4
LW		 2175 ENTER;
2176 SAVETMPS;
ac27b0f5 2177
1d76a5c3 2178 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 2179 PUSHEVAL(cx, 0, 0);
533c011a 2180 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 2181
faef0170 2182 PL_in_eval = EVAL_INEVAL;
4633a7c4 2183 if (flags & G_KEEPERR)
faef0170 2184 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 2185 else
c69006e4 2186 sv_setpvn(ERRSV,"",0);
4633a7c4 2187 }
3280af22 2188 PL_markstack_ptr++;
a0d0e21e 2189
14dd3ad8 2190 JMPENV_PUSH(ret);
6224f72b
GS		 2191 switch (ret) {
2192 case 0:
14dd3ad8
GS		 2193 redo_body:
2194 call_body((OP*)&myop, FALSE);
312caa8e
CS		 2195 retval = PL_stack_sp - (PL_stack_base + oldmark);
2196 if (!(flags & G_KEEPERR))
c69006e4 2197 sv_setpvn(ERRSV,"",0);
a0d0e21e 2198 break;
6224f72b 2199 case 1:
f86702cc 2200 STATUS_ALL_FAILURE;
a0d0e21e 2201 /* FALL THROUGH */
6224f72b 2202 case 2:
a0d0e21e 2203 /* my_exit() was called */
3280af22 2204 PL_curstash = PL_defstash;
a0d0e21e 2205 FREETMPS;
14dd3ad8 2206 JMPENV_POP;
cc3604b1 2207 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2208 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2209 my_exit_jump();
a0d0e21e 2210 /* NOTREACHED */
6224f72b 2211 case 3:
3280af22 2212 if (PL_restartop) {
533c011a 2213 PL_op = PL_restartop;
3280af22 2214 PL_restartop = 0;
312caa8e 2215 goto redo_body;
a0d0e21e 2216 }
3280af22 2217 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2218 if (flags & G_ARRAY)
2219 retval = 0;
2220 else {
2221 retval = 1;
3280af22 2222 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2223 }
312caa8e 2224 break;
a0d0e21e 2225 }
a0d0e21e 2226
3280af22 2227 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 2228 SV **newsp;
2229 PMOP *newpm;
2230 I32 gimme;
c09156bb 2231 register PERL_CONTEXT *cx;
a0a2876f
LW		 2232 I32 optype;
2233
2234 POPBLOCK(cx,newpm);
2235 POPEVAL(cx);
3280af22 2236 PL_curpm = newpm;
a0a2876f 2237 LEAVE;
a0d0e21e 2238 }
14dd3ad8 2239 JMPENV_POP;
a0d0e21e 2240 }
1e422769 2241
a0d0e21e 2242 if (flags & G_DISCARD) {
3280af22 2243 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2244 retval = 0;
2245 FREETMPS;
2246 LEAVE;
2247 }
533c011a 2248 PL_op = oldop;
a0d0e21e
LW		 2249 return retval;
2250}
2251
312caa8e 2252STATIC void
dd374669 2253S_call_body(pTHX_ const OP *myop, bool is_eval)
312caa8e 2254{
312caa8e
CS		 2255 if (PL_op == myop) {
2256 if (is_eval)
f807eda9 2257 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 2258 else
f807eda9 2259 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 2260 }
2261 if (PL_op)
cea2e8a9 2262 CALLRUNOPS(aTHX);
312caa8e
CS		 2263}
2264
6e72f9df 2265/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2266
954c1994
GS		 2267/*
2268=for apidoc p||eval_sv
2269
2270Tells Perl to C<eval> the string in the SV.
2271
2272=cut
2273*/
2274
a0d0e21e 2275I32
864dbfa3 2276Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2277
8ac85365 2278 /* See G_* flags in cop.h */
a0d0e21e 2279{
924508f0 2280 dSP;
a0d0e21e 2281 UNOP myop; /* fake syntax tree node */
8fa7f367 2282 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2283 volatile I32 retval = 0;
6224f72b 2284 int ret;
533c011a 2285 OP* oldop = PL_op;
db36c5a1 2286 dJMPENV;
84902520 2287
4633a7c4
LW		 2288 if (flags & G_DISCARD) {
2289 ENTER;
2290 SAVETMPS;
2291 }
2292
462e5cf6 2293 SAVEOP();
533c011a
NIS		 2294 PL_op = (OP*)&myop;
2295 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2296 EXTEND(PL_stack_sp, 1);
2297 *++PL_stack_sp = sv;
79072805 2298
4633a7c4
LW		 2299 if (!(flags & G_NOARGS))
2300 myop.op_flags = OPf_STACKED;
79072805 2301 myop.op_next = Nullop;
6e72f9df 2302 myop.op_type = OP_ENTEREVAL;
54310121 2303 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2304 (flags & G_ARRAY) ? OPf_WANT_LIST :
2305 OPf_WANT_SCALAR);
6e72f9df 2306 if (flags & G_KEEPERR)
2307 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2308
dedbcade
DM		 2309 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2310 * before a PUSHEVAL, which corrupts the stack after a croak */
2311 TAINT_PROPER("eval_sv()");
2312
14dd3ad8 2313 JMPENV_PUSH(ret);
6224f72b
GS		 2314 switch (ret) {
2315 case 0:
14dd3ad8
GS		 2316 redo_body:
2317 call_body((OP*)&myop,TRUE);
312caa8e
CS		 2318 retval = PL_stack_sp - (PL_stack_base + oldmark);
2319 if (!(flags & G_KEEPERR))
c69006e4 2320 sv_setpvn(ERRSV,"",0);
4633a7c4 2321 break;
6224f72b 2322 case 1:
f86702cc 2323 STATUS_ALL_FAILURE;
4633a7c4 2324 /* FALL THROUGH */
6224f72b 2325 case 2:
4633a7c4 2326 /* my_exit() was called */
3280af22 2327 PL_curstash = PL_defstash;
4633a7c4 2328 FREETMPS;
14dd3ad8 2329 JMPENV_POP;
cc3604b1 2330 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2331 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2332 my_exit_jump();
4633a7c4 2333 /* NOTREACHED */
6224f72b 2334 case 3:
3280af22 2335 if (PL_restartop) {
533c011a 2336 PL_op = PL_restartop;
3280af22 2337 PL_restartop = 0;
312caa8e 2338 goto redo_body;
4633a7c4 2339 }
3280af22 2340 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2341 if (flags & G_ARRAY)
2342 retval = 0;
2343 else {
2344 retval = 1;
3280af22 2345 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2346 }
312caa8e 2347 break;
4633a7c4
LW		 2348 }
2349
14dd3ad8 2350 JMPENV_POP;
4633a7c4 2351 if (flags & G_DISCARD) {
3280af22 2352 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2353 retval = 0;
2354 FREETMPS;
2355 LEAVE;
2356 }
533c011a 2357 PL_op = oldop;
4633a7c4
LW		 2358 return retval;
2359}
2360
954c1994
GS		 2361/*
2362=for apidoc p||eval_pv
2363
2364Tells Perl to C<eval> the given string and return an SV* result.
2365
2366=cut
2367*/
2368
137443ea 2369SV*
864dbfa3 2370Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2371{
2372 dSP;
2373 SV* sv = newSVpv(p, 0);
2374
864dbfa3 2375 eval_sv(sv, G_SCALAR);
137443ea 2376 SvREFCNT_dec(sv);
2377
2378 SPAGAIN;
2379 sv = POPs;
2380 PUTBACK;
2381
2d8e6c8d 2382 if (croak_on_error && SvTRUE(ERRSV)) {
0510663f 2383 Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2d8e6c8d 2384 }
137443ea 2385
2386 return sv;
2387}
2388
4633a7c4
LW		 2389/* Require a module. */
2390
954c1994 2391/*
ccfc67b7
JH		 2392=head1 Embedding Functions
2393
954c1994
GS		 2394=for apidoc p||require_pv
2395
7d3fb230
BS		 2396Tells Perl to C<require> the file named by the string argument. It is
2397analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2398implemented that way; consider using load_module instead.
954c1994 2399
7d3fb230 2400=cut */
954c1994 2401
4633a7c4 2402void
864dbfa3 2403Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2404{
d3acc0f7
JP		 2405 SV* sv;
2406 dSP;
e788e7d3 2407 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2408 PUTBACK;
2409 sv = sv_newmortal();
4633a7c4
LW		 2410 sv_setpv(sv, "require '");
2411 sv_catpv(sv, pv);
2412 sv_catpv(sv, "'");
864dbfa3 2413 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2414 SPAGAIN;
2415 POPSTACK;
79072805
LW		 2416}
2417
79072805 2418void
e1ec3a88 2419Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
79072805
LW		 2420{
2421 register GV *gv;
2422
155aba94 2423 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2424 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2425}
2426
76e3520e 2427STATIC void
e1ec3a88 2428S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
4633a7c4 2429{
ab821d7f 2430 /* This message really ought to be max 23 lines.
75c72d73 2431 * Removed -h because the user already knows that option. Others? */
fb73857a 2432
27da23d5 2433 static const char * const usage_msg[] = {
aefc56c5
SF		 2434"-0[octal] specify record separator (\\0, if no argument)",
2435"-A[mod][=pattern] activate all/given assertions",
2436"-a autosplit mode with -n or -p (splits $_ into @F)",
2437"-C[number/list] enables the listed Unicode features",
2438"-c check syntax only (runs BEGIN and CHECK blocks)",
2439"-d[:debugger] run program under debugger",
2440"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2441"-e program one line of program (several -e's allowed, omit programfile)",
f71cb6df 2442#ifdef USE_SITECUSTOMIZE
aefc56c5 2443"-f don't do $sitelib/sitecustomize.pl at startup",
f71cb6df 2444#endif
aefc56c5
SF		 2445"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2446"-i[extension] edit <> files in place (makes backup if extension supplied)",
2447"-Idirectory specify @INC/#include directory (several -I's allowed)",
2448"-l[octal] enable line ending processing, specifies line terminator",
2449"-[mM][-]module execute \"use/no module...\" before executing program",
2450"-n assume \"while (<>) { ... }\" loop around program",
2451"-p assume loop like -n but print line also, like sed",
2452"-P run program through C preprocessor before compilation",
2453"-s enable rudimentary parsing for switches after programfile",
2454"-S look for programfile using PATH environment variable",
2455"-t enable tainting warnings",
2456"-T enable tainting checks",
2457"-u dump core after parsing program",
2458"-U allow unsafe operations",
2459"-v print version, subversion (includes VERY IMPORTANT perl info)",
2460"-V[:variable] print configuration summary (or a single Config.pm variable)",
2461"-w enable many useful warnings (RECOMMENDED)",
2462"-W enable all warnings",
2463"-x[directory] strip off text before #!perl line and perhaps cd to directory",
2464"-X disable all warnings",
fb73857a 2465"\n",
2466NULL
2467};
27da23d5 2468 const char * const *p = usage_msg;
fb73857a 2469
b0e47665
GS		 2470 PerlIO_printf(PerlIO_stdout(),
2471 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2472 name);
fb73857a 2473 while (*p)
b0e47665 2474 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2475}
2476
b4ab917c
DM		 2477/* convert a string of -D options (or digits) into an int.
2478 * sets *s to point to the char after the options */
2479
2480#ifdef DEBUGGING
2481int
e1ec3a88 2482Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
b4ab917c 2483{
27da23d5 2484 static const char * const usage_msgd[] = {
e6e64d9b
JC		 2485 " Debugging flag values: (see also -d)",
2486 " p Tokenizing and parsing (with v, displays parse stack)",
3679267a 2487 " s Stack snapshots (with v, displays all stacks)",
e6e64d9b
JC		 2488 " l Context (loop) stack processing",
2489 " t Trace execution",
2490 " o Method and overloading resolution",
2491 " c String/numeric conversions",
2492 " P Print profiling info, preprocessor command for -P, source file input state",
2493 " m Memory allocation",
2494 " f Format processing",
2495 " r Regular expression parsing and execution",
2496 " x Syntax tree dump",
3679267a 2497 " u Tainting checks",
e6e64d9b
JC		 2498 " H Hash dump -- usurps values()",
2499 " X Scratchpad allocation",
2500 " D Cleaning up",
2501 " S Thread synchronization",
2502 " T Tokenising",
2503 " R Include reference counts of dumped variables (eg when using -Ds)",
2504 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2505 " v Verbose: use in conjunction with other flags",
2506 " C Copy On Write",
2507 " A Consistency checks on internal structures",
3679267a 2508 " q quiet - currently only suppresses the 'EXECUTING' message",
e6e64d9b
JC		 2509 NULL
2510 };
b4ab917c
DM		 2511 int i = 0;
2512 if (isALPHA(**s)) {
2513 /* if adding extra options, remember to update DEBUG_MASK */
bfed75c6 2514 static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
b4ab917c
DM		 2515
2516 for (; isALNUM(**s); (*s)++) {
e1ec3a88 2517 const char *d = strchr(debopts,**s);
b4ab917c
DM		 2518 if (d)
2519 i |= 1 << (d - debopts);
2520 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC		 2521 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2522 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM		 2523 }
2524 }
e6e64d9b 2525 else if (isDIGIT(**s)) {
b4ab917c
DM		 2526 i = atoi(*s);
2527 for (; isALNUM(**s); (*s)++) ;
2528 }
ddcf8bc1 2529 else if (givehelp) {
aadb217d 2530 char **p = (char **)usage_msgd;
e6e64d9b
JC		 2531 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2532 }
b4ab917c
DM		 2533# ifdef EBCDIC
2534 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2535 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2536 "-Dp not implemented on this platform\n");
2537# endif
2538 return i;
2539}
2540#endif
2541
79072805
LW		 2542/* This routine handles any switches that can be given during run */
2543
2544char *
864dbfa3 2545Perl_moreswitches(pTHX_ char *s)
79072805 2546{
27da23d5 2547 dVAR;
84c133a0 2548 UV rschar;
79072805
LW		 2549
2550 switch (*s) {
2551 case '0':
a863c7d1 2552 {
f2095865 2553 I32 flags = 0;
a3b680e6 2554 STRLEN numlen;
f2095865
JH		 2555
2556 SvREFCNT_dec(PL_rs);
2557 if (s[1] == 'x' && s[2]) {
a3b680e6 2558 const char *e = s+=2;
f2095865
JH		 2559 U8 *tmps;
2560
a3b680e6
AL		 2561 while (*e)
2562 e++;
f2095865
JH		 2563 numlen = e - s;
2564 flags = PERL_SCAN_SILENT_ILLDIGIT;
2565 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2566 if (s + numlen < e) {
2567 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2568 numlen = 0;
2569 s--;
2570 }
2571 PL_rs = newSVpvn("", 0);
c5661c80 2572 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 2573 tmps = (U8*)SvPVX(PL_rs);
2574 uvchr_to_utf8(tmps, rschar);
2575 SvCUR_set(PL_rs, UNISKIP(rschar));
2576 SvUTF8_on(PL_rs);
2577 }
2578 else {
2579 numlen = 4;
2580 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2581 if (rschar & ~((U8)~0))
2582 PL_rs = &PL_sv_undef;
2583 else if (!rschar && numlen >= 2)
2584 PL_rs = newSVpvn("", 0);
2585 else {
2586 char ch = (char)rschar;
2587 PL_rs = newSVpvn(&ch, 1);
2588 }
2589 }
800633c3 2590 sv_setsv(get_sv("/", TRUE), PL_rs);
f2095865 2591 return s + numlen;
a863c7d1 2592 }
46487f74 2593 case 'C':
a05d7ebb 2594 s++;
dd374669 2595 PL_unicode = parse_unicode_opts( (const char **)&s );
46487f74 2596 return s;
2304df62 2597 case 'F':
3280af22 2598 PL_minus_F = TRUE;
ebce5377
RGS		 2599 PL_splitstr = ++s;
2600 while (*s && !isSPACE(*s)) ++s;
2601 *s = '\0';
2602 PL_splitstr = savepv(PL_splitstr);
2304df62 2603 return s;
79072805 2604 case 'a':
3280af22 2605 PL_minus_a = TRUE;
79072805
LW		 2606 s++;
2607 return s;
2608 case 'c':
3280af22 2609 PL_minus_c = TRUE;
79072805
LW		 2610 s++;
2611 return s;
2612 case 'd':
bbce6d69 2613 forbid_setid("-d");
4633a7c4 2614 s++;
2cbb2ee1
RGS		 2615
2616 /* -dt indicates to the debugger that threads will be used */
2617 if (*s == 't' && !isALNUM(s[1])) {
2618 ++s;
2619 my_setenv("PERL5DB_THREADED", "1");
2620 }
2621
70c94a19
RR		 2622 /* The following permits -d:Mod to accepts arguments following an =
2623 in the fashion that -MSome::Mod does. */
2624 if (*s == ':' || *s == '=') {
06b5626a 2625 const char *start;
70c94a19
RR		 2626 SV *sv;
2627 sv = newSVpv("use Devel::", 0);
2628 start = ++s;
2629 /* We now allow -d:Module=Foo,Bar */
2630 while(isALNUM(*s) || *s==':') ++s;
2631 if (*s != '=')
2632 sv_catpv(sv, start);
2633 else {
2634 sv_catpvn(sv, start, s-start);
2635 sv_catpv(sv, " split(/,/,q{");
2636 sv_catpv(sv, ++s);
3d27e215 2637 sv_catpv(sv, "})");
70c94a19 2638 }
4633a7c4 2639 s += strlen(s);
70c94a19 2640 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2641 }
ed094faf 2642 if (!PL_perldb) {
3280af22 2643 PL_perldb = PERLDB_ALL;
a0d0e21e 2644 init_debugger();
ed094faf 2645 }
79072805
LW		 2646 return s;
2647 case 'D':
0453d815 2648 {
79072805 2649#ifdef DEBUGGING
bbce6d69 2650 forbid_setid("-D");
b4ab917c 2651 s++;
dd374669 2652 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
12a43e32 2653#else /* !DEBUGGING */
0453d815 2654 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2655 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
e6e64d9b 2656 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
a0d0e21e 2657 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2658#endif
2659 /*SUPPRESS 530*/
2660 return s;
0453d815 2661 }
4633a7c4 2662 case 'h':
ac27b0f5 2663 usage(PL_origargv[0]);
7ca617d0 2664 my_exit(0);
79072805 2665 case 'i':
3280af22
NIS		 2666 if (PL_inplace)
2667 Safefree(PL_inplace);
c030f24b
GH		 2668#if defined(__CYGWIN__) /* do backup extension automagically */
2669 if (*(s+1) == '\0') {
2670 PL_inplace = savepv(".bak");
2671 return s+1;
2672 }
2673#endif /* __CYGWIN__ */
3280af22 2674 PL_inplace = savepv(s+1);
79072805 2675 /*SUPPRESS 530*/
3280af22 2676 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2677 if (*s) {
fb73857a 2678 *s++ = '\0';
7b8d334a
GS		 2679 if (*s == '-') /* Additional switches on #! line. */
2680 s++;
2681 }
fb73857a 2682 return s;
4e49a025 2683 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2684 forbid_setid("-I");
fb73857a 2685 ++s;
2686 while (*s && isSPACE(*s))
2687 ++s;
2688 if (*s) {
774d564b 2689 char *e, *p;
0df16ed7
GS		 2690 p = s;
2691 /* ignore trailing spaces (possibly followed by other switches) */
2692 do {
2693 for (e = p; *e && !isSPACE(*e); e++) ;
2694 p = e;
2695 while (isSPACE(*p))
2696 p++;
2697 } while (*p && *p != '-');
2698 e = savepvn(s, e-s);
88fe16b2 2699 incpush(e, TRUE, TRUE, FALSE, FALSE);
0df16ed7
GS		 2700 Safefree(e);
2701 s = p;
2702 if (*s == '-')
2703 s++;
79072805
LW		 2704 }
2705 else
a67e862a 2706 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2707 return s;
79072805 2708 case 'l':
3280af22 2709 PL_minus_l = TRUE;
79072805 2710 s++;
7889fe52
NIS		 2711 if (PL_ors_sv) {
2712 SvREFCNT_dec(PL_ors_sv);
2713 PL_ors_sv = Nullsv;
2714 }
79072805 2715 if (isDIGIT(*s)) {
53305cf1 2716 I32 flags = 0;
a3b680e6 2717 STRLEN numlen;
7889fe52 2718 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2719 numlen = 3 + (*s == '0');
2720 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2721 s += numlen;
2722 }
2723 else {
8bfdd7d9 2724 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2725 PL_ors_sv = newSVpvn("\n\n",2);
2726 }
2727 else {
8bfdd7d9 2728 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2729 }
79072805
LW		 2730 }
2731 return s;
06492da6
SF		 2732 case 'A':
2733 forbid_setid("-A");
930366bd
RGS		 2734 if (!PL_preambleav)
2735 PL_preambleav = newAV();
aefc56c5
SF		 2736 s++;
2737 {
2738 char *start = s;
2739 SV *sv = newSVpv("use assertions::activate", 24);
2740 while(isALNUM(*s) || *s == ':') ++s;
2741 if (s != start) {
2742 sv_catpvn(sv, "::", 2);
2743 sv_catpvn(sv, start, s-start);
2744 }
2745 if (*s == '=') {
2746 sv_catpvn(sv, " split(/,/,q\0", 13);
2747 sv_catpv(sv, s+1);
2748 sv_catpvn(sv, "\0)", 2);
2749 s+=strlen(s);
2750 }
2751 else if (*s != '\0') {
2752 Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start);
2753 }
06492da6 2754 av_push(PL_preambleav, sv);
aefc56c5 2755 return s;
06492da6 2756 }
1a30305b 2757 case 'M':
bbce6d69 2758 forbid_setid("-M"); /* XXX ? */
1a30305b 2759 /* FALL THROUGH */
2760 case 'm':
bbce6d69 2761 forbid_setid("-m"); /* XXX ? */
1a30305b 2762 if (*++s) {
a5f75d66 2763 char *start;
11343788 2764 SV *sv;
e1ec3a88 2765 const char *use = "use ";
a5f75d66
AD		 2766 /* -M-foo == 'no foo' */
2767 if (*s == '-') { use = "no "; ++s; }
11343788 2768 sv = newSVpv(use,0);
a5f75d66 2769 start = s;
1a30305b 2770 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2771 while(isALNUM(*s) || *s==':') ++s;
2772 if (*s != '=') {
11343788 2773 sv_catpv(sv, start);
c07a80fd 2774 if (*(start-1) == 'm') {
2775 if (*s != '\0')
cea2e8a9 2776 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2777 sv_catpv( sv, " ()");
c07a80fd 2778 }
2779 } else {
6df41af2 2780 if (s == start)
be98fb35
GS		 2781 Perl_croak(aTHX_ "Module name required with -%c option",
2782 s[-1]);
11343788 2783 sv_catpvn(sv, start, s-start);
3d27e215
LM		 2784 sv_catpv(sv, " split(/,/,q");
2785 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
11343788 2786 sv_catpv(sv, ++s);
3d27e215 2787 sv_catpvn(sv, "\0)", 2);
c07a80fd 2788 }
1a30305b 2789 s += strlen(s);
5c831c24 2790 if (!PL_preambleav)
3280af22
NIS		 2791 PL_preambleav = newAV();
2792 av_push(PL_preambleav, sv);
1a30305b 2793 }
2794 else
9e81e6a1 2795 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
1a30305b 2796 return s;
79072805 2797 case 'n':
3280af22 2798 PL_minus_n = TRUE;
79072805
LW		 2799 s++;
2800 return s;
2801 case 'p':
3280af22 2802 PL_minus_p = TRUE;
79072805
LW		 2803 s++;
2804 return s;
2805 case 's':
bbce6d69 2806 forbid_setid("-s");
3280af22 2807 PL_doswitches = TRUE;
79072805
LW		 2808 s++;
2809 return s;
6537fe72
MS		 2810 case 't':
2811 if (!PL_tainting)
22f7c9c9 2812 TOO_LATE_FOR('t');
6537fe72
MS		 2813 s++;
2814 return s;
463ee0b2 2815 case 'T':
3280af22 2816 if (!PL_tainting)
22f7c9c9 2817 TOO_LATE_FOR('T');
463ee0b2
LW		 2818 s++;
2819 return s;
79072805 2820 case 'u':
bf4acbe4
GS		 2821#ifdef MACOS_TRADITIONAL
2822 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2823#endif
3280af22 2824 PL_do_undump = TRUE;
79072805
LW		 2825 s++;
2826 return s;
2827 case 'U':
3280af22 2828 PL_unsafe = TRUE;
79072805
LW		 2829 s++;
2830 return s;
2831 case 'v':
d7aa5382
JP		 2832 if (!sv_derived_from(PL_patchlevel, "version"))
2833 (void *)upg_version(PL_patchlevel);
8e9464f1 2834#if !defined(DGUX)
b0e47665 2835 PerlIO_printf(PerlIO_stdout(),
014ead4b 2836 Perl_form(aTHX_ "\nThis is perl, v%"SVf" built for %s",
d7aa5382
JP		 2837 vstringify(PL_patchlevel),
2838 ARCHNAME));
8e9464f1
JH		 2839#else /* DGUX */
2840/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2841 PerlIO_printf(PerlIO_stdout(),
014ead4b 2842 Perl_form(aTHX_ "\nThis is perl, v%"SVf"\n",
d7aa5382 2843 vstringify(PL_patchlevel)));
8e9464f1
JH		 2844 PerlIO_printf(PerlIO_stdout(),
2845 Perl_form(aTHX_ " built under %s at %s %s\n",
2846 OSNAME, __DATE__, __TIME__));
2847 PerlIO_printf(PerlIO_stdout(),
2848 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2849 OSVERS));
8e9464f1
JH		 2850#endif /* !DGUX */
2851
fb73857a 2852#if defined(LOCAL_PATCH_COUNT)
2853 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2854 PerlIO_printf(PerlIO_stdout(),
2855 "\n(with %d registered patch%s, "
2856 "see perl -V for more detail)",
2857 (int)LOCAL_PATCH_COUNT,
2858 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2859#endif
1a30305b 2860
b0e47665 2861 PerlIO_printf(PerlIO_stdout(),
359b00fe 2862 "\n\nCopyright 1987-2005, Larry Wall\n");
eae9c151
JH		 2863#ifdef MACOS_TRADITIONAL
2864 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2865 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2866 "maintained by Chris Nandor\n");
eae9c151 2867#endif
79072805 2868#ifdef MSDOS
b0e47665
GS		 2869 PerlIO_printf(PerlIO_stdout(),
2870 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2871#endif
2872#ifdef DJGPP
b0e47665
GS		 2873 PerlIO_printf(PerlIO_stdout(),
2874 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2875 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2876#endif
79072805 2877#ifdef OS2
b0e47665
GS		 2878 PerlIO_printf(PerlIO_stdout(),
2879 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2880 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2881#endif
79072805 2882#ifdef atarist
b0e47665
GS		 2883 PerlIO_printf(PerlIO_stdout(),
2884 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2885#endif
a3f9223b 2886#ifdef __BEOS__
b0e47665
GS		 2887 PerlIO_printf(PerlIO_stdout(),
2888 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2889#endif
1d84e8df 2890#ifdef MPE
b0e47665 2891 PerlIO_printf(PerlIO_stdout(),
e583a879 2892 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 2893#endif
9d116dd7 2894#ifdef OEMVS
b0e47665
GS		 2895 PerlIO_printf(PerlIO_stdout(),
2896 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2897#endif
495c5fdc 2898#ifdef __VOS__
b0e47665 2899 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2900 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2901#endif
092bebab 2902#ifdef __OPEN_VM
b0e47665
GS		 2903 PerlIO_printf(PerlIO_stdout(),
2904 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2905#endif
a1a0e61e 2906#ifdef POSIX_BC
b0e47665
GS		 2907 PerlIO_printf(PerlIO_stdout(),
2908 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2909#endif
61ae2fbf 2910#ifdef __MINT__
b0e47665
GS		 2911 PerlIO_printf(PerlIO_stdout(),
2912 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2913#endif
f83d2536 2914#ifdef EPOC
b0e47665 2915 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2916 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2917#endif
e1caacb4 2918#ifdef UNDER_CE
b475b3e6
JH		 2919 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2920 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2921 wce_hitreturn();
2922#endif
27da23d5
JH		 2923#ifdef SYMBIAN
2924 PerlIO_printf(PerlIO_stdout(),
2925 "Symbian port by Nokia, 2004-2005\n");
2926#endif
baed7233
DL		 2927#ifdef BINARY_BUILD_NOTICE
2928 BINARY_BUILD_NOTICE;
2929#endif
b0e47665
GS		 2930 PerlIO_printf(PerlIO_stdout(),
2931 "\n\
79072805 2932Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2933GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687 2934Complete documentation for Perl, including FAQ lists, should be found on\n\
a0288114 2935this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
c9e30dd8 2936Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
7ca617d0 2937 my_exit(0);
79072805 2938 case 'w':
599cee73 2939 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2940 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2941 s++;
2942 return s;
2943 case 'W':
ac27b0f5 2944 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2945 if (!specialWARN(PL_compiling.cop_warnings))
2946 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2947 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2948 s++;
2949 return s;
2950 case 'X':
ac27b0f5 2951 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2952 if (!specialWARN(PL_compiling.cop_warnings))
2953 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2954 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2955 s++;
2956 return s;
a0d0e21e 2957 case '*':
79072805
LW		 2958 case ' ':
2959 if (s[1] == '-') /* Additional switches on #! line. */
2960 return s+2;
2961 break;
a0d0e21e 2962 case '-':
79072805 2963 case 0:
51882d45 2964#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2965 case '\r':
2966#endif
79072805
LW		 2967 case '\n':
2968 case '\t':
2969 break;
aa689395 2970#ifdef ALTERNATE_SHEBANG
2971 case 'S': /* OS/2 needs -S on "extproc" line. */
2972 break;
2973#endif
a0d0e21e 2974 case 'P':
3280af22 2975 if (PL_preprocess)
a0d0e21e
LW		 2976 return s+1;
2977 /* FALL THROUGH */
79072805 2978 default:
cea2e8a9 2979 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2980 }
2981 return Nullch;
2982}
2983
2984/* compliments of Tom Christiansen */
2985
2986/* unexec() can be found in the Gnu emacs distribution */
ee580363 2987/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2988
2989void
864dbfa3 2990Perl_my_unexec(pTHX)
79072805
LW		 2991{
2992#ifdef UNEXEC
46fc3d4c 2993 SV* prog;
2994 SV* file;
ee580363 2995 int status = 1;
79072805
LW		 2996 extern int etext;
2997
ee580363 2998 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2999 sv_catpv(prog, "/perl");
6b88bc9c 3000 file = newSVpv(PL_origfilename, 0);
46fc3d4c 3001 sv_catpv(file, ".perldump");
79072805 3002
ee580363
GS		 3003 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3004 /* unexec prints msg to stderr in case of failure */
6ad3d225 3005 PerlProc_exit(status);
79072805 3006#else
a5f75d66
AD		 3007# ifdef VMS
3008# include <lib$routines.h>
3009 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 3010# else
79072805 3011 ABORT(); /* for use with undump */
aa689395 3012# endif
a5f75d66 3013#endif
79072805
LW		 3014}
3015
cb68f92d
GS		 3016/* initialize curinterp */
3017STATIC void
cea2e8a9 3018S_init_interp(pTHX)
cb68f92d
GS		 3019{
3020
acfe0abc
GS		 3021#ifdef MULTIPLICITY
3022# define PERLVAR(var,type)
3023# define PERLVARA(var,n,type)
3024# if defined(PERL_IMPLICIT_CONTEXT)
3025# if defined(USE_5005THREADS)
3026# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
27da23d5 3027# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 3028# else /* !USE_5005THREADS */
3029# define PERLVARI(var,type,init) aTHX->var = init;
3030# define PERLVARIC(var,type,init) aTHX->var = init;
3031# endif /* USE_5005THREADS */
3967c732 3032# else
acfe0abc
GS		 3033# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3034# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 3035# endif
acfe0abc
GS		 3036# include "intrpvar.h"
3037# ifndef USE_5005THREADS
3038# include "thrdvar.h"
3039# endif
3040# undef PERLVAR
3041# undef PERLVARA
3042# undef PERLVARI
3043# undef PERLVARIC
3044#else
3045# define PERLVAR(var,type)
3046# define PERLVARA(var,n,type)
3047# define PERLVARI(var,type,init) PL_##var = init;
3048# define PERLVARIC(var,type,init) PL_##var = init;
3049# include "intrpvar.h"
3050# ifndef USE_5005THREADS
3051# include "thrdvar.h"
3052# endif
3053# undef PERLVAR
3054# undef PERLVARA
3055# undef PERLVARI
3056# undef PERLVARIC
cb68f92d
GS		 3057#endif
3058
cb68f92d
GS		 3059}
3060
76e3520e 3061STATIC void
cea2e8a9 3062S_init_main_stash(pTHX)
79072805 3063{
463ee0b2 3064 GV *gv;
6e72f9df 3065
3280af22 3066 PL_curstash = PL_defstash = newHV();
79cb57f6 3067 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 3068 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
3069 SvREFCNT_dec(GvHV(gv));
3280af22 3070 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 3071 SvREADONLY_on(gv);
bfcb3514 3072 Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0);
3280af22
NIS		 3073 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
3074 GvMULTI_on(PL_incgv);
3075 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
3076 GvMULTI_on(PL_hintgv);
3077 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
3078 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
3079 GvMULTI_on(PL_errgv);
3080 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
3081 GvMULTI_on(PL_replgv);
cea2e8a9 3082 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 3083 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3084 sv_setpvn(ERRSV, "", 0);
3280af22 3085 PL_curstash = PL_defstash;
11faa288 3086 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 3087 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 3088 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 3089 /* We must init $/ before switches are processed. */
864dbfa3 3090 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 3091}
3092
ae3f3efd 3093/* PSz 18 Nov 03 fdscript now global but do not change prototype */
76e3520e 3094STATIC void
dd374669 3095S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
79072805 3096{
ae3f3efd 3097#ifndef IAMSUID
e1ec3a88
AL		 3098 const char *quote;
3099 const char *code;
3100 const char *cpp_discard_flag;
3101 const char *perl;
ae3f3efd 3102#endif
27da23d5 3103 dVAR;
1b24ed4b 3104
ae3f3efd
PS		 3105 PL_fdscript = -1;
3106 PL_suidscript = -1;
79072805 3107
3280af22 3108 if (PL_e_script) {
ff5bdd37 3109 PL_origfilename = savepvn("-e", 2);
96436eeb 3110 }
6c4ab083
GS		 3111 else {
3112 /* if find_script() returns, it returns a malloc()-ed value */
dd374669 3113 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 3114
3115 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
e1ec3a88 3116 const char *s = scriptname + 8;
ae3f3efd 3117 PL_fdscript = atoi(s);
6c4ab083
GS		 3118 while (isDIGIT(*s))
3119 s++;
3120 if (*s) {
ae3f3efd
PS		 3121 /* PSz 18 Feb 04
3122 * Tell apart "normal" usage of fdscript, e.g.
3123 * with bash on FreeBSD:
3124 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3125 * from usage in suidperl.
3126 * Does any "normal" usage leave garbage after the number???
3127 * Is it a mistake to use a similar /dev/fd/ construct for
3128 * suidperl?
3129 */
3130 PL_suidscript = 1;
3131 /* PSz 20 Feb 04
3132 * Be supersafe and do some sanity-checks.
3133 * Still, can we be sure we got the right thing?
3134 */
3135 if (*s != '/') {
3136 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3137 }
3138 if (! *(s+1)) {
3139 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3140 }
6c4ab083 3141 scriptname = savepv(s + 1);
3280af22 3142 Safefree(PL_origfilename);
dd374669 3143 PL_origfilename = (char *)scriptname;
6c4ab083
GS		 3144 }
3145 }
3146 }
3147
05ec9bb3 3148 CopFILE_free(PL_curcop);
57843af0 3149 CopFILE_set(PL_curcop, PL_origfilename);
770526c1 3150 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
dd374669 3151 scriptname = (char *)"";
ae3f3efd
PS		 3152 if (PL_fdscript >= 0) {
3153 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3154# if defined(HAS_FCNTL) && defined(F_SETFD)
3155 if (PL_rsfp)
3156 /* ensure close-on-exec */
3157 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3158# endif
96436eeb 3159 }
ae3f3efd
PS		 3160#ifdef IAMSUID
3161 else {
86207487
NC		 3162 Perl_croak(aTHX_ "sperl needs fd script\n"
3163 "You should not call sperl directly; do you need to "
3164 "change a #! line\nfrom sperl to perl?\n");
3165
ae3f3efd
PS		 3166/* PSz 11 Nov 03
3167 * Do not open (or do other fancy stuff) while setuid.
3168 * Perl does the open, and hands script to suidperl on a fd;
3169 * suidperl only does some checks, sets up UIDs and re-execs
3170 * perl with that fd as it has always done.
3171 */
3172 }
3173 if (PL_suidscript != 1) {
3174 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3175 }
3176#else /* IAMSUID */
3280af22 3177 else if (PL_preprocess) {
dd374669 3178 const char *cpp_cfg = CPPSTDIN;
79cb57f6 3179 SV *cpp = newSVpvn("",0);
46fc3d4c 3180 SV *cmd = NEWSV(0,0);
3181
ae58f265
JH		 3182 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3183 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
46fc3d4c 3184 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 3185 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 3186 sv_catpv(cpp, cpp_cfg);
79072805 3187
1b24ed4b
MS		 3188# ifndef VMS
3189 sv_catpvn(sv, "-I", 2);
3190 sv_catpv(sv,PRIVLIB_EXP);
3191# endif
46fc3d4c 3192
14953ddc
MB		 3193 DEBUG_P(PerlIO_printf(Perl_debug_log,
3194 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
848ef955
NC		 3195 scriptname, SvPVX_const (cpp), SvPVX_const (sv),
3196 CPPMINUS));
1b24ed4b
MS		 3197
3198# if defined(MSDOS) || defined(WIN32) || defined(VMS)
3199 quote = "\"";
3200# else
3201 quote = "'";
3202# endif
3203
3204# ifdef VMS
3205 cpp_discard_flag = "";
3206# else
3207 cpp_discard_flag = "-C";
3208# endif
3209
3210# ifdef OS2
3211 perl = os2_execname(aTHX);
3212# else
3213 perl = PL_origargv[0];
3214# endif
3215
3216
3217 /* This strips off Perl comments which might interfere with
62375a60
NIS		 3218 the C pre-processor, including #!. #line directives are
3219 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 3220 of #line. FWP played some golf with it so it will fit
3221 into VMS's 255 character buffer.
3222 */
3223 if( PL_doextract )
3224 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3225 else
3226 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3227
3228 Perl_sv_setpvf(aTHX_ cmd, "\
3229%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 3230 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 3231 cpp_discard_flag, sv, CPPMINUS);
3232
3280af22 3233 PL_doextract = FALSE;
0a6c758d 3234
62375a60
NIS		 3235 DEBUG_P(PerlIO_printf(Perl_debug_log,
3236 "PL_preprocess: cmd=\"%s\"\n",
848ef955 3237 SvPVX_const(cmd)));
0a6c758d 3238
848ef955 3239 PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
46fc3d4c 3240 SvREFCNT_dec(cmd);
3241 SvREFCNT_dec(cpp);
79072805
LW		 3242 }
3243 else if (!*scriptname) {
bbce6d69 3244 forbid_setid("program input from stdin");
3280af22 3245 PL_rsfp = PerlIO_stdin();
79072805 3246 }
96436eeb 3247 else {
3280af22 3248 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3249# if defined(HAS_FCNTL) && defined(F_SETFD)
3250 if (PL_rsfp)
3251 /* ensure close-on-exec */
3252 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3253# endif
96436eeb 3254 }
ae3f3efd 3255#endif /* IAMSUID */
3280af22 3256 if (!PL_rsfp) {
447218f8 3257 /* PSz 16 Sep 03 Keep neat error message */
fa3aa65a
JC		 3258 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3259 CopFILE(PL_curcop), Strerror(errno));
13281fa4 3260 }
79072805 3261}
8d063cd8 3262
7b89560d
JH		 3263/* Mention
3264 * I_SYSSTATVFS HAS_FSTATVFS
3265 * I_SYSMOUNT
c890dc6c 3266 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3267 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3268 * here so that metaconfig picks them up. */
3269
104d25b7 3270#ifdef IAMSUID
864dbfa3 3271STATIC int
e688b231 3272S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 3273{
ae3f3efd
PS		 3274/* PSz 27 Feb 04
3275 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3276 * but is needed also on machines without setreuid.
3277 * Seems safe enough to run as root.
3278 */
0545a864
JH		 3279 int check_okay = 0; /* able to do all the required sys/libcalls */
3280 int on_nosuid = 0; /* the fd is on a nosuid fs */
ae3f3efd
PS		 3281 /* PSz 12 Nov 03
3282 * Need to check noexec also: nosuid might not be set, the average
3283 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3284 */
3285 int on_noexec = 0; /* the fd is on a noexec fs */
3286
104d25b7 3287/*
ad27e871 3288 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 3289 * fstatvfs() is UNIX98.
0545a864 3290 * fstatfs() is 4.3 BSD.
ad27e871 3291 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 3292 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3293 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 3294 */
3295
6439433f
JH		 3296#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3297
3298# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3299 defined(HAS_FSTATVFS)
3300# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 3301 struct statvfs stfs;
6439433f 3302
104d25b7
JH		 3303 check_okay = fstatvfs(fd, &stfs) == 0;
3304 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
ae3f3efd
PS		 3305#ifdef ST_NOEXEC
3306 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3307 on platforms where it is present. */
3308 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3309#endif
6439433f 3310# endif /* fstatvfs */
ac27b0f5 3311
6439433f
JH		 3312# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3313 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3314 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3315 defined(HAS_FSTATFS) && \
3316 defined(HAS_STRUCT_STATFS) && \
3317 defined(HAS_STRUCT_STATFS_F_FLAGS)
3318# define FD_ON_NOSUID_CHECK_OKAY
e688b231 3319 struct statfs stfs;
6439433f 3320
104d25b7 3321 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 3322 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
ae3f3efd 3323 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
6439433f
JH		 3324# endif /* fstatfs */
3325
3326# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3327 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3328 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3329 defined(HAS_FSTAT) && \
3330 defined(HAS_USTAT) && \
3331 defined(HAS_GETMNT) && \
3332 defined(HAS_STRUCT_FS_DATA) && \
3333 defined(NOSTAT_ONE)
3334# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 3335 Stat_t fdst;
6439433f 3336
0545a864 3337 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 3338 struct ustat us;
3339 if (ustat(fdst.st_dev, &us) == 0) {
3340 struct fs_data fsd;
3341 /* NOSTAT_ONE here because we're not examining fields which
3342 * vary between that case and STAT_ONE. */
ad27e871 3343 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3344 size_t cmplen = sizeof(us.f_fname);
3345 if (sizeof(fsd.fd_req.path) < cmplen)
3346 cmplen = sizeof(fsd.fd_req.path);
3347 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3348 fdst.st_dev == fsd.fd_req.dev) {
3349 check_okay = 1;
3350 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
ae3f3efd 3351 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
6439433f
JH		 3352 }
3353 }
3354 }
3355 }
0545a864 3356 }
6439433f
JH		 3357# endif /* fstat+ustat+getmnt */
3358
3359# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3360 defined(HAS_GETMNTENT) && \
3361 defined(HAS_HASMNTOPT) && \
ae3f3efd
PS		 3362 defined(MNTOPT_NOSUID) && \
3363 defined(MNTOPT_NOEXEC)
6439433f
JH		 3364# define FD_ON_NOSUID_CHECK_OKAY
3365 FILE *mtab = fopen("/etc/mtab", "r");
3366 struct mntent *entry;
c623ac67 3367 Stat_t stb, fsb;
104d25b7
JH		 3368
3369 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3370 while (entry = getmntent(mtab)) {
3371 if (stat(entry->mnt_dir, &fsb) == 0
3372 && fsb.st_dev == stb.st_dev)
3373 {
3374 /* found the filesystem */
3375 check_okay = 1;
3376 if (hasmntopt(entry, MNTOPT_NOSUID))
3377 on_nosuid = 1;
ae3f3efd
PS		 3378 if (hasmntopt(entry, MNTOPT_NOEXEC))
3379 on_noexec = 1;
6439433f
JH		 3380 break;
3381 } /* A single fs may well fail its stat(). */
3382 }
104d25b7
JH		 3383 }
3384 if (mtab)
6439433f
JH		 3385 fclose(mtab);
3386# endif /* getmntent+hasmntopt */
0545a864 3387
ac27b0f5 3388 if (!check_okay)
ae3f3efd
PS		 3389 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3390 if (on_nosuid)
3391 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3392 if (on_noexec)
3393 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3394 return ((!check_okay) || on_nosuid || on_noexec);
104d25b7
JH		 3395}
3396#endif /* IAMSUID */
3397
76e3520e 3398STATIC void
e1ec3a88 3399S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
79072805 3400{
27da23d5 3401 dVAR;
155aba94 3402#ifdef IAMSUID
ae3f3efd
PS		 3403 /* int which; */
3404#endif /* IAMSUID */
96436eeb 3405
13281fa4
LW		 3406 /* do we need to emulate setuid on scripts? */
3407
3408 /* This code is for those BSD systems that have setuid #! scripts disabled
3409 * in the kernel because of a security problem. Merely defining DOSUID
3410 * in perl will not fix that problem, but if you have disabled setuid
3411 * scripts in the kernel, this will attempt to emulate setuid and setgid
3412 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3413 * root version must be called suidperl or sperlN.NNN. If regular perl
3414 * discovers that it has opened a setuid script, it calls suidperl with
3415 * the same argv that it had. If suidperl finds that the script it has
3416 * just opened is NOT setuid root, it sets the effective uid back to the
3417 * uid. We don't just make perl setuid root because that loses the
3418 * effective uid we had before invoking perl, if it was different from the
3419 * uid.
ae3f3efd
PS		 3420 * PSz 27 Feb 04
3421 * Description/comments above do not match current workings:
3422 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3423 * suidperl called with script open and name changed to /dev/fd/N/X;
3424 * suidperl croaks if script is not setuid;
3425 * making perl setuid would be a huge security risk (and yes, that
3426 * would lose any euid we might have had).
13281fa4
LW		 3427 *
3428 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3429 * be defined in suidperl only. suidperl must be setuid root. The
3430 * Configure script will set this up for you if you want it.
3431 */
a687059c 3432
13281fa4 3433#ifdef DOSUID
dd720ed5 3434 const char *s, *s2;
a0d0e21e 3435
b28d0864 3436 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3437 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
ae3f3efd 3438 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3439 I32 len;
dd720ed5 3440 const char *linestr;
13281fa4 3441
a687059c 3442#ifdef IAMSUID
ae3f3efd
PS		 3443 if (PL_fdscript < 0 || PL_suidscript != 1)
3444 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3445 /* PSz 11 Nov 03
3446 * Since the script is opened by perl, not suidperl, some of these
3447 * checks are superfluous. Leaving them in probably does not lower
3448 * security(?!).
3449 */
3450 /* PSz 27 Feb 04
3451 * Do checks even for systems with no HAS_SETREUID.
3452 * We used to swap, then re-swap UIDs with
3453#ifdef HAS_SETREUID
3454 if (setreuid(PL_euid,PL_uid) < 0
3455 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3456 Perl_croak(aTHX_ "Can't swap uid and euid");
3457#endif
3458#ifdef HAS_SETREUID
3459 if (setreuid(PL_uid,PL_euid) < 0
3460 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3461 Perl_croak(aTHX_ "Can't reswap uid and euid");
3462#endif
3463 */
3464
a687059c
LW		 3465 /* On this access check to make sure the directories are readable,
3466 * there is actually a small window that the user could use to make
3467 * filename point to an accessible directory. So there is a faint
3468 * chance that someone could execute a setuid script down in a
3469 * non-accessible directory. I don't know what to do about that.
3470 * But I don't think it's too important. The manual lies when
3471 * it says access() is useful in setuid programs.
ae3f3efd
PS		 3472 *
3473 * So, access() is pretty useless... but not harmful... do anyway.
a687059c 3474 */
e57400b1 3475 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
ae3f3efd 3476 Perl_croak(aTHX_ "Can't access() script\n");
e57400b1 3477 }
ae3f3efd 3478
a687059c
LW		 3479 /* If we can swap euid and uid, then we can determine access rights
3480 * with a simple stat of the file, and then compare device and
3481 * inode to make sure we did stat() on the same file we opened.
3482 * Then we just have to make sure he or she can execute it.
ae3f3efd
PS		 3483 *
3484 * PSz 24 Feb 04
3485 * As the script is opened by perl, not suidperl, we do not need to
3486 * care much about access rights.
3487 *
3488 * The 'script changed' check is needed, or we can get lied to
3489 * about $0 with e.g.
3490 * suidperl /dev/fd/4//bin/x 4<setuidscript
3491 * Without HAS_SETREUID, is it safe to stat() as root?
3492 *
3493 * Are there any operating systems that pass /dev/fd/xxx for setuid
3494 * scripts, as suggested/described in perlsec(1)? Surely they do not
3495 * pass the script name as we do, so the "script changed" test would
3496 * fail for them... but we never get here with
3497 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3498 *
3499 * This is one place where we must "lie" about return status: not
3500 * say if the stat() failed. We are doing this as root, and could
3501 * be tricked into reporting existence or not of files that the
3502 * "plain" user cannot even see.
a687059c
LW		 3503 */
3504 {
c623ac67 3505 Stat_t tmpstatbuf;
ae3f3efd
PS		 3506 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3507 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
b28d0864 3508 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
ae3f3efd 3509 Perl_croak(aTHX_ "Setuid script changed\n");
a687059c 3510 }
ae3f3efd 3511
a687059c 3512 }
ae3f3efd
PS		 3513 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3514 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3515
3516 /* PSz 27 Feb 04
3517 * We used to do this check as the "plain" user (after swapping
3518 * UIDs). But the check for nosuid and noexec filesystem is needed,
3519 * and should be done even without HAS_SETREUID. (Maybe those
3520 * operating systems do not have such mount options anyway...)
3521 * Seems safe enough to do as root.
3522 */
3523#if !defined(NO_NOSUID_CHECK)
3524 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3525 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3526 }
3527#endif
a687059c
LW		 3528#endif /* IAMSUID */
3529
e57400b1 3530 if (!S_ISREG(PL_statbuf.st_mode)) {
ae3f3efd 3531 Perl_croak(aTHX_ "Setuid script not plain file\n");
e57400b1 3532 }
b28d0864 3533 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3534 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3535 PL_doswitches = FALSE; /* -s is insecure in suid */
ae3f3efd 3536 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
57843af0 3537 CopLINE_inc(PL_curcop);
dd720ed5 3538 linestr = SvPV_nolen_const(PL_linestr);
6b88bc9c 3539 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
dd720ed5 3540 strnNE(linestr,"#!",2) ) /* required even on Sys V */
cea2e8a9 3541 Perl_croak(aTHX_ "No #! line");
dd720ed5
NC		 3542 linestr+=2;
3543 s = linestr;
ae3f3efd
PS		 3544 /* PSz 27 Feb 04 */
3545 /* Sanity check on line length */
3546 if (strlen(s) < 1 || strlen(s) > 4000)
3547 Perl_croak(aTHX_ "Very long #! line");
3548 /* Allow more than a single space after #! */
3549 while (isSPACE(*s)) s++;
3550 /* Sanity check on buffer end */
3551 while ((*s) && !isSPACE(*s)) s++;
dd720ed5 3552 for (s2 = s; (s2 > linestr &&
3792a11b
NC		 3553 (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
3554 || s2[-1] == '-')); s2--) ;
ae3f3efd 3555 /* Sanity check on buffer start */
dd720ed5
NC		 3556 if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
3557 (s-9 < linestr || strnNE(s-9,"perl",4)) )
cea2e8a9 3558 Perl_croak(aTHX_ "Not a perl script");
a687059c 3559 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3560 /*
3561 * #! arg must be what we saw above. They can invoke it by
3562 * mentioning suidperl explicitly, but they may not add any strange
3563 * arguments beyond what #! says if they do invoke suidperl that way.
3564 */
ae3f3efd
PS		 3565 /*
3566 * The way validarg was set up, we rely on the kernel to start
3567 * scripts with argv[1] set to contain all #! line switches (the
3568 * whole line).
3569 */
3570 /*
3571 * Check that we got all the arguments listed in the #! line (not
3572 * just that there are no extraneous arguments). Might not matter
3573 * much, as switches from #! line seem to be acted upon (also), and
3574 * so may be checked and trapped in perl. But, security checks must
3575 * be done in suidperl and not deferred to perl. Note that suidperl
3576 * does not get around to parsing (and checking) the switches on
3577 * the #! line (but execs perl sooner).
3578 * Allow (require) a trailing newline (which may be of two
3579 * characters on some architectures?) (but no other trailing
3580 * whitespace).
3581 */
13281fa4
LW		 3582 len = strlen(validarg);
3583 if (strEQ(validarg," PHOOEY ") ||
ae3f3efd
PS		 3584 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3585 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
cea2e8a9 3586 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3587
3588#ifndef IAMSUID
ae3f3efd
PS		 3589 if (PL_fdscript < 0 &&
3590 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
b28d0864
NIS		 3591 PL_euid == PL_statbuf.st_uid)
3592 if (!PL_do_undump)
cea2e8a9 3593 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
11fb1898 3594FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
a687059c 3595#endif /* IAMSUID */
13281fa4 3596
ae3f3efd
PS		 3597 if (PL_fdscript < 0 &&
3598 PL_euid) { /* oops, we're not the setuid root perl */
3599 /* PSz 18 Feb 04
3600 * When root runs a setuid script, we do not go through the same
3601 * steps of execing sperl and then perl with fd scripts, but
3602 * simply set up UIDs within the same perl invocation; so do
3603 * not have the same checks (on options, whatever) that we have
3604 * for plain users. No problem really: would have to be a script
3605 * that does not actually work for plain users; and if root is
3606 * foolish and can be persuaded to run such an unsafe script, he
3607 * might run also non-setuid ones, and deserves what he gets.
3608 *
3609 * Or, we might drop the PL_euid check above (and rely just on
3610 * PL_fdscript to avoid loops), and do the execs
3611 * even for root.
3612 */
13281fa4 3613#ifndef IAMSUID
ae3f3efd
PS		 3614 int which;
3615 /* PSz 11 Nov 03
3616 * Pass fd script to suidperl.
3617 * Exec suidperl, substituting fd script for scriptname.
3618 * Pass script name as "subdir" of fd, which perl will grok;
3619 * in fact will use that to distinguish this from "normal"
3620 * usage, see comments above.
3621 */
3622 PerlIO_rewind(PL_rsfp);
3623 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3624 /* PSz 27 Feb 04 Sanity checks on scriptname */
3625 if ((!scriptname) || (!*scriptname) ) {
3626 Perl_croak(aTHX_ "No setuid script name\n");
3627 }
3628 if (*scriptname == '-') {
3629 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3630 /* Or we might confuse it with an option when replacing
3631 * name in argument list, below (though we do pointer, not
3632 * string, comparisons).
3633 */
3634 }
3635 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3636 if (!PL_origargv[which]) {
3637 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3638 }
3639 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3640 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3641#if defined(HAS_FCNTL) && defined(F_SETFD)
3642 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3643#endif
b35112e7 3644 PERL_FPU_PRE_EXEC
a7cb1f99 3645 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3646 (int)PERL_REVISION, (int)PERL_VERSION,
3647 (int)PERL_SUBVERSION), PL_origargv);
b35112e7 3648 PERL_FPU_POST_EXEC
ae3f3efd
PS		 3649#endif /* IAMSUID */
3650 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
13281fa4
LW		 3651 }
3652
b28d0864 3653 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
ae3f3efd
PS		 3654/* PSz 26 Feb 04
3655 * This seems back to front: we try HAS_SETEGID first; if not available
3656 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3657 * in the sense that we only want to set EGID; but are there any machines
3658 * with either of the latter, but not the former? Same with UID, later.
3659 */
fe14fcc3 3660#ifdef HAS_SETEGID
b28d0864 3661 (void)setegid(PL_statbuf.st_gid);
a687059c 3662#else
fe14fcc3 3663#ifdef HAS_SETREGID
b28d0864 3664 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3665#else
3666#ifdef HAS_SETRESGID
b28d0864 3667 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3668#else
b28d0864 3669 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3670#endif
3671#endif
85e6fe83 3672#endif
b28d0864 3673 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3674 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3675 }
b28d0864
NIS		 3676 if (PL_statbuf.st_mode & S_ISUID) {
3677 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3678#ifdef HAS_SETEUID
b28d0864 3679 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3680#else
fe14fcc3 3681#ifdef HAS_SETREUID
b28d0864 3682 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3683#else
3684#ifdef HAS_SETRESUID
b28d0864 3685 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3686#else
b28d0864 3687 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3688#endif
3689#endif
85e6fe83 3690#endif
b28d0864 3691 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3692 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3693 }
b28d0864 3694 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3695#ifdef HAS_SETEUID
b28d0864 3696 (void)seteuid((Uid_t)PL_uid);
a687059c 3697#else
fe14fcc3 3698#ifdef HAS_SETREUID
b28d0864 3699 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3700#else
85e6fe83 3701#ifdef HAS_SETRESUID
b28d0864 3702 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3703#else
b28d0864 3704 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3705#endif
a687059c
LW		 3706#endif
3707#endif
b28d0864 3708 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3709 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3710 }
748a9306 3711 init_ids();
b28d0864 3712 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
ae3f3efd 3713 Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
13281fa4
LW		 3714 }
3715#ifdef IAMSUID
ae3f3efd 3716 else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
cea2e8a9 3717 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
ae3f3efd
PS		 3718 else if (PL_fdscript < 0 || PL_suidscript != 1)
3719 /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
3720 Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
e57400b1 3721 else {
ae3f3efd
PS		 3722/* PSz 16 Sep 03 Keep neat error message */
3723 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
e57400b1 3724 }
96436eeb 3725
3726 /* We absolutely must clear out any saved ids here, so we */
3727 /* exec the real perl, substituting fd script for scriptname. */
3728 /* (We pass script name as "subdir" of fd, which perl will grok.) */
ae3f3efd
PS		 3729 /*
3730 * It might be thought that using setresgid and/or setresuid (changed to
3731 * set the saved IDs) above might obviate the need to exec, and we could
3732 * go on to "do the perl thing".
3733 *
3734 * Is there such a thing as "saved GID", and is that set for setuid (but
3735 * not setgid) execution like suidperl? Without exec, it would not be
3736 * cleared for setuid (but not setgid) scripts (or might need a dummy
3737 * setresgid).
3738 *
3739 * We need suidperl to do the exact same argument checking that perl
3740 * does. Thus it cannot be very small; while it could be significantly
3741 * smaller, it is safer (simpler?) to make it essentially the same
3742 * binary as perl (but they are not identical). - Maybe could defer that
3743 * check to the invoked perl, and suidperl be a tiny wrapper instead;
3744 * but prefer to do thorough checks in suidperl itself. Such deferral
3745 * would make suidperl security rely on perl, a design no-no.
3746 *
3747 * Setuid things should be short and simple, thus easy to understand and
3748 * verify. They should do their "own thing", without influence by
3749 * attackers. It may help if their internal execution flow is fixed,
3750 * regardless of platform: it may be best to exec anyway.
3751 *
3752 * Suidperl should at least be conceptually simple: a wrapper only,
3753 * never to do any real perl. Maybe we should put
3754 * #ifdef IAMSUID
3755 * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
3756 * #endif
3757 * into the perly bits.
3758 */
b28d0864
NIS		 3759 PerlIO_rewind(PL_rsfp);
3760 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
ae3f3efd
PS		 3761 /* PSz 11 Nov 03
3762 * Keep original arguments: suidperl already has fd script.
3763 */
3764/* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
3765/* if (!PL_origargv[which]) { */
3766/* errno = EPERM; */
3767/* Perl_croak(aTHX_ "Permission denied\n"); */
3768/* } */
3769/* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */
3770/* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
96436eeb 3771#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3772 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3773#endif
b35112e7 3774 PERL_FPU_PRE_EXEC
a7cb1f99 3775 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3776 (int)PERL_REVISION, (int)PERL_VERSION,
3777 (int)PERL_SUBVERSION), PL_origargv);/* try again */
b35112e7 3778 PERL_FPU_POST_EXEC
ae3f3efd 3779 Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
13281fa4 3780#endif /* IAMSUID */
a687059c 3781#else /* !DOSUID */
3280af22 3782 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3783#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3784 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3785 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3786 ||
b28d0864 3787 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3788 )
b28d0864 3789 if (!PL_do_undump)
cea2e8a9 3790 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3791FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3792#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3793 /* not set-id, must be wrapped */
a687059c 3794 }
13281fa4 3795#endif /* DOSUID */
dd374669
AL		 3796 (void)validarg;
3797 (void)scriptname;
79072805 3798}
13281fa4 3799
76e3520e 3800STATIC void
cea2e8a9 3801S_find_beginning(pTHX)
79072805 3802{
dd374669
AL		 3803 register char *s;
3804 register const char *s2;
e55ac0fa
HS		 3805#ifdef MACOS_TRADITIONAL
3806 int maclines = 0;
3807#endif
33b78306
LW		 3808
3809 /* skip forward in input to the real script? */
3810
bbce6d69 3811 forbid_setid("-x");
bf4acbe4 3812#ifdef MACOS_TRADITIONAL
084592ab 3813 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3814
bf4acbe4
GS		 3815 while (PL_doextract || gMacPerl_AlwaysExtract) {
3816 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3817 if (!gMacPerl_AlwaysExtract)
3818 Perl_croak(aTHX_ "No Perl script found in input\n");
e55ac0fa 3819
bf4acbe4
GS		 3820 if (PL_doextract) /* require explicit override ? */
3821 if (!OverrideExtract(PL_origfilename))
3822 Perl_croak(aTHX_ "User aborted script\n");
3823 else
3824 PL_doextract = FALSE;
e55ac0fa 3825
bf4acbe4
GS		 3826 /* Pater peccavi, file does not have #! */
3827 PerlIO_rewind(PL_rsfp);
e55ac0fa 3828
bf4acbe4
GS		 3829 break;
3830 }
3831#else
3280af22
NIS		 3832 while (PL_doextract) {
3833 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3834 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3835#endif
4f0c37ba
IZ		 3836 s2 = s;
3837 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3838 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3839 PL_doextract = FALSE;
6e72f9df 3840 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3841 s2 = s;
3842 while (*s == ' ' || *s == '\t') s++;
3843 if (*s++ == '-') {
3792a11b
NC		 3844 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3845 || s2[-1] == '_') s2--;
6e72f9df 3846 if (strnEQ(s2-4,"perl",4))
3847 /*SUPPRESS 530*/
155aba94
GS		 3848 while ((s = moreswitches(s)))
3849 ;
33b78306 3850 }
95e8664e 3851#ifdef MACOS_TRADITIONAL
e55ac0fa
HS		 3852 /* We are always searching for the #!perl line in MacPerl,
3853 * so if we find it, still keep the line count correct
3854 * by counting lines we already skipped over
3855 */
3856 for (; maclines > 0 ; maclines--)
3857 PerlIO_ungetc(PL_rsfp, '\n');
3858
95e8664e 3859 break;
e55ac0fa
HS		 3860
3861 /* gMacPerl_AlwaysExtract is false in MPW tool */
3862 } else if (gMacPerl_AlwaysExtract) {
3863 ++maclines;
95e8664e 3864#endif
83025b21
LW		 3865 }
3866 }
3867}
3868
afe37c7d 3869
76e3520e 3870STATIC void
cea2e8a9 3871S_init_ids(pTHX)
352d5a3a 3872{
d8eceb89
JH		 3873 PL_uid = PerlProc_getuid();
3874 PL_euid = PerlProc_geteuid();
3875 PL_gid = PerlProc_getgid();
3876 PL_egid = PerlProc_getegid();
748a9306 3877#ifdef VMS
b28d0864
NIS		 3878 PL_uid |= PL_gid << 16;
3879 PL_euid |= PL_egid << 16;
748a9306 3880#endif
22f7c9c9
JH		 3881 /* Should not happen: */
3882 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3280af22 3883 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
ae3f3efd
PS		 3884 /* BUG */
3885 /* PSz 27 Feb 04
3886 * Should go by suidscript, not uid!=euid: why disallow
3887 * system("ls") in scripts run from setuid things?
3888 * Or, is this run before we check arguments and set suidscript?
3889 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3890 * (We never have suidscript, can we be sure to have fdscript?)
3891 * Or must then go by UID checks? See comments in forbid_setid also.
3892 */
748a9306 3893}
79072805 3894
a0643315
JH		 3895/* This is used very early in the lifetime of the program,
3896 * before even the options are parsed, so PL_tainting has
b0891165 3897 * not been initialized properly. */
af419de7 3898bool
8f42b153 3899Perl_doing_taint(int argc, char *argv[], char *envp[])
22f7c9c9 3900{
c3446a78
JH		 3901#ifndef PERL_IMPLICIT_SYS
3902 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3903 * before we have an interpreter-- and the whole point of this
3904 * function is to be called at such an early stage. If you are on
3905 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3906 * "tainted because running with altered effective ids', you'll
3907 * have to add your own checks somewhere in here. The two most
3908 * known samples of 'implicitness' are Win32 and NetWare, neither
3909 * of which has much of concept of 'uids'. */
af419de7 3910 int uid = PerlProc_getuid();
22f7c9c9 3911 int euid = PerlProc_geteuid();
af419de7 3912 int gid = PerlProc_getgid();
22f7c9c9 3913 int egid = PerlProc_getegid();
6867be6d 3914 (void)envp;
22f7c9c9
JH		 3915
3916#ifdef VMS
af419de7 3917 uid |= gid << 16;
22f7c9c9
JH		 3918 euid |= egid << 16;
3919#endif
3920 if (uid && (euid != uid || egid != gid))
3921 return 1;
c3446a78 3922#endif /* !PERL_IMPLICIT_SYS */
af419de7
JH		 3923 /* This is a really primitive check; environment gets ignored only
3924 * if -T are the first chars together; otherwise one gets
3925 * "Too late" message. */
22f7c9c9
JH		 3926 if ( argc > 1 && argv[1][0] == '-'
3927 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3928 return 1;
3929 return 0;
3930}
22f7c9c9 3931
76e3520e 3932STATIC void
e1ec3a88 3933S_forbid_setid(pTHX_ const char *s)
bbce6d69 3934{
ae3f3efd 3935#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3280af22 3936 if (PL_euid != PL_uid)
cea2e8a9 3937 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 3938 if (PL_egid != PL_gid)
cea2e8a9 3939 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
ae3f3efd
PS		 3940#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3941 /* PSz 29 Feb 04
3942 * Checks for UID/GID above "wrong": why disallow
3943 * perl -e 'print "Hello\n"'
3944 * from within setuid things?? Simply drop them: replaced by
3945 * fdscript/suidscript and #ifdef IAMSUID checks below.
3946 *
3947 * This may be too late for command-line switches. Will catch those on
3948 * the #! line, after finding the script name and setting up
3949 * fdscript/suidscript. Note that suidperl does not get around to
3950 * parsing (and checking) the switches on the #! line, but checks that
3951 * the two sets are identical.
3952 *
3953 * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
3954 * instead, or would that be "too late"? (We never have suidscript, can
3955 * we be sure to have fdscript?)
3956 *
3957 * Catch things with suidscript (in descendant of suidperl), even with
3958 * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
3959 * below; but I am paranoid.
3960 *
3961 * Also see comments about root running a setuid script, elsewhere.
3962 */
3963 if (PL_suidscript >= 0)
3964 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
3965#ifdef IAMSUID
3966 /* PSz 11 Nov 03 Catch it in suidperl, always! */
3967 Perl_croak(aTHX_ "No %s allowed in suidperl", s);
3968#endif /* IAMSUID */
bbce6d69 3969}
3970
1ee4443e
IZ		 3971void
3972Perl_init_debugger(pTHX)
748a9306 3973{
1ee4443e
IZ		 3974 HV *ostash = PL_curstash;
3975
3280af22 3976 PL_curstash = PL_debstash;
7619c85e 3977 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
3280af22 3978 AvREAL_off(PL_dbargs);
7619c85e
RG		 3979 PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
3980 PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3981 PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
7619c85e 3982 PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3983 sv_setiv(PL_DBsingle, 0);
7619c85e 3984 PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3985 sv_setiv(PL_DBtrace, 0);
7619c85e 3986 PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3987 sv_setiv(PL_DBsignal, 0);
bf9cdc68 3988 PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
06492da6 3989 sv_setiv(PL_DBassertion, 0);
1ee4443e 3990 PL_curstash = ostash;
352d5a3a
LW		 3991}
3992
2ce36478
SM		 3993#ifndef STRESS_REALLOC
3994#define REASONABLE(size) (size)
3995#else
3996#define REASONABLE(size) (1) /* unreasonable */
3997#endif
3998
11343788 3999void
cea2e8a9 4000Perl_init_stacks(pTHX)
79072805 4001{
e336de0d 4002 /* start with 128-item stack and 8K cxstack */
3280af22 4003 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 4004 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 4005 PL_curstackinfo->si_type = PERLSI_MAIN;
4006 PL_curstack = PL_curstackinfo->si_stack;
4007 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 4008
3280af22
NIS		 4009 PL_stack_base = AvARRAY(PL_curstack);
4010 PL_stack_sp = PL_stack_base;
4011 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 4012
3280af22
NIS		 4013 New(50,PL_tmps_stack,REASONABLE(128),SV*);
4014 PL_tmps_floor = -1;
4015 PL_tmps_ix = -1;
4016 PL_tmps_max = REASONABLE(128);
8990e307 4017
3280af22
NIS		 4018 New(54,PL_markstack,REASONABLE(32),I32);
4019 PL_markstack_ptr = PL_markstack;
4020 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 4021
ce2f7c3b 4022 SET_MARK_OFFSET;
e336de0d 4023
3280af22
NIS		 4024 New(54,PL_scopestack,REASONABLE(32),I32);
4025 PL_scopestack_ix = 0;
4026 PL_scopestack_max = REASONABLE(32);
79072805 4027
3280af22
NIS		 4028 New(54,PL_savestack,REASONABLE(128),ANY);
4029 PL_savestack_ix = 0;
4030 PL_savestack_max = REASONABLE(128);
378cc40b 4031}
33b78306 4032
2ce36478
SM		 4033#undef REASONABLE
4034
76e3520e 4035STATIC void
cea2e8a9 4036S_nuke_stacks(pTHX)
6e72f9df 4037{
3280af22
NIS		 4038 while (PL_curstackinfo->si_next)
4039 PL_curstackinfo = PL_curstackinfo->si_next;
4040 while (PL_curstackinfo) {
4041 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 4042 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 4043 Safefree(PL_curstackinfo->si_cxstack);
4044 Safefree(PL_curstackinfo);
4045 PL_curstackinfo = p;
e336de0d 4046 }
3280af22
NIS		 4047 Safefree(PL_tmps_stack);
4048 Safefree(PL_markstack);
4049 Safefree(PL_scopestack);
4050 Safefree(PL_savestack);
378cc40b 4051}
33b78306 4052
76e3520e 4053STATIC void
cea2e8a9 4054S_init_lexer(pTHX)
8990e307 4055{
06039172 4056 PerlIO *tmpfp;
3280af22
NIS		 4057 tmpfp = PL_rsfp;
4058 PL_rsfp = Nullfp;
4059 lex_start(PL_linestr);
4060 PL_rsfp = tmpfp;
79cb57f6 4061 PL_subname = newSVpvn("main",4);
8990e307
LW		 4062}
4063
76e3520e 4064STATIC void
cea2e8a9 4065S_init_predump_symbols(pTHX)
45d8adaa 4066{
93a17b20 4067 GV *tmpgv;
af8c498a 4068 IO *io;
79072805 4069
864dbfa3 4070 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 4071 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
4072 GvMULTI_on(PL_stdingv);
af8c498a 4073 io = GvIOp(PL_stdingv);
a04651f4 4074 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 4075 IoIFP(io) = PerlIO_stdin();
adbc6bb1 4076 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 4077 GvMULTI_on(tmpgv);
af8c498a 4078 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 4079
85e6fe83 4080 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 4081 GvMULTI_on(tmpgv);
af8c498a 4082 io = GvIOp(tmpgv);
a04651f4 4083 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 4084 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 4085 setdefout(tmpgv);
adbc6bb1 4086 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 4087 GvMULTI_on(tmpgv);
af8c498a 4088 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 4089
bf49b057
GS		 4090 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
4091 GvMULTI_on(PL_stderrgv);
4092 io = GvIOp(PL_stderrgv);
a04651f4 4093 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 4094 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 4095 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 4096 GvMULTI_on(tmpgv);
af8c498a 4097 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 4098
3280af22 4099 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 4100
bf4acbe4
GS		 4101 if (PL_osname)
4102 Safefree(PL_osname);
4103 PL_osname = savepv(OSNAME);
79072805 4104}
33b78306 4105
a11ec5a9 4106void
8f42b153 4107Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
33b78306 4108{
79072805 4109 char *s;
79072805 4110 argc--,argv++; /* skip name of script */
3280af22 4111 if (PL_doswitches) {
79072805
LW		 4112 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4113 if (!argv[0][1])
4114 break;
379d538a 4115 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 4116 argc--,argv++;
4117 break;
4118 }
155aba94 4119 if ((s = strchr(argv[0], '='))) {
79072805 4120 *s++ = '\0';
85e6fe83 4121 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 4122 }
4123 else
85e6fe83 4124 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 4125 }
79072805 4126 }
a11ec5a9
RGS		 4127 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4128 GvMULTI_on(PL_argvgv);
4129 (void)gv_AVadd(PL_argvgv);
4130 av_clear(GvAVn(PL_argvgv));
4131 for (; argc > 0; argc--,argv++) {
4132 SV *sv = newSVpv(argv[0],0);
4133 av_push(GvAVn(PL_argvgv),sv);
ce81ff12
JH		 4134 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4135 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4136 SvUTF8_on(sv);
4137 }
a05d7ebb
JH		 4138 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4139 (void)sv_utf8_decode(sv);
a11ec5a9
RGS		 4140 }
4141 }
4142}
4143
4144STATIC void
4145S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4146{
27da23d5 4147 dVAR;
a11ec5a9 4148 GV* tmpgv;
a11ec5a9 4149
3280af22
NIS		 4150 PL_toptarget = NEWSV(0,0);
4151 sv_upgrade(PL_toptarget, SVt_PVFM);
4152 sv_setpvn(PL_toptarget, "", 0);
4153 PL_bodytarget = NEWSV(0,0);
4154 sv_upgrade(PL_bodytarget, SVt_PVFM);
4155 sv_setpvn(PL_bodytarget, "", 0);
4156 PL_formtarget = PL_bodytarget;
79072805 4157
bbce6d69 4158 TAINT;
a11ec5a9
RGS		 4159
4160 init_argv_symbols(argc,argv);
4161
155aba94 4162 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
bf4acbe4
GS		 4163#ifdef MACOS_TRADITIONAL
4164 /* $0 is not majick on a Mac */
4165 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4166#else
3280af22 4167 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 4168 magicname("0", "0", 1);
bf4acbe4 4169#endif
79072805 4170 }
155aba94 4171 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
79072805 4172 HV *hv;
3280af22
NIS		 4173 GvMULTI_on(PL_envgv);
4174 hv = GvHVn(PL_envgv);
14befaf4 4175 hv_magic(hv, Nullgv, PERL_MAGIC_env);
2f42fcb0 4176#ifndef PERL_MICRO
fa6a1c44 4177#ifdef USE_ENVIRON_ARRAY
4633a7c4
LW		 4178 /* Note that if the supplied env parameter is actually a copy
4179 of the global environ then it may now point to free'd memory
4180 if the environment has been modified since. To avoid this
4181 problem we treat env==NULL as meaning 'use the default'
4182 */
4183 if (!env)
4184 env = environ;
4efc5df6
GS		 4185 if (env != environ
4186# ifdef USE_ITHREADS
4187 && PL_curinterp == aTHX
4188# endif
4189 )
4190 {
79072805 4191 environ[0] = Nullch;
4efc5df6 4192 }
9b4eeda5
MB		 4193 if (env) {
4194 char** origenv = environ;
27da23d5
JH		 4195 char *s;
4196 SV *sv;
764df951 4197 for (; *env; env++) {
9b4eeda5 4198 if (!(s = strchr(*env,'=')) || s == *env)
79072805 4199 continue;
7da0e383 4200#if defined(MSDOS) && !defined(DJGPP)
61968511 4201 *s = '\0';
137443ea 4202 (void)strupr(*env);
61968511 4203 *s = '=';
137443ea 4204#endif
61968511 4205 sv = newSVpv(s+1, 0);
79072805 4206 (void)hv_store(hv, *env, s - *env, sv, 0);
61968511
GA		 4207 if (env != environ)
4208 mg_set(sv);
9b4eeda5
MB		 4209 if (origenv != environ) {
4210 /* realloc has shifted us */
4211 env = (env - origenv) + environ;
4212 origenv = environ;
4213 }
764df951 4214 }
9b4eeda5 4215 }
103a7189 4216#endif /* USE_ENVIRON_ARRAY */
2f42fcb0 4217#endif /* !PERL_MICRO */
79072805 4218 }
bbce6d69 4219 TAINT_NOT;
306196c3
MS		 4220 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4221 SvREADONLY_off(GvSV(tmpgv));
7766f137 4222 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
306196c3
MS		 4223 SvREADONLY_on(GvSV(tmpgv));
4224 }
4d76a344
RGS		 4225#ifdef THREADS_HAVE_PIDS
4226 PL_ppid = (IV)getppid();
4227#endif
2710853f
MJD		 4228
4229 /* touch @F array to prevent spurious warnings 20020415 MJD */
4230 if (PL_minus_a) {
4231 (void) get_av("main::F", TRUE | GV_ADDMULTI);
4232 }
4233 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4234 (void) get_av("main::-", TRUE | GV_ADDMULTI);
4235 (void) get_av("main::+", TRUE | GV_ADDMULTI);
33b78306 4236}
34de22dd 4237
76e3520e 4238STATIC void
cea2e8a9 4239S_init_perllib(pTHX)
34de22dd 4240{
85e6fe83 4241 char *s;
3280af22 4242 if (!PL_tainting) {
552a7a9b 4243#ifndef VMS
76e3520e 4244 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 4245 if (s)
88fe16b2 4246 incpush(s, TRUE, TRUE, TRUE, FALSE);
85e6fe83 4247 else
88fe16b2 4248 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
552a7a9b 4249#else /* VMS */
4250 /* Treat PERL5?LIB as a possible search list logical name -- the
4251 * "natural" VMS idiom for a Unix path string. We allow each
4252 * element to be a set of |-separated directories for compatibility.
4253 */
4254 char buf[256];
4255 int idx = 0;
4256 if (my_trnlnm("PERL5LIB",buf,0))
88fe16b2 4257 do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 4258 else
88fe16b2 4259 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
552a7a9b 4260#endif /* VMS */
85e6fe83 4261 }
34de22dd 4262
c90c0ff4 4263/* Use the ~-expanded versions of APPLLIB (undocumented),
65f19062 4264 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
df5cef82 4265*/
4633a7c4 4266#ifdef APPLLIB_EXP
88fe16b2 4267 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
16d20bd9 4268#endif
4633a7c4 4269
fed7345c 4270#ifdef ARCHLIB_EXP
88fe16b2 4271 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
a0d0e21e 4272#endif
bf4acbe4
GS		 4273#ifdef MACOS_TRADITIONAL
4274 {
c623ac67 4275 Stat_t tmpstatbuf;
bf4acbe4
GS		 4276 SV * privdir = NEWSV(55, 0);
4277 char * macperl = PerlEnv_getenv("MACPERL");
4278
4279 if (!macperl)
4280 macperl = "";
4281
4282 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4283 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
88fe16b2 4284 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
bf4acbe4
GS		 4285 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4286 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
88fe16b2 4287 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
ac27b0f5 4288
bf4acbe4
GS		 4289 SvREFCNT_dec(privdir);
4290 }
4291 if (!PL_tainting)
88fe16b2 4292 incpush(":", FALSE, FALSE, TRUE, FALSE);
bf4acbe4 4293#else
fed7345c 4294#ifndef PRIVLIB_EXP
65f19062 4295# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 4296#endif
ac27b0f5 4297#if defined(WIN32)
88fe16b2 4298 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
00dc2f4f 4299#else
88fe16b2 4300 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
00dc2f4f 4301#endif
4633a7c4 4302
65f19062 4303#ifdef SITEARCH_EXP
3b290362
GS		 4304 /* sitearch is always relative to sitelib on Windows for
4305 * DLL-based path intuition to work correctly */
4306# if !defined(WIN32)
88fe16b2 4307 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062
GS		 4308# endif
4309#endif
4310
4633a7c4 4311#ifdef SITELIB_EXP
65f19062 4312# if defined(WIN32)
574c798a 4313 /* this picks up sitearch as well */
88fe16b2 4314 incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
65f19062 4315# else
88fe16b2 4316 incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062
GS		 4317# endif
4318#endif
189d1e8d 4319
65f19062 4320#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
88fe16b2 4321 incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
81c6dfba 4322#endif
65f19062
GS		 4323
4324#ifdef PERL_VENDORARCH_EXP
4ea817c6 4325 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS		 4326 * DLL-based path intuition to work correctly */
4327# if !defined(WIN32)
88fe16b2 4328 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062 4329# endif
4b03c463 4330#endif
65f19062
GS		 4331
4332#ifdef PERL_VENDORLIB_EXP
4333# if defined(WIN32)
88fe16b2 4334 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE); /* this picks up vendorarch as well */
65f19062 4335# else
88fe16b2 4336 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062 4337# endif
a3635516 4338#endif
65f19062
GS		 4339
4340#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
88fe16b2 4341 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
00dc2f4f 4342#endif
65f19062 4343
3b777bb4 4344#ifdef PERL_OTHERLIBDIRS
88fe16b2 4345 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
3b777bb4
GS		 4346#endif
4347
3280af22 4348 if (!PL_tainting)
88fe16b2 4349 incpush(".", FALSE, FALSE, TRUE, FALSE);
bf4acbe4 4350#endif /* MACOS_TRADITIONAL */
774d564b 4351}
4352
27da23d5 4353#if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
774d564b 4354# define PERLLIB_SEP ';'
4355#else
4356# if defined(VMS)
4357# define PERLLIB_SEP '|'
4358# else
bf4acbe4
GS		 4359# if defined(MACOS_TRADITIONAL)
4360# define PERLLIB_SEP ','
4361# else
4362# define PERLLIB_SEP ':'
4363# endif
774d564b 4364# endif
4365#endif
4366#ifndef PERLLIB_MANGLE
4367# define PERLLIB_MANGLE(s,n) (s)
ac27b0f5 4368#endif
774d564b 4369
ad17a1ae
NC		 4370/* Push a directory onto @INC if it exists.
4371 Generate a new SV if we do this, to save needing to copy the SV we push
4372 onto @INC */
4373STATIC SV *
4374S_incpush_if_exists(pTHX_ SV *dir)
4375{
4376 Stat_t tmpstatbuf;
848ef955 4377 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
ad17a1ae
NC		 4378 S_ISDIR(tmpstatbuf.st_mode)) {
4379 av_push(GvAVn(PL_incgv), dir);
4380 dir = NEWSV(0,0);
4381 }
4382 return dir;
4383}
4384
76e3520e 4385STATIC void
dd374669
AL		 4386S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
4387 bool canrelocate)
774d564b 4388{
4389 SV *subdir = Nullsv;
dd374669 4390 const char *p = dir;
774d564b 4391
3b290362 4392 if (!p || !*p)
774d564b 4393 return;
4394
9c8a64f0 4395 if (addsubdirs || addoldvers) {
ad17a1ae 4396 subdir = NEWSV(0,0);
774d564b 4397 }
4398
4399 /* Break at all separators */
4400 while (p && *p) {
8c52afec 4401 SV *libdir = NEWSV(55,0);
e1ec3a88 4402 const char *s;
774d564b 4403
4404 /* skip any consecutive separators */
574c798a
SR		 4405 if (usesep) {
4406 while ( *p == PERLLIB_SEP ) {
4407 /* Uncomment the next line for PATH semantics */
4408 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4409 p++;
4410 }
774d564b 4411 }
4412
574c798a 4413 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
774d564b 4414 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4415 (STRLEN)(s - p));
4416 p = s + 1;
4417 }
4418 else {
4419 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4420 p = Nullch; /* break out */
4421 }
bf4acbe4 4422#ifdef MACOS_TRADITIONAL
e69a2255
JH		 4423 if (!strchr(SvPVX(libdir), ':')) {
4424 char buf[256];
4425
4426 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4427 }
bf4acbe4
GS		 4428 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4429 sv_catpv(libdir, ":");
4430#endif
774d564b 4431
dd374669
AL		 4432 /* Do the if() outside the #ifdef to avoid warnings about an unused
4433 parameter. */
4434 if (canrelocate) {
88fe16b2
NC		 4435#ifdef PERL_RELOCATABLE_INC
4436 /*
4437 * Relocatable include entries are marked with a leading .../
4438 *
4439 * The algorithm is
4440 * 0: Remove that leading ".../"
4441 * 1: Remove trailing executable name (anything after the last '/')
4442 * from the perl path to give a perl prefix
4443 * Then
4444 * While the @INC element starts "../" and the prefix ends with a real
4445 * directory (ie not . or ..) chop that real directory off the prefix
4446 * and the leading "../" from the @INC element. ie a logical "../"
4447 * cleanup
4448 * Finally concatenate the prefix and the remainder of the @INC element
4449 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4450 * generates /usr/local/lib/perl5
4451 */
88fe16b2
NC		 4452 char *libpath = SvPVX(libdir);
4453 STRLEN libpath_len = SvCUR(libdir);
4454 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4455 /* Game on! */
4456 SV *caret_X = get_sv("\030", 0);
4457 /* Going to use the SV just as a scratch buffer holding a C
4458 string: */
4459 SV *prefix_sv;
4460 char *prefix;
4461 char *lastslash;
4462
4463 /* $^X is *the* source of taint if tainting is on, hence
4464 SvPOK() won't be true. */
4465 assert(caret_X);
4466 assert(SvPOKp(caret_X));
4467 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
4468 /* Firstly take off the leading .../
4469 If all else fail we'll do the paths relative to the current
4470 directory. */
4471 sv_chop(libdir, libpath + 4);
4472 /* Don't use SvPV as we're intentionally bypassing taining,
4473 mortal copies that the mg_get of tainting creates, and
4474 corruption that seems to come via the save stack.
4475 I guess that the save stack isn't correctly set up yet. */
4476 libpath = SvPVX(libdir);
4477 libpath_len = SvCUR(libdir);
4478
4479 /* This would work more efficiently with memrchr, but as it's
4480 only a GNU extension we'd need to probe for it and
4481 implement our own. Not hard, but maybe not worth it? */
4482
4483 prefix = SvPVX(prefix_sv);
4484 lastslash = strrchr(prefix, '/');
4485
4486 /* First time in with the *lastslash = '\0' we just wipe off
4487 the trailing /perl from (say) /usr/foo/bin/perl
4488 */
4489 if (lastslash) {
4490 SV *tempsv;
4491 while ((*lastslash = '\0'), /* Do that, come what may. */
4492 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4493 && (lastslash = strrchr(prefix, '/')))) {
4494 if (lastslash[1] == '\0'
4495 || (lastslash[1] == '.'
4496 && (lastslash[2] == '/' /* ends "/." */
4497 || (lastslash[2] == '/'
4498 && lastslash[3] == '/' /* or "/.." */
4499 )))) {
4500 /* Prefix ends "/" or "/." or "/..", any of which
4501 are fishy, so don't do any more logical cleanup.
4502 */
4503 break;
4504 }
4505 /* Remove leading "../" from path */
4506 libpath += 3;
4507 libpath_len -= 3;
4508 /* Next iteration round the loop removes the last
4509 directory name from prefix by writing a '\0' in
4510 the while clause. */
4511 }
4512 /* prefix has been terminated with a '\0' to the correct
4513 length. libpath points somewhere into the libdir SV.
4514 We need to join the 2 with '/' and drop the result into
4515 libdir. */
4516 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4517 SvREFCNT_dec(libdir);
4518 /* And this is the new libdir. */
4519 libdir = tempsv;
4520 if (PL_tainting &&
4521 (PL_uid != PL_euid || PL_gid != PL_egid)) {
4522 /* Need to taint reloccated paths if running set ID */
4523 SvTAINTED_on(libdir);
4524 }
4525 }
4526 SvREFCNT_dec(prefix_sv);
4527 }
88fe16b2 4528#endif
dd374669 4529 }
774d564b 4530 /*
4531 * BEFORE pushing libdir onto @INC we may first push version- and
4532 * archname-specific sub-directories.
4533 */
9c8a64f0 4534 if (addsubdirs || addoldvers) {
29d82f8d 4535#ifdef PERL_INC_VERSION_LIST
8353b874
GS		 4536 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4537 const char *incverlist[] = { PERL_INC_VERSION_LIST };
29d82f8d
GS		 4538 const char **incver;
4539#endif
aa689395 4540#ifdef VMS
4541 char *unix;
4542 STRLEN len;
774d564b 4543
2d8e6c8d 4544 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 4545 len = strlen(unix);
4546 while (unix[len-1] == '/') len--; /* Cosmetic */
4547 sv_usepvn(libdir,unix,len);
4548 }
4549 else
bf49b057 4550 PerlIO_printf(Perl_error_log,
aa689395 4551 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 4552 SvPV(libdir,len));
aa689395 4553#endif
9c8a64f0 4554 if (addsubdirs) {
bf4acbe4
GS		 4555#ifdef MACOS_TRADITIONAL
4556#define PERL_AV_SUFFIX_FMT ""
084592ab
CN		 4557#define PERL_ARCH_FMT "%s:"
4558#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
bf4acbe4
GS		 4559#else
4560#define PERL_AV_SUFFIX_FMT "/"
4561#define PERL_ARCH_FMT "/%s"
084592ab 4562#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
bf4acbe4 4563#endif
9c8a64f0 4564 /* .../version/archname if -d .../version/archname */
084592ab 4565 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
9c8a64f0
GS		 4566 libdir,
4567 (int)PERL_REVISION, (int)PERL_VERSION,
4568 (int)PERL_SUBVERSION, ARCHNAME);
ad17a1ae 4569 subdir = S_incpush_if_exists(aTHX_ subdir);
4b03c463 4570
9c8a64f0 4571 /* .../version if -d .../version */
084592ab 4572 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
9c8a64f0
GS		 4573 (int)PERL_REVISION, (int)PERL_VERSION,
4574 (int)PERL_SUBVERSION);
ad17a1ae 4575 subdir = S_incpush_if_exists(aTHX_ subdir);
9c8a64f0
GS		 4576
4577 /* .../archname if -d .../archname */
bf4acbe4 4578 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
ad17a1ae
NC		 4579 subdir = S_incpush_if_exists(aTHX_ subdir);
4580
29d82f8d 4581 }
9c8a64f0 4582
9c8a64f0 4583#ifdef PERL_INC_VERSION_LIST
ccc2aad8 4584 if (addoldvers) {
9c8a64f0
GS		 4585 for (incver = incverlist; *incver; incver++) {
4586 /* .../xxx if -d .../xxx */
bf4acbe4 4587 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
ad17a1ae 4588 subdir = S_incpush_if_exists(aTHX_ subdir);
9c8a64f0
GS		 4589 }
4590 }
29d82f8d 4591#endif
774d564b 4592 }
4593
4594 /* finally push this lib directory on the end of @INC */
3280af22 4595 av_push(GvAVn(PL_incgv), libdir);
774d564b 4596 }
ad17a1ae 4597 if (subdir) {
ef97f5b3 4598 assert (SvREFCNT(subdir) == 1);
ad17a1ae
NC		 4599 SvREFCNT_dec(subdir);
4600 }
34de22dd 4601}
93a17b20 4602
4d1ff10f 4603#ifdef USE_5005THREADS
76e3520e 4604STATIC struct perl_thread *
cea2e8a9 4605S_init_main_thread(pTHX)
199100c8 4606{
c5be433b 4607#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 4608 struct perl_thread *thr;
cea2e8a9 4609#endif
199100c8
MB		 4610 XPV *xpv;
4611
52e1cb5e 4612 Newz(53, thr, 1, struct perl_thread);
533c011a 4613 PL_curcop = &PL_compiling;
c5be433b 4614 thr->interp = PERL_GET_INTERP;
199100c8 4615 thr->cvcache = newHV();
54b9620d 4616 thr->threadsv = newAV();
940cb80d 4617 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 4618 thr->specific = newAV();
4619 thr->flags = THRf_R_JOINABLE;
4620 MUTEX_INIT(&thr->mutex);
4621 /* Handcraft thrsv similarly to mess_sv */
533c011a 4622 New(53, PL_thrsv, 1, SV);
199100c8 4623 Newz(53, xpv, 1, XPV);
533c011a
NIS		 4624 SvFLAGS(PL_thrsv) = SVt_PV;
4625 SvANY(PL_thrsv) = (void*)xpv;
4626 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
f880fe2f 4627 SvPV_set(PL_thrsvr, (char*)thr);
533c011a
NIS		 4628 SvCUR_set(PL_thrsv, sizeof(thr));
4629 SvLEN_set(PL_thrsv, sizeof(thr));
4630 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
4631 thr->oursv = PL_thrsv;
4632 PL_chopset = " \n-";
3967c732 4633 PL_dumpindent = 4;
533c011a
NIS		 4634
4635 MUTEX_LOCK(&PL_threads_mutex);
4636 PL_nthreads++;
199100c8
MB		 4637 thr->tid = 0;
4638 thr->next = thr;
4639 thr->prev = thr;
8dcd6f7b 4640 thr->thr_done = 0;
533c011a 4641 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 4642
4b026b9e 4643#ifdef HAVE_THREAD_INTERN
4f63d024 4644 Perl_init_thread_intern(thr);
235db74f
GS		 4645#endif
4646
4647#ifdef SET_THREAD_SELF
4648 SET_THREAD_SELF(thr);
199100c8
MB		 4649#else
4650 thr->self = pthread_self();
235db74f 4651#endif /* SET_THREAD_SELF */
06d86050 4652 PERL_SET_THX(thr);
199100c8
MB		 4653
4654 /*
411caa50
JH		 4655 * These must come after the thread self setting
4656 * because sv_setpvn does SvTAINT and the taint
4657 * fields thread selfness being set.
199100c8 4658 */
533c011a
NIS		 4659 PL_toptarget = NEWSV(0,0);
4660 sv_upgrade(PL_toptarget, SVt_PVFM);
4661 sv_setpvn(PL_toptarget, "", 0);
4662 PL_bodytarget = NEWSV(0,0);
4663 sv_upgrade(PL_bodytarget, SVt_PVFM);
4664 sv_setpvn(PL_bodytarget, "", 0);
4665 PL_formtarget = PL_bodytarget;
79cb57f6 4666 thr->errsv = newSVpvn("", 0);
78857c3c 4667 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 4668
533c011a 4669 PL_maxscream = -1;
a2efc822 4670 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
0b94c7bb
GS		 4671 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4672 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4673 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4674 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4675 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 4676 PL_regindent = 0;
4677 PL_reginterp_cnt = 0;
5c0ca799 4678
199100c8
MB		 4679 return thr;
4680}
4d1ff10f 4681#endif /* USE_5005THREADS */
199100c8 4682
93a17b20 4683void
864dbfa3 4684Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 4685{
27da23d5 4686 dVAR;
971a9dd3 4687 SV *atsv;
dd374669 4688 const line_t oldline = CopLINE(PL_curcop);
312caa8e 4689 CV *cv;
22921e25 4690 STRLEN len;
6224f72b 4691 int ret;
db36c5a1 4692 dJMPENV;
93a17b20 4693
e1ec3a88 4694 while (av_len(paramList) >= 0) {
312caa8e 4695 cv = (CV*)av_shift(paramList);
ece599bd
RGS		 4696 if (PL_savebegin) {
4697 if (paramList == PL_beginav) {
059a8bb7 4698 /* save PL_beginav for compiler */
ece599bd
RGS		 4699 if (! PL_beginav_save)
4700 PL_beginav_save = newAV();
4701 av_push(PL_beginav_save, (SV*)cv);
4702 }
4703 else if (paramList == PL_checkav) {
4704 /* save PL_checkav for compiler */
4705 if (! PL_checkav_save)
4706 PL_checkav_save = newAV();
4707 av_push(PL_checkav_save, (SV*)cv);
4708 }
059a8bb7
JH		 4709 } else {
4710 SAVEFREESV(cv);
4711 }
14dd3ad8 4712 JMPENV_PUSH(ret);
6224f72b 4713 switch (ret) {
312caa8e 4714 case 0:
14dd3ad8 4715 call_list_body(cv);
971a9dd3 4716 atsv = ERRSV;
10516c54 4717 (void)SvPV_const(atsv, len);
312caa8e
CS		 4718 if (len) {
4719 PL_curcop = &PL_compiling;
57843af0 4720 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 4721 if (paramList == PL_beginav)
4722 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4723 else
4f25aa18
GS		 4724 Perl_sv_catpvf(aTHX_ atsv,
4725 "%s failed--call queue aborted",
7d30b5c4 4726 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4727 : paramList == PL_initav ? "INIT"
4728 : "END");
312caa8e
CS		 4729 while (PL_scopestack_ix > oldscope)
4730 LEAVE;
14dd3ad8 4731 JMPENV_POP;
35c1215d 4732 Perl_croak(aTHX_ "%"SVf"", atsv);
a0d0e21e 4733 }
85e6fe83 4734 break;
6224f72b 4735 case 1:
f86702cc 4736 STATUS_ALL_FAILURE;
85e6fe83 4737 /* FALL THROUGH */
6224f72b 4738 case 2:
85e6fe83 4739 /* my_exit() was called */
3280af22 4740 while (PL_scopestack_ix > oldscope)
2ae324a7 4741 LEAVE;
84902520 4742 FREETMPS;
3280af22 4743 PL_curstash = PL_defstash;
3280af22 4744 PL_curcop = &PL_compiling;
57843af0 4745 CopLINE_set(PL_curcop, oldline);
14dd3ad8 4746 JMPENV_POP;
cc3604b1 4747 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 4748 if (paramList == PL_beginav)
cea2e8a9 4749 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 4750 else
4f25aa18 4751 Perl_croak(aTHX_ "%s failed--call queue aborted",
7d30b5c4 4752 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4753 : paramList == PL_initav ? "INIT"
4754 : "END");
85e6fe83 4755 }
f86702cc 4756 my_exit_jump();
85e6fe83 4757 /* NOTREACHED */
6224f72b 4758 case 3:
312caa8e
CS		 4759 if (PL_restartop) {
4760 PL_curcop = &PL_compiling;
57843af0 4761 CopLINE_set(PL_curcop, oldline);
312caa8e 4762 JMPENV_JUMP(3);
85e6fe83 4763 }
bf49b057 4764 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 4765 FREETMPS;
4766 break;
8990e307 4767 }
14dd3ad8 4768 JMPENV_POP;
93a17b20 4769 }
93a17b20 4770}
93a17b20 4771
14dd3ad8
GS		 4772STATIC void *
4773S_call_list_body(pTHX_ CV *cv)
4774{
312caa8e 4775 PUSHMARK(PL_stack_sp);
864dbfa3 4776 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 4777 return NULL;
4778}
4779
f86702cc 4780void
864dbfa3 4781Perl_my_exit(pTHX_ U32 status)
f86702cc 4782{
8b73bbec 4783 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 4784 thr, (unsigned long) status));
f86702cc 4785 switch (status) {
4786 case 0:
4787 STATUS_ALL_SUCCESS;
4788 break;
4789 case 1:
4790 STATUS_ALL_FAILURE;
4791 break;
4792 default:
4793 STATUS_NATIVE_SET(status);
4794 break;
4795 }
4796 my_exit_jump();
4797}
4798
4799void
864dbfa3 4800Perl_my_failure_exit(pTHX)
f86702cc 4801{
4802#ifdef VMS
4803 if (vaxc$errno & 1) {
4fdae800 4804 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4805 STATUS_NATIVE_SET(44);
f86702cc 4806 }
4807 else {
69232efa 4808 if (!vaxc$errno) /* unlikely */
4fdae800 4809 STATUS_NATIVE_SET(44);
f86702cc 4810 else
4fdae800 4811 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 4812 }
4813#else
9b599b2a 4814 int exitstatus;
f86702cc 4815 if (errno & 255)
e5218da5 4816 STATUS_UNIX_SET(errno);
9b599b2a 4817 else {
e5218da5 4818 exitstatus = STATUS_UNIX >> 8;
9b599b2a 4819 if (exitstatus & 255)
e5218da5 4820 STATUS_UNIX_SET(exitstatus);
9b599b2a 4821 else
e5218da5 4822 STATUS_UNIX_SET(255);
9b599b2a 4823 }
f86702cc 4824#endif
4825 my_exit_jump();
93a17b20
LW		 4826}
4827
76e3520e 4828STATIC void
cea2e8a9 4829S_my_exit_jump(pTHX)
f86702cc 4830{
27da23d5 4831 dVAR;
c09156bb 4832 register PERL_CONTEXT *cx;
f86702cc 4833 I32 gimme;
4834 SV **newsp;
4835
3280af22
NIS		 4836 if (PL_e_script) {
4837 SvREFCNT_dec(PL_e_script);
4838 PL_e_script = Nullsv;
f86702cc 4839 }
4840
3280af22 4841 POPSTACK_TO(PL_mainstack);
f86702cc 4842 if (cxstack_ix >= 0) {
4843 if (cxstack_ix > 0)
4844 dounwind(0);
3280af22 4845 POPBLOCK(cx,PL_curpm);
f86702cc 4846 LEAVE;
4847 }
ff0cee69 4848
6224f72b 4849 JMPENV_JUMP(2);
f86702cc 4850}
873ef191 4851
0cb96387 4852static I32
acfe0abc 4853read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
873ef191 4854{
848ef955 4855 const char *p, *nl;
dd374669
AL		 4856 (void)idx;
4857 (void)maxlen;
4858
848ef955 4859 p = SvPVX_const(PL_e_script);
873ef191 4860 nl = strchr(p, '\n');
3280af22 4861 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 4862 if (nl-p == 0) {
0cb96387 4863 filter_del(read_e_script);
873ef191 4864 return 0;
7dfe3f66 4865 }
873ef191 4866 sv_catpvn(buf_sv, p, nl-p);
3280af22 4867 sv_chop(PL_e_script, nl);
873ef191
GS		 4868 return 1;
4869}
66610fdd
RGS		 4870
4871/*
4872 * Local variables:
4873 * c-indentation-style: bsd
4874 * c-basic-offset: 4
4875 * indent-tabs-mode: t
4876 * End:
4877 *
37442d52
RGS		 4878 * ex: set ts=8 sts=4 sw=4 noet:
4879 */
Unnamed repository; edit this file 'description' to name the repository.