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