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
correctly handle C<< >> and C<<< >>> in diagnostics
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW		 1/* perl.c
2 *
4bb101f2 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
b5f8cc5c 4 * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
a687059c 5 *
352d5a3a
LW		 6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
a687059c 8 *
8d063cd8
LW		 9 */
10
a0d0e21e
LW		 11/*
12 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
13 */
45d8adaa 14
ae3f3efd
PS		 15/* PSz 12 Nov 03
16 *
17 * Be proud that perl(1) may proclaim:
18 * Setuid Perl scripts are safer than C programs ...
19 * Do not abandon (deprecate) suidperl. Do not advocate C wrappers.
20 *
21 * The flow was: perl starts, notices script is suid, execs suidperl with same
22 * arguments; suidperl opens script, checks many things, sets itself with
23 * right UID, execs perl with similar arguments but with script pre-opened on
24 * /dev/fd/xxx; perl checks script is as should be and does work. This was
25 * insecure: see perlsec(1) for many problems with this approach.
26 *
27 * The "correct" flow should be: perl starts, opens script and notices it is
28 * suid, checks many things, execs suidperl with similar arguments but with
29 * script on /dev/fd/xxx; suidperl checks script and /dev/fd/xxx object are
30 * same, checks arguments match #! line, sets itself with right UID, execs
31 * perl with same arguments; perl checks many things and does work.
32 *
33 * (Opening the script in perl instead of suidperl, we "lose" scripts that
34 * are readable to the target UID but not to the invoker. Where did
35 * unreadable scripts work anyway?)
36 *
37 * For now, suidperl and perl are pretty much the same large and cumbersome
38 * program, so suidperl can check its argument list (see comments elsewhere).
39 *
40 * References:
41 * Original bug report:
42 * http://bugs.perl.org/index.html?req=bug_id&bug_id=20010322.218
43 * http://rt.perl.org/rt2/Ticket/Display.html?id=6511
44 * Comments and discussion with Debian:
45 * http://bugs.debian.org/203426
46 * http://bugs.debian.org/220486
47 * Debian Security Advisory DSA 431-1 (does not fully fix problem):
48 * http://www.debian.org/security/2004/dsa-431
49 * CVE candidate:
50 * http://cve.mitre.org/cgi-bin/cvename.cgi?name=CAN-2003-0618
51 * Previous versions of this patch sent to perl5-porters:
52 * http://www.mail-archive.com/perl5-porters@perl.org/msg71953.html
53 * http://www.mail-archive.com/perl5-porters@perl.org/msg75245.html
54 * http://www.mail-archive.com/perl5-porters@perl.org/msg75563.html
55 * http://www.mail-archive.com/perl5-porters@perl.org/msg75635.html
56 *
57Paul Szabo - psz@maths.usyd.edu.au http://www.maths.usyd.edu.au:8000/u/psz/
58School of Mathematics and Statistics University of Sydney 2006 Australia
59 *
60 */
61/* PSz 13 Nov 03
62 * Use truthful, neat, specific error messages.
63 * Cannot always hide the truth; security must not depend on doing so.
64 */
65
66/* PSz 18 Feb 04
67 * Use global(?), thread-local fdscript for easier checks.
68 * (I do not understand how we could possibly get a thread race:
69 * do not all threads go through the same initialization? Or in
70 * fact, are not threads started only after we get the script and
71 * so know what to do? Oh well, make things super-safe...)
72 */
73
378cc40b 74#include "EXTERN.h"
864dbfa3 75#define PERL_IN_PERL_C
378cc40b 76#include "perl.h"
e3321bb0 77#include "patchlevel.h" /* for local_patches */
378cc40b 78
011f1a1a
JH		 79#ifdef NETWARE
80#include "nwutil.h"
81char *nw_get_sitelib(const char *pl);
82#endif
83
df5cef82 84/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW		 85#ifdef I_UNISTD
86#include <unistd.h>
87#endif
a0d0e21e 88
5311654c
JH		 89#ifdef __BEOS__
90# define HZ 1000000
91#endif
92
93#ifndef HZ
94# ifdef CLK_TCK
95# define HZ CLK_TCK
96# else
97# define HZ 60
98# endif
99#endif
100
7114a2d2 101#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
20ce7b12 102char *getenv (char *); /* Usually in <stdlib.h> */
54310121 103#endif
104
acfe0abc 105static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
0cb96387 106
a687059c
LW		 107#ifdef IAMSUID
108#ifndef DOSUID
109#define DOSUID
110#endif
ae3f3efd 111#endif /* IAMSUID */
378cc40b 112
a687059c
LW		 113#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
114#ifdef DOSUID
115#undef DOSUID
116#endif
117#endif
8d063cd8 118
3db8f154 119#if defined(USE_ITHREADS)
06d86050
GS		 120# define INIT_TLS_AND_INTERP \
121 STMT_START { \
122 if (!PL_curinterp) { \
123 PERL_SET_INTERP(my_perl); \
124 INIT_THREADS; \
125 ALLOC_THREAD_KEY; \
534825c4
GS		 126 PERL_SET_THX(my_perl); \
127 OP_REFCNT_INIT; \
7d4724a4 128 MUTEX_INIT(&PL_dollarzero_mutex); \
534825c4
GS		 129 } \
130 else { \
131 PERL_SET_THX(my_perl); \
06d86050 132 } \
06d86050 133 } STMT_END
3db8f154 134#else
06d86050
GS		 135# define INIT_TLS_AND_INTERP \
136 STMT_START { \
137 if (!PL_curinterp) { \
138 PERL_SET_INTERP(my_perl); \
139 } \
140 PERL_SET_THX(my_perl); \
141 } STMT_END
142# endif
06d86050 143
32e30700
GS		 144#ifdef PERL_IMPLICIT_SYS
145PerlInterpreter *
7766f137
GS		 146perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
147 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
32e30700
GS		 148 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
149 struct IPerlDir* ipD, struct IPerlSock* ipS,
150 struct IPerlProc* ipP)
151{
152 PerlInterpreter *my_perl;
32e30700
GS		 153 /* New() needs interpreter, so call malloc() instead */
154 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
06d86050 155 INIT_TLS_AND_INTERP;
32e30700
GS		 156 Zero(my_perl, 1, PerlInterpreter);
157 PL_Mem = ipM;
7766f137
GS		 158 PL_MemShared = ipMS;
159 PL_MemParse = ipMP;
32e30700
GS		 160 PL_Env = ipE;
161 PL_StdIO = ipStd;
162 PL_LIO = ipLIO;
163 PL_Dir = ipD;
164 PL_Sock = ipS;
165 PL_Proc = ipP;
7766f137 166
32e30700
GS		 167 return my_perl;
168}
169#else
954c1994
GS		 170
171/*
ccfc67b7
JH		 172=head1 Embedding Functions
173
954c1994
GS		 174=for apidoc perl_alloc
175
176Allocates a new Perl interpreter. See L<perlembed>.
177
178=cut
179*/
180
93a17b20 181PerlInterpreter *
cea2e8a9 182perl_alloc(void)
79072805 183{
cea2e8a9 184 PerlInterpreter *my_perl;
35d7cf2c
JH		 185#ifdef USE_5005THREADS
186 dTHX;
187#endif
79072805 188
54aff467 189 /* New() needs interpreter, so call malloc() instead */
e8ee3774 190 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 191
06d86050 192 INIT_TLS_AND_INTERP;
dedcbb81 193 Zero(my_perl, 1, PerlInterpreter);
cea2e8a9 194 return my_perl;
79072805 195}
32e30700 196#endif /* PERL_IMPLICIT_SYS */
79072805 197
954c1994
GS		 198/*
199=for apidoc perl_construct
200
201Initializes a new Perl interpreter. See L<perlembed>.
202
203=cut
204*/
205
79072805 206void
0cb96387 207perl_construct(pTHXx)
79072805 208{
8990e307 209#ifdef MULTIPLICITY
54aff467 210 init_interp();
ac27b0f5 211 PL_perl_destruct_level = 1;
54aff467
GS		 212#else
213 if (PL_perl_destruct_level > 0)
214 init_interp();
215#endif
33f46ff6 216 /* Init the real globals (and main thread)? */
3280af22 217 if (!PL_linestr) {
14dd3ad8 218#ifdef PERL_FLEXIBLE_EXCEPTIONS
0b94c7bb 219 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
14dd3ad8 220#endif
312caa8e 221
2aea9f8a
GS		 222 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
223
3280af22
NIS		 224 PL_linestr = NEWSV(65,79);
225 sv_upgrade(PL_linestr,SVt_PVIV);
79072805 226
3280af22 227 if (!SvREADONLY(&PL_sv_undef)) {
d689ffdd
JP		 228 /* set read-only and try to insure than we wont see REFCNT==0
229 very often */
230
3280af22
NIS		 231 SvREADONLY_on(&PL_sv_undef);
232 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
79072805 233
3280af22
NIS		 234 sv_setpv(&PL_sv_no,PL_No);
235 SvNV(&PL_sv_no);
236 SvREADONLY_on(&PL_sv_no);
237 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
79072805 238
3280af22
NIS		 239 sv_setpv(&PL_sv_yes,PL_Yes);
240 SvNV(&PL_sv_yes);
241 SvREADONLY_on(&PL_sv_yes);
242 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7996736c
MHM		 243
244 SvREADONLY_on(&PL_sv_placeholder);
245 SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
6e72f9df 246 }
79072805 247
cea2e8a9 248 PL_sighandlerp = Perl_sighandler;
3280af22 249 PL_pidstatus = newHV();
79072805
LW		 250 }
251
8bfdd7d9 252 PL_rs = newSVpvn("\n", 1);
dc92893f 253
cea2e8a9 254 init_stacks();
79072805 255
748a9306 256 init_ids();
3280af22 257 PL_lex_state = LEX_NOTPARSING;
a5f75d66 258
312caa8e 259 JMPENV_BOOTSTRAP;
f86702cc 260 STATUS_ALL_SUCCESS;
261
0672f40e 262 init_i18nl10n(1);
36477c24 263 SET_NUMERIC_STANDARD();
0b5b802d 264
a7cb1f99
GS		 265 {
266 U8 *s;
267 PL_patchlevel = NEWSV(0,4);
155aba94 268 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
a7cb1f99 269 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
806e7201 270 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
a7cb1f99 271 s = (U8*)SvPVX(PL_patchlevel);
9041c2e3
NIS		 272 /* Build version strings using "native" characters */
273 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
274 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
275 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
a7cb1f99
GS		 276 *s = '\0';
277 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
278 SvPOK_on(PL_patchlevel);
00d6e121
MB		 279 SvNVX(PL_patchlevel) = (NV)PERL_REVISION +
280 ((NV)PERL_VERSION / (NV)1000) +
281 ((NV)PERL_SUBVERSION / (NV)1000000);
a7cb1f99
GS		 282 SvNOK_on(PL_patchlevel); /* dual valued */
283 SvUTF8_on(PL_patchlevel);
284 SvREADONLY_on(PL_patchlevel);
285 }
79072805 286
ab821d7f 287#if defined(LOCAL_PATCH_COUNT)
3280af22 288 PL_localpatches = local_patches; /* For possible -v */
ab821d7f 289#endif
290
52853b95
GS		 291#ifdef HAVE_INTERP_INTERN
292 sys_intern_init();
293#endif
294
3a1ee7e8 295 PerlIO_init(aTHX); /* Hook to IO system */
760ac839 296
3280af22
NIS		 297 PL_fdpid = newAV(); /* for remembering popen pids by fd */
298 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
24944567 299 PL_errors = newSVpvn("",0);
48c6b404 300 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
1f483ca1
JH		 301 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
302 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
1fcf4c12 303#ifdef USE_ITHREADS
13137afc
AB		 304 PL_regex_padav = newAV();
305 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
306 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 307#endif
e5dd39fc 308#ifdef USE_REENTRANT_API
59bd0823 309 Perl_reentrant_init(aTHX);
e5dd39fc 310#endif
3d47000e
AB		 311
312 /* Note that strtab is a rather special HV. Assumptions are made
313 about not iterating on it, and not adding tie magic to it.
314 It is properly deallocated in perl_destruct() */
315 PL_strtab = newHV();
316
3d47000e
AB		 317 HvSHAREKEYS_off(PL_strtab); /* mandatory */
318 hv_ksplit(PL_strtab, 512);
319
0631ea03
AB		 320#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
321 _dyld_lookup_and_bind
322 ("__environ", (unsigned long *) &environ_pointer, NULL);
323#endif /* environ */
324
2f42fcb0
JH		 325#ifndef PERL_MICRO
326# ifdef USE_ENVIRON_ARRAY
0631ea03 327 PL_origenviron = environ;
2f42fcb0 328# endif
0631ea03
AB		 329#endif
330
5311654c
JH		 331 /* Use sysconf(_SC_CLK_TCK) if available, if not
332 * available or if the sysconf() fails, use the HZ. */
333#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
334 PL_clocktick = sysconf(_SC_CLK_TCK);
335 if (PL_clocktick <= 0)
336#endif
337 PL_clocktick = HZ;
338
081fc587
AB		 339 PL_stashcache = newHV();
340
8990e307 341 ENTER;
79072805
LW		 342}
343
954c1994 344/*
62375a60
NIS		 345=for apidoc nothreadhook
346
347Stub that provides thread hook for perl_destruct when there are
348no threads.
349
350=cut
351*/
352
353int
4e9e3734 354Perl_nothreadhook(pTHX)
62375a60
NIS		 355{
356 return 0;
357}
358
359/*
954c1994
GS		 360=for apidoc perl_destruct
361
362Shuts down a Perl interpreter. See L<perlembed>.
363
364=cut
365*/
366
31d77e54 367int
0cb96387 368perl_destruct(pTHXx)
79072805 369{
7c474504 370 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
a0d0e21e 371 HV *hv;
4d1ff10f 372#ifdef USE_5005THREADS
cea2e8a9 373 dTHX;
4d1ff10f 374#endif /* USE_5005THREADS */
8990e307 375
7766f137
GS		 376 /* wait for all pseudo-forked children to finish */
377 PERL_WAIT_FOR_CHILDREN;
378
3280af22 379 destruct_level = PL_perl_destruct_level;
4633a7c4
LW		 380#ifdef DEBUGGING
381 {
382 char *s;
155aba94 383 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
5f05dabc 384 int i = atoi(s);
385 if (destruct_level < i)
386 destruct_level = i;
387 }
4633a7c4
LW		 388 }
389#endif
390
31d77e54
AB		 391
392 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
f3faeb53
AB		 393 dJMPENV;
394 int x = 0;
395
396 JMPENV_PUSH(x);
397 if (PL_endav && !PL_minus_c)
398 call_list(PL_scopestack_ix, PL_endav);
399 JMPENV_POP;
26f423df 400 }
f3faeb53 401 LEAVE;
a0d0e21e
LW		 402 FREETMPS;
403
e00b64d4 404 /* Need to flush since END blocks can produce output */
f13a2bc0 405 my_fflush_all();
e00b64d4 406
62375a60
NIS		 407 if (CALL_FPTR(PL_threadhook)(aTHX)) {
408 /* Threads hook has vetoed further cleanup */
b47cad08 409 return STATUS_NATIVE_EXPORT;
62375a60
NIS		 410 }
411
ff0cee69 412 /* We must account for everything. */
413
414 /* Destroy the main CV and syntax tree */
3280af22 415 if (PL_main_root) {
4e380990
DM		 416 /* ensure comppad/curpad to refer to main's pad */
417 if (CvPADLIST(PL_main_cv)) {
418 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
419 }
3280af22
NIS		 420 op_free(PL_main_root);
421 PL_main_root = Nullop;
a0d0e21e 422 }
3280af22
NIS		 423 PL_curcop = &PL_compiling;
424 PL_main_start = Nullop;
425 SvREFCNT_dec(PL_main_cv);
426 PL_main_cv = Nullcv;
24d3c518 427 PL_dirty = TRUE;
ff0cee69 428
13621cfb
NIS		 429 /* Tell PerlIO we are about to tear things apart in case
430 we have layers which are using resources that should
431 be cleaned up now.
432 */
433
434 PerlIO_destruct(aTHX);
435
3280af22 436 if (PL_sv_objcount) {
a0d0e21e
LW		 437 /*
438 * Try to destruct global references. We do this first so that the
439 * destructors and destructees still exist. Some sv's might remain.
440 * Non-referenced objects are on their own.
441 */
a0d0e21e 442 sv_clean_objs();
bf9cdc68 443 PL_sv_objcount = 0;
8990e307
LW		 444 }
445
5cd24f17 446 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS		 447 SvREFCNT_dec(PL_warnhook);
448 PL_warnhook = Nullsv;
449 SvREFCNT_dec(PL_diehook);
450 PL_diehook = Nullsv;
5cd24f17 451
4b556e6c 452 /* call exit list functions */
3280af22 453 while (PL_exitlistlen-- > 0)
acfe0abc 454 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 455
3280af22 456 Safefree(PL_exitlist);
4b556e6c 457
1c4916e5
CB		 458 PL_exitlist = NULL;
459 PL_exitlistlen = 0;
460
a0d0e21e 461 if (destruct_level == 0){
8990e307 462
a0d0e21e 463 DEBUG_P(debprofdump());
ac27b0f5 464
56a2bab7
NIS		 465#if defined(PERLIO_LAYERS)
466 /* No more IO - including error messages ! */
467 PerlIO_cleanup(aTHX);
468#endif
469
a0d0e21e 470 /* The exit() function will do everything that needs doing. */
b47cad08 471 return STATUS_NATIVE_EXPORT;
a0d0e21e 472 }
5dd60ef7 473
551a8b83 474 /* jettison our possibly duplicated environment */
4b647fb0
DM		 475 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
476 * so we certainly shouldn't free it here
477 */
2f42fcb0 478#ifndef PERL_MICRO
4b647fb0 479#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
4efc5df6
GS		 480 if (environ != PL_origenviron
481#ifdef USE_ITHREADS
482 /* only main thread can free environ[0] contents */
483 && PL_curinterp == aTHX
484#endif
485 )
486 {
551a8b83
JH		 487 I32 i;
488
489 for (i = 0; environ[i]; i++)
4b420006 490 safesysfree(environ[i]);
0631ea03 491
4b420006
JH		 492 /* Must use safesysfree() when working with environ. */
493 safesysfree(environ);
551a8b83
JH		 494
495 environ = PL_origenviron;
496 }
497#endif
2f42fcb0 498#endif /* !PERL_MICRO */
551a8b83 499
5f8cb046
DM		 500#ifdef USE_ITHREADS
501 /* the syntax tree is shared between clones
502 * so op_free(PL_main_root) only ReREFCNT_dec's
503 * REGEXPs in the parent interpreter
504 * we need to manually ReREFCNT_dec for the clones
505 */
506 {
507 I32 i = AvFILLp(PL_regex_padav) + 1;
508 SV **ary = AvARRAY(PL_regex_padav);
509
510 while (i) {
35061a7e 511 SV *resv = ary[--i];
ba89bb6e 512 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
35061a7e
DM		 513
514 if (SvFLAGS(resv) & SVf_BREAK) {
577e12cc 515 /* this is PL_reg_curpm, already freed
35061a7e
DM		 516 * flag is set in regexec.c:S_regtry
517 */
518 SvFLAGS(resv) &= ~SVf_BREAK;
3a1ee7e8 519 }
1cc8b4c5
AB		 520 else if(SvREPADTMP(resv)) {
521 SvREPADTMP_off(resv);
522 }
35061a7e 523 else {
5f8cb046
DM		 524 ReREFCNT_dec(re);
525 }
526 }
527 }
528 SvREFCNT_dec(PL_regex_padav);
529 PL_regex_padav = Nullav;
530 PL_regex_pad = NULL;
531#endif
532
081fc587
AB		 533 SvREFCNT_dec((SV*) PL_stashcache);
534 PL_stashcache = NULL;
535
5f05dabc 536 /* loosen bonds of global variables */
537
3280af22
NIS		 538 if(PL_rsfp) {
539 (void)PerlIO_close(PL_rsfp);
540 PL_rsfp = Nullfp;
8ebc5c01 541 }
542
543 /* Filters for program text */
3280af22
NIS		 544 SvREFCNT_dec(PL_rsfp_filters);
545 PL_rsfp_filters = Nullav;
8ebc5c01 546
547 /* switches */
3280af22
NIS		 548 PL_preprocess = FALSE;
549 PL_minus_n = FALSE;
550 PL_minus_p = FALSE;
551 PL_minus_l = FALSE;
552 PL_minus_a = FALSE;
553 PL_minus_F = FALSE;
554 PL_doswitches = FALSE;
599cee73 555 PL_dowarn = G_WARN_OFF;
3280af22
NIS		 556 PL_doextract = FALSE;
557 PL_sawampersand = FALSE; /* must save all match strings */
3280af22
NIS		 558 PL_unsafe = FALSE;
559
560 Safefree(PL_inplace);
561 PL_inplace = Nullch;
a7cb1f99 562 SvREFCNT_dec(PL_patchlevel);
3280af22
NIS		 563
564 if (PL_e_script) {
565 SvREFCNT_dec(PL_e_script);
566 PL_e_script = Nullsv;
8ebc5c01 567 }
568
bf9cdc68
RG		 569 PL_perldb = 0;
570
8ebc5c01 571 /* magical thingies */
572
7889fe52
NIS		 573 SvREFCNT_dec(PL_ofs_sv); /* $, */
574 PL_ofs_sv = Nullsv;
5f05dabc 575
7889fe52
NIS		 576 SvREFCNT_dec(PL_ors_sv); /* $\ */
577 PL_ors_sv = Nullsv;
8ebc5c01 578
3280af22
NIS		 579 SvREFCNT_dec(PL_rs); /* $/ */
580 PL_rs = Nullsv;
dc92893f 581
d33b2eba
GS		 582 PL_multiline = 0; /* $* */
583 Safefree(PL_osname); /* $^O */
584 PL_osname = Nullch;
5f05dabc 585
3280af22
NIS		 586 SvREFCNT_dec(PL_statname);
587 PL_statname = Nullsv;
588 PL_statgv = Nullgv;
5f05dabc 589
8ebc5c01 590 /* defgv, aka *_ should be taken care of elsewhere */
591
8ebc5c01 592 /* clean up after study() */
3280af22
NIS		 593 SvREFCNT_dec(PL_lastscream);
594 PL_lastscream = Nullsv;
595 Safefree(PL_screamfirst);
596 PL_screamfirst = 0;
597 Safefree(PL_screamnext);
598 PL_screamnext = 0;
8ebc5c01 599
7d5ea4e7
GS		 600 /* float buffer */
601 Safefree(PL_efloatbuf);
602 PL_efloatbuf = Nullch;
603 PL_efloatsize = 0;
604
8ebc5c01 605 /* startup and shutdown function lists */
3280af22 606 SvREFCNT_dec(PL_beginav);
5a837c8f 607 SvREFCNT_dec(PL_beginav_save);
3280af22 608 SvREFCNT_dec(PL_endav);
7d30b5c4 609 SvREFCNT_dec(PL_checkav);
ece599bd 610 SvREFCNT_dec(PL_checkav_save);
3280af22
NIS		 611 SvREFCNT_dec(PL_initav);
612 PL_beginav = Nullav;
5a837c8f 613 PL_beginav_save = Nullav;
3280af22 614 PL_endav = Nullav;
7d30b5c4 615 PL_checkav = Nullav;
ece599bd 616 PL_checkav_save = Nullav;
3280af22 617 PL_initav = Nullav;
5618dfe8 618
8ebc5c01 619 /* shortcuts just get cleared */
3280af22 620 PL_envgv = Nullgv;
3280af22
NIS		 621 PL_incgv = Nullgv;
622 PL_hintgv = Nullgv;
623 PL_errgv = Nullgv;
624 PL_argvgv = Nullgv;
625 PL_argvoutgv = Nullgv;
626 PL_stdingv = Nullgv;
bf49b057 627 PL_stderrgv = Nullgv;
3280af22
NIS		 628 PL_last_in_gv = Nullgv;
629 PL_replgv = Nullgv;
bf9cdc68
RG		 630 PL_DBgv = Nullgv;
631 PL_DBline = Nullgv;
632 PL_DBsub = Nullgv;
633 PL_DBsingle = Nullsv;
634 PL_DBtrace = Nullsv;
635 PL_DBsignal = Nullsv;
636 PL_DBassertion = Nullsv;
637 PL_DBcv = Nullcv;
638 PL_dbargs = Nullav;
5c831c24 639 PL_debstash = Nullhv;
8ebc5c01 640
641 /* reset so print() ends up where we expect */
642 setdefout(Nullgv);
5c831c24 643
7a1c5554
GS		 644 SvREFCNT_dec(PL_argvout_stack);
645 PL_argvout_stack = Nullav;
8ebc5c01 646
5c831c24
GS		 647 SvREFCNT_dec(PL_modglobal);
648 PL_modglobal = Nullhv;
649 SvREFCNT_dec(PL_preambleav);
650 PL_preambleav = Nullav;
651 SvREFCNT_dec(PL_subname);
652 PL_subname = Nullsv;
653 SvREFCNT_dec(PL_linestr);
654 PL_linestr = Nullsv;
655 SvREFCNT_dec(PL_pidstatus);
656 PL_pidstatus = Nullhv;
657 SvREFCNT_dec(PL_toptarget);
658 PL_toptarget = Nullsv;
659 SvREFCNT_dec(PL_bodytarget);
660 PL_bodytarget = Nullsv;
661 PL_formtarget = Nullsv;
662
d33b2eba 663 /* free locale stuff */
b9582b6a 664#ifdef USE_LOCALE_COLLATE
d33b2eba
GS		 665 Safefree(PL_collation_name);
666 PL_collation_name = Nullch;
b9582b6a 667#endif
d33b2eba 668
b9582b6a 669#ifdef USE_LOCALE_NUMERIC
d33b2eba
GS		 670 Safefree(PL_numeric_name);
671 PL_numeric_name = Nullch;
a453c169 672 SvREFCNT_dec(PL_numeric_radix_sv);
bf9cdc68 673 PL_numeric_radix_sv = Nullsv;
b9582b6a 674#endif
d33b2eba 675
5c831c24
GS		 676 /* clear utf8 character classes */
677 SvREFCNT_dec(PL_utf8_alnum);
678 SvREFCNT_dec(PL_utf8_alnumc);
679 SvREFCNT_dec(PL_utf8_ascii);
680 SvREFCNT_dec(PL_utf8_alpha);
681 SvREFCNT_dec(PL_utf8_space);
682 SvREFCNT_dec(PL_utf8_cntrl);
683 SvREFCNT_dec(PL_utf8_graph);
684 SvREFCNT_dec(PL_utf8_digit);
685 SvREFCNT_dec(PL_utf8_upper);
686 SvREFCNT_dec(PL_utf8_lower);
687 SvREFCNT_dec(PL_utf8_print);
688 SvREFCNT_dec(PL_utf8_punct);
689 SvREFCNT_dec(PL_utf8_xdigit);
690 SvREFCNT_dec(PL_utf8_mark);
691 SvREFCNT_dec(PL_utf8_toupper);
4dbdbdc2 692 SvREFCNT_dec(PL_utf8_totitle);
5c831c24 693 SvREFCNT_dec(PL_utf8_tolower);
b4e400f9 694 SvREFCNT_dec(PL_utf8_tofold);
82686b01
JH		 695 SvREFCNT_dec(PL_utf8_idstart);
696 SvREFCNT_dec(PL_utf8_idcont);
5c831c24
GS		 697 PL_utf8_alnum = Nullsv;
698 PL_utf8_alnumc = Nullsv;
699 PL_utf8_ascii = Nullsv;
700 PL_utf8_alpha = Nullsv;
701 PL_utf8_space = Nullsv;
702 PL_utf8_cntrl = Nullsv;
703 PL_utf8_graph = Nullsv;
704 PL_utf8_digit = Nullsv;
705 PL_utf8_upper = Nullsv;
706 PL_utf8_lower = Nullsv;
707 PL_utf8_print = Nullsv;
708 PL_utf8_punct = Nullsv;
709 PL_utf8_xdigit = Nullsv;
710 PL_utf8_mark = Nullsv;
711 PL_utf8_toupper = Nullsv;
712 PL_utf8_totitle = Nullsv;
713 PL_utf8_tolower = Nullsv;
b4e400f9 714 PL_utf8_tofold = Nullsv;
82686b01
JH		 715 PL_utf8_idstart = Nullsv;
716 PL_utf8_idcont = Nullsv;
5c831c24 717
971a9dd3
GS		 718 if (!specialWARN(PL_compiling.cop_warnings))
719 SvREFCNT_dec(PL_compiling.cop_warnings);
5c831c24 720 PL_compiling.cop_warnings = Nullsv;
ac27b0f5
NIS		 721 if (!specialCopIO(PL_compiling.cop_io))
722 SvREFCNT_dec(PL_compiling.cop_io);
723 PL_compiling.cop_io = Nullsv;
05ec9bb3
NIS		 724 CopFILE_free(&PL_compiling);
725 CopSTASH_free(&PL_compiling);
5c831c24 726
a0d0e21e 727 /* Prepare to destruct main symbol table. */
5f05dabc 728
3280af22
NIS		 729 hv = PL_defstash;
730 PL_defstash = 0;
a0d0e21e 731 SvREFCNT_dec(hv);
5c831c24
GS		 732 SvREFCNT_dec(PL_curstname);
733 PL_curstname = Nullsv;
a0d0e21e 734
5a844595
GS		 735 /* clear queued errors */
736 SvREFCNT_dec(PL_errors);
737 PL_errors = Nullsv;
738
a0d0e21e 739 FREETMPS;
0453d815 740 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
3280af22 741 if (PL_scopestack_ix != 0)
9014280d 742 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 743 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
3280af22
NIS		 744 (long)PL_scopestack_ix);
745 if (PL_savestack_ix != 0)
9014280d 746 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 747 "Unbalanced saves: %ld more saves than restores\n",
3280af22
NIS		 748 (long)PL_savestack_ix);
749 if (PL_tmps_floor != -1)
9014280d 750 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
3280af22 751 (long)PL_tmps_floor + 1);
a0d0e21e 752 if (cxstack_ix != -1)
9014280d 753 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
ff0cee69 754 (long)cxstack_ix + 1);
a0d0e21e 755 }
8990e307
LW		 756
757 /* Now absolutely destruct everything, somehow or other, loops or no. */
d33b2eba 758 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
3280af22 759 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
5226ed68
JH		 760
761 /* the 2 is for PL_fdpid and PL_strtab */
762 while (PL_sv_count > 2 && sv_clean_all())
763 ;
764
d33b2eba
GS		 765 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
766 SvFLAGS(PL_fdpid) |= SVt_PVAV;
3280af22
NIS		 767 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
768 SvFLAGS(PL_strtab) |= SVt_PVHV;
d33b2eba 769
d4777f27
GS		 770 AvREAL_off(PL_fdpid); /* no surviving entries */
771 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
d33b2eba
GS		 772 PL_fdpid = Nullav;
773
6c644e78
GS		 774#ifdef HAVE_INTERP_INTERN
775 sys_intern_clear();
776#endif
777
6e72f9df 778 /* Destruct the global string table. */
779 {
780 /* Yell and reset the HeVAL() slots that are still holding refcounts,
781 * so that sv_free() won't fail on them.
782 */
783 I32 riter;
784 I32 max;
785 HE *hent;
786 HE **array;
787
788 riter = 0;
3280af22
NIS		 789 max = HvMAX(PL_strtab);
790 array = HvARRAY(PL_strtab);
6e72f9df 791 hent = array[0];
792 for (;;) {
0453d815 793 if (hent && ckWARN_d(WARN_INTERNAL)) {
9014280d 794 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 795 "Unbalanced string table refcount: (%d) for \"%s\"",
6e72f9df 796 HeVAL(hent) - Nullsv, HeKEY(hent));
797 HeVAL(hent) = Nullsv;
798 hent = HeNEXT(hent);
799 }
800 if (!hent) {
801 if (++riter > max)
802 break;
803 hent = array[riter];
804 }
805 }
806 }
3280af22 807 SvREFCNT_dec(PL_strtab);
6e72f9df 808
e652bb2f 809#ifdef USE_ITHREADS
a0739874
DM		 810 /* free the pointer table used for cloning */
811 ptr_table_free(PL_ptr_table);
bf9cdc68 812 PL_ptr_table = (PTR_TBL_t*)NULL;
53186e96 813#endif
a0739874 814
d33b2eba
GS		 815 /* free special SVs */
816
817 SvREFCNT(&PL_sv_yes) = 0;
818 sv_clear(&PL_sv_yes);
819 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 820 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS		 821
822 SvREFCNT(&PL_sv_no) = 0;
823 sv_clear(&PL_sv_no);
824 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 825 SvFLAGS(&PL_sv_no) = 0;
01724ea0 826
9f375a43
DM		 827 {
828 int i;
829 for (i=0; i<=2; i++) {
830 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
831 sv_clear(PERL_DEBUG_PAD(i));
832 SvANY(PERL_DEBUG_PAD(i)) = NULL;
833 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
834 }
835 }
836
0453d815 837 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
9014280d 838 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 839
eba0f806
DM		 840#ifdef DEBUG_LEAKING_SCALARS
841 if (PL_sv_count != 0) {
842 SV* sva;
843 SV* sv;
844 register SV* svend;
845
846 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
847 svend = &sva[SvREFCNT(sva)];
848 for (sv = sva + 1; sv < svend; ++sv) {
849 if (SvTYPE(sv) != SVTYPEMASK) {
472d47bc
SB		 850 PerlIO_printf(Perl_debug_log, "leaked: 0x%p"
851 pTHX__FORMAT "\n",
852 sv pTHX__VALUE);
eba0f806
DM		 853 }
854 }
855 }
856 }
857#endif
bf9cdc68 858 PL_sv_count = 0;
eba0f806
DM		 859
860
56a2bab7 861#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS		 862 /* No more IO - including error messages ! */
863 PerlIO_cleanup(aTHX);
864#endif
865
9f4bd222
NIS		 866 /* sv_undef needs to stay immortal until after PerlIO_cleanup
867 as currently layers use it rather than Nullsv as a marker
868 for no arg - and will try and SvREFCNT_dec it.
869 */
870 SvREFCNT(&PL_sv_undef) = 0;
871 SvREADONLY_off(&PL_sv_undef);
872
3280af22 873 Safefree(PL_origfilename);
bf9cdc68 874 PL_origfilename = Nullch;
3280af22 875 Safefree(PL_reg_start_tmp);
bf9cdc68
RG		 876 PL_reg_start_tmp = (char**)NULL;
877 PL_reg_start_tmpl = 0;
5c5e4c24
IZ		 878 if (PL_reg_curpm)
879 Safefree(PL_reg_curpm);
82ba1be6 880 Safefree(PL_reg_poscache);
dd28f7bb 881 free_tied_hv_pool();
3280af22 882 Safefree(PL_op_mask);
cf36064f 883 Safefree(PL_psig_ptr);
bf9cdc68 884 PL_psig_ptr = (SV**)NULL;
cf36064f 885 Safefree(PL_psig_name);
bf9cdc68 886 PL_psig_name = (SV**)NULL;
2c2666fc 887 Safefree(PL_bitcount);
bf9cdc68 888 PL_bitcount = Nullch;
ce08f86c 889 Safefree(PL_psig_pend);
bf9cdc68
RG		 890 PL_psig_pend = (int*)NULL;
891 PL_formfeed = Nullsv;
892 Safefree(PL_ofmt);
893 PL_ofmt = Nullch;
6e72f9df 894 nuke_stacks();
bf9cdc68
RG		 895 PL_tainting = FALSE;
896 PL_taint_warn = FALSE;
3280af22 897 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
bf9cdc68 898 PL_debug = 0;
ac27b0f5 899
a0d0e21e 900 DEBUG_P(debprofdump());
d33b2eba 901
e5dd39fc 902#ifdef USE_REENTRANT_API
10bc17b6 903 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 904#endif
905
612f20c3
GS		 906 sv_free_arenas();
907
fc36a67e 908 /* As the absolutely last thing, free the non-arena SV for mess() */
909
3280af22 910 if (PL_mess_sv) {
9c63abab
GS		 911 /* it could have accumulated taint magic */
912 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
913 MAGIC* mg;
914 MAGIC* moremagic;
915 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
916 moremagic = mg->mg_moremagic;
14befaf4
DM		 917 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
918 && mg->mg_len >= 0)
9c63abab
GS		 919 Safefree(mg->mg_ptr);
920 Safefree(mg);
921 }
922 }
fc36a67e 923 /* we know that type >= SVt_PV */
155aba94 924 (void)SvOOK_off(PL_mess_sv);
3280af22
NIS		 925 Safefree(SvPVX(PL_mess_sv));
926 Safefree(SvANY(PL_mess_sv));
927 Safefree(PL_mess_sv);
928 PL_mess_sv = Nullsv;
fc36a67e 929 }
31d77e54 930 return STATUS_NATIVE_EXPORT;
79072805
LW		 931}
932
954c1994
GS		 933/*
934=for apidoc perl_free
935
936Releases a Perl interpreter. See L<perlembed>.
937
938=cut
939*/
940
79072805 941void
0cb96387 942perl_free(pTHXx)
79072805 943{
acfe0abc 944#if defined(WIN32) || defined(NETWARE)
ce3e5b80 945# if defined(PERL_IMPLICIT_SYS)
acfe0abc
GS		 946# ifdef NETWARE
947 void *host = nw_internal_host;
948# else
949 void *host = w32_internal_host;
950# endif
ce3e5b80 951 PerlMem_free(aTHXx);
acfe0abc 952# ifdef NETWARE
011f1a1a 953 nw_delete_internal_host(host);
acfe0abc
GS		 954# else
955 win32_delete_internal_host(host);
956# endif
1c0ca838
GS		 957# else
958 PerlMem_free(aTHXx);
959# endif
acfe0abc
GS		 960#else
961 PerlMem_free(aTHXx);
76e3520e 962#endif
79072805
LW		 963}
964
4b556e6c 965void
864dbfa3 966Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 967{
3280af22
NIS		 968 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
969 PL_exitlist[PL_exitlistlen].fn = fn;
970 PL_exitlist[PL_exitlistlen].ptr = ptr;
971 ++PL_exitlistlen;
4b556e6c
JD		 972}
973
954c1994
GS		 974/*
975=for apidoc perl_parse
976
977Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
978
979=cut
980*/
981
79072805 982int
0cb96387 983perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 984{
6224f72b 985 I32 oldscope;
6224f72b 986 int ret;
db36c5a1 987 dJMPENV;
4d1ff10f 988#ifdef USE_5005THREADS
cea2e8a9
GS		 989 dTHX;
990#endif
8d063cd8 991
a687059c
LW		 992#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
993#ifdef IAMSUID
994#undef IAMSUID
cea2e8a9 995 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c 996setuid perl scripts securely.\n");
ae3f3efd 997#endif /* IAMSUID */
a687059c
LW		 998#endif
999
b0891165
JH		 1000#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1001 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
103dd899 1002 * This MUST be done before any hash stores or fetches take place.
008fb0c0
NC		 1003 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1004 * yourself, it is your responsibility to provide a good random seed!
830b38bd 1005 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
008fb0c0
NC		 1006 if (!PL_rehash_seed_set)
1007 PL_rehash_seed = get_hash_seed();
b0891165 1008 {
bed60192
JH		 1009 char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1010
1011 if (s) {
1012 int i = atoi(s);
1013
1014 if (i == 1)
1015 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
008fb0c0 1016 PL_rehash_seed);
bed60192 1017 }
b0891165
JH		 1018 }
1019#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1020
3280af22 1021 PL_origargc = argc;
e2975953 1022 PL_origargv = argv;
a0d0e21e 1023
54bfe034 1024 {
3cb9023d
JH		 1025 /* Set PL_origalen be the sum of the contiguous argv[]
1026 * elements plus the size of the env in case that it is
e9137a8e 1027 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
3cb9023d
JH		 1028 * as the maximum modifiable length of $0. In the worst case
1029 * the area we are able to modify is limited to the size of
43c32782 1030 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d 1031 * --jhi */
84458fbf 1032 char *s = NULL;
54bfe034 1033 int i;
7d8e7db3
JH		 1034 UV mask =
1035 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
43c32782
JH		 1036 /* Do the mask check only if the args seem like aligned. */
1037 UV aligned =
1038 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1039
1040 /* See if all the arguments are contiguous in memory. Note
1041 * that 'contiguous' is a loose term because some platforms
1042 * align the argv[] and the envp[]. If the arguments look
1043 * like non-aligned, assume that they are 'strictly' or
1044 * 'traditionally' contiguous. If the arguments look like
1045 * aligned, we just check that they are within aligned
1046 * PTRSIZE bytes. As long as no system has something bizarre
1047 * like the argv[] interleaved with some other data, we are
1048 * fine. (Did I just evoke Murphy's Law?) --jhi */
c8941eeb
JH		 1049 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1050 while (*s) s++;
1051 for (i = 1; i < PL_origargc; i++) {
1052 if ((PL_origargv[i] == s + 1
43c32782 1053#ifdef OS2
c8941eeb 1054 || PL_origargv[i] == s + 2
43c32782 1055#endif
c8941eeb
JH		 1056 )
1057 ||
1058 (aligned &&
1059 (PL_origargv[i] > s &&
1060 PL_origargv[i] <=
1061 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1062 )
1063 {
1064 s = PL_origargv[i];
1065 while (*s) s++;
1066 }
1067 else
1068 break;
54bfe034 1069 }
54bfe034 1070 }
3cb9023d 1071 /* Can we grab env area too to be used as the area for $0? */
43c32782
JH		 1072 if (PL_origenviron) {
1073 if ((PL_origenviron[0] == s + 1
1074#ifdef OS2
1075 || (PL_origenviron[0] == s + 9 && (s += 8))
1076#endif
1077 )
1078 ||
1079 (aligned &&
1080 (PL_origenviron[0] > s &&
1081 PL_origenviron[0] <=
1082 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1083 )
1084 {
1085#ifndef OS2
1086 s = PL_origenviron[0];
1087 while (*s) s++;
1088#endif
1089 my_setenv("NoNe SuCh", Nullch);
1090 /* Force copy of environment. */
1091 for (i = 1; PL_origenviron[i]; i++) {
1092 if (PL_origenviron[i] == s + 1
1093 ||
1094 (aligned &&
1095 (PL_origenviron[i] > s &&
1096 PL_origenviron[i] <=
1097 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1098 )
1099 {
1100 s = PL_origenviron[i];
1101 while (*s) s++;
1102 }
1103 else
1104 break;
54bfe034 1105 }
43c32782 1106 }
54bfe034 1107 }
284e1220 1108 PL_origalen = s - PL_origargv[0] + 1;
54bfe034
JH		 1109 }
1110
3280af22 1111 if (PL_do_undump) {
a0d0e21e
LW		 1112
1113 /* Come here if running an undumped a.out. */
1114
3280af22
NIS		 1115 PL_origfilename = savepv(argv[0]);
1116 PL_do_undump = FALSE;
a0d0e21e 1117 cxstack_ix = -1; /* start label stack again */
748a9306 1118 init_ids();
a0d0e21e
LW		 1119 init_postdump_symbols(argc,argv,env);
1120 return 0;
1121 }
1122
3280af22 1123 if (PL_main_root) {
3280af22
NIS		 1124 op_free(PL_main_root);
1125 PL_main_root = Nullop;
ff0cee69 1126 }
3280af22
NIS		 1127 PL_main_start = Nullop;
1128 SvREFCNT_dec(PL_main_cv);
1129 PL_main_cv = Nullcv;
79072805 1130
3280af22
NIS		 1131 time(&PL_basetime);
1132 oldscope = PL_scopestack_ix;
599cee73 1133 PL_dowarn = G_WARN_OFF;
f86702cc 1134
14dd3ad8
GS		 1135#ifdef PERL_FLEXIBLE_EXCEPTIONS
1136 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1137#else
1138 JMPENV_PUSH(ret);
1139#endif
6224f72b 1140 switch (ret) {
312caa8e 1141 case 0:
14dd3ad8
GS		 1142#ifndef PERL_FLEXIBLE_EXCEPTIONS
1143 parse_body(env,xsinit);
1144#endif
7d30b5c4
GS		 1145 if (PL_checkav)
1146 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1147 ret = 0;
1148 break;
6224f72b
GS		 1149 case 1:
1150 STATUS_ALL_FAILURE;
1151 /* FALL THROUGH */
1152 case 2:
1153 /* my_exit() was called */
3280af22 1154 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1155 LEAVE;
1156 FREETMPS;
3280af22 1157 PL_curstash = PL_defstash;
7d30b5c4
GS		 1158 if (PL_checkav)
1159 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1160 ret = STATUS_NATIVE_EXPORT;
1161 break;
6224f72b 1162 case 3:
bf49b057 1163 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1164 ret = 1;
1165 break;
6224f72b 1166 }
14dd3ad8
GS		 1167 JMPENV_POP;
1168 return ret;
1169}
1170
1171#ifdef PERL_FLEXIBLE_EXCEPTIONS
1172STATIC void *
1173S_vparse_body(pTHX_ va_list args)
1174{
1175 char **env = va_arg(args, char**);
1176 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1177
1178 return parse_body(env, xsinit);
312caa8e 1179}
14dd3ad8 1180#endif
312caa8e
CS		 1181
1182STATIC void *
14dd3ad8 1183S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1184{
312caa8e
CS		 1185 int argc = PL_origargc;
1186 char **argv = PL_origargv;
312caa8e 1187 char *scriptname = NULL;
312caa8e
CS		 1188 VOL bool dosearch = FALSE;
1189 char *validarg = "";
312caa8e
CS		 1190 register SV *sv;
1191 register char *s;
cf756827 1192 char *cddir = Nullch;
312caa8e 1193
ae3f3efd
PS		 1194 PL_fdscript = -1;
1195 PL_suidscript = -1;
3280af22 1196 sv_setpvn(PL_linestr,"",0);
79cb57f6 1197 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 1198 SAVEFREESV(sv);
1199 init_main_stash();
54310121 1200
6224f72b
GS		 1201 for (argc--,argv++; argc > 0; argc--,argv++) {
1202 if (argv[0][0] != '-' || !argv[0][1])
1203 break;
1204#ifdef DOSUID
1205 if (*validarg)
1206 validarg = " PHOOEY ";
1207 else
1208 validarg = argv[0];
ae3f3efd
PS		 1209 /*
1210 * Can we rely on the kernel to start scripts with argv[1] set to
1211 * contain all #! line switches (the whole line)? (argv[0] is set to
1212 * the interpreter name, argv[2] to the script name; argv[3] and
1213 * above may contain other arguments.)
1214 */
13281fa4 1215#endif
6224f72b
GS		 1216 s = argv[0]+1;
1217 reswitch:
1218 switch (*s) {
729a02f2 1219 case 'C':
1d5472a9
GS		 1220#ifndef PERL_STRICT_CR
1221 case '\r':
1222#endif
6224f72b
GS		 1223 case ' ':
1224 case '0':
1225 case 'F':
1226 case 'a':
1227 case 'c':
1228 case 'd':
1229 case 'D':
1230 case 'h':
1231 case 'i':
1232 case 'l':
1233 case 'M':
1234 case 'm':
1235 case 'n':
1236 case 'p':
1237 case 's':
1238 case 'u':
1239 case 'U':
1240 case 'v':
599cee73
PM		 1241 case 'W':
1242 case 'X':
6224f72b 1243 case 'w':
06492da6 1244 case 'A':
155aba94 1245 if ((s = moreswitches(s)))
6224f72b
GS		 1246 goto reswitch;
1247 break;
33b78306 1248
1dbad523 1249 case 't':
22f7c9c9 1250 CHECK_MALLOC_TOO_LATE_FOR('t');
317ea90d
MS		 1251 if( !PL_tainting ) {
1252 PL_taint_warn = TRUE;
1253 PL_tainting = TRUE;
1254 }
1255 s++;
1256 goto reswitch;
6224f72b 1257 case 'T':
22f7c9c9 1258 CHECK_MALLOC_TOO_LATE_FOR('T');
3280af22 1259 PL_tainting = TRUE;
317ea90d 1260 PL_taint_warn = FALSE;
6224f72b
GS		 1261 s++;
1262 goto reswitch;
f86702cc 1263
6224f72b 1264 case 'e':
bf4acbe4
GS		 1265#ifdef MACOS_TRADITIONAL
1266 /* ignore -e for Dev:Pseudo argument */
1267 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1268 break;
bf4acbe4 1269#endif
ae3f3efd 1270 forbid_setid("-e");
3280af22 1271 if (!PL_e_script) {
79cb57f6 1272 PL_e_script = newSVpvn("",0);
0cb96387 1273 filter_add(read_e_script, NULL);
6224f72b
GS		 1274 }
1275 if (*++s)
3280af22 1276 sv_catpv(PL_e_script, s);
6224f72b 1277 else if (argv[1]) {
3280af22 1278 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1279 argc--,argv++;
1280 }
1281 else
cea2e8a9 1282 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1283 sv_catpv(PL_e_script, "\n");
6224f72b 1284 break;
afe37c7d 1285
6224f72b
GS		 1286 case 'I': /* -I handled both here and in moreswitches() */
1287 forbid_setid("-I");
1288 if (!*++s && (s=argv[1]) != Nullch) {
1289 argc--,argv++;
1290 }
6224f72b 1291 if (s && *s) {
0df16ed7
GS		 1292 char *p;
1293 STRLEN len = strlen(s);
1294 p = savepvn(s, len);
574c798a 1295 incpush(p, TRUE, TRUE, FALSE);
0df16ed7
GS		 1296 sv_catpvn(sv, "-I", 2);
1297 sv_catpvn(sv, p, len);
1298 sv_catpvn(sv, " ", 1);
6224f72b 1299 Safefree(p);
0df16ed7
GS		 1300 }
1301 else
a67e862a 1302 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1303 break;
1304 case 'P':
1305 forbid_setid("-P");
3280af22 1306 PL_preprocess = TRUE;
6224f72b
GS		 1307 s++;
1308 goto reswitch;
1309 case 'S':
1310 forbid_setid("-S");
1311 dosearch = TRUE;
1312 s++;
1313 goto reswitch;
1314 case 'V':
3280af22
NIS		 1315 if (!PL_preambleav)
1316 PL_preambleav = newAV();
1317 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1318 if (*++s != ':') {
3280af22 1319 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1320#ifdef VMS
6b88bc9c 1321 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1322#else
3280af22 1323 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1324#endif
3280af22 1325 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1326# ifdef DEBUGGING
3280af22 1327 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1328# endif
6224f72b 1329# ifdef MULTIPLICITY
8f872242 1330 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1331# endif
4d1ff10f
AB		 1332# ifdef USE_5005THREADS
1333 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1334# endif
ac5e8965
JH		 1335# ifdef USE_ITHREADS
1336 sv_catpv(PL_Sv," USE_ITHREADS");
1337# endif
10cc9d2a
JH		 1338# ifdef USE_64_BIT_INT
1339 sv_catpv(PL_Sv," USE_64_BIT_INT");
1340# endif
1341# ifdef USE_64_BIT_ALL
1342 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1343# endif
1344# ifdef USE_LONG_DOUBLE
1345 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1346# endif
53430762
JH		 1347# ifdef USE_LARGE_FILES
1348 sv_catpv(PL_Sv," USE_LARGE_FILES");
1349# endif
ac5e8965
JH		 1350# ifdef USE_SOCKS
1351 sv_catpv(PL_Sv," USE_SOCKS");
1352# endif
b363f7ed
GS		 1353# ifdef PERL_IMPLICIT_CONTEXT
1354 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1355# endif
1356# ifdef PERL_IMPLICIT_SYS
1357 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1358# endif
3280af22 1359 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1360
6224f72b
GS		 1361#if defined(LOCAL_PATCH_COUNT)
1362 if (LOCAL_PATCH_COUNT > 0) {
1363 int i;
3280af22 1364 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1365 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1366 if (PL_localpatches[i])
cea2e8a9 1367 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS		 1368 }
1369 }
1370#endif
cea2e8a9 1371 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1372#ifdef __DATE__
1373# ifdef __TIME__
cea2e8a9 1374 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1375# else
cea2e8a9 1376 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1377# endif
1378#endif
3280af22 1379 sv_catpv(PL_Sv, "; \
6224f72b 1380$\"=\"\\n \"; \
69fcd688
JH		 1381@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1382#ifdef __CYGWIN__
1383 sv_catpv(PL_Sv,"\
1384push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1385#endif
1386 sv_catpv(PL_Sv, "\
6224f72b
GS		 1387print \" \\%ENV:\\n @env\\n\" if @env; \
1388print \" \\@INC:\\n @INC\\n\";");
1389 }
1390 else {
3280af22
NIS		 1391 PL_Sv = newSVpv("config_vars(qw(",0);
1392 sv_catpv(PL_Sv, ++s);
1393 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1394 s += strlen(s);
1395 }
3280af22 1396 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1397 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1398 goto reswitch;
1399 case 'x':
3280af22 1400 PL_doextract = TRUE;
6224f72b
GS		 1401 s++;
1402 if (*s)
f4c556ac 1403 cddir = s;
6224f72b
GS		 1404 break;
1405 case 0:
1406 break;
1407 case '-':
1408 if (!*++s || isSPACE(*s)) {
1409 argc--,argv++;
1410 goto switch_end;
1411 }
1412 /* catch use of gnu style long options */
1413 if (strEQ(s, "version")) {
1414 s = "v";
1415 goto reswitch;
1416 }
1417 if (strEQ(s, "help")) {
1418 s = "h";
1419 goto reswitch;
1420 }
1421 s--;
1422 /* FALL THROUGH */
1423 default:
cea2e8a9 1424 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1425 }
1426 }
6224f72b 1427 switch_end:
54310121 1428
f675dbe5
CB		 1429 if (
1430#ifndef SECURE_INTERNAL_GETENV
1431 !PL_tainting &&
1432#endif
cf756827 1433 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1434 {
cf756827 1435 char *popt = s;
74288ac8
GS		 1436 while (isSPACE(*s))
1437 s++;
317ea90d 1438 if (*s == '-' && *(s+1) == 'T') {
22f7c9c9 1439 CHECK_MALLOC_TOO_LATE_FOR('T');
74288ac8 1440 PL_tainting = TRUE;
317ea90d
MS		 1441 PL_taint_warn = FALSE;
1442 }
74288ac8 1443 else {
cf756827 1444 char *popt_copy = Nullch;
74288ac8 1445 while (s && *s) {
4ea8f8fb 1446 char *d;
74288ac8
GS		 1447 while (isSPACE(*s))
1448 s++;
1449 if (*s == '-') {
1450 s++;
1451 if (isSPACE(*s))
1452 continue;
1453 }
4ea8f8fb 1454 d = s;
74288ac8
GS		 1455 if (!*s)
1456 break;
06492da6 1457 if (!strchr("DIMUdmtwA", *s))
cea2e8a9 1458 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1459 while (++s && *s) {
1460 if (isSPACE(*s)) {
cf756827
GS		 1461 if (!popt_copy) {
1462 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1463 s = popt_copy + (s - popt);
1464 d = popt_copy + (d - popt);
1465 }
4ea8f8fb
MS		 1466 *s++ = '\0';
1467 break;
1468 }
1469 }
1c4db469 1470 if (*d == 't') {
317ea90d
MS		 1471 if( !PL_tainting ) {
1472 PL_taint_warn = TRUE;
1473 PL_tainting = TRUE;
1474 }
1c4db469
RGS		 1475 } else {
1476 moreswitches(d);
1477 }
6224f72b 1478 }
6224f72b
GS		 1479 }
1480 }
a0d0e21e 1481
317ea90d
MS		 1482 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1483 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1484 }
1485
6224f72b
GS		 1486 if (!scriptname)
1487 scriptname = argv[0];
3280af22 1488 if (PL_e_script) {
6224f72b
GS		 1489 argc++,argv--;
1490 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1491 }
1492 else if (scriptname == Nullch) {
1493#ifdef MSDOS
1494 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1495 moreswitches("h");
1496#endif
1497 scriptname = "-";
1498 }
1499
1500 init_perllib();
1501
c5cccb17 1502 open_script(scriptname,dosearch,sv);
6224f72b 1503
c5cccb17 1504 validate_suid(validarg, scriptname);
6224f72b 1505
64ca3a65 1506#ifndef PERL_MICRO
0b5b802d
GS		 1507#if defined(SIGCHLD) || defined(SIGCLD)
1508 {
1509#ifndef SIGCHLD
1510# define SIGCHLD SIGCLD
1511#endif
1512 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1513 if (sigstate == SIG_IGN) {
1514 if (ckWARN(WARN_SIGNAL))
9014280d 1515 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1516 "Can't ignore signal CHLD, forcing to default");
1517 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1518 }
1519 }
1520#endif
64ca3a65 1521#endif
0b5b802d 1522
bf4acbe4
GS		 1523#ifdef MACOS_TRADITIONAL
1524 if (PL_doextract || gMacPerl_AlwaysExtract) {
1525#else
f4c556ac 1526 if (PL_doextract) {
bf4acbe4 1527#endif
6224f72b 1528 find_beginning();
f4c556ac
GS		 1529 if (cddir && PerlDir_chdir(cddir) < 0)
1530 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1531
1532 }
6224f72b 1533
3280af22
NIS		 1534 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1535 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1536 CvUNIQUE_on(PL_compcv);
1537
dd2155a4 1538 CvPADLIST(PL_compcv) = pad_new(0);
4d1ff10f 1539#ifdef USE_5005THREADS
533c011a
NIS		 1540 CvOWNER(PL_compcv) = 0;
1541 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1542 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1543#endif /* USE_5005THREADS */
6224f72b 1544
0c4f7ff0 1545 boot_core_PerlIO();
6224f72b 1546 boot_core_UNIVERSAL();
09bef843 1547 boot_core_xsutils();
6224f72b
GS		 1548
1549 if (xsinit)
acfe0abc 1550 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1551#ifndef PERL_MICRO
ed79a026 1552#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1553 init_os_extras();
6224f72b 1554#endif
64ca3a65 1555#endif
6224f72b 1556
29209bc5 1557#ifdef USE_SOCKS
1b9c9cf5
DH		 1558# ifdef HAS_SOCKS5_INIT
1559 socks5_init(argv[0]);
1560# else
29209bc5 1561 SOCKSinit(argv[0]);
1b9c9cf5 1562# endif
ac27b0f5 1563#endif
29209bc5 1564
6224f72b
GS		 1565 init_predump_symbols();
1566 /* init_postdump_symbols not currently designed to be called */
1567 /* more than once (ENV isn't cleared first, for example) */
1568 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1569 if (!PL_do_undump)
6224f72b
GS		 1570 init_postdump_symbols(argc,argv,env);
1571
a05d7ebb
JH		 1572 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1573 * PL_utf8locale is conditionally turned on by
085a54d9 1574 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 1575 * look like the user wants to use UTF-8. */
06e66572
JH		 1576 if (PL_unicode) {
1577 /* Requires init_predump_symbols(). */
a05d7ebb 1578 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH		 1579 IO* io;
1580 PerlIO* fp;
1581 SV* sv;
1582
a05d7ebb 1583 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 1584 * and the default open disciplines. */
a05d7ebb
JH		 1585 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1586 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1587 (fp = IoIFP(io)))
1588 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1589 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1590 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1591 (fp = IoOFP(io)))
1592 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1593 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1594 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1595 (fp = IoOFP(io)))
1596 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1597 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1598 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1599 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1600 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1601 if (in) {
1602 if (out)
1603 sv_setpvn(sv, ":utf8\0:utf8", 11);
1604 else
1605 sv_setpvn(sv, ":utf8\0", 6);
1606 }
1607 else if (out)
1608 sv_setpvn(sv, "\0:utf8", 6);
1609 SvSETMAGIC(sv);
1610 }
b310b053
JH		 1611 }
1612 }
1613
4ffa73a3
JH		 1614 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1615 if (strEQ(s, "unsafe"))
1616 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1617 else if (strEQ(s, "safe"))
1618 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1619 else
1620 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1621 }
1622
6224f72b
GS		 1623 init_lexer();
1624
1625 /* now parse the script */
1626
93189314 1627 SETERRNO(0,SS_NORMAL);
3280af22 1628 PL_error_count = 0;
bf4acbe4
GS		 1629#ifdef MACOS_TRADITIONAL
1630 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1631 if (PL_minus_c)
1632 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1633 else {
1634 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1635 MacPerl_MPWFileName(PL_origfilename));
1636 }
1637 }
1638#else
3280af22
NIS		 1639 if (yyparse() || PL_error_count) {
1640 if (PL_minus_c)
cea2e8a9 1641 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1642 else {
cea2e8a9 1643 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1644 PL_origfilename);
6224f72b
GS		 1645 }
1646 }
bf4acbe4 1647#endif
57843af0 1648 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1649 PL_curstash = PL_defstash;
1650 PL_preprocess = FALSE;
1651 if (PL_e_script) {
1652 SvREFCNT_dec(PL_e_script);
1653 PL_e_script = Nullsv;
6224f72b
GS		 1654 }
1655
3280af22 1656 if (PL_do_undump)
6224f72b
GS		 1657 my_unexec();
1658
57843af0
GS		 1659 if (isWARN_ONCE) {
1660 SAVECOPFILE(PL_curcop);
1661 SAVECOPLINE(PL_curcop);
3280af22 1662 gv_check(PL_defstash);
57843af0 1663 }
6224f72b
GS		 1664
1665 LEAVE;
1666 FREETMPS;
1667
1668#ifdef MYMALLOC
1669 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1670 dump_mstats("after compilation:");
1671#endif
1672
1673 ENTER;
3280af22 1674 PL_restartop = 0;
312caa8e 1675 return NULL;
6224f72b
GS		 1676}
1677
954c1994
GS		 1678/*
1679=for apidoc perl_run
1680
1681Tells a Perl interpreter to run. See L<perlembed>.
1682
1683=cut
1684*/
1685
6224f72b 1686int
0cb96387 1687perl_run(pTHXx)
6224f72b 1688{
6224f72b 1689 I32 oldscope;
14dd3ad8 1690 int ret = 0;
db36c5a1 1691 dJMPENV;
4d1ff10f 1692#ifdef USE_5005THREADS
cea2e8a9
GS		 1693 dTHX;
1694#endif
6224f72b 1695
3280af22 1696 oldscope = PL_scopestack_ix;
96e176bf
CL		 1697#ifdef VMS
1698 VMSISH_HUSHED = 0;
1699#endif
6224f72b 1700
14dd3ad8 1701#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1702 redo_body:
14dd3ad8
GS		 1703 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1704#else
1705 JMPENV_PUSH(ret);
1706#endif
6224f72b
GS		 1707 switch (ret) {
1708 case 1:
1709 cxstack_ix = -1; /* start context stack again */
312caa8e 1710 goto redo_body;
14dd3ad8
GS		 1711 case 0: /* normal completion */
1712#ifndef PERL_FLEXIBLE_EXCEPTIONS
1713 redo_body:
1714 run_body(oldscope);
1715#endif
1716 /* FALL THROUGH */
1717 case 2: /* my_exit() */
3280af22 1718 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1719 LEAVE;
1720 FREETMPS;
3280af22 1721 PL_curstash = PL_defstash;
3a1ee7e8 1722 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1723 PL_endav && !PL_minus_c)
1724 call_list(oldscope, PL_endav);
6224f72b
GS		 1725#ifdef MYMALLOC
1726 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1727 dump_mstats("after execution: ");
1728#endif
14dd3ad8
GS		 1729 ret = STATUS_NATIVE_EXPORT;
1730 break;
6224f72b 1731 case 3:
312caa8e
CS		 1732 if (PL_restartop) {
1733 POPSTACK_TO(PL_mainstack);
1734 goto redo_body;
6224f72b 1735 }
bf49b057 1736 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1737 FREETMPS;
14dd3ad8
GS		 1738 ret = 1;
1739 break;
6224f72b
GS		 1740 }
1741
14dd3ad8
GS		 1742 JMPENV_POP;
1743 return ret;
312caa8e
CS		 1744}
1745
14dd3ad8 1746#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1747STATIC void *
14dd3ad8 1748S_vrun_body(pTHX_ va_list args)
312caa8e 1749{
312caa8e
CS		 1750 I32 oldscope = va_arg(args, I32);
1751
14dd3ad8
GS		 1752 return run_body(oldscope);
1753}
1754#endif
1755
1756
1757STATIC void *
1758S_run_body(pTHX_ I32 oldscope)
1759{
6224f72b 1760 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1761 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1762
3280af22 1763 if (!PL_restartop) {
6224f72b 1764 DEBUG_x(dump_all());
ecae49c0
NC		 1765 if (!DEBUG_q_TEST)
1766 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1767 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1768 PTR2UV(thr)));
6224f72b 1769
3280af22 1770 if (PL_minus_c) {
bf4acbe4 1771#ifdef MACOS_TRADITIONAL
e69a2255
JH		 1772 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1773 (gMacPerl_ErrorFormat ? "# " : ""),
1774 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1775#else
bf49b057 1776 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1777#endif
6224f72b
GS		 1778 my_exit(0);
1779 }
3280af22 1780 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1781 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1782 if (PL_initav)
1783 call_list(oldscope, PL_initav);
6224f72b
GS		 1784 }
1785
1786 /* do it */
1787
3280af22 1788 if (PL_restartop) {
533c011a 1789 PL_op = PL_restartop;
3280af22 1790 PL_restartop = 0;
cea2e8a9 1791 CALLRUNOPS(aTHX);
6224f72b 1792 }
3280af22
NIS		 1793 else if (PL_main_start) {
1794 CvDEPTH(PL_main_cv) = 1;
533c011a 1795 PL_op = PL_main_start;
cea2e8a9 1796 CALLRUNOPS(aTHX);
6224f72b
GS		 1797 }
1798
f6b3007c
JH		 1799 my_exit(0);
1800 /* NOTREACHED */
312caa8e 1801 return NULL;
6224f72b
GS		 1802}
1803
954c1994 1804/*
ccfc67b7
JH		 1805=head1 SV Manipulation Functions
1806
954c1994
GS		 1807=for apidoc p||get_sv
1808
1809Returns the SV of the specified Perl scalar. If C<create> is set and the
1810Perl variable does not exist then it will be created. If C<create> is not
1811set and the variable does not exist then NULL is returned.
1812
1813=cut
1814*/
1815
6224f72b 1816SV*
864dbfa3 1817Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1818{
1819 GV *gv;
4d1ff10f 1820#ifdef USE_5005THREADS
6224f72b
GS		 1821 if (name[1] == '\0' && !isALPHA(name[0])) {
1822 PADOFFSET tmp = find_threadsv(name);
411caa50 1823 if (tmp != NOT_IN_PAD)
6224f72b 1824 return THREADSV(tmp);
6224f72b 1825 }
4d1ff10f 1826#endif /* USE_5005THREADS */
6224f72b
GS		 1827 gv = gv_fetchpv(name, create, SVt_PV);
1828 if (gv)
1829 return GvSV(gv);
1830 return Nullsv;
1831}
1832
954c1994 1833/*
ccfc67b7
JH		 1834=head1 Array Manipulation Functions
1835
954c1994
GS		 1836=for apidoc p||get_av
1837
1838Returns the AV of the specified Perl array. If C<create> is set and the
1839Perl variable does not exist then it will be created. If C<create> is not
1840set and the variable does not exist then NULL is returned.
1841
1842=cut
1843*/
1844
6224f72b 1845AV*
864dbfa3 1846Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1847{
1848 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1849 if (create)
1850 return GvAVn(gv);
1851 if (gv)
1852 return GvAV(gv);
1853 return Nullav;
1854}
1855
954c1994 1856/*
ccfc67b7
JH		 1857=head1 Hash Manipulation Functions
1858
954c1994
GS		 1859=for apidoc p||get_hv
1860
1861Returns the HV of the specified Perl hash. If C<create> is set and the
1862Perl variable does not exist then it will be created. If C<create> is not
1863set and the variable does not exist then NULL is returned.
1864
1865=cut
1866*/
1867
6224f72b 1868HV*
864dbfa3 1869Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1870{
a0d0e21e
LW		 1871 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1872 if (create)
1873 return GvHVn(gv);
1874 if (gv)
1875 return GvHV(gv);
1876 return Nullhv;
1877}
1878
954c1994 1879/*
ccfc67b7
JH		 1880=head1 CV Manipulation Functions
1881
954c1994
GS		 1882=for apidoc p||get_cv
1883
1884Returns the CV of the specified Perl subroutine. If C<create> is set and
1885the Perl subroutine does not exist then it will be declared (which has the
1886same effect as saying C<sub name;>). If C<create> is not set and the
1887subroutine does not exist then NULL is returned.
1888
1889=cut
1890*/
1891
a0d0e21e 1892CV*
864dbfa3 1893Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1894{
1895 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1896 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 1897 /* XXX this is probably not what they think they're getting.
1898 * It has the same effect as "sub name;", i.e. just a forward
1899 * declaration! */
8ebc5c01 1900 if (create && !GvCVu(gv))
774d564b 1901 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1902 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1903 Nullop,
a0d0e21e
LW		 1904 Nullop);
1905 if (gv)
8ebc5c01 1906 return GvCVu(gv);
a0d0e21e
LW		 1907 return Nullcv;
1908}
1909
79072805
LW		 1910/* Be sure to refetch the stack pointer after calling these routines. */
1911
954c1994 1912/*
ccfc67b7
JH		 1913
1914=head1 Callback Functions
1915
954c1994
GS		 1916=for apidoc p||call_argv
1917
1918Performs a callback to the specified Perl sub. See L<perlcall>.
1919
1920=cut
1921*/
1922
a0d0e21e 1923I32
864dbfa3 1924Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 1925
8ac85365
NIS		 1926 /* See G_* flags in cop.h */
1927 /* null terminated arg list */
8990e307 1928{
a0d0e21e 1929 dSP;
8990e307 1930
924508f0 1931 PUSHMARK(SP);
a0d0e21e 1932 if (argv) {
8990e307 1933 while (*argv) {
a0d0e21e 1934 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 1935 argv++;
1936 }
a0d0e21e 1937 PUTBACK;
8990e307 1938 }
864dbfa3 1939 return call_pv(sub_name, flags);
8990e307
LW		 1940}
1941
954c1994
GS		 1942/*
1943=for apidoc p||call_pv
1944
1945Performs a callback to the specified Perl sub. See L<perlcall>.
1946
1947=cut
1948*/
1949
a0d0e21e 1950I32
864dbfa3 1951Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 1952 /* name of the subroutine */
1953 /* See G_* flags in cop.h */
a0d0e21e 1954{
864dbfa3 1955 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 1956}
1957
954c1994
GS		 1958/*
1959=for apidoc p||call_method
1960
1961Performs a callback to the specified Perl method. The blessed object must
1962be on the stack. See L<perlcall>.
1963
1964=cut
1965*/
1966
a0d0e21e 1967I32
864dbfa3 1968Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 1969 /* name of the subroutine */
1970 /* See G_* flags in cop.h */
a0d0e21e 1971{
968b3946 1972 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 1973}
1974
1975/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 1976/*
1977=for apidoc p||call_sv
1978
1979Performs a callback to the Perl sub whose name is in the SV. See
1980L<perlcall>.
1981
1982=cut
1983*/
1984
a0d0e21e 1985I32
864dbfa3 1986Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 1987 /* See G_* flags in cop.h */
a0d0e21e 1988{
924508f0 1989 dSP;
a0d0e21e 1990 LOGOP myop; /* fake syntax tree node */
968b3946 1991 UNOP method_op;
aa689395 1992 I32 oldmark;
13689cfe 1993 volatile I32 retval = 0;
a0d0e21e 1994 I32 oldscope;
54310121 1995 bool oldcatch = CATCH_GET;
6224f72b 1996 int ret;
533c011a 1997 OP* oldop = PL_op;
db36c5a1 1998 dJMPENV;
1e422769 1999
a0d0e21e
LW		 2000 if (flags & G_DISCARD) {
2001 ENTER;
2002 SAVETMPS;
2003 }
2004
aa689395 2005 Zero(&myop, 1, LOGOP);
54310121 2006 myop.op_next = Nullop;
f51d4af5 2007 if (!(flags & G_NOARGS))
aa689395 2008 myop.op_flags |= OPf_STACKED;
54310121 2009 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2010 (flags & G_ARRAY) ? OPf_WANT_LIST :
2011 OPf_WANT_SCALAR);
462e5cf6 2012 SAVEOP();
533c011a 2013 PL_op = (OP*)&myop;
aa689395 2014
3280af22
NIS		 2015 EXTEND(PL_stack_sp, 1);
2016 *++PL_stack_sp = sv;
aa689395 2017 oldmark = TOPMARK;
3280af22 2018 oldscope = PL_scopestack_ix;
a0d0e21e 2019
3280af22 2020 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 2021 /* Handle first BEGIN of -d. */
3280af22 2022 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 2023 /* Try harder, since this may have been a sighandler, thus
2024 * curstash may be meaningless. */
3280af22 2025 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 2026 && !(flags & G_NODEBUG))
533c011a 2027 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2028
968b3946
GS		 2029 if (flags & G_METHOD) {
2030 Zero(&method_op, 1, UNOP);
2031 method_op.op_next = PL_op;
2032 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2033 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 2034 PL_op = (OP*)&method_op;
968b3946
GS		 2035 }
2036
312caa8e 2037 if (!(flags & G_EVAL)) {
0cdb2077 2038 CATCH_SET(TRUE);
14dd3ad8 2039 call_body((OP*)&myop, FALSE);
312caa8e 2040 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 2041 CATCH_SET(oldcatch);
312caa8e
CS		 2042 }
2043 else {
d78bda3d 2044 myop.op_other = (OP*)&myop;
3280af22 2045 PL_markstack_ptr--;
4633a7c4
LW		 2046 /* we're trying to emulate pp_entertry() here */
2047 {
c09156bb 2048 register PERL_CONTEXT *cx;
54310121 2049 I32 gimme = GIMME_V;
ac27b0f5 2050
4633a7c4
LW		 2051 ENTER;
2052 SAVETMPS;
ac27b0f5 2053
968b3946 2054 push_return(Nullop);
1d76a5c3 2055 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 2056 PUSHEVAL(cx, 0, 0);
533c011a 2057 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 2058
faef0170 2059 PL_in_eval = EVAL_INEVAL;
4633a7c4 2060 if (flags & G_KEEPERR)
faef0170 2061 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 2062 else
38a03e6e 2063 sv_setpv(ERRSV,"");
4633a7c4 2064 }
3280af22 2065 PL_markstack_ptr++;
a0d0e21e 2066
14dd3ad8
GS		 2067#ifdef PERL_FLEXIBLE_EXCEPTIONS
2068 redo_body:
2069 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 2070 (OP*)&myop, FALSE);
14dd3ad8
GS		 2071#else
2072 JMPENV_PUSH(ret);
2073#endif
6224f72b
GS		 2074 switch (ret) {
2075 case 0:
14dd3ad8
GS		 2076#ifndef PERL_FLEXIBLE_EXCEPTIONS
2077 redo_body:
2078 call_body((OP*)&myop, FALSE);
2079#endif
312caa8e
CS		 2080 retval = PL_stack_sp - (PL_stack_base + oldmark);
2081 if (!(flags & G_KEEPERR))
2082 sv_setpv(ERRSV,"");
a0d0e21e 2083 break;
6224f72b 2084 case 1:
f86702cc 2085 STATUS_ALL_FAILURE;
a0d0e21e 2086 /* FALL THROUGH */
6224f72b 2087 case 2:
a0d0e21e 2088 /* my_exit() was called */
3280af22 2089 PL_curstash = PL_defstash;
a0d0e21e 2090 FREETMPS;
14dd3ad8 2091 JMPENV_POP;
cc3604b1 2092 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2093 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2094 my_exit_jump();
a0d0e21e 2095 /* NOTREACHED */
6224f72b 2096 case 3:
3280af22 2097 if (PL_restartop) {
533c011a 2098 PL_op = PL_restartop;
3280af22 2099 PL_restartop = 0;
312caa8e 2100 goto redo_body;
a0d0e21e 2101 }
3280af22 2102 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2103 if (flags & G_ARRAY)
2104 retval = 0;
2105 else {
2106 retval = 1;
3280af22 2107 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2108 }
312caa8e 2109 break;
a0d0e21e 2110 }
a0d0e21e 2111
3280af22 2112 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 2113 SV **newsp;
2114 PMOP *newpm;
2115 I32 gimme;
c09156bb 2116 register PERL_CONTEXT *cx;
a0a2876f
LW		 2117 I32 optype;
2118
2119 POPBLOCK(cx,newpm);
2120 POPEVAL(cx);
2121 pop_return();
3280af22 2122 PL_curpm = newpm;
a0a2876f 2123 LEAVE;
a0d0e21e 2124 }
14dd3ad8 2125 JMPENV_POP;
a0d0e21e 2126 }
1e422769 2127
a0d0e21e 2128 if (flags & G_DISCARD) {
3280af22 2129 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2130 retval = 0;
2131 FREETMPS;
2132 LEAVE;
2133 }
533c011a 2134 PL_op = oldop;
a0d0e21e
LW		 2135 return retval;
2136}
2137
14dd3ad8 2138#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2139STATIC void *
14dd3ad8 2140S_vcall_body(pTHX_ va_list args)
312caa8e
CS		 2141{
2142 OP *myop = va_arg(args, OP*);
2143 int is_eval = va_arg(args, int);
2144
14dd3ad8 2145 call_body(myop, is_eval);
312caa8e
CS		 2146 return NULL;
2147}
14dd3ad8 2148#endif
312caa8e
CS		 2149
2150STATIC void
14dd3ad8 2151S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e 2152{
312caa8e
CS		 2153 if (PL_op == myop) {
2154 if (is_eval)
f807eda9 2155 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 2156 else
f807eda9 2157 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 2158 }
2159 if (PL_op)
cea2e8a9 2160 CALLRUNOPS(aTHX);
312caa8e
CS		 2161}
2162
6e72f9df 2163/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2164
954c1994
GS		 2165/*
2166=for apidoc p||eval_sv
2167
2168Tells Perl to C<eval> the string in the SV.
2169
2170=cut
2171*/
2172
a0d0e21e 2173I32
864dbfa3 2174Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2175
8ac85365 2176 /* See G_* flags in cop.h */
a0d0e21e 2177{
924508f0 2178 dSP;
a0d0e21e 2179 UNOP myop; /* fake syntax tree node */
8fa7f367 2180 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2181 volatile I32 retval = 0;
4633a7c4 2182 I32 oldscope;
6224f72b 2183 int ret;
533c011a 2184 OP* oldop = PL_op;
db36c5a1 2185 dJMPENV;
84902520 2186
4633a7c4
LW		 2187 if (flags & G_DISCARD) {
2188 ENTER;
2189 SAVETMPS;
2190 }
2191
462e5cf6 2192 SAVEOP();
533c011a
NIS		 2193 PL_op = (OP*)&myop;
2194 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2195 EXTEND(PL_stack_sp, 1);
2196 *++PL_stack_sp = sv;
2197 oldscope = PL_scopestack_ix;
79072805 2198
4633a7c4
LW		 2199 if (!(flags & G_NOARGS))
2200 myop.op_flags = OPf_STACKED;
79072805 2201 myop.op_next = Nullop;
6e72f9df 2202 myop.op_type = OP_ENTEREVAL;
54310121 2203 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2204 (flags & G_ARRAY) ? OPf_WANT_LIST :
2205 OPf_WANT_SCALAR);
6e72f9df 2206 if (flags & G_KEEPERR)
2207 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2208
14dd3ad8 2209#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2210 redo_body:
14dd3ad8 2211 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 2212 (OP*)&myop, TRUE);
14dd3ad8
GS		 2213#else
2214 JMPENV_PUSH(ret);
2215#endif
6224f72b
GS		 2216 switch (ret) {
2217 case 0:
14dd3ad8
GS		 2218#ifndef PERL_FLEXIBLE_EXCEPTIONS
2219 redo_body:
2220 call_body((OP*)&myop,TRUE);
2221#endif
312caa8e
CS		 2222 retval = PL_stack_sp - (PL_stack_base + oldmark);
2223 if (!(flags & G_KEEPERR))
2224 sv_setpv(ERRSV,"");
4633a7c4 2225 break;
6224f72b 2226 case 1:
f86702cc 2227 STATUS_ALL_FAILURE;
4633a7c4 2228 /* FALL THROUGH */
6224f72b 2229 case 2:
4633a7c4 2230 /* my_exit() was called */
3280af22 2231 PL_curstash = PL_defstash;
4633a7c4 2232 FREETMPS;
14dd3ad8 2233 JMPENV_POP;
cc3604b1 2234 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2235 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2236 my_exit_jump();
4633a7c4 2237 /* NOTREACHED */
6224f72b 2238 case 3:
3280af22 2239 if (PL_restartop) {
533c011a 2240 PL_op = PL_restartop;
3280af22 2241 PL_restartop = 0;
312caa8e 2242 goto redo_body;
4633a7c4 2243 }
3280af22 2244 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2245 if (flags & G_ARRAY)
2246 retval = 0;
2247 else {
2248 retval = 1;
3280af22 2249 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2250 }
312caa8e 2251 break;
4633a7c4
LW		 2252 }
2253
14dd3ad8 2254 JMPENV_POP;
4633a7c4 2255 if (flags & G_DISCARD) {
3280af22 2256 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2257 retval = 0;
2258 FREETMPS;
2259 LEAVE;
2260 }
533c011a 2261 PL_op = oldop;
4633a7c4
LW		 2262 return retval;
2263}
2264
954c1994
GS		 2265/*
2266=for apidoc p||eval_pv
2267
2268Tells Perl to C<eval> the given string and return an SV* result.
2269
2270=cut
2271*/
2272
137443ea 2273SV*
864dbfa3 2274Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2275{
2276 dSP;
2277 SV* sv = newSVpv(p, 0);
2278
864dbfa3 2279 eval_sv(sv, G_SCALAR);
137443ea 2280 SvREFCNT_dec(sv);
2281
2282 SPAGAIN;
2283 sv = POPs;
2284 PUTBACK;
2285
2d8e6c8d
GS		 2286 if (croak_on_error && SvTRUE(ERRSV)) {
2287 STRLEN n_a;
cea2e8a9 2288 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 2289 }
137443ea 2290
2291 return sv;
2292}
2293
4633a7c4
LW		 2294/* Require a module. */
2295
954c1994 2296/*
ccfc67b7
JH		 2297=head1 Embedding Functions
2298
954c1994
GS		 2299=for apidoc p||require_pv
2300
7d3fb230
BS		 2301Tells Perl to C<require> the file named by the string argument. It is
2302analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2303implemented that way; consider using load_module instead.
954c1994 2304
7d3fb230 2305=cut */
954c1994 2306
4633a7c4 2307void
864dbfa3 2308Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2309{
d3acc0f7
JP		 2310 SV* sv;
2311 dSP;
e788e7d3 2312 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2313 PUTBACK;
2314 sv = sv_newmortal();
4633a7c4
LW		 2315 sv_setpv(sv, "require '");
2316 sv_catpv(sv, pv);
2317 sv_catpv(sv, "'");
864dbfa3 2318 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2319 SPAGAIN;
2320 POPSTACK;
79072805
LW		 2321}
2322
79072805 2323void
864dbfa3 2324Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 2325{
2326 register GV *gv;
2327
155aba94 2328 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2329 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2330}
2331
76e3520e 2332STATIC void
cea2e8a9 2333S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 2334{
ab821d7f 2335 /* This message really ought to be max 23 lines.
75c72d73 2336 * Removed -h because the user already knows that option. Others? */
fb73857a 2337
76e3520e 2338 static char *usage_msg[] = {
fb73857a 2339"-0[octal] specify record separator (\\0, if no argument)",
2340"-a autosplit mode with -n or -p (splits $_ into @F)",
fb3560ee 2341"-C[number/list] enables the listed Unicode features",
1950ee41 2342"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS		 2343"-d[:debugger] run program under debugger",
2344"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
90490ea3 2345"-e program one line of program (several -e's allowed, omit programfile)",
aac3bd0d
GS		 2346"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2347"-i[extension] edit <> files in place (makes backup if extension supplied)",
2348"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 2349"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 2350"-[mM][-]module execute `use/no module...' before executing program",
2351"-n assume 'while (<>) { ... }' loop around program",
2352"-p assume loop like -n but print line also, like sed",
2353"-P run program through C preprocessor before compilation",
2354"-s enable rudimentary parsing for switches after programfile",
2355"-S look for programfile using PATH environment variable",
9cbc33e8 2356"-t enable tainting warnings",
90490ea3 2357"-T enable tainting checks",
aac3bd0d 2358"-u dump core after parsing program",
fb73857a 2359"-U allow unsafe operations",
aac3bd0d
GS		 2360"-v print version, subversion (includes VERY IMPORTANT perl info)",
2361"-V[:variable] print configuration summary (or a single Config.pm variable)",
2362"-w enable many useful warnings (RECOMMENDED)",
3c0facb2 2363"-W enable all warnings",
fb73857a 2364"-x[directory] strip off text before #!perl line and perhaps cd to directory",
90490ea3 2365"-X disable all warnings",
fb73857a 2366"\n",
2367NULL
2368};
76e3520e 2369 char **p = usage_msg;
fb73857a 2370
b0e47665
GS		 2371 PerlIO_printf(PerlIO_stdout(),
2372 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2373 name);
fb73857a 2374 while (*p)
b0e47665 2375 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2376}
2377
b4ab917c
DM		 2378/* convert a string of -D options (or digits) into an int.
2379 * sets *s to point to the char after the options */
2380
2381#ifdef DEBUGGING
2382int
2383Perl_get_debug_opts(pTHX_ char **s)
2384{
e6e64d9b
JC		 2385 static char *usage_msgd[] = {
2386 " Debugging flag values: (see also -d)",
2387 " p Tokenizing and parsing (with v, displays parse stack)",
2388 " s Stack snapshots. with v, displays all stacks",
2389 " l Context (loop) stack processing",
2390 " t Trace execution",
2391 " o Method and overloading resolution",
2392 " c String/numeric conversions",
2393 " P Print profiling info, preprocessor command for -P, source file input state",
2394 " m Memory allocation",
2395 " f Format processing",
2396 " r Regular expression parsing and execution",
2397 " x Syntax tree dump",
2398 " u Tainting checks (Obsolete, previously used for LEAKTEST)",
2399 " H Hash dump -- usurps values()",
2400 " X Scratchpad allocation",
2401 " D Cleaning up",
2402 " S Thread synchronization",
2403 " T Tokenising",
2404 " R Include reference counts of dumped variables (eg when using -Ds)",
2405 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2406 " v Verbose: use in conjunction with other flags",
2407 " C Copy On Write",
2408 " A Consistency checks on internal structures",
2409 " q quiet - currently only suppressed the 'EXECUTING' message",
2410 NULL
2411 };
b4ab917c
DM		 2412 int i = 0;
2413 if (isALPHA(**s)) {
2414 /* if adding extra options, remember to update DEBUG_MASK */
ecae49c0 2415 static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
b4ab917c
DM		 2416
2417 for (; isALNUM(**s); (*s)++) {
2418 char *d = strchr(debopts,**s);
2419 if (d)
2420 i |= 1 << (d - debopts);
2421 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC		 2422 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2423 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM		 2424 }
2425 }
e6e64d9b 2426 else if (isDIGIT(**s)) {
b4ab917c
DM		 2427 i = atoi(*s);
2428 for (; isALNUM(**s); (*s)++) ;
2429 }
e6e64d9b
JC		 2430 else {
2431 char **p = usage_msgd;
2432 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2433 }
b4ab917c
DM		 2434# ifdef EBCDIC
2435 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2436 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2437 "-Dp not implemented on this platform\n");
2438# endif
2439 return i;
2440}
2441#endif
2442
79072805
LW		 2443/* This routine handles any switches that can be given during run */
2444
2445char *
864dbfa3 2446Perl_moreswitches(pTHX_ char *s)
79072805 2447{
ba210ebe 2448 STRLEN numlen;
84c133a0 2449 UV rschar;
79072805
LW		 2450
2451 switch (*s) {
2452 case '0':
a863c7d1 2453 {
f2095865
JH		 2454 I32 flags = 0;
2455
2456 SvREFCNT_dec(PL_rs);
2457 if (s[1] == 'x' && s[2]) {
2458 char *e;
2459 U8 *tmps;
2460
2461 for (s += 2, e = s; *e; e++);
2462 numlen = e - s;
2463 flags = PERL_SCAN_SILENT_ILLDIGIT;
2464 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2465 if (s + numlen < e) {
2466 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2467 numlen = 0;
2468 s--;
2469 }
2470 PL_rs = newSVpvn("", 0);
c5661c80 2471 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 2472 tmps = (U8*)SvPVX(PL_rs);
2473 uvchr_to_utf8(tmps, rschar);
2474 SvCUR_set(PL_rs, UNISKIP(rschar));
2475 SvUTF8_on(PL_rs);
2476 }
2477 else {
2478 numlen = 4;
2479 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2480 if (rschar & ~((U8)~0))
2481 PL_rs = &PL_sv_undef;
2482 else if (!rschar && numlen >= 2)
2483 PL_rs = newSVpvn("", 0);
2484 else {
2485 char ch = (char)rschar;
2486 PL_rs = newSVpvn(&ch, 1);
2487 }
2488 }
800633c3 2489 sv_setsv(get_sv("/", TRUE), PL_rs);
f2095865 2490 return s + numlen;
a863c7d1 2491 }
46487f74 2492 case 'C':
a05d7ebb
JH		 2493 s++;
2494 PL_unicode = parse_unicode_opts(&s);
46487f74 2495 return s;
2304df62 2496 case 'F':
3280af22 2497 PL_minus_F = TRUE;
ebce5377
RGS		 2498 PL_splitstr = ++s;
2499 while (*s && !isSPACE(*s)) ++s;
2500 *s = '\0';
2501 PL_splitstr = savepv(PL_splitstr);
2304df62 2502 return s;
79072805 2503 case 'a':
3280af22 2504 PL_minus_a = TRUE;
79072805
LW		 2505 s++;
2506 return s;
2507 case 'c':
3280af22 2508 PL_minus_c = TRUE;
79072805
LW		 2509 s++;
2510 return s;
2511 case 'd':
bbce6d69 2512 forbid_setid("-d");
4633a7c4 2513 s++;
70c94a19
RR		 2514 /* The following permits -d:Mod to accepts arguments following an =
2515 in the fashion that -MSome::Mod does. */
2516 if (*s == ':' || *s == '=') {
2517 char *start;
2518 SV *sv;
2519 sv = newSVpv("use Devel::", 0);
2520 start = ++s;
2521 /* We now allow -d:Module=Foo,Bar */
2522 while(isALNUM(*s) || *s==':') ++s;
2523 if (*s != '=')
2524 sv_catpv(sv, start);
2525 else {
2526 sv_catpvn(sv, start, s-start);
2527 sv_catpv(sv, " split(/,/,q{");
2528 sv_catpv(sv, ++s);
3d27e215 2529 sv_catpv(sv, "})");
70c94a19 2530 }
4633a7c4 2531 s += strlen(s);
70c94a19 2532 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2533 }
ed094faf 2534 if (!PL_perldb) {
3280af22 2535 PL_perldb = PERLDB_ALL;
a0d0e21e 2536 init_debugger();
ed094faf 2537 }
79072805
LW		 2538 return s;
2539 case 'D':
0453d815 2540 {
79072805 2541#ifdef DEBUGGING
bbce6d69 2542 forbid_setid("-D");
b4ab917c
DM		 2543 s++;
2544 PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
12a43e32 2545#else /* !DEBUGGING */
0453d815 2546 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2547 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
e6e64d9b 2548 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
a0d0e21e 2549 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2550#endif
2551 /*SUPPRESS 530*/
2552 return s;
0453d815 2553 }
4633a7c4 2554 case 'h':
ac27b0f5 2555 usage(PL_origargv[0]);
7ca617d0 2556 my_exit(0);
79072805 2557 case 'i':
3280af22
NIS		 2558 if (PL_inplace)
2559 Safefree(PL_inplace);
c030f24b
GH		 2560#if defined(__CYGWIN__) /* do backup extension automagically */
2561 if (*(s+1) == '\0') {
2562 PL_inplace = savepv(".bak");
2563 return s+1;
2564 }
2565#endif /* __CYGWIN__ */
3280af22 2566 PL_inplace = savepv(s+1);
79072805 2567 /*SUPPRESS 530*/
3280af22 2568 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2569 if (*s) {
fb73857a 2570 *s++ = '\0';
7b8d334a
GS		 2571 if (*s == '-') /* Additional switches on #! line. */
2572 s++;
2573 }
fb73857a 2574 return s;
4e49a025 2575 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2576 forbid_setid("-I");
fb73857a 2577 ++s;
2578 while (*s && isSPACE(*s))
2579 ++s;
2580 if (*s) {
774d564b 2581 char *e, *p;
0df16ed7
GS		 2582 p = s;
2583 /* ignore trailing spaces (possibly followed by other switches) */
2584 do {
2585 for (e = p; *e && !isSPACE(*e); e++) ;
2586 p = e;
2587 while (isSPACE(*p))
2588 p++;
2589 } while (*p && *p != '-');
2590 e = savepvn(s, e-s);
574c798a 2591 incpush(e, TRUE, TRUE, FALSE);
0df16ed7
GS		 2592 Safefree(e);
2593 s = p;
2594 if (*s == '-')
2595 s++;
79072805
LW		 2596 }
2597 else
a67e862a 2598 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2599 return s;
79072805 2600 case 'l':
3280af22 2601 PL_minus_l = TRUE;
79072805 2602 s++;
7889fe52
NIS		 2603 if (PL_ors_sv) {
2604 SvREFCNT_dec(PL_ors_sv);
2605 PL_ors_sv = Nullsv;
2606 }
79072805 2607 if (isDIGIT(*s)) {
53305cf1 2608 I32 flags = 0;
7889fe52 2609 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2610 numlen = 3 + (*s == '0');
2611 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2612 s += numlen;
2613 }
2614 else {
8bfdd7d9 2615 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2616 PL_ors_sv = newSVpvn("\n\n",2);
2617 }
2618 else {
8bfdd7d9 2619 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2620 }
79072805
LW		 2621 }
2622 return s;
06492da6
SF		 2623 case 'A':
2624 forbid_setid("-A");
930366bd
RGS		 2625 if (!PL_preambleav)
2626 PL_preambleav = newAV();
06492da6 2627 if (*++s) {
3d27e215
LM		 2628 SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
2629 sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
06492da6 2630 sv_catpv(sv,s);
3d27e215 2631 sv_catpvn(sv, "\0)", 2);
06492da6 2632 s+=strlen(s);
06492da6
SF		 2633 av_push(PL_preambleav, sv);
2634 }
2635 else
930366bd 2636 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
06492da6 2637 return s;
1a30305b 2638 case 'M':
bbce6d69 2639 forbid_setid("-M"); /* XXX ? */
1a30305b 2640 /* FALL THROUGH */
2641 case 'm':
bbce6d69 2642 forbid_setid("-m"); /* XXX ? */
1a30305b 2643 if (*++s) {
a5f75d66 2644 char *start;
11343788 2645 SV *sv;
a5f75d66
AD		 2646 char *use = "use ";
2647 /* -M-foo == 'no foo' */
2648 if (*s == '-') { use = "no "; ++s; }
11343788 2649 sv = newSVpv(use,0);
a5f75d66 2650 start = s;
1a30305b 2651 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2652 while(isALNUM(*s) || *s==':') ++s;
2653 if (*s != '=') {
11343788 2654 sv_catpv(sv, start);
c07a80fd 2655 if (*(start-1) == 'm') {
2656 if (*s != '\0')
cea2e8a9 2657 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2658 sv_catpv( sv, " ()");
c07a80fd 2659 }
2660 } else {
6df41af2 2661 if (s == start)
be98fb35
GS		 2662 Perl_croak(aTHX_ "Module name required with -%c option",
2663 s[-1]);
11343788 2664 sv_catpvn(sv, start, s-start);
3d27e215
LM		 2665 sv_catpv(sv, " split(/,/,q");
2666 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
11343788 2667 sv_catpv(sv, ++s);
3d27e215 2668 sv_catpvn(sv, "\0)", 2);
c07a80fd 2669 }
1a30305b 2670 s += strlen(s);
5c831c24 2671 if (!PL_preambleav)
3280af22
NIS		 2672 PL_preambleav = newAV();
2673 av_push(PL_preambleav, sv);
1a30305b 2674 }
2675 else
cea2e8a9 2676 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2677 return s;
79072805 2678 case 'n':
3280af22 2679 PL_minus_n = TRUE;
79072805
LW		 2680 s++;
2681 return s;
2682 case 'p':
3280af22 2683 PL_minus_p = TRUE;
79072805
LW		 2684 s++;
2685 return s;
2686 case 's':
bbce6d69 2687 forbid_setid("-s");
3280af22 2688 PL_doswitches = TRUE;
79072805
LW		 2689 s++;
2690 return s;
6537fe72
MS		 2691 case 't':
2692 if (!PL_tainting)
22f7c9c9 2693 TOO_LATE_FOR('t');
6537fe72
MS		 2694 s++;
2695 return s;
463ee0b2 2696 case 'T':
3280af22 2697 if (!PL_tainting)
22f7c9c9 2698 TOO_LATE_FOR('T');
463ee0b2
LW		 2699 s++;
2700 return s;
79072805 2701 case 'u':
bf4acbe4
GS		 2702#ifdef MACOS_TRADITIONAL
2703 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2704#endif
3280af22 2705 PL_do_undump = TRUE;
79072805
LW		 2706 s++;
2707 return s;
2708 case 'U':
3280af22 2709 PL_unsafe = TRUE;
79072805
LW		 2710 s++;
2711 return s;
2712 case 'v':
8e9464f1 2713#if !defined(DGUX)
b0e47665 2714 PerlIO_printf(PerlIO_stdout(),
d2560b70 2715 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
b0e47665 2716 PL_patchlevel, ARCHNAME));
8e9464f1
JH		 2717#else /* DGUX */
2718/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2719 PerlIO_printf(PerlIO_stdout(),
2720 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2721 PerlIO_printf(PerlIO_stdout(),
2722 Perl_form(aTHX_ " built under %s at %s %s\n",
2723 OSNAME, __DATE__, __TIME__));
2724 PerlIO_printf(PerlIO_stdout(),
2725 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2726 OSVERS));
8e9464f1
JH		 2727#endif /* !DGUX */
2728
fb73857a 2729#if defined(LOCAL_PATCH_COUNT)
2730 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2731 PerlIO_printf(PerlIO_stdout(),
2732 "\n(with %d registered patch%s, "
2733 "see perl -V for more detail)",
2734 (int)LOCAL_PATCH_COUNT,
2735 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2736#endif
1a30305b 2737
b0e47665 2738 PerlIO_printf(PerlIO_stdout(),
45a2796c 2739 "\n\nCopyright 1987-2004, Larry Wall\n");
eae9c151
JH		 2740#ifdef MACOS_TRADITIONAL
2741 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2742 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2743 "maintained by Chris Nandor\n");
eae9c151 2744#endif
79072805 2745#ifdef MSDOS
b0e47665
GS		 2746 PerlIO_printf(PerlIO_stdout(),
2747 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2748#endif
2749#ifdef DJGPP
b0e47665
GS		 2750 PerlIO_printf(PerlIO_stdout(),
2751 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2752 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2753#endif
79072805 2754#ifdef OS2
b0e47665
GS		 2755 PerlIO_printf(PerlIO_stdout(),
2756 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2757 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2758#endif
79072805 2759#ifdef atarist
b0e47665
GS		 2760 PerlIO_printf(PerlIO_stdout(),
2761 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2762#endif
a3f9223b 2763#ifdef __BEOS__
b0e47665
GS		 2764 PerlIO_printf(PerlIO_stdout(),
2765 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2766#endif
1d84e8df 2767#ifdef MPE
b0e47665 2768 PerlIO_printf(PerlIO_stdout(),
e583a879 2769 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 2770#endif
9d116dd7 2771#ifdef OEMVS
b0e47665
GS		 2772 PerlIO_printf(PerlIO_stdout(),
2773 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2774#endif
495c5fdc 2775#ifdef __VOS__
b0e47665 2776 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2777 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2778#endif
092bebab 2779#ifdef __OPEN_VM
b0e47665
GS		 2780 PerlIO_printf(PerlIO_stdout(),
2781 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2782#endif
a1a0e61e 2783#ifdef POSIX_BC
b0e47665
GS		 2784 PerlIO_printf(PerlIO_stdout(),
2785 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2786#endif
61ae2fbf 2787#ifdef __MINT__
b0e47665
GS		 2788 PerlIO_printf(PerlIO_stdout(),
2789 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2790#endif
f83d2536 2791#ifdef EPOC
b0e47665 2792 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2793 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2794#endif
e1caacb4 2795#ifdef UNDER_CE
b475b3e6
JH		 2796 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2797 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2798 wce_hitreturn();
2799#endif
baed7233
DL		 2800#ifdef BINARY_BUILD_NOTICE
2801 BINARY_BUILD_NOTICE;
2802#endif
b0e47665
GS		 2803 PerlIO_printf(PerlIO_stdout(),
2804 "\n\
79072805 2805Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2806GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2807Complete documentation for Perl, including FAQ lists, should be found on\n\
2808this system using `man perl' or `perldoc perl'. If you have access to the\n\
2809Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
7ca617d0 2810 my_exit(0);
79072805 2811 case 'w':
599cee73 2812 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2813 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2814 s++;
2815 return s;
2816 case 'W':
ac27b0f5 2817 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2818 if (!specialWARN(PL_compiling.cop_warnings))
2819 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2820 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2821 s++;
2822 return s;
2823 case 'X':
ac27b0f5 2824 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2825 if (!specialWARN(PL_compiling.cop_warnings))
2826 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2827 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2828 s++;
2829 return s;
a0d0e21e 2830 case '*':
79072805
LW		 2831 case ' ':
2832 if (s[1] == '-') /* Additional switches on #! line. */
2833 return s+2;
2834 break;
a0d0e21e 2835 case '-':
79072805 2836 case 0:
51882d45 2837#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2838 case '\r':
2839#endif
79072805
LW		 2840 case '\n':
2841 case '\t':
2842 break;
aa689395 2843#ifdef ALTERNATE_SHEBANG
2844 case 'S': /* OS/2 needs -S on "extproc" line. */
2845 break;
2846#endif
a0d0e21e 2847 case 'P':
3280af22 2848 if (PL_preprocess)
a0d0e21e
LW		 2849 return s+1;
2850 /* FALL THROUGH */
79072805 2851 default:
cea2e8a9 2852 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2853 }
2854 return Nullch;
2855}
2856
2857/* compliments of Tom Christiansen */
2858
2859/* unexec() can be found in the Gnu emacs distribution */
ee580363 2860/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2861
2862void
864dbfa3 2863Perl_my_unexec(pTHX)
79072805
LW		 2864{
2865#ifdef UNEXEC
46fc3d4c 2866 SV* prog;
2867 SV* file;
ee580363 2868 int status = 1;
79072805
LW		 2869 extern int etext;
2870
ee580363 2871 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2872 sv_catpv(prog, "/perl");
6b88bc9c 2873 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2874 sv_catpv(file, ".perldump");
79072805 2875
ee580363
GS		 2876 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2877 /* unexec prints msg to stderr in case of failure */
6ad3d225 2878 PerlProc_exit(status);
79072805 2879#else
a5f75d66
AD		 2880# ifdef VMS
2881# include <lib$routines.h>
2882 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2883# else
79072805 2884 ABORT(); /* for use with undump */
aa689395 2885# endif
a5f75d66 2886#endif
79072805
LW		 2887}
2888
cb68f92d
GS		 2889/* initialize curinterp */
2890STATIC void
cea2e8a9 2891S_init_interp(pTHX)
cb68f92d
GS		 2892{
2893
acfe0abc
GS		 2894#ifdef MULTIPLICITY
2895# define PERLVAR(var,type)
2896# define PERLVARA(var,n,type)
2897# if defined(PERL_IMPLICIT_CONTEXT)
2898# if defined(USE_5005THREADS)
2899# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2900# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2901# else /* !USE_5005THREADS */
2902# define PERLVARI(var,type,init) aTHX->var = init;
2903# define PERLVARIC(var,type,init) aTHX->var = init;
2904# endif /* USE_5005THREADS */
3967c732 2905# else
acfe0abc
GS		 2906# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2907# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2908# endif
acfe0abc
GS		 2909# include "intrpvar.h"
2910# ifndef USE_5005THREADS
2911# include "thrdvar.h"
2912# endif
2913# undef PERLVAR
2914# undef PERLVARA
2915# undef PERLVARI
2916# undef PERLVARIC
2917#else
2918# define PERLVAR(var,type)
2919# define PERLVARA(var,n,type)
2920# define PERLVARI(var,type,init) PL_##var = init;
2921# define PERLVARIC(var,type,init) PL_##var = init;
2922# include "intrpvar.h"
2923# ifndef USE_5005THREADS
2924# include "thrdvar.h"
2925# endif
2926# undef PERLVAR
2927# undef PERLVARA
2928# undef PERLVARI
2929# undef PERLVARIC
cb68f92d
GS		 2930#endif
2931
cb68f92d
GS		 2932}
2933
76e3520e 2934STATIC void
cea2e8a9 2935S_init_main_stash(pTHX)
79072805 2936{
463ee0b2 2937 GV *gv;
6e72f9df 2938
3280af22 2939 PL_curstash = PL_defstash = newHV();
79cb57f6 2940 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2941 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2942 SvREFCNT_dec(GvHV(gv));
3280af22 2943 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2944 SvREADONLY_on(gv);
3280af22
NIS		 2945 HvNAME(PL_defstash) = savepv("main");
2946 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2947 GvMULTI_on(PL_incgv);
2948 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2949 GvMULTI_on(PL_hintgv);
2950 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2951 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2952 GvMULTI_on(PL_errgv);
2953 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2954 GvMULTI_on(PL_replgv);
cea2e8a9 2955 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2956 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2957 sv_setpvn(ERRSV, "", 0);
3280af22 2958 PL_curstash = PL_defstash;
11faa288 2959 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2960 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2961 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2962 /* We must init $/ before switches are processed. */
864dbfa3 2963 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2964}
2965
ae3f3efd 2966/* PSz 18 Nov 03 fdscript now global but do not change prototype */
76e3520e 2967STATIC void
c5cccb17 2968S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
79072805 2969{
ae3f3efd 2970#ifndef IAMSUID
1b24ed4b
MS		 2971 char *quote;
2972 char *code;
2973 char *cpp_discard_flag;
2974 char *perl;
ae3f3efd 2975#endif
1b24ed4b 2976
ae3f3efd
PS		 2977 PL_fdscript = -1;
2978 PL_suidscript = -1;
79072805 2979
3280af22
NIS		 2980 if (PL_e_script) {
2981 PL_origfilename = savepv("-e");
96436eeb 2982 }
6c4ab083
GS		 2983 else {
2984 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2985 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2986
2987 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2988 char *s = scriptname + 8;
ae3f3efd 2989 PL_fdscript = atoi(s);
6c4ab083
GS		 2990 while (isDIGIT(*s))
2991 s++;
2992 if (*s) {
ae3f3efd
PS		 2993 /* PSz 18 Feb 04
2994 * Tell apart "normal" usage of fdscript, e.g.
2995 * with bash on FreeBSD:
2996 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
2997 * from usage in suidperl.
2998 * Does any "normal" usage leave garbage after the number???
2999 * Is it a mistake to use a similar /dev/fd/ construct for
3000 * suidperl?
3001 */
3002 PL_suidscript = 1;
3003 /* PSz 20 Feb 04
3004 * Be supersafe and do some sanity-checks.
3005 * Still, can we be sure we got the right thing?
3006 */
3007 if (*s != '/') {
3008 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3009 }
3010 if (! *(s+1)) {
3011 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3012 }
6c4ab083 3013 scriptname = savepv(s + 1);
3280af22
NIS		 3014 Safefree(PL_origfilename);
3015 PL_origfilename = scriptname;
6c4ab083
GS		 3016 }
3017 }
3018 }
3019
05ec9bb3 3020 CopFILE_free(PL_curcop);
57843af0 3021 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 3022 if (strEQ(PL_origfilename,"-"))
79072805 3023 scriptname = "";
ae3f3efd
PS		 3024 if (PL_fdscript >= 0) {
3025 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3026# if defined(HAS_FCNTL) && defined(F_SETFD)
3027 if (PL_rsfp)
3028 /* ensure close-on-exec */
3029 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3030# endif
96436eeb 3031 }
ae3f3efd
PS		 3032#ifdef IAMSUID
3033 else {
86207487
NC		 3034 Perl_croak(aTHX_ "sperl needs fd script\n"
3035 "You should not call sperl directly; do you need to "
3036 "change a #! line\nfrom sperl to perl?\n");
3037
ae3f3efd
PS		 3038/* PSz 11 Nov 03
3039 * Do not open (or do other fancy stuff) while setuid.
3040 * Perl does the open, and hands script to suidperl on a fd;
3041 * suidperl only does some checks, sets up UIDs and re-execs
3042 * perl with that fd as it has always done.
3043 */
3044 }
3045 if (PL_suidscript != 1) {
3046 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3047 }
3048#else /* IAMSUID */
3280af22 3049 else if (PL_preprocess) {
46fc3d4c 3050 char *cpp_cfg = CPPSTDIN;
79cb57f6 3051 SV *cpp = newSVpvn("",0);
46fc3d4c 3052 SV *cmd = NEWSV(0,0);
3053
ae58f265
JH		 3054 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3055 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
46fc3d4c 3056 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 3057 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 3058 sv_catpv(cpp, cpp_cfg);
79072805 3059
1b24ed4b
MS		 3060# ifndef VMS
3061 sv_catpvn(sv, "-I", 2);
3062 sv_catpv(sv,PRIVLIB_EXP);
3063# endif
46fc3d4c 3064
14953ddc
MB		 3065 DEBUG_P(PerlIO_printf(Perl_debug_log,
3066 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3067 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 3068
3069# if defined(MSDOS) || defined(WIN32) || defined(VMS)
3070 quote = "\"";
3071# else
3072 quote = "'";
3073# endif
3074
3075# ifdef VMS
3076 cpp_discard_flag = "";
3077# else
3078 cpp_discard_flag = "-C";
3079# endif
3080
3081# ifdef OS2
3082 perl = os2_execname(aTHX);
3083# else
3084 perl = PL_origargv[0];
3085# endif
3086
3087
3088 /* This strips off Perl comments which might interfere with
62375a60
NIS		 3089 the C pre-processor, including #!. #line directives are
3090 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 3091 of #line. FWP played some golf with it so it will fit
3092 into VMS's 255 character buffer.
3093 */
3094 if( PL_doextract )
3095 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3096 else
3097 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3098
3099 Perl_sv_setpvf(aTHX_ cmd, "\
3100%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 3101 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 3102 cpp_discard_flag, sv, CPPMINUS);
3103
3280af22 3104 PL_doextract = FALSE;
0a6c758d 3105
62375a60
NIS		 3106 DEBUG_P(PerlIO_printf(Perl_debug_log,
3107 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 3108 SvPVX(cmd)));
3109
3280af22 3110 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 3111 SvREFCNT_dec(cmd);
3112 SvREFCNT_dec(cpp);
79072805
LW		 3113 }
3114 else if (!*scriptname) {
bbce6d69 3115 forbid_setid("program input from stdin");
3280af22 3116 PL_rsfp = PerlIO_stdin();
79072805 3117 }
96436eeb 3118 else {
3280af22 3119 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3120# if defined(HAS_FCNTL) && defined(F_SETFD)
3121 if (PL_rsfp)
3122 /* ensure close-on-exec */
3123 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3124# endif
96436eeb 3125 }
ae3f3efd 3126#endif /* IAMSUID */
3280af22 3127 if (!PL_rsfp) {
447218f8
RGS		 3128 /* PSz 16 Sep 03 Keep neat error message */
3129 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s%s\n",
3130 CopFILE(PL_curcop), Strerror(errno),
3131 ".\nUse -S to search $PATH for it.");
13281fa4 3132 }
79072805 3133}
8d063cd8 3134
7b89560d
JH		 3135/* Mention
3136 * I_SYSSTATVFS HAS_FSTATVFS
3137 * I_SYSMOUNT
c890dc6c 3138 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3139 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3140 * here so that metaconfig picks them up. */
3141
104d25b7 3142#ifdef IAMSUID
864dbfa3 3143STATIC int
e688b231 3144S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 3145{
ae3f3efd
PS		 3146/* PSz 27 Feb 04
3147 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3148 * but is needed also on machines without setreuid.
3149 * Seems safe enough to run as root.
3150 */
0545a864
JH		 3151 int check_okay = 0; /* able to do all the required sys/libcalls */
3152 int on_nosuid = 0; /* the fd is on a nosuid fs */
ae3f3efd
PS		 3153 /* PSz 12 Nov 03
3154 * Need to check noexec also: nosuid might not be set, the average
3155 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3156 */
3157 int on_noexec = 0; /* the fd is on a noexec fs */
3158
104d25b7 3159/*
ad27e871 3160 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 3161 * fstatvfs() is UNIX98.
0545a864 3162 * fstatfs() is 4.3 BSD.
ad27e871 3163 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 3164 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3165 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 3166 */
3167
6439433f
JH		 3168#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3169
3170# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3171 defined(HAS_FSTATVFS)
3172# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 3173 struct statvfs stfs;
6439433f 3174
104d25b7
JH		 3175 check_okay = fstatvfs(fd, &stfs) == 0;
3176 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
ae3f3efd
PS		 3177#ifdef ST_NOEXEC
3178 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3179 on platforms where it is present. */
3180 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3181#endif
6439433f 3182# endif /* fstatvfs */
ac27b0f5 3183
6439433f
JH		 3184# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3185 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3186 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3187 defined(HAS_FSTATFS) && \
3188 defined(HAS_STRUCT_STATFS) && \
3189 defined(HAS_STRUCT_STATFS_F_FLAGS)
3190# define FD_ON_NOSUID_CHECK_OKAY
e688b231 3191 struct statfs stfs;
6439433f 3192
104d25b7 3193 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 3194 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
ae3f3efd 3195 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
6439433f
JH		 3196# endif /* fstatfs */
3197
3198# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3199 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3200 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3201 defined(HAS_FSTAT) && \
3202 defined(HAS_USTAT) && \
3203 defined(HAS_GETMNT) && \
3204 defined(HAS_STRUCT_FS_DATA) && \
3205 defined(NOSTAT_ONE)
3206# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 3207 Stat_t fdst;
6439433f 3208
0545a864 3209 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 3210 struct ustat us;
3211 if (ustat(fdst.st_dev, &us) == 0) {
3212 struct fs_data fsd;
3213 /* NOSTAT_ONE here because we're not examining fields which
3214 * vary between that case and STAT_ONE. */
ad27e871 3215 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3216 size_t cmplen = sizeof(us.f_fname);
3217 if (sizeof(fsd.fd_req.path) < cmplen)
3218 cmplen = sizeof(fsd.fd_req.path);
3219 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3220 fdst.st_dev == fsd.fd_req.dev) {
3221 check_okay = 1;
3222 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
ae3f3efd 3223 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
6439433f
JH		 3224 }
3225 }
3226 }
3227 }
0545a864 3228 }
6439433f
JH		 3229# endif /* fstat+ustat+getmnt */
3230
3231# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3232 defined(HAS_GETMNTENT) && \
3233 defined(HAS_HASMNTOPT) && \
ae3f3efd
PS		 3234 defined(MNTOPT_NOSUID) && \
3235 defined(MNTOPT_NOEXEC)
6439433f
JH		 3236# define FD_ON_NOSUID_CHECK_OKAY
3237 FILE *mtab = fopen("/etc/mtab", "r");
3238 struct mntent *entry;
c623ac67 3239 Stat_t stb, fsb;
104d25b7
JH		 3240
3241 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3242 while (entry = getmntent(mtab)) {
3243 if (stat(entry->mnt_dir, &fsb) == 0
3244 && fsb.st_dev == stb.st_dev)
3245 {
3246 /* found the filesystem */
3247 check_okay = 1;
3248 if (hasmntopt(entry, MNTOPT_NOSUID))
3249 on_nosuid = 1;
ae3f3efd
PS		 3250 if (hasmntopt(entry, MNTOPT_NOEXEC))
3251 on_noexec = 1;
6439433f
JH		 3252 break;
3253 } /* A single fs may well fail its stat(). */
3254 }
104d25b7
JH		 3255 }
3256 if (mtab)
6439433f
JH		 3257 fclose(mtab);
3258# endif /* getmntent+hasmntopt */
0545a864 3259
ac27b0f5 3260 if (!check_okay)
ae3f3efd
PS		 3261 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3262 if (on_nosuid)
3263 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3264 if (on_noexec)
3265 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3266 return ((!check_okay) || on_nosuid || on_noexec);
104d25b7
JH		 3267}
3268#endif /* IAMSUID */
3269
76e3520e 3270STATIC void
c5cccb17 3271S_validate_suid(pTHX_ char *validarg, char *scriptname)
79072805 3272{
155aba94 3273#ifdef IAMSUID
ae3f3efd
PS		 3274 /* int which; */
3275#endif /* IAMSUID */
96436eeb 3276
13281fa4
LW		 3277 /* do we need to emulate setuid on scripts? */
3278
3279 /* This code is for those BSD systems that have setuid #! scripts disabled
3280 * in the kernel because of a security problem. Merely defining DOSUID
3281 * in perl will not fix that problem, but if you have disabled setuid
3282 * scripts in the kernel, this will attempt to emulate setuid and setgid
3283 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3284 * root version must be called suidperl or sperlN.NNN. If regular perl
3285 * discovers that it has opened a setuid script, it calls suidperl with
3286 * the same argv that it had. If suidperl finds that the script it has
3287 * just opened is NOT setuid root, it sets the effective uid back to the
3288 * uid. We don't just make perl setuid root because that loses the
3289 * effective uid we had before invoking perl, if it was different from the
3290 * uid.
ae3f3efd
PS		 3291 * PSz 27 Feb 04
3292 * Description/comments above do not match current workings:
3293 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3294 * suidperl called with script open and name changed to /dev/fd/N/X;
3295 * suidperl croaks if script is not setuid;
3296 * making perl setuid would be a huge security risk (and yes, that
3297 * would lose any euid we might have had).
13281fa4
LW		 3298 *
3299 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3300 * be defined in suidperl only. suidperl must be setuid root. The
3301 * Configure script will set this up for you if you want it.
3302 */
a687059c 3303
13281fa4 3304#ifdef DOSUID
6e72f9df 3305 char *s, *s2;
a0d0e21e 3306
b28d0864 3307 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3308 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
ae3f3efd 3309 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3310 I32 len;
2d8e6c8d 3311 STRLEN n_a;
13281fa4 3312
a687059c 3313#ifdef IAMSUID
ae3f3efd
PS		 3314 if (PL_fdscript < 0 || PL_suidscript != 1)
3315 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3316 /* PSz 11 Nov 03
3317 * Since the script is opened by perl, not suidperl, some of these
3318 * checks are superfluous. Leaving them in probably does not lower
3319 * security(?!).
3320 */
3321 /* PSz 27 Feb 04
3322 * Do checks even for systems with no HAS_SETREUID.
3323 * We used to swap, then re-swap UIDs with
3324#ifdef HAS_SETREUID
3325 if (setreuid(PL_euid,PL_uid) < 0
3326 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3327 Perl_croak(aTHX_ "Can't swap uid and euid");
3328#endif
3329#ifdef HAS_SETREUID
3330 if (setreuid(PL_uid,PL_euid) < 0
3331 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3332 Perl_croak(aTHX_ "Can't reswap uid and euid");
3333#endif
3334 */
3335
a687059c
LW		 3336 /* On this access check to make sure the directories are readable,
3337 * there is actually a small window that the user could use to make
3338 * filename point to an accessible directory. So there is a faint
3339 * chance that someone could execute a setuid script down in a
3340 * non-accessible directory. I don't know what to do about that.
3341 * But I don't think it's too important. The manual lies when
3342 * it says access() is useful in setuid programs.
ae3f3efd
PS		 3343 *
3344 * So, access() is pretty useless... but not harmful... do anyway.
a687059c 3345 */
e57400b1 3346 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
ae3f3efd 3347 Perl_croak(aTHX_ "Can't access() script\n");
e57400b1 3348 }
ae3f3efd 3349
a687059c
LW		 3350 /* If we can swap euid and uid, then we can determine access rights
3351 * with a simple stat of the file, and then compare device and
3352 * inode to make sure we did stat() on the same file we opened.
3353 * Then we just have to make sure he or she can execute it.
ae3f3efd
PS		 3354 *
3355 * PSz 24 Feb 04
3356 * As the script is opened by perl, not suidperl, we do not need to
3357 * care much about access rights.
3358 *
3359 * The 'script changed' check is needed, or we can get lied to
3360 * about $0 with e.g.
3361 * suidperl /dev/fd/4//bin/x 4<setuidscript
3362 * Without HAS_SETREUID, is it safe to stat() as root?
3363 *
3364 * Are there any operating systems that pass /dev/fd/xxx for setuid
3365 * scripts, as suggested/described in perlsec(1)? Surely they do not
3366 * pass the script name as we do, so the "script changed" test would
3367 * fail for them... but we never get here with
3368 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3369 *
3370 * This is one place where we must "lie" about return status: not
3371 * say if the stat() failed. We are doing this as root, and could
3372 * be tricked into reporting existence or not of files that the
3373 * "plain" user cannot even see.
a687059c
LW		 3374 */
3375 {
c623ac67 3376 Stat_t tmpstatbuf;
ae3f3efd
PS		 3377 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3378 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
b28d0864 3379 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
ae3f3efd 3380 Perl_croak(aTHX_ "Setuid script changed\n");
a687059c 3381 }
ae3f3efd 3382
a687059c 3383 }
ae3f3efd
PS		 3384 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3385 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3386
3387 /* PSz 27 Feb 04
3388 * We used to do this check as the "plain" user (after swapping
3389 * UIDs). But the check for nosuid and noexec filesystem is needed,
3390 * and should be done even without HAS_SETREUID. (Maybe those
3391 * operating systems do not have such mount options anyway...)
3392 * Seems safe enough to do as root.
3393 */
3394#if !defined(NO_NOSUID_CHECK)
3395 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3396 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3397 }
3398#endif
a687059c
LW		 3399#endif /* IAMSUID */
3400
e57400b1 3401 if (!S_ISREG(PL_statbuf.st_mode)) {
ae3f3efd 3402 Perl_croak(aTHX_ "Setuid script not plain file\n");
e57400b1 3403 }
b28d0864 3404 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3405 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3406 PL_doswitches = FALSE; /* -s is insecure in suid */
ae3f3efd 3407 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
57843af0 3408 CopLINE_inc(PL_curcop);
6b88bc9c 3409 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3410 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3411 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3412 s = SvPV(PL_linestr,n_a)+2;
ae3f3efd
PS		 3413 /* PSz 27 Feb 04 */
3414 /* Sanity check on line length */
3415 if (strlen(s) < 1 || strlen(s) > 4000)
3416 Perl_croak(aTHX_ "Very long #! line");
3417 /* Allow more than a single space after #! */
3418 while (isSPACE(*s)) s++;
3419 /* Sanity check on buffer end */
3420 while ((*s) && !isSPACE(*s)) s++;
2d8e6c8d 3421 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3422 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
ae3f3efd
PS		 3423 /* Sanity check on buffer start */
3424 if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
3425 (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
cea2e8a9 3426 Perl_croak(aTHX_ "Not a perl script");
a687059c 3427 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3428 /*
3429 * #! arg must be what we saw above. They can invoke it by
3430 * mentioning suidperl explicitly, but they may not add any strange
3431 * arguments beyond what #! says if they do invoke suidperl that way.
3432 */
ae3f3efd
PS		 3433 /*
3434 * The way validarg was set up, we rely on the kernel to start
3435 * scripts with argv[1] set to contain all #! line switches (the
3436 * whole line).
3437 */
3438 /*
3439 * Check that we got all the arguments listed in the #! line (not
3440 * just that there are no extraneous arguments). Might not matter
3441 * much, as switches from #! line seem to be acted upon (also), and
3442 * so may be checked and trapped in perl. But, security checks must
3443 * be done in suidperl and not deferred to perl. Note that suidperl
3444 * does not get around to parsing (and checking) the switches on
3445 * the #! line (but execs perl sooner).
3446 * Allow (require) a trailing newline (which may be of two
3447 * characters on some architectures?) (but no other trailing
3448 * whitespace).
3449 */
13281fa4
LW		 3450 len = strlen(validarg);
3451 if (strEQ(validarg," PHOOEY ") ||
ae3f3efd
PS		 3452 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3453 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
cea2e8a9 3454 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3455
3456#ifndef IAMSUID
ae3f3efd
PS		 3457 if (PL_fdscript < 0 &&
3458 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
b28d0864
NIS		 3459 PL_euid == PL_statbuf.st_uid)
3460 if (!PL_do_undump)
cea2e8a9 3461 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
11fb1898 3462FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
a687059c 3463#endif /* IAMSUID */
13281fa4 3464
ae3f3efd
PS		 3465 if (PL_fdscript < 0 &&
3466 PL_euid) { /* oops, we're not the setuid root perl */
3467 /* PSz 18 Feb 04
3468 * When root runs a setuid script, we do not go through the same
3469 * steps of execing sperl and then perl with fd scripts, but
3470 * simply set up UIDs within the same perl invocation; so do
3471 * not have the same checks (on options, whatever) that we have
3472 * for plain users. No problem really: would have to be a script
3473 * that does not actually work for plain users; and if root is
3474 * foolish and can be persuaded to run such an unsafe script, he
3475 * might run also non-setuid ones, and deserves what he gets.
3476 *
3477 * Or, we might drop the PL_euid check above (and rely just on
3478 * PL_fdscript to avoid loops), and do the execs
3479 * even for root.
3480 */
13281fa4 3481#ifndef IAMSUID
ae3f3efd
PS		 3482 int which;
3483 /* PSz 11 Nov 03
3484 * Pass fd script to suidperl.
3485 * Exec suidperl, substituting fd script for scriptname.
3486 * Pass script name as "subdir" of fd, which perl will grok;
3487 * in fact will use that to distinguish this from "normal"
3488 * usage, see comments above.
3489 */
3490 PerlIO_rewind(PL_rsfp);
3491 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3492 /* PSz 27 Feb 04 Sanity checks on scriptname */
3493 if ((!scriptname) || (!*scriptname) ) {
3494 Perl_croak(aTHX_ "No setuid script name\n");
3495 }
3496 if (*scriptname == '-') {
3497 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3498 /* Or we might confuse it with an option when replacing
3499 * name in argument list, below (though we do pointer, not
3500 * string, comparisons).
3501 */
3502 }
3503 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3504 if (!PL_origargv[which]) {
3505 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3506 }
3507 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3508 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3509#if defined(HAS_FCNTL) && defined(F_SETFD)
3510 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3511#endif
b35112e7 3512 PERL_FPU_PRE_EXEC
a7cb1f99 3513 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3514 (int)PERL_REVISION, (int)PERL_VERSION,
3515 (int)PERL_SUBVERSION), PL_origargv);
b35112e7 3516 PERL_FPU_POST_EXEC
ae3f3efd
PS		 3517#endif /* IAMSUID */
3518 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
13281fa4
LW		 3519 }
3520
b28d0864 3521 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
ae3f3efd
PS		 3522/* PSz 26 Feb 04
3523 * This seems back to front: we try HAS_SETEGID first; if not available
3524 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3525 * in the sense that we only want to set EGID; but are there any machines
3526 * with either of the latter, but not the former? Same with UID, later.
3527 */
fe14fcc3 3528#ifdef HAS_SETEGID
b28d0864 3529 (void)setegid(PL_statbuf.st_gid);
a687059c 3530#else
fe14fcc3 3531#ifdef HAS_SETREGID
b28d0864 3532 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3533#else
3534#ifdef HAS_SETRESGID
b28d0864 3535 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3536#else
b28d0864 3537 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3538#endif
3539#endif
85e6fe83 3540#endif
b28d0864 3541 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3542 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3543 }
b28d0864
NIS		 3544 if (PL_statbuf.st_mode & S_ISUID) {
3545 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3546#ifdef HAS_SETEUID
b28d0864 3547 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3548#else
fe14fcc3 3549#ifdef HAS_SETREUID
b28d0864 3550 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3551#else
3552#ifdef HAS_SETRESUID
b28d0864 3553 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3554#else
b28d0864 3555 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3556#endif
3557#endif
85e6fe83 3558#endif
b28d0864 3559 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3560 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 35