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
Make usemallocwrap a Configure-time question. Default is yes for
[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;
ae3f3efd
PS		 1191/* PSz 18 Feb 04 fdscript now global, keep from confusion */
1192 int dummy_fdscript = -1;
312caa8e 1193
ae3f3efd
PS		 1194 PL_fdscript = -1;
1195 PL_suidscript = -1;
3280af22 1196 sv_setpvn(PL_linestr,"",0);
79cb57f6 1197 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 1198 SAVEFREESV(sv);
1199 init_main_stash();
54310121 1200
6224f72b
GS		 1201 for (argc--,argv++; argc > 0; argc--,argv++) {
1202 if (argv[0][0] != '-' || !argv[0][1])
1203 break;
1204#ifdef DOSUID
1205 if (*validarg)
1206 validarg = " PHOOEY ";
1207 else
1208 validarg = argv[0];
ae3f3efd
PS		 1209 /*
1210 * Can we rely on the kernel to start scripts with argv[1] set to
1211 * contain all #! line switches (the whole line)? (argv[0] is set to
1212 * the interpreter name, argv[2] to the script name; argv[3] and
1213 * above may contain other arguments.)
1214 */
13281fa4 1215#endif
6224f72b
GS		 1216 s = argv[0]+1;
1217 reswitch:
1218 switch (*s) {
729a02f2 1219 case 'C':
1d5472a9
GS		 1220#ifndef PERL_STRICT_CR
1221 case '\r':
1222#endif
6224f72b
GS		 1223 case ' ':
1224 case '0':
1225 case 'F':
1226 case 'a':
1227 case 'c':
1228 case 'd':
1229 case 'D':
1230 case 'h':
1231 case 'i':
1232 case 'l':
1233 case 'M':
1234 case 'm':
1235 case 'n':
1236 case 'p':
1237 case 's':
1238 case 'u':
1239 case 'U':
1240 case 'v':
599cee73
PM		 1241 case 'W':
1242 case 'X':
6224f72b 1243 case 'w':
06492da6 1244 case 'A':
155aba94 1245 if ((s = moreswitches(s)))
6224f72b
GS		 1246 goto reswitch;
1247 break;
33b78306 1248
1dbad523 1249 case 't':
22f7c9c9 1250 CHECK_MALLOC_TOO_LATE_FOR('t');
317ea90d
MS		 1251 if( !PL_tainting ) {
1252 PL_taint_warn = TRUE;
1253 PL_tainting = TRUE;
1254 }
1255 s++;
1256 goto reswitch;
6224f72b 1257 case 'T':
22f7c9c9 1258 CHECK_MALLOC_TOO_LATE_FOR('T');
3280af22 1259 PL_tainting = TRUE;
317ea90d 1260 PL_taint_warn = FALSE;
6224f72b
GS		 1261 s++;
1262 goto reswitch;
f86702cc 1263
6224f72b 1264 case 'e':
bf4acbe4
GS		 1265#ifdef MACOS_TRADITIONAL
1266 /* ignore -e for Dev:Pseudo argument */
1267 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1268 break;
bf4acbe4 1269#endif
ae3f3efd 1270 forbid_setid("-e");
3280af22 1271 if (!PL_e_script) {
79cb57f6 1272 PL_e_script = newSVpvn("",0);
0cb96387 1273 filter_add(read_e_script, NULL);
6224f72b
GS		 1274 }
1275 if (*++s)
3280af22 1276 sv_catpv(PL_e_script, s);
6224f72b 1277 else if (argv[1]) {
3280af22 1278 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1279 argc--,argv++;
1280 }
1281 else
cea2e8a9 1282 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1283 sv_catpv(PL_e_script, "\n");
6224f72b 1284 break;
afe37c7d 1285
6224f72b
GS		 1286 case 'I': /* -I handled both here and in moreswitches() */
1287 forbid_setid("-I");
1288 if (!*++s && (s=argv[1]) != Nullch) {
1289 argc--,argv++;
1290 }
6224f72b 1291 if (s && *s) {
0df16ed7
GS		 1292 char *p;
1293 STRLEN len = strlen(s);
1294 p = savepvn(s, len);
574c798a 1295 incpush(p, TRUE, TRUE, FALSE);
0df16ed7
GS		 1296 sv_catpvn(sv, "-I", 2);
1297 sv_catpvn(sv, p, len);
1298 sv_catpvn(sv, " ", 1);
6224f72b 1299 Safefree(p);
0df16ed7
GS		 1300 }
1301 else
a67e862a 1302 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1303 break;
1304 case 'P':
1305 forbid_setid("-P");
3280af22 1306 PL_preprocess = TRUE;
6224f72b
GS		 1307 s++;
1308 goto reswitch;
1309 case 'S':
1310 forbid_setid("-S");
1311 dosearch = TRUE;
1312 s++;
1313 goto reswitch;
1314 case 'V':
3280af22
NIS		 1315 if (!PL_preambleav)
1316 PL_preambleav = newAV();
1317 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1318 if (*++s != ':') {
3280af22 1319 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1320#ifdef VMS
6b88bc9c 1321 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1322#else
3280af22 1323 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1324#endif
3280af22 1325 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1326# ifdef DEBUGGING
3280af22 1327 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1328# endif
6224f72b 1329# ifdef MULTIPLICITY
8f872242 1330 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1331# endif
4d1ff10f
AB		 1332# ifdef USE_5005THREADS
1333 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1334# endif
ac5e8965
JH		 1335# ifdef USE_ITHREADS
1336 sv_catpv(PL_Sv," USE_ITHREADS");
1337# endif
10cc9d2a
JH		 1338# ifdef USE_64_BIT_INT
1339 sv_catpv(PL_Sv," USE_64_BIT_INT");
1340# endif
1341# ifdef USE_64_BIT_ALL
1342 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1343# endif
1344# ifdef USE_LONG_DOUBLE
1345 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1346# endif
53430762
JH		 1347# ifdef USE_LARGE_FILES
1348 sv_catpv(PL_Sv," USE_LARGE_FILES");
1349# endif
ac5e8965
JH		 1350# ifdef USE_SOCKS
1351 sv_catpv(PL_Sv," USE_SOCKS");
1352# endif
b363f7ed
GS		 1353# ifdef PERL_IMPLICIT_CONTEXT
1354 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1355# endif
1356# ifdef PERL_IMPLICIT_SYS
1357 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1358# endif
3280af22 1359 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1360
6224f72b
GS		 1361#if defined(LOCAL_PATCH_COUNT)
1362 if (LOCAL_PATCH_COUNT > 0) {
1363 int i;
3280af22 1364 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1365 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1366 if (PL_localpatches[i])
cea2e8a9 1367 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS		 1368 }
1369 }
1370#endif
cea2e8a9 1371 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1372#ifdef __DATE__
1373# ifdef __TIME__
cea2e8a9 1374 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1375# else
cea2e8a9 1376 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1377# endif
1378#endif
3280af22 1379 sv_catpv(PL_Sv, "; \
6224f72b 1380$\"=\"\\n \"; \
69fcd688
JH		 1381@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1382#ifdef __CYGWIN__
1383 sv_catpv(PL_Sv,"\
1384push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1385#endif
1386 sv_catpv(PL_Sv, "\
6224f72b
GS		 1387print \" \\%ENV:\\n @env\\n\" if @env; \
1388print \" \\@INC:\\n @INC\\n\";");
1389 }
1390 else {
3280af22
NIS		 1391 PL_Sv = newSVpv("config_vars(qw(",0);
1392 sv_catpv(PL_Sv, ++s);
1393 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1394 s += strlen(s);
1395 }
3280af22 1396 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1397 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1398 goto reswitch;
1399 case 'x':
3280af22 1400 PL_doextract = TRUE;
6224f72b
GS		 1401 s++;
1402 if (*s)
f4c556ac 1403 cddir = s;
6224f72b
GS		 1404 break;
1405 case 0:
1406 break;
1407 case '-':
1408 if (!*++s || isSPACE(*s)) {
1409 argc--,argv++;
1410 goto switch_end;
1411 }
1412 /* catch use of gnu style long options */
1413 if (strEQ(s, "version")) {
1414 s = "v";
1415 goto reswitch;
1416 }
1417 if (strEQ(s, "help")) {
1418 s = "h";
1419 goto reswitch;
1420 }
1421 s--;
1422 /* FALL THROUGH */
1423 default:
cea2e8a9 1424 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1425 }
1426 }
6224f72b 1427 switch_end:
54310121 1428
f675dbe5
CB		 1429 if (
1430#ifndef SECURE_INTERNAL_GETENV
1431 !PL_tainting &&
1432#endif
cf756827 1433 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1434 {
cf756827 1435 char *popt = s;
74288ac8
GS		 1436 while (isSPACE(*s))
1437 s++;
317ea90d 1438 if (*s == '-' && *(s+1) == 'T') {
22f7c9c9 1439 CHECK_MALLOC_TOO_LATE_FOR('T');
74288ac8 1440 PL_tainting = TRUE;
317ea90d
MS		 1441 PL_taint_warn = FALSE;
1442 }
74288ac8 1443 else {
cf756827 1444 char *popt_copy = Nullch;
74288ac8 1445 while (s && *s) {
4ea8f8fb 1446 char *d;
74288ac8
GS		 1447 while (isSPACE(*s))
1448 s++;
1449 if (*s == '-') {
1450 s++;
1451 if (isSPACE(*s))
1452 continue;
1453 }
4ea8f8fb 1454 d = s;
74288ac8
GS		 1455 if (!*s)
1456 break;
06492da6 1457 if (!strchr("DIMUdmtwA", *s))
cea2e8a9 1458 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1459 while (++s && *s) {
1460 if (isSPACE(*s)) {
cf756827
GS		 1461 if (!popt_copy) {
1462 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1463 s = popt_copy + (s - popt);
1464 d = popt_copy + (d - popt);
1465 }
4ea8f8fb
MS		 1466 *s++ = '\0';
1467 break;
1468 }
1469 }
1c4db469 1470 if (*d == 't') {
317ea90d
MS		 1471 if( !PL_tainting ) {
1472 PL_taint_warn = TRUE;
1473 PL_tainting = TRUE;
1474 }
1c4db469
RGS		 1475 } else {
1476 moreswitches(d);
1477 }
6224f72b 1478 }
6224f72b
GS		 1479 }
1480 }
a0d0e21e 1481
317ea90d
MS		 1482 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1483 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1484 }
1485
6224f72b
GS		 1486 if (!scriptname)
1487 scriptname = argv[0];
3280af22 1488 if (PL_e_script) {
6224f72b
GS		 1489 argc++,argv--;
1490 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1491 }
1492 else if (scriptname == Nullch) {
1493#ifdef MSDOS
1494 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1495 moreswitches("h");
1496#endif
1497 scriptname = "-";
1498 }
1499
1500 init_perllib();
1501
ae3f3efd 1502 open_script(scriptname,dosearch,sv,&dummy_fdscript);
6224f72b 1503
ae3f3efd 1504 validate_suid(validarg, scriptname,dummy_fdscript);
6224f72b 1505
64ca3a65 1506#ifndef PERL_MICRO
0b5b802d
GS		 1507#if defined(SIGCHLD) || defined(SIGCLD)
1508 {
1509#ifndef SIGCHLD
1510# define SIGCHLD SIGCLD
1511#endif
1512 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1513 if (sigstate == SIG_IGN) {
1514 if (ckWARN(WARN_SIGNAL))
9014280d 1515 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1516 "Can't ignore signal CHLD, forcing to default");
1517 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1518 }
1519 }
1520#endif
64ca3a65 1521#endif
0b5b802d 1522
bf4acbe4
GS		 1523#ifdef MACOS_TRADITIONAL
1524 if (PL_doextract || gMacPerl_AlwaysExtract) {
1525#else
f4c556ac 1526 if (PL_doextract) {
bf4acbe4 1527#endif
6224f72b 1528 find_beginning();
f4c556ac
GS		 1529 if (cddir && PerlDir_chdir(cddir) < 0)
1530 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1531
1532 }
6224f72b 1533
3280af22
NIS		 1534 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1535 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1536 CvUNIQUE_on(PL_compcv);
1537
dd2155a4 1538 CvPADLIST(PL_compcv) = pad_new(0);
4d1ff10f 1539#ifdef USE_5005THREADS
533c011a
NIS		 1540 CvOWNER(PL_compcv) = 0;
1541 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1542 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1543#endif /* USE_5005THREADS */
6224f72b 1544
0c4f7ff0 1545 boot_core_PerlIO();
6224f72b 1546 boot_core_UNIVERSAL();
09bef843 1547 boot_core_xsutils();
6224f72b
GS		 1548
1549 if (xsinit)
acfe0abc 1550 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1551#ifndef PERL_MICRO
ed79a026 1552#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1553 init_os_extras();
6224f72b 1554#endif
64ca3a65 1555#endif
6224f72b 1556
29209bc5 1557#ifdef USE_SOCKS
1b9c9cf5
DH		 1558# ifdef HAS_SOCKS5_INIT
1559 socks5_init(argv[0]);
1560# else
29209bc5 1561 SOCKSinit(argv[0]);
1b9c9cf5 1562# endif
ac27b0f5 1563#endif
29209bc5 1564
6224f72b
GS		 1565 init_predump_symbols();
1566 /* init_postdump_symbols not currently designed to be called */
1567 /* more than once (ENV isn't cleared first, for example) */
1568 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1569 if (!PL_do_undump)
6224f72b
GS		 1570 init_postdump_symbols(argc,argv,env);
1571
a05d7ebb
JH		 1572 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1573 * PL_utf8locale is conditionally turned on by
085a54d9 1574 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 1575 * look like the user wants to use UTF-8. */
06e66572
JH		 1576 if (PL_unicode) {
1577 /* Requires init_predump_symbols(). */
a05d7ebb 1578 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH		 1579 IO* io;
1580 PerlIO* fp;
1581 SV* sv;
1582
a05d7ebb 1583 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 1584 * and the default open disciplines. */
a05d7ebb
JH		 1585 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1586 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1587 (fp = IoIFP(io)))
1588 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1589 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1590 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1591 (fp = IoOFP(io)))
1592 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1593 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1594 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1595 (fp = IoOFP(io)))
1596 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1597 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1598 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1599 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1600 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1601 if (in) {
1602 if (out)
1603 sv_setpvn(sv, ":utf8\0:utf8", 11);
1604 else
1605 sv_setpvn(sv, ":utf8\0", 6);
1606 }
1607 else if (out)
1608 sv_setpvn(sv, "\0:utf8", 6);
1609 SvSETMAGIC(sv);
1610 }
b310b053
JH		 1611 }
1612 }
1613
4ffa73a3
JH		 1614 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1615 if (strEQ(s, "unsafe"))
1616 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1617 else if (strEQ(s, "safe"))
1618 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1619 else
1620 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1621 }
1622
6224f72b
GS		 1623 init_lexer();
1624
1625 /* now parse the script */
1626
93189314 1627 SETERRNO(0,SS_NORMAL);
3280af22 1628 PL_error_count = 0;
bf4acbe4
GS		 1629#ifdef MACOS_TRADITIONAL
1630 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1631 if (PL_minus_c)
1632 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1633 else {
1634 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1635 MacPerl_MPWFileName(PL_origfilename));
1636 }
1637 }
1638#else
3280af22
NIS		 1639 if (yyparse() || PL_error_count) {
1640 if (PL_minus_c)
cea2e8a9 1641 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1642 else {
cea2e8a9 1643 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1644 PL_origfilename);
6224f72b
GS		 1645 }
1646 }
bf4acbe4 1647#endif
57843af0 1648 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1649 PL_curstash = PL_defstash;
1650 PL_preprocess = FALSE;
1651 if (PL_e_script) {
1652 SvREFCNT_dec(PL_e_script);
1653 PL_e_script = Nullsv;
6224f72b
GS		 1654 }
1655
3280af22 1656 if (PL_do_undump)
6224f72b
GS		 1657 my_unexec();
1658
57843af0
GS		 1659 if (isWARN_ONCE) {
1660 SAVECOPFILE(PL_curcop);
1661 SAVECOPLINE(PL_curcop);
3280af22 1662 gv_check(PL_defstash);
57843af0 1663 }
6224f72b
GS		 1664
1665 LEAVE;
1666 FREETMPS;
1667
1668#ifdef MYMALLOC
1669 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1670 dump_mstats("after compilation:");
1671#endif
1672
1673 ENTER;
3280af22 1674 PL_restartop = 0;
312caa8e 1675 return NULL;
6224f72b
GS		 1676}
1677
954c1994
GS		 1678/*
1679=for apidoc perl_run
1680
1681Tells a Perl interpreter to run. See L<perlembed>.
1682
1683=cut
1684*/
1685
6224f72b 1686int
0cb96387 1687perl_run(pTHXx)
6224f72b 1688{
6224f72b 1689 I32 oldscope;
14dd3ad8 1690 int ret = 0;
db36c5a1 1691 dJMPENV;
4d1ff10f 1692#ifdef USE_5005THREADS
cea2e8a9
GS		 1693 dTHX;
1694#endif
6224f72b 1695
3280af22 1696 oldscope = PL_scopestack_ix;
96e176bf
CL		 1697#ifdef VMS
1698 VMSISH_HUSHED = 0;
1699#endif
6224f72b 1700
14dd3ad8 1701#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1702 redo_body:
14dd3ad8
GS		 1703 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1704#else
1705 JMPENV_PUSH(ret);
1706#endif
6224f72b
GS		 1707 switch (ret) {
1708 case 1:
1709 cxstack_ix = -1; /* start context stack again */
312caa8e 1710 goto redo_body;
14dd3ad8
GS		 1711 case 0: /* normal completion */
1712#ifndef PERL_FLEXIBLE_EXCEPTIONS
1713 redo_body:
1714 run_body(oldscope);
1715#endif
1716 /* FALL THROUGH */
1717 case 2: /* my_exit() */
3280af22 1718 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1719 LEAVE;
1720 FREETMPS;
3280af22 1721 PL_curstash = PL_defstash;
3a1ee7e8 1722 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1723 PL_endav && !PL_minus_c)
1724 call_list(oldscope, PL_endav);
6224f72b
GS		 1725#ifdef MYMALLOC
1726 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1727 dump_mstats("after execution: ");
1728#endif
14dd3ad8
GS		 1729 ret = STATUS_NATIVE_EXPORT;
1730 break;
6224f72b 1731 case 3:
312caa8e
CS		 1732 if (PL_restartop) {
1733 POPSTACK_TO(PL_mainstack);
1734 goto redo_body;
6224f72b 1735 }
bf49b057 1736 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1737 FREETMPS;
14dd3ad8
GS		 1738 ret = 1;
1739 break;
6224f72b
GS		 1740 }
1741
14dd3ad8
GS		 1742 JMPENV_POP;
1743 return ret;
312caa8e
CS		 1744}
1745
14dd3ad8 1746#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1747STATIC void *
14dd3ad8 1748S_vrun_body(pTHX_ va_list args)
312caa8e 1749{
312caa8e
CS		 1750 I32 oldscope = va_arg(args, I32);
1751
14dd3ad8
GS		 1752 return run_body(oldscope);
1753}
1754#endif
1755
1756
1757STATIC void *
1758S_run_body(pTHX_ I32 oldscope)
1759{
6224f72b 1760 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1761 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1762
3280af22 1763 if (!PL_restartop) {
6224f72b 1764 DEBUG_x(dump_all());
ecae49c0
NC		 1765 if (!DEBUG_q_TEST)
1766 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1767 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1768 PTR2UV(thr)));
6224f72b 1769
3280af22 1770 if (PL_minus_c) {
bf4acbe4 1771#ifdef MACOS_TRADITIONAL
e69a2255
JH		 1772 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1773 (gMacPerl_ErrorFormat ? "# " : ""),
1774 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1775#else
bf49b057 1776 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1777#endif
6224f72b
GS		 1778 my_exit(0);
1779 }
3280af22 1780 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1781 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1782 if (PL_initav)
1783 call_list(oldscope, PL_initav);
6224f72b
GS		 1784 }
1785
1786 /* do it */
1787
3280af22 1788 if (PL_restartop) {
533c011a 1789 PL_op = PL_restartop;
3280af22 1790 PL_restartop = 0;
cea2e8a9 1791 CALLRUNOPS(aTHX);
6224f72b 1792 }
3280af22
NIS		 1793 else if (PL_main_start) {
1794 CvDEPTH(PL_main_cv) = 1;
533c011a 1795 PL_op = PL_main_start;
cea2e8a9 1796 CALLRUNOPS(aTHX);
6224f72b
GS		 1797 }
1798
f6b3007c
JH		 1799 my_exit(0);
1800 /* NOTREACHED */
312caa8e 1801 return NULL;
6224f72b
GS		 1802}
1803
954c1994 1804/*
ccfc67b7
JH		 1805=head1 SV Manipulation Functions
1806
954c1994
GS		 1807=for apidoc p||get_sv
1808
1809Returns the SV of the specified Perl scalar. If C<create> is set and the
1810Perl variable does not exist then it will be created. If C<create> is not
1811set and the variable does not exist then NULL is returned.
1812
1813=cut
1814*/
1815
6224f72b 1816SV*
864dbfa3 1817Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1818{
1819 GV *gv;
4d1ff10f 1820#ifdef USE_5005THREADS
6224f72b
GS		 1821 if (name[1] == '\0' && !isALPHA(name[0])) {
1822 PADOFFSET tmp = find_threadsv(name);
411caa50 1823 if (tmp != NOT_IN_PAD)
6224f72b 1824 return THREADSV(tmp);
6224f72b 1825 }
4d1ff10f 1826#endif /* USE_5005THREADS */
6224f72b
GS		 1827 gv = gv_fetchpv(name, create, SVt_PV);
1828 if (gv)
1829 return GvSV(gv);
1830 return Nullsv;
1831}
1832
954c1994 1833/*
ccfc67b7
JH		 1834=head1 Array Manipulation Functions
1835
954c1994
GS		 1836=for apidoc p||get_av
1837
1838Returns the AV of the specified Perl array. If C<create> is set and the
1839Perl variable does not exist then it will be created. If C<create> is not
1840set and the variable does not exist then NULL is returned.
1841
1842=cut
1843*/
1844
6224f72b 1845AV*
864dbfa3 1846Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1847{
1848 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1849 if (create)
1850 return GvAVn(gv);
1851 if (gv)
1852 return GvAV(gv);
1853 return Nullav;
1854}
1855
954c1994 1856/*
ccfc67b7
JH		 1857=head1 Hash Manipulation Functions
1858
954c1994
GS		 1859=for apidoc p||get_hv
1860
1861Returns the HV of the specified Perl hash. If C<create> is set and the
1862Perl variable does not exist then it will be created. If C<create> is not
1863set and the variable does not exist then NULL is returned.
1864
1865=cut
1866*/
1867
6224f72b 1868HV*
864dbfa3 1869Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1870{
a0d0e21e
LW		 1871 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1872 if (create)
1873 return GvHVn(gv);
1874 if (gv)
1875 return GvHV(gv);
1876 return Nullhv;
1877}
1878
954c1994 1879/*
ccfc67b7
JH		 1880=head1 CV Manipulation Functions
1881
954c1994
GS		 1882=for apidoc p||get_cv
1883
1884Returns the CV of the specified Perl subroutine. If C<create> is set and
1885the Perl subroutine does not exist then it will be declared (which has the
1886same effect as saying C<sub name;>). If C<create> is not set and the
1887subroutine does not exist then NULL is returned.
1888
1889=cut
1890*/
1891
a0d0e21e 1892CV*
864dbfa3 1893Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1894{
1895 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1896 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 1897 /* XXX this is probably not what they think they're getting.
1898 * It has the same effect as "sub name;", i.e. just a forward
1899 * declaration! */
8ebc5c01 1900 if (create && !GvCVu(gv))
774d564b 1901 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1902 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1903 Nullop,
a0d0e21e
LW		 1904 Nullop);
1905 if (gv)
8ebc5c01 1906 return GvCVu(gv);
a0d0e21e
LW		 1907 return Nullcv;
1908}
1909
79072805
LW		 1910/* Be sure to refetch the stack pointer after calling these routines. */
1911
954c1994 1912/*
ccfc67b7
JH		 1913
1914=head1 Callback Functions
1915
954c1994
GS		 1916=for apidoc p||call_argv
1917
1918Performs a callback to the specified Perl sub. See L<perlcall>.
1919
1920=cut
1921*/
1922
a0d0e21e 1923I32
864dbfa3 1924Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 1925
8ac85365
NIS		 1926 /* See G_* flags in cop.h */
1927 /* null terminated arg list */
8990e307 1928{
a0d0e21e 1929 dSP;
8990e307 1930
924508f0 1931 PUSHMARK(SP);
a0d0e21e 1932 if (argv) {
8990e307 1933 while (*argv) {
a0d0e21e 1934 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 1935 argv++;
1936 }
a0d0e21e 1937 PUTBACK;
8990e307 1938 }
864dbfa3 1939 return call_pv(sub_name, flags);
8990e307
LW		 1940}
1941
954c1994
GS		 1942/*
1943=for apidoc p||call_pv
1944
1945Performs a callback to the specified Perl sub. See L<perlcall>.
1946
1947=cut
1948*/
1949
a0d0e21e 1950I32
864dbfa3 1951Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 1952 /* name of the subroutine */
1953 /* See G_* flags in cop.h */
a0d0e21e 1954{
864dbfa3 1955 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 1956}
1957
954c1994
GS		 1958/*
1959=for apidoc p||call_method
1960
1961Performs a callback to the specified Perl method. The blessed object must
1962be on the stack. See L<perlcall>.
1963
1964=cut
1965*/
1966
a0d0e21e 1967I32
864dbfa3 1968Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 1969 /* name of the subroutine */
1970 /* See G_* flags in cop.h */
a0d0e21e 1971{
968b3946 1972 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 1973}
1974
1975/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 1976/*
1977=for apidoc p||call_sv
1978
1979Performs a callback to the Perl sub whose name is in the SV. See
1980L<perlcall>.
1981
1982=cut
1983*/
1984
a0d0e21e 1985I32
864dbfa3 1986Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 1987 /* See G_* flags in cop.h */
a0d0e21e 1988{
924508f0 1989 dSP;
a0d0e21e 1990 LOGOP myop; /* fake syntax tree node */
968b3946 1991 UNOP method_op;
aa689395 1992 I32 oldmark;
13689cfe 1993 volatile I32 retval = 0;
a0d0e21e 1994 I32 oldscope;
54310121 1995 bool oldcatch = CATCH_GET;
6224f72b 1996 int ret;
533c011a 1997 OP* oldop = PL_op;
db36c5a1 1998 dJMPENV;
1e422769 1999
a0d0e21e
LW		 2000 if (flags & G_DISCARD) {
2001 ENTER;
2002 SAVETMPS;
2003 }
2004
aa689395 2005 Zero(&myop, 1, LOGOP);
54310121 2006 myop.op_next = Nullop;
f51d4af5 2007 if (!(flags & G_NOARGS))
aa689395 2008 myop.op_flags |= OPf_STACKED;
54310121 2009 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2010 (flags & G_ARRAY) ? OPf_WANT_LIST :
2011 OPf_WANT_SCALAR);
462e5cf6 2012 SAVEOP();
533c011a 2013 PL_op = (OP*)&myop;
aa689395 2014
3280af22
NIS		 2015 EXTEND(PL_stack_sp, 1);
2016 *++PL_stack_sp = sv;
aa689395 2017 oldmark = TOPMARK;
3280af22 2018 oldscope = PL_scopestack_ix;
a0d0e21e 2019
3280af22 2020 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 2021 /* Handle first BEGIN of -d. */
3280af22 2022 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 2023 /* Try harder, since this may have been a sighandler, thus
2024 * curstash may be meaningless. */
3280af22 2025 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 2026 && !(flags & G_NODEBUG))
533c011a 2027 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2028
968b3946
GS		 2029 if (flags & G_METHOD) {
2030 Zero(&method_op, 1, UNOP);
2031 method_op.op_next = PL_op;
2032 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2033 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 2034 PL_op = (OP*)&method_op;
968b3946
GS		 2035 }
2036
312caa8e 2037 if (!(flags & G_EVAL)) {
0cdb2077 2038 CATCH_SET(TRUE);
14dd3ad8 2039 call_body((OP*)&myop, FALSE);
312caa8e 2040 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 2041 CATCH_SET(oldcatch);
312caa8e
CS		 2042 }
2043 else {
d78bda3d 2044 myop.op_other = (OP*)&myop;
3280af22 2045 PL_markstack_ptr--;
4633a7c4
LW		 2046 /* we're trying to emulate pp_entertry() here */
2047 {
c09156bb 2048 register PERL_CONTEXT *cx;
54310121 2049 I32 gimme = GIMME_V;
ac27b0f5 2050
4633a7c4
LW		 2051 ENTER;
2052 SAVETMPS;
ac27b0f5 2053
968b3946 2054 push_return(Nullop);
1d76a5c3 2055 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 2056 PUSHEVAL(cx, 0, 0);
533c011a 2057 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 2058
faef0170 2059 PL_in_eval = EVAL_INEVAL;
4633a7c4 2060 if (flags & G_KEEPERR)
faef0170 2061 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 2062 else
38a03e6e 2063 sv_setpv(ERRSV,"");
4633a7c4 2064 }
3280af22 2065 PL_markstack_ptr++;
a0d0e21e 2066
14dd3ad8
GS		 2067#ifdef PERL_FLEXIBLE_EXCEPTIONS
2068 redo_body:
2069 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 2070 (OP*)&myop, FALSE);
14dd3ad8
GS		 2071#else
2072 JMPENV_PUSH(ret);
2073#endif
6224f72b
GS		 2074 switch (ret) {
2075 case 0:
14dd3ad8
GS		 2076#ifndef PERL_FLEXIBLE_EXCEPTIONS
2077 redo_body:
2078 call_body((OP*)&myop, FALSE);
2079#endif
312caa8e
CS		 2080 retval = PL_stack_sp - (PL_stack_base + oldmark);
2081 if (!(flags & G_KEEPERR))
2082 sv_setpv(ERRSV,"");
a0d0e21e 2083 break;
6224f72b 2084 case 1:
f86702cc 2085 STATUS_ALL_FAILURE;
a0d0e21e 2086 /* FALL THROUGH */
6224f72b 2087 case 2:
a0d0e21e 2088 /* my_exit() was called */
3280af22 2089 PL_curstash = PL_defstash;
a0d0e21e 2090 FREETMPS;
14dd3ad8 2091 JMPENV_POP;
cc3604b1 2092 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2093 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2094 my_exit_jump();
a0d0e21e 2095 /* NOTREACHED */
6224f72b 2096 case 3:
3280af22 2097 if (PL_restartop) {
533c011a 2098 PL_op = PL_restartop;
3280af22 2099 PL_restartop = 0;
312caa8e 2100 goto redo_body;
a0d0e21e 2101 }
3280af22 2102 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2103 if (flags & G_ARRAY)
2104 retval = 0;
2105 else {
2106 retval = 1;
3280af22 2107 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2108 }
312caa8e 2109 break;
a0d0e21e 2110 }
a0d0e21e 2111
3280af22 2112 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 2113 SV **newsp;
2114 PMOP *newpm;
2115 I32 gimme;
c09156bb 2116 register PERL_CONTEXT *cx;
a0a2876f
LW		 2117 I32 optype;
2118
2119 POPBLOCK(cx,newpm);
2120 POPEVAL(cx);
2121 pop_return();
3280af22 2122 PL_curpm = newpm;
a0a2876f 2123 LEAVE;
a0d0e21e 2124 }
14dd3ad8 2125 JMPENV_POP;
a0d0e21e 2126 }
1e422769 2127
a0d0e21e 2128 if (flags & G_DISCARD) {
3280af22 2129 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2130 retval = 0;
2131 FREETMPS;
2132 LEAVE;
2133 }
533c011a 2134 PL_op = oldop;
a0d0e21e
LW		 2135 return retval;
2136}
2137
14dd3ad8 2138#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2139STATIC void *
14dd3ad8 2140S_vcall_body(pTHX_ va_list args)
312caa8e
CS		 2141{
2142 OP *myop = va_arg(args, OP*);
2143 int is_eval = va_arg(args, int);
2144
14dd3ad8 2145 call_body(myop, is_eval);
312caa8e
CS		 2146 return NULL;
2147}
14dd3ad8 2148#endif
312caa8e
CS		 2149
2150STATIC void
14dd3ad8 2151S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e 2152{
312caa8e
CS		 2153 if (PL_op == myop) {
2154 if (is_eval)
f807eda9 2155 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 2156 else
f807eda9 2157 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 2158 }
2159 if (PL_op)
cea2e8a9 2160 CALLRUNOPS(aTHX);
312caa8e
CS		 2161}
2162
6e72f9df 2163/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2164
954c1994
GS		 2165/*
2166=for apidoc p||eval_sv
2167
2168Tells Perl to C<eval> the string in the SV.
2169
2170=cut
2171*/
2172
a0d0e21e 2173I32
864dbfa3 2174Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2175
8ac85365 2176 /* See G_* flags in cop.h */
a0d0e21e 2177{
924508f0 2178 dSP;
a0d0e21e 2179 UNOP myop; /* fake syntax tree node */
8fa7f367 2180 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2181 volatile I32 retval = 0;
4633a7c4 2182 I32 oldscope;
6224f72b 2183 int ret;
533c011a 2184 OP* oldop = PL_op;
db36c5a1 2185 dJMPENV;
84902520 2186
4633a7c4
LW		 2187 if (flags & G_DISCARD) {
2188 ENTER;
2189 SAVETMPS;
2190 }
2191
462e5cf6 2192 SAVEOP();
533c011a
NIS		 2193 PL_op = (OP*)&myop;
2194 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2195 EXTEND(PL_stack_sp, 1);
2196 *++PL_stack_sp = sv;
2197 oldscope = PL_scopestack_ix;
79072805 2198
4633a7c4
LW		 2199 if (!(flags & G_NOARGS))
2200 myop.op_flags = OPf_STACKED;
79072805 2201 myop.op_next = Nullop;
6e72f9df 2202 myop.op_type = OP_ENTEREVAL;
54310121 2203 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2204 (flags & G_ARRAY) ? OPf_WANT_LIST :
2205 OPf_WANT_SCALAR);
6e72f9df 2206 if (flags & G_KEEPERR)
2207 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2208
14dd3ad8 2209#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2210 redo_body:
14dd3ad8 2211 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 2212 (OP*)&myop, TRUE);
14dd3ad8
GS		 2213#else
2214 JMPENV_PUSH(ret);
2215#endif
6224f72b
GS		 2216 switch (ret) {
2217 case 0:
14dd3ad8
GS		 2218#ifndef PERL_FLEXIBLE_EXCEPTIONS
2219 redo_body:
2220 call_body((OP*)&myop,TRUE);
2221#endif
312caa8e
CS		 2222 retval = PL_stack_sp - (PL_stack_base + oldmark);
2223 if (!(flags & G_KEEPERR))
2224 sv_setpv(ERRSV,"");
4633a7c4 2225 break;
6224f72b 2226 case 1:
f86702cc 2227 STATUS_ALL_FAILURE;
4633a7c4 2228 /* FALL THROUGH */
6224f72b 2229 case 2:
4633a7c4 2230 /* my_exit() was called */
3280af22 2231 PL_curstash = PL_defstash;
4633a7c4 2232 FREETMPS;
14dd3ad8 2233 JMPENV_POP;
cc3604b1 2234 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2235 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2236 my_exit_jump();
4633a7c4 2237 /* NOTREACHED */
6224f72b 2238 case 3:
3280af22 2239 if (PL_restartop) {
533c011a 2240 PL_op = PL_restartop;
3280af22 2241 PL_restartop = 0;
312caa8e 2242 goto redo_body;
4633a7c4 2243 }
3280af22 2244 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2245 if (flags & G_ARRAY)
2246 retval = 0;
2247 else {
2248 retval = 1;
3280af22 2249 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2250 }
312caa8e 2251 break;
4633a7c4
LW		 2252 }
2253
14dd3ad8 2254 JMPENV_POP;
4633a7c4 2255 if (flags & G_DISCARD) {
3280af22 2256 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2257 retval = 0;
2258 FREETMPS;
2259 LEAVE;
2260 }
533c011a 2261 PL_op = oldop;
4633a7c4
LW		 2262 return retval;
2263}
2264
954c1994
GS		 2265/*
2266=for apidoc p||eval_pv
2267
2268Tells Perl to C<eval> the given string and return an SV* result.
2269
2270=cut
2271*/
2272
137443ea 2273SV*
864dbfa3 2274Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2275{
2276 dSP;
2277 SV* sv = newSVpv(p, 0);
2278
864dbfa3 2279 eval_sv(sv, G_SCALAR);
137443ea 2280 SvREFCNT_dec(sv);
2281
2282 SPAGAIN;
2283 sv = POPs;
2284 PUTBACK;
2285
2d8e6c8d
GS		 2286 if (croak_on_error && SvTRUE(ERRSV)) {
2287 STRLEN n_a;
cea2e8a9 2288 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 2289 }
137443ea 2290
2291 return sv;
2292}
2293
4633a7c4
LW		 2294/* Require a module. */
2295
954c1994 2296/*
ccfc67b7
JH		 2297=head1 Embedding Functions
2298
954c1994
GS		 2299=for apidoc p||require_pv
2300
7d3fb230
BS		 2301Tells Perl to C<require> the file named by the string argument. It is
2302analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2303implemented that way; consider using load_module instead.
954c1994 2304
7d3fb230 2305=cut */
954c1994 2306
4633a7c4 2307void
864dbfa3 2308Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2309{
d3acc0f7
JP		 2310 SV* sv;
2311 dSP;
e788e7d3 2312 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2313 PUTBACK;
2314 sv = sv_newmortal();
4633a7c4
LW		 2315 sv_setpv(sv, "require '");
2316 sv_catpv(sv, pv);
2317 sv_catpv(sv, "'");
864dbfa3 2318 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2319 SPAGAIN;
2320 POPSTACK;
79072805
LW		 2321}
2322
79072805 2323void
864dbfa3 2324Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 2325{
2326 register GV *gv;
2327
155aba94 2328 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2329 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2330}
2331
76e3520e 2332STATIC void
cea2e8a9 2333S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 2334{
ab821d7f 2335 /* This message really ought to be max 23 lines.
75c72d73 2336 * Removed -h because the user already knows that option. Others? */
fb73857a 2337
76e3520e 2338 static char *usage_msg[] = {
fb73857a 2339"-0[octal] specify record separator (\\0, if no argument)",
2340"-a autosplit mode with -n or -p (splits $_ into @F)",
fb3560ee 2341"-C[number/list] enables the listed Unicode features",
1950ee41 2342"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS		 2343"-d[:debugger] run program under debugger",
2344"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
90490ea3 2345"-e program one line of program (several -e's allowed, omit programfile)",
aac3bd0d
GS		 2346"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2347"-i[extension] edit <> files in place (makes backup if extension supplied)",
2348"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 2349"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 2350"-[mM][-]module execute `use/no module...' before executing program",
2351"-n assume 'while (<>) { ... }' loop around program",
2352"-p assume loop like -n but print line also, like sed",
2353"-P run program through C preprocessor before compilation",
2354"-s enable rudimentary parsing for switches after programfile",
2355"-S look for programfile using PATH environment variable",
9cbc33e8 2356"-t enable tainting warnings",
90490ea3 2357"-T enable tainting checks",
aac3bd0d 2358"-u dump core after parsing program",
fb73857a 2359"-U allow unsafe operations",
aac3bd0d
GS		 2360"-v print version, subversion (includes VERY IMPORTANT perl info)",
2361"-V[:variable] print configuration summary (or a single Config.pm variable)",
2362"-w enable many useful warnings (RECOMMENDED)",
3c0facb2 2363"-W enable all warnings",
fb73857a 2364"-x[directory] strip off text before #!perl line and perhaps cd to directory",
90490ea3 2365"-X disable all warnings",
fb73857a 2366"\n",
2367NULL
2368};
76e3520e 2369 char **p = usage_msg;
fb73857a 2370
b0e47665
GS		 2371 PerlIO_printf(PerlIO_stdout(),
2372 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2373 name);
fb73857a 2374 while (*p)
b0e47665 2375 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2376}
2377
b4ab917c
DM		 2378/* convert a string of -D options (or digits) into an int.
2379 * sets *s to point to the char after the options */
2380
2381#ifdef DEBUGGING
2382int
2383Perl_get_debug_opts(pTHX_ char **s)
2384{
2385 int i = 0;
2386 if (isALPHA(**s)) {
2387 /* if adding extra options, remember to update DEBUG_MASK */
ecae49c0 2388 static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
b4ab917c
DM		 2389
2390 for (; isALNUM(**s); (*s)++) {
2391 char *d = strchr(debopts,**s);
2392 if (d)
2393 i |= 1 << (d - debopts);
2394 else if (ckWARN_d(WARN_DEBUGGING))
2395 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2396 "invalid option -D%c\n", **s);
2397 }
2398 }
2399 else {
2400 i = atoi(*s);
2401 for (; isALNUM(**s); (*s)++) ;
2402 }
2403# ifdef EBCDIC
2404 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2405 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2406 "-Dp not implemented on this platform\n");
2407# endif
2408 return i;
2409}
2410#endif
2411
79072805
LW		 2412/* This routine handles any switches that can be given during run */
2413
2414char *
864dbfa3 2415Perl_moreswitches(pTHX_ char *s)
79072805 2416{
ba210ebe 2417 STRLEN numlen;
84c133a0 2418 UV rschar;
79072805
LW		 2419
2420 switch (*s) {
2421 case '0':
a863c7d1 2422 {
f2095865
JH		 2423 I32 flags = 0;
2424
2425 SvREFCNT_dec(PL_rs);
2426 if (s[1] == 'x' && s[2]) {
2427 char *e;
2428 U8 *tmps;
2429
2430 for (s += 2, e = s; *e; e++);
2431 numlen = e - s;
2432 flags = PERL_SCAN_SILENT_ILLDIGIT;
2433 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2434 if (s + numlen < e) {
2435 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2436 numlen = 0;
2437 s--;
2438 }
2439 PL_rs = newSVpvn("", 0);
c5661c80 2440 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 2441 tmps = (U8*)SvPVX(PL_rs);
2442 uvchr_to_utf8(tmps, rschar);
2443 SvCUR_set(PL_rs, UNISKIP(rschar));
2444 SvUTF8_on(PL_rs);
2445 }
2446 else {
2447 numlen = 4;
2448 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2449 if (rschar & ~((U8)~0))
2450 PL_rs = &PL_sv_undef;
2451 else if (!rschar && numlen >= 2)
2452 PL_rs = newSVpvn("", 0);
2453 else {
2454 char ch = (char)rschar;
2455 PL_rs = newSVpvn(&ch, 1);
2456 }
2457 }
800633c3 2458 sv_setsv(get_sv("/", TRUE), PL_rs);
f2095865 2459 return s + numlen;
a863c7d1 2460 }
46487f74 2461 case 'C':
a05d7ebb
JH		 2462 s++;
2463 PL_unicode = parse_unicode_opts(&s);
46487f74 2464 return s;
2304df62 2465 case 'F':
3280af22 2466 PL_minus_F = TRUE;
ebce5377
RGS		 2467 PL_splitstr = ++s;
2468 while (*s && !isSPACE(*s)) ++s;
2469 *s = '\0';
2470 PL_splitstr = savepv(PL_splitstr);
2304df62 2471 return s;
79072805 2472 case 'a':
3280af22 2473 PL_minus_a = TRUE;
79072805
LW		 2474 s++;
2475 return s;
2476 case 'c':
3280af22 2477 PL_minus_c = TRUE;
79072805
LW		 2478 s++;
2479 return s;
2480 case 'd':
bbce6d69 2481 forbid_setid("-d");
4633a7c4 2482 s++;
70c94a19
RR		 2483 /* The following permits -d:Mod to accepts arguments following an =
2484 in the fashion that -MSome::Mod does. */
2485 if (*s == ':' || *s == '=') {
2486 char *start;
2487 SV *sv;
2488 sv = newSVpv("use Devel::", 0);
2489 start = ++s;
2490 /* We now allow -d:Module=Foo,Bar */
2491 while(isALNUM(*s) || *s==':') ++s;
2492 if (*s != '=')
2493 sv_catpv(sv, start);
2494 else {
2495 sv_catpvn(sv, start, s-start);
2496 sv_catpv(sv, " split(/,/,q{");
2497 sv_catpv(sv, ++s);
3d27e215 2498 sv_catpv(sv, "})");
70c94a19 2499 }
4633a7c4 2500 s += strlen(s);
70c94a19 2501 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2502 }
ed094faf 2503 if (!PL_perldb) {
3280af22 2504 PL_perldb = PERLDB_ALL;
a0d0e21e 2505 init_debugger();
ed094faf 2506 }
79072805
LW		 2507 return s;
2508 case 'D':
0453d815 2509 {
79072805 2510#ifdef DEBUGGING
bbce6d69 2511 forbid_setid("-D");
b4ab917c
DM		 2512 s++;
2513 PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
12a43e32 2514#else /* !DEBUGGING */
0453d815 2515 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2516 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
0453d815 2517 "Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 2518 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2519#endif
2520 /*SUPPRESS 530*/
2521 return s;
0453d815 2522 }
4633a7c4 2523 case 'h':
ac27b0f5 2524 usage(PL_origargv[0]);
7ca617d0 2525 my_exit(0);
79072805 2526 case 'i':
3280af22
NIS		 2527 if (PL_inplace)
2528 Safefree(PL_inplace);
c030f24b
GH		 2529#if defined(__CYGWIN__) /* do backup extension automagically */
2530 if (*(s+1) == '\0') {
2531 PL_inplace = savepv(".bak");
2532 return s+1;
2533 }
2534#endif /* __CYGWIN__ */
3280af22 2535 PL_inplace = savepv(s+1);
79072805 2536 /*SUPPRESS 530*/
3280af22 2537 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2538 if (*s) {
fb73857a 2539 *s++ = '\0';
7b8d334a
GS		 2540 if (*s == '-') /* Additional switches on #! line. */
2541 s++;
2542 }
fb73857a 2543 return s;
4e49a025 2544 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2545 forbid_setid("-I");
fb73857a 2546 ++s;
2547 while (*s && isSPACE(*s))
2548 ++s;
2549 if (*s) {
774d564b 2550 char *e, *p;
0df16ed7
GS		 2551 p = s;
2552 /* ignore trailing spaces (possibly followed by other switches) */
2553 do {
2554 for (e = p; *e && !isSPACE(*e); e++) ;
2555 p = e;
2556 while (isSPACE(*p))
2557 p++;
2558 } while (*p && *p != '-');
2559 e = savepvn(s, e-s);
574c798a 2560 incpush(e, TRUE, TRUE, FALSE);
0df16ed7
GS		 2561 Safefree(e);
2562 s = p;
2563 if (*s == '-')
2564 s++;
79072805
LW		 2565 }
2566 else
a67e862a 2567 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2568 return s;
79072805 2569 case 'l':
3280af22 2570 PL_minus_l = TRUE;
79072805 2571 s++;
7889fe52
NIS		 2572 if (PL_ors_sv) {
2573 SvREFCNT_dec(PL_ors_sv);
2574 PL_ors_sv = Nullsv;
2575 }
79072805 2576 if (isDIGIT(*s)) {
53305cf1 2577 I32 flags = 0;
7889fe52 2578 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2579 numlen = 3 + (*s == '0');
2580 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2581 s += numlen;
2582 }
2583 else {
8bfdd7d9 2584 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2585 PL_ors_sv = newSVpvn("\n\n",2);
2586 }
2587 else {
8bfdd7d9 2588 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2589 }
79072805
LW		 2590 }
2591 return s;
06492da6
SF		 2592 case 'A':
2593 forbid_setid("-A");
930366bd
RGS		 2594 if (!PL_preambleav)
2595 PL_preambleav = newAV();
06492da6 2596 if (*++s) {
3d27e215
LM		 2597 SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
2598 sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
06492da6 2599 sv_catpv(sv,s);
3d27e215 2600 sv_catpvn(sv, "\0)", 2);
06492da6 2601 s+=strlen(s);
06492da6
SF		 2602 av_push(PL_preambleav, sv);
2603 }
2604 else
930366bd 2605 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
06492da6 2606 return s;
1a30305b 2607 case 'M':
bbce6d69 2608 forbid_setid("-M"); /* XXX ? */
1a30305b 2609 /* FALL THROUGH */
2610 case 'm':
bbce6d69 2611 forbid_setid("-m"); /* XXX ? */
1a30305b 2612 if (*++s) {
a5f75d66 2613 char *start;
11343788 2614 SV *sv;
a5f75d66
AD		 2615 char *use = "use ";
2616 /* -M-foo == 'no foo' */
2617 if (*s == '-') { use = "no "; ++s; }
11343788 2618 sv = newSVpv(use,0);
a5f75d66 2619 start = s;
1a30305b 2620 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2621 while(isALNUM(*s) || *s==':') ++s;
2622 if (*s != '=') {
11343788 2623 sv_catpv(sv, start);
c07a80fd 2624 if (*(start-1) == 'm') {
2625 if (*s != '\0')
cea2e8a9 2626 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2627 sv_catpv( sv, " ()");
c07a80fd 2628 }
2629 } else {
6df41af2 2630 if (s == start)
be98fb35
GS		 2631 Perl_croak(aTHX_ "Module name required with -%c option",
2632 s[-1]);
11343788 2633 sv_catpvn(sv, start, s-start);
3d27e215
LM		 2634 sv_catpv(sv, " split(/,/,q");
2635 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
11343788 2636 sv_catpv(sv, ++s);
3d27e215 2637 sv_catpvn(sv, "\0)", 2);
c07a80fd 2638 }
1a30305b 2639 s += strlen(s);
5c831c24 2640 if (!PL_preambleav)
3280af22
NIS		 2641 PL_preambleav = newAV();
2642 av_push(PL_preambleav, sv);
1a30305b 2643 }
2644 else
cea2e8a9 2645 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2646 return s;
79072805 2647 case 'n':
3280af22 2648 PL_minus_n = TRUE;
79072805
LW		 2649 s++;
2650 return s;
2651 case 'p':
3280af22 2652 PL_minus_p = TRUE;
79072805
LW		 2653 s++;
2654 return s;
2655 case 's':
bbce6d69 2656 forbid_setid("-s");
3280af22 2657 PL_doswitches = TRUE;
79072805
LW		 2658 s++;
2659 return s;
6537fe72
MS		 2660 case 't':
2661 if (!PL_tainting)
22f7c9c9 2662 TOO_LATE_FOR('t');
6537fe72
MS		 2663 s++;
2664 return s;
463ee0b2 2665 case 'T':
3280af22 2666 if (!PL_tainting)
22f7c9c9 2667 TOO_LATE_FOR('T');
463ee0b2
LW		 2668 s++;
2669 return s;
79072805 2670 case 'u':
bf4acbe4
GS		 2671#ifdef MACOS_TRADITIONAL
2672 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2673#endif
3280af22 2674 PL_do_undump = TRUE;
79072805
LW		 2675 s++;
2676 return s;
2677 case 'U':
3280af22 2678 PL_unsafe = TRUE;
79072805
LW		 2679 s++;
2680 return s;
2681 case 'v':
8e9464f1 2682#if !defined(DGUX)
b0e47665 2683 PerlIO_printf(PerlIO_stdout(),
d2560b70 2684 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
b0e47665 2685 PL_patchlevel, ARCHNAME));
8e9464f1
JH		 2686#else /* DGUX */
2687/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2688 PerlIO_printf(PerlIO_stdout(),
2689 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2690 PerlIO_printf(PerlIO_stdout(),
2691 Perl_form(aTHX_ " built under %s at %s %s\n",
2692 OSNAME, __DATE__, __TIME__));
2693 PerlIO_printf(PerlIO_stdout(),
2694 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2695 OSVERS));
8e9464f1
JH		 2696#endif /* !DGUX */
2697
fb73857a 2698#if defined(LOCAL_PATCH_COUNT)
2699 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2700 PerlIO_printf(PerlIO_stdout(),
2701 "\n(with %d registered patch%s, "
2702 "see perl -V for more detail)",
2703 (int)LOCAL_PATCH_COUNT,
2704 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2705#endif
1a30305b 2706
b0e47665 2707 PerlIO_printf(PerlIO_stdout(),
45a2796c 2708 "\n\nCopyright 1987-2004, Larry Wall\n");
eae9c151
JH		 2709#ifdef MACOS_TRADITIONAL
2710 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2711 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2712 "maintained by Chris Nandor\n");
eae9c151 2713#endif
79072805 2714#ifdef MSDOS
b0e47665
GS		 2715 PerlIO_printf(PerlIO_stdout(),
2716 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2717#endif
2718#ifdef DJGPP
b0e47665
GS		 2719 PerlIO_printf(PerlIO_stdout(),
2720 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2721 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2722#endif
79072805 2723#ifdef OS2
b0e47665
GS		 2724 PerlIO_printf(PerlIO_stdout(),
2725 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2726 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2727#endif
79072805 2728#ifdef atarist
b0e47665
GS		 2729 PerlIO_printf(PerlIO_stdout(),
2730 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2731#endif
a3f9223b 2732#ifdef __BEOS__
b0e47665
GS		 2733 PerlIO_printf(PerlIO_stdout(),
2734 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2735#endif
1d84e8df 2736#ifdef MPE
b0e47665 2737 PerlIO_printf(PerlIO_stdout(),
e583a879 2738 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 2739#endif
9d116dd7 2740#ifdef OEMVS
b0e47665
GS		 2741 PerlIO_printf(PerlIO_stdout(),
2742 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2743#endif
495c5fdc 2744#ifdef __VOS__
b0e47665 2745 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2746 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2747#endif
092bebab 2748#ifdef __OPEN_VM
b0e47665
GS		 2749 PerlIO_printf(PerlIO_stdout(),
2750 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2751#endif
a1a0e61e 2752#ifdef POSIX_BC
b0e47665
GS		 2753 PerlIO_printf(PerlIO_stdout(),
2754 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2755#endif
61ae2fbf 2756#ifdef __MINT__
b0e47665
GS		 2757 PerlIO_printf(PerlIO_stdout(),
2758 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2759#endif
f83d2536 2760#ifdef EPOC
b0e47665 2761 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2762 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2763#endif
e1caacb4 2764#ifdef UNDER_CE
b475b3e6
JH		 2765 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2766 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2767 wce_hitreturn();
2768#endif
baed7233
DL		 2769#ifdef BINARY_BUILD_NOTICE
2770 BINARY_BUILD_NOTICE;
2771#endif
b0e47665
GS		 2772 PerlIO_printf(PerlIO_stdout(),
2773 "\n\
79072805 2774Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2775GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2776Complete documentation for Perl, including FAQ lists, should be found on\n\
2777this system using `man perl' or `perldoc perl'. If you have access to the\n\
2778Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
7ca617d0 2779 my_exit(0);
79072805 2780 case 'w':
599cee73 2781 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2782 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2783 s++;
2784 return s;
2785 case 'W':
ac27b0f5 2786 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2787 if (!specialWARN(PL_compiling.cop_warnings))
2788 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2789 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2790 s++;
2791 return s;
2792 case 'X':
ac27b0f5 2793 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2794 if (!specialWARN(PL_compiling.cop_warnings))
2795 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2796 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2797 s++;
2798 return s;
a0d0e21e 2799 case '*':
79072805
LW		 2800 case ' ':
2801 if (s[1] == '-') /* Additional switches on #! line. */
2802 return s+2;
2803 break;
a0d0e21e 2804 case '-':
79072805 2805 case 0:
51882d45 2806#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2807 case '\r':
2808#endif
79072805
LW		 2809 case '\n':
2810 case '\t':
2811 break;
aa689395 2812#ifdef ALTERNATE_SHEBANG
2813 case 'S': /* OS/2 needs -S on "extproc" line. */
2814 break;
2815#endif
a0d0e21e 2816 case 'P':
3280af22 2817 if (PL_preprocess)
a0d0e21e
LW		 2818 return s+1;
2819 /* FALL THROUGH */
79072805 2820 default:
cea2e8a9 2821 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2822 }
2823 return Nullch;
2824}
2825
2826/* compliments of Tom Christiansen */
2827
2828/* unexec() can be found in the Gnu emacs distribution */
ee580363 2829/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2830
2831void
864dbfa3 2832Perl_my_unexec(pTHX)
79072805
LW		 2833{
2834#ifdef UNEXEC
46fc3d4c 2835 SV* prog;
2836 SV* file;
ee580363 2837 int status = 1;
79072805
LW		 2838 extern int etext;
2839
ee580363 2840 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2841 sv_catpv(prog, "/perl");
6b88bc9c 2842 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2843 sv_catpv(file, ".perldump");
79072805 2844
ee580363
GS		 2845 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2846 /* unexec prints msg to stderr in case of failure */
6ad3d225 2847 PerlProc_exit(status);
79072805 2848#else
a5f75d66
AD		 2849# ifdef VMS
2850# include <lib$routines.h>
2851 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2852# else
79072805 2853 ABORT(); /* for use with undump */
aa689395 2854# endif
a5f75d66 2855#endif
79072805
LW		 2856}
2857
cb68f92d
GS		 2858/* initialize curinterp */
2859STATIC void
cea2e8a9 2860S_init_interp(pTHX)
cb68f92d
GS		 2861{
2862
acfe0abc
GS		 2863#ifdef MULTIPLICITY
2864# define PERLVAR(var,type)
2865# define PERLVARA(var,n,type)
2866# if defined(PERL_IMPLICIT_CONTEXT)
2867# if defined(USE_5005THREADS)
2868# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2869# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2870# else /* !USE_5005THREADS */
2871# define PERLVARI(var,type,init) aTHX->var = init;
2872# define PERLVARIC(var,type,init) aTHX->var = init;
2873# endif /* USE_5005THREADS */
3967c732 2874# else
acfe0abc
GS		 2875# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2876# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2877# endif
acfe0abc
GS		 2878# include "intrpvar.h"
2879# ifndef USE_5005THREADS
2880# include "thrdvar.h"
2881# endif
2882# undef PERLVAR
2883# undef PERLVARA
2884# undef PERLVARI
2885# undef PERLVARIC
2886#else
2887# define PERLVAR(var,type)
2888# define PERLVARA(var,n,type)
2889# define PERLVARI(var,type,init) PL_##var = init;
2890# define PERLVARIC(var,type,init) PL_##var = init;
2891# include "intrpvar.h"
2892# ifndef USE_5005THREADS
2893# include "thrdvar.h"
2894# endif
2895# undef PERLVAR
2896# undef PERLVARA
2897# undef PERLVARI
2898# undef PERLVARIC
cb68f92d
GS		 2899#endif
2900
cb68f92d
GS		 2901}
2902
76e3520e 2903STATIC void
cea2e8a9 2904S_init_main_stash(pTHX)
79072805 2905{
463ee0b2 2906 GV *gv;
6e72f9df 2907
3280af22 2908 PL_curstash = PL_defstash = newHV();
79cb57f6 2909 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2910 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2911 SvREFCNT_dec(GvHV(gv));
3280af22 2912 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2913 SvREADONLY_on(gv);
3280af22
NIS		 2914 HvNAME(PL_defstash) = savepv("main");
2915 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2916 GvMULTI_on(PL_incgv);
2917 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2918 GvMULTI_on(PL_hintgv);
2919 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2920 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2921 GvMULTI_on(PL_errgv);
2922 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2923 GvMULTI_on(PL_replgv);
cea2e8a9 2924 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2925 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2926 sv_setpvn(ERRSV, "", 0);
3280af22 2927 PL_curstash = PL_defstash;
11faa288 2928 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2929 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2930 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2931 /* We must init $/ before switches are processed. */
864dbfa3 2932 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2933}
2934
ae3f3efd 2935/* PSz 18 Nov 03 fdscript now global but do not change prototype */
76e3520e 2936STATIC void
ae3f3efd 2937S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *dummy_fdscript)
79072805 2938{
ae3f3efd 2939#ifndef IAMSUID
1b24ed4b
MS		 2940 char *quote;
2941 char *code;
2942 char *cpp_discard_flag;
2943 char *perl;
ae3f3efd 2944#endif
1b24ed4b 2945
ae3f3efd
PS		 2946 PL_fdscript = -1;
2947 PL_suidscript = -1;
79072805 2948
3280af22
NIS		 2949 if (PL_e_script) {
2950 PL_origfilename = savepv("-e");
96436eeb 2951 }
6c4ab083
GS		 2952 else {
2953 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2954 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2955
2956 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2957 char *s = scriptname + 8;
ae3f3efd 2958 PL_fdscript = atoi(s);
6c4ab083
GS		 2959 while (isDIGIT(*s))
2960 s++;
2961 if (*s) {
ae3f3efd
PS		 2962 /* PSz 18 Feb 04
2963 * Tell apart "normal" usage of fdscript, e.g.
2964 * with bash on FreeBSD:
2965 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
2966 * from usage in suidperl.
2967 * Does any "normal" usage leave garbage after the number???
2968 * Is it a mistake to use a similar /dev/fd/ construct for
2969 * suidperl?
2970 */
2971 PL_suidscript = 1;
2972 /* PSz 20 Feb 04
2973 * Be supersafe and do some sanity-checks.
2974 * Still, can we be sure we got the right thing?
2975 */
2976 if (*s != '/') {
2977 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
2978 }
2979 if (! *(s+1)) {
2980 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
2981 }
6c4ab083 2982 scriptname = savepv(s + 1);
3280af22
NIS		 2983 Safefree(PL_origfilename);
2984 PL_origfilename = scriptname;
6c4ab083
GS		 2985 }
2986 }
2987 }
2988
05ec9bb3 2989 CopFILE_free(PL_curcop);
57843af0 2990 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2991 if (strEQ(PL_origfilename,"-"))
79072805 2992 scriptname = "";
ae3f3efd
PS		 2993 if (PL_fdscript >= 0) {
2994 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2995# if defined(HAS_FCNTL) && defined(F_SETFD)
2996 if (PL_rsfp)
2997 /* ensure close-on-exec */
2998 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2999# endif
96436eeb 3000 }
ae3f3efd
PS		 3001#ifdef IAMSUID
3002 else {
3003 Perl_croak(aTHX_ "suidperl needs fd script\n");
3004/* PSz 11 Nov 03
3005 * Do not open (or do other fancy stuff) while setuid.
3006 * Perl does the open, and hands script to suidperl on a fd;
3007 * suidperl only does some checks, sets up UIDs and re-execs
3008 * perl with that fd as it has always done.
3009 */
3010 }
3011 if (PL_suidscript != 1) {
3012 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3013 }
3014#else /* IAMSUID */
3280af22 3015 else if (PL_preprocess) {
46fc3d4c 3016 char *cpp_cfg = CPPSTDIN;
79cb57f6 3017 SV *cpp = newSVpvn("",0);
46fc3d4c 3018 SV *cmd = NEWSV(0,0);
3019
ae58f265
JH		 3020 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3021 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
46fc3d4c 3022 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 3023 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 3024 sv_catpv(cpp, cpp_cfg);
79072805 3025
1b24ed4b
MS		 3026# ifndef VMS
3027 sv_catpvn(sv, "-I", 2);
3028 sv_catpv(sv,PRIVLIB_EXP);
3029# endif
46fc3d4c 3030
14953ddc
MB		 3031 DEBUG_P(PerlIO_printf(Perl_debug_log,
3032 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3033 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 3034
3035# if defined(MSDOS) || defined(WIN32) || defined(VMS)
3036 quote = "\"";
3037# else
3038 quote = "'";
3039# endif
3040
3041# ifdef VMS
3042 cpp_discard_flag = "";
3043# else
3044 cpp_discard_flag = "-C";
3045# endif
3046
3047# ifdef OS2
3048 perl = os2_execname(aTHX);
3049# else
3050 perl = PL_origargv[0];
3051# endif
3052
3053
3054 /* This strips off Perl comments which might interfere with
62375a60
NIS		 3055 the C pre-processor, including #!. #line directives are
3056 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 3057 of #line. FWP played some golf with it so it will fit
3058 into VMS's 255 character buffer.
3059 */
3060 if( PL_doextract )
3061 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3062 else
3063 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3064
3065 Perl_sv_setpvf(aTHX_ cmd, "\
3066%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 3067 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 3068 cpp_discard_flag, sv, CPPMINUS);
3069
3280af22 3070 PL_doextract = FALSE;
0a6c758d 3071
62375a60
NIS		 3072 DEBUG_P(PerlIO_printf(Perl_debug_log,
3073 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 3074 SvPVX(cmd)));
3075
3280af22 3076 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 3077 SvREFCNT_dec(cmd);
3078 SvREFCNT_dec(cpp);
79072805
LW		 3079 }
3080 else if (!*scriptname) {
bbce6d69 3081 forbid_setid("program input from stdin");
3280af22 3082 PL_rsfp = PerlIO_stdin();
79072805 3083 }
96436eeb 3084 else {
3280af22 3085 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3086# if defined(HAS_FCNTL) && defined(F_SETFD)
3087 if (PL_rsfp)
3088 /* ensure close-on-exec */
3089 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3090# endif
96436eeb 3091 }
ae3f3efd 3092#endif /* IAMSUID */
3280af22 3093 if (!PL_rsfp) {
ae3f3efd 3094/* PSz 16 Sep 03 Keep neat error message */
1b24ed4b
MS		 3095 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3096 CopFILE(PL_curcop), Strerror(errno));
13281fa4 3097 }
79072805 3098}
8d063cd8 3099
7b89560d
JH		 3100/* Mention
3101 * I_SYSSTATVFS HAS_FSTATVFS
3102 * I_SYSMOUNT
c890dc6c 3103 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3104 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3105 * here so that metaconfig picks them up. */
3106
104d25b7 3107#ifdef IAMSUID
864dbfa3 3108STATIC int
e688b231 3109S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 3110{
ae3f3efd
PS		 3111/* PSz 27 Feb 04
3112 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3113 * but is needed also on machines without setreuid.
3114 * Seems safe enough to run as root.
3115 */
0545a864
JH		 3116 int check_okay = 0; /* able to do all the required sys/libcalls */
3117 int on_nosuid = 0; /* the fd is on a nosuid fs */
ae3f3efd
PS		 3118 /* PSz 12 Nov 03
3119 * Need to check noexec also: nosuid might not be set, the average
3120 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3121 */
3122 int on_noexec = 0; /* the fd is on a noexec fs */
3123
104d25b7 3124/*
ad27e871 3125 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 3126 * fstatvfs() is UNIX98.
0545a864 3127 * fstatfs() is 4.3 BSD.
ad27e871 3128 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 3129 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3130 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 3131 */
3132
6439433f
JH		 3133#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3134
3135# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3136 defined(HAS_FSTATVFS)
3137# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 3138 struct statvfs stfs;
6439433f 3139
104d25b7
JH		 3140 check_okay = fstatvfs(fd, &stfs) == 0;
3141 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
ae3f3efd
PS		 3142#ifdef ST_NOEXEC
3143 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3144 on platforms where it is present. */
3145 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3146#endif
6439433f 3147# endif /* fstatvfs */
ac27b0f5 3148
6439433f
JH		 3149# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3150 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3151 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3152 defined(HAS_FSTATFS) && \
3153 defined(HAS_STRUCT_STATFS) && \
3154 defined(HAS_STRUCT_STATFS_F_FLAGS)
3155# define FD_ON_NOSUID_CHECK_OKAY
e688b231 3156 struct statfs stfs;
6439433f 3157
104d25b7 3158 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 3159 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
ae3f3efd 3160 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
6439433f
JH		 3161# endif /* fstatfs */
3162
3163# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3164 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3165 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3166 defined(HAS_FSTAT) && \
3167 defined(HAS_USTAT) && \
3168 defined(HAS_GETMNT) && \
3169 defined(HAS_STRUCT_FS_DATA) && \
3170 defined(NOSTAT_ONE)
3171# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 3172 Stat_t fdst;
6439433f 3173
0545a864 3174 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 3175 struct ustat us;
3176 if (ustat(fdst.st_dev, &us) == 0) {
3177 struct fs_data fsd;
3178 /* NOSTAT_ONE here because we're not examining fields which
3179 * vary between that case and STAT_ONE. */
ad27e871 3180 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3181 size_t cmplen = sizeof(us.f_fname);
3182 if (sizeof(fsd.fd_req.path) < cmplen)
3183 cmplen = sizeof(fsd.fd_req.path);
3184 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3185 fdst.st_dev == fsd.fd_req.dev) {
3186 check_okay = 1;
3187 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
ae3f3efd 3188 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
6439433f
JH		 3189 }
3190 }
3191 }
3192 }
0545a864 3193 }
6439433f
JH		 3194# endif /* fstat+ustat+getmnt */
3195
3196# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3197 defined(HAS_GETMNTENT) && \
3198 defined(HAS_HASMNTOPT) && \
ae3f3efd
PS		 3199 defined(MNTOPT_NOSUID) && \
3200 defined(MNTOPT_NOEXEC)
6439433f
JH		 3201# define FD_ON_NOSUID_CHECK_OKAY
3202 FILE *mtab = fopen("/etc/mtab", "r");
3203 struct mntent *entry;
c623ac67 3204 Stat_t stb, fsb;
104d25b7
JH		 3205
3206 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3207 while (entry = getmntent(mtab)) {
3208 if (stat(entry->mnt_dir, &fsb) == 0
3209 && fsb.st_dev == stb.st_dev)
3210 {
3211 /* found the filesystem */
3212 check_okay = 1;
3213 if (hasmntopt(entry, MNTOPT_NOSUID))
3214 on_nosuid = 1;
ae3f3efd
PS		 3215 if (hasmntopt(entry, MNTOPT_NOEXEC))
3216 on_noexec = 1;
6439433f
JH		 3217 break;
3218 } /* A single fs may well fail its stat(). */
3219 }
104d25b7
JH		 3220 }
3221 if (mtab)
6439433f
JH		 3222 fclose(mtab);
3223# endif /* getmntent+hasmntopt */
0545a864 3224
ac27b0f5 3225 if (!check_okay)
ae3f3efd
PS		 3226 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3227 if (on_nosuid)
3228 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3229 if (on_noexec)
3230 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3231 return ((!check_okay) || on_nosuid || on_noexec);
104d25b7
JH		 3232}
3233#endif /* IAMSUID */
3234
ae3f3efd 3235/* PSz 18 Nov 03 fdscript now global but do not change prototype */
76e3520e 3236STATIC void
ae3f3efd 3237S_validate_suid(pTHX_ char *validarg, char *scriptname, int dummy_fdscript)
79072805 3238{
155aba94 3239#ifdef IAMSUID
ae3f3efd
PS		 3240 /* int which; */
3241#endif /* IAMSUID */
96436eeb 3242
13281fa4
LW		 3243 /* do we need to emulate setuid on scripts? */
3244
3245 /* This code is for those BSD systems that have setuid #! scripts disabled
3246 * in the kernel because of a security problem. Merely defining DOSUID
3247 * in perl will not fix that problem, but if you have disabled setuid
3248 * scripts in the kernel, this will attempt to emulate setuid and setgid
3249 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3250 * root version must be called suidperl or sperlN.NNN. If regular perl
3251 * discovers that it has opened a setuid script, it calls suidperl with
3252 * the same argv that it had. If suidperl finds that the script it has
3253 * just opened is NOT setuid root, it sets the effective uid back to the
3254 * uid. We don't just make perl setuid root because that loses the
3255 * effective uid we had before invoking perl, if it was different from the
3256 * uid.
ae3f3efd
PS		 3257 * PSz 27 Feb 04
3258 * Description/comments above do not match current workings:
3259 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3260 * suidperl called with script open and name changed to /dev/fd/N/X;
3261 * suidperl croaks if script is not setuid;
3262 * making perl setuid would be a huge security risk (and yes, that
3263 * would lose any euid we might have had).
13281fa4
LW		 3264 *
3265 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3266 * be defined in suidperl only. suidperl must be setuid root. The
3267 * Configure script will set this up for you if you want it.
3268 */
a687059c 3269
13281fa4 3270#ifdef DOSUID
6e72f9df 3271 char *s, *s2;
a0d0e21e 3272
b28d0864 3273 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3274 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
ae3f3efd 3275 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3276 I32 len;
2d8e6c8d 3277 STRLEN n_a;
13281fa4 3278
a687059c 3279#ifdef IAMSUID
ae3f3efd
PS		 3280 if (PL_fdscript < 0 || PL_suidscript != 1)
3281 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3282 /* PSz 11 Nov 03
3283 * Since the script is opened by perl, not suidperl, some of these
3284 * checks are superfluous. Leaving them in probably does not lower
3285 * security(?!).
3286 */
3287 /* PSz 27 Feb 04
3288 * Do checks even for systems with no HAS_SETREUID.
3289 * We used to swap, then re-swap UIDs with
3290#ifdef HAS_SETREUID
3291 if (setreuid(PL_euid,PL_uid) < 0
3292 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3293 Perl_croak(aTHX_ "Can't swap uid and euid");
3294#endif
3295#ifdef HAS_SETREUID
3296 if (setreuid(PL_uid,PL_euid) < 0
3297 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3298 Perl_croak(aTHX_ "Can't reswap uid and euid");
3299#endif
3300 */
3301
a687059c
LW		 3302 /* On this access check to make sure the directories are readable,
3303 * there is actually a small window that the user could use to make
3304 * filename point to an accessible directory. So there is a faint
3305 * chance that someone could execute a setuid script down in a
3306 * non-accessible directory. I don't know what to do about that.
3307 * But I don't think it's too important. The manual lies when
3308 * it says access() is useful in setuid programs.
ae3f3efd
PS		 3309 *
3310 * So, access() is pretty useless... but not harmful... do anyway.
a687059c 3311 */
e57400b1 3312 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
ae3f3efd 3313 Perl_croak(aTHX_ "Can't access() script\n");
e57400b1 3314 }
ae3f3efd 3315
a687059c
LW		 3316 /* If we can swap euid and uid, then we can determine access rights
3317 * with a simple stat of the file, and then compare device and
3318 * inode to make sure we did stat() on the same file we opened.
3319 * Then we just have to make sure he or she can execute it.
ae3f3efd
PS		 3320 *
3321 * PSz 24 Feb 04
3322 * As the script is opened by perl, not suidperl, we do not need to
3323 * care much about access rights.
3324 *
3325 * The 'script changed' check is needed, or we can get lied to
3326 * about $0 with e.g.
3327 * suidperl /dev/fd/4//bin/x 4<setuidscript
3328 * Without HAS_SETREUID, is it safe to stat() as root?
3329 *
3330 * Are there any operating systems that pass /dev/fd/xxx for setuid
3331 * scripts, as suggested/described in perlsec(1)? Surely they do not
3332 * pass the script name as we do, so the "script changed" test would
3333 * fail for them... but we never get here with
3334 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3335 *
3336 * This is one place where we must "lie" about return status: not
3337 * say if the stat() failed. We are doing this as root, and could
3338 * be tricked into reporting existence or not of files that the
3339 * "plain" user cannot even see.
a687059c
LW		 3340 */
3341 {
c623ac67 3342 Stat_t tmpstatbuf;
ae3f3efd
PS		 3343 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3344 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
b28d0864 3345 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
ae3f3efd 3346 Perl_croak(aTHX_ "Setuid script changed\n");
a687059c 3347 }
ae3f3efd 3348
a687059c 3349 }
ae3f3efd
PS		 3350 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3351 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3352
3353 /* PSz 27 Feb 04
3354 * We used to do this check as the "plain" user (after swapping
3355 * UIDs). But the check for nosuid and noexec filesystem is needed,
3356 * and should be done even without HAS_SETREUID. (Maybe those
3357 * operating systems do not have such mount options anyway...)
3358 * Seems safe enough to do as root.
3359 */
3360#if !defined(NO_NOSUID_CHECK)
3361 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3362 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3363 }
3364#endif
a687059c
LW		 3365#endif /* IAMSUID */
3366
e57400b1 3367 if (!S_ISREG(PL_statbuf.st_mode)) {
ae3f3efd 3368 Perl_croak(aTHX_ "Setuid script not plain file\n");
e57400b1 3369 }
b28d0864 3370 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3371 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3372 PL_doswitches = FALSE; /* -s is insecure in suid */
ae3f3efd 3373 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
57843af0 3374 CopLINE_inc(PL_curcop);
6b88bc9c 3375 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3376 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3377 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3378 s = SvPV(PL_linestr,n_a)+2;
ae3f3efd
PS		 3379 /* PSz 27 Feb 04 */
3380 /* Sanity check on line length */
3381 if (strlen(s) < 1 || strlen(s) > 4000)
3382 Perl_croak(aTHX_ "Very long #! line");
3383 /* Allow more than a single space after #! */
3384 while (isSPACE(*s)) s++;
3385 /* Sanity check on buffer end */
3386 while ((*s) && !isSPACE(*s)) s++;
2d8e6c8d 3387 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3388 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
ae3f3efd
PS		 3389 /* Sanity check on buffer start */
3390 if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
3391 (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
cea2e8a9 3392 Perl_croak(aTHX_ "Not a perl script");
a687059c 3393 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3394 /*
3395 * #! arg must be what we saw above. They can invoke it by
3396 * mentioning suidperl explicitly, but they may not add any strange
3397 * arguments beyond what #! says if they do invoke suidperl that way.
3398 */
ae3f3efd
PS		 3399 /*
3400 * The way validarg was set up, we rely on the kernel to start
3401 * scripts with argv[1] set to contain all #! line switches (the
3402 * whole line).
3403 */
3404 /*
3405 * Check that we got all the arguments listed in the #! line (not
3406 * just that there are no extraneous arguments). Might not matter
3407 * much, as switches from #! line seem to be acted upon (also), and
3408 * so may be checked and trapped in perl. But, security checks must
3409 * be done in suidperl and not deferred to perl. Note that suidperl
3410 * does not get around to parsing (and checking) the switches on
3411 * the #! line (but execs perl sooner).
3412 * Allow (require) a trailing newline (which may be of two
3413 * characters on some architectures?) (but no other trailing
3414 * whitespace).
3415 */
13281fa4
LW		 3416 len = strlen(validarg);
3417 if (strEQ(validarg," PHOOEY ") ||
ae3f3efd
PS		 3418 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3419 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
cea2e8a9 3420 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3421
3422#ifndef IAMSUID
ae3f3efd
PS		 3423 if (PL_fdscript < 0 &&
3424 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
b28d0864
NIS		 3425 PL_euid == PL_statbuf.st_uid)
3426 if (!PL_do_undump)
cea2e8a9 3427 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
11fb1898 3428FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
a687059c 3429#endif /* IAMSUID */
13281fa4 3430
ae3f3efd
PS		 3431 if (PL_fdscript < 0 &&
3432 PL_euid) { /* oops, we're not the setuid root perl */
3433 /* PSz 18 Feb 04
3434 * When root runs a setuid script, we do not go through the same
3435 * steps of execing sperl and then perl with fd scripts, but
3436 * simply set up UIDs within the same perl invocation; so do
3437 * not have the same checks (on options, whatever) that we have
3438 * for plain users. No problem really: would have to be a script
3439 * that does not actually work for plain users; and if root is
3440 * foolish and can be persuaded to run such an unsafe script, he
3441 * might run also non-setuid ones, and deserves what he gets.
3442 *
3443 * Or, we might drop the PL_euid check above (and rely just on
3444 * PL_fdscript to avoid loops), and do the execs
3445 * even for root.
3446 */
13281fa4 3447#ifndef IAMSUID
ae3f3efd
PS		 3448 int which;
3449 /* PSz 11 Nov 03
3450 * Pass fd script to suidperl.
3451 * Exec suidperl, substituting fd script for scriptname.
3452 * Pass script name as "subdir" of fd, which perl will grok;
3453 * in fact will use that to distinguish this from "normal"
3454 * usage, see comments above.
3455 */
3456 PerlIO_rewind(PL_rsfp);
3457 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3458 /* PSz 27 Feb 04 Sanity checks on scriptname */
3459 if ((!scriptname) || (!*scriptname) ) {
3460 Perl_croak(aTHX_ "No setuid script name\n");
3461 }
3462 if (*scriptname == '-') {
3463 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3464 /* Or we might confuse it with an option when replacing
3465 * name in argument list, below (though we do pointer, not
3466 * string, comparisons).
3467 */
3468 }
3469 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3470 if (!PL_origargv[which]) {
3471 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3472 }
3473 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3474 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3475#if defined(HAS_FCNTL) && defined(F_SETFD)
3476 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3477#endif
b35112e7 3478 PERL_FPU_PRE_EXEC
a7cb1f99 3479 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3480 (int)PERL_REVISION, (int)PERL_VERSION,
3481 (int)PERL_SUBVERSION), PL_origargv);
b35112e7 3482 PERL_FPU_POST_EXEC
ae3f3efd
PS		 3483#endif /* IAMSUID */
3484 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
13281fa4
LW		 3485 }
3486
b28d0864 3487 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
ae3f3efd
PS		 3488/* PSz 26 Feb 04
3489 * This seems back to front: we try HAS_SETEGID first; if not available
3490 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3491 * in the sense that we only want to set EGID; but are there any machines
3492 * with either of the latter, but not the former? Same with UID, later.
3493 */
fe14fcc3 3494#ifdef HAS_SETEGID
b28d0864 3495 (void)setegid(PL_statbuf.st_gid);
a687059c 3496#else
fe14fcc3 3497#ifdef HAS_SETREGID
b28d0864 3498 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3499#else
3500#ifdef HAS_SETRESGID
b28d0864 3501 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3502#else
b28d0864 3503 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3504#endif
3505#endif
85e6fe83 3506#endif
b28d0864 3507 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3508 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3509 }
b28d0864
NIS		 3510 if (PL_statbuf.st_mode & S_ISUID) {
3511 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3512#ifdef HAS_SETEUID
b28d0864 3513 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3514#else
fe14fcc3 3515#ifdef HAS_SETREUID
b28d0864 3516 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3517#else
3518#ifdef HAS_SETRESUID
b28d0864 3519 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3520#else
b28d0864 3521 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3522#endif
3523#endif
85e6fe83 3524#endif
b28d0864 3525 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3526 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3527 }
b28d0864 3528 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3529#ifdef HAS_SETEUID
b28d0864 3530 (void)seteuid((Uid_t)PL_uid);
a687059c 3531#else
fe14fcc3 3532#ifdef HAS_SETREUID
b28d0864 3533 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3534#else
85e6fe83 3535#ifdef HAS_SETRESUID
b28d0864 3536 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3537#else
b28d0864 3538 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3539#endif
a687059c
LW		 3540#endif
3541#endif
b28d0864 3542 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3543 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3544 }
748a9306 3545 init_ids();
b28d0864 3546 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
ae3f3efd 3547 Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
13281fa4
LW		 3548 }
3549#ifdef IAMSUID
ae3f3efd 3550 else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
cea2e8a9 3551 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
ae3f3efd
PS		 3552 else if (PL_fdscript < 0 || PL_suidscript != 1)
3553 /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
3554 Perl_croak(aTHX_ "(sui