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