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