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