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