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