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