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