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