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