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