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