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