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