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