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