This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add facility to fork() early in perl_destruct and use the child to
[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);
431 if (PL_endav && !PL_minus_c)
432 call_list(PL_scopestack_ix, PL_endav);
433 JMPENV_POP;
26f423df 434 }
f3faeb53 435 LEAVE;
a0d0e21e
LW
436 FREETMPS;
437
e00b64d4 438 /* Need to flush since END blocks can produce output */
f13a2bc0 439 my_fflush_all();
e00b64d4 440
62375a60
NIS
441 if (CALL_FPTR(PL_threadhook)(aTHX)) {
442 /* Threads hook has vetoed further cleanup */
b47cad08 443 return STATUS_NATIVE_EXPORT;
62375a60
NIS
444 }
445
2aa47728
NC
446#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
447 if (destruct_level != 0) {
448 /* Fork here to create a child. Our child's job is to preserve the
449 state of scalars prior to destruction, so that we can instruct it
450 to dump any scalars that we later find have leaked.
451 There's no subtlety in this code - it assumes POSIX, and it doesn't
452 fail gracefully */
453 int fd[2];
454
455 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
456 perror("Debug leaking scalars socketpair failed");
457 abort();
458 }
459
460 child = fork();
461 if(child == -1) {
462 perror("Debug leaking scalars fork failed");
463 abort();
464 }
465 if (!child) {
466 /* We are the child */
467 close(fd[0]);
468 sock = fd[1];
469
470 while (1) {
471 SV *target;
472 ssize_t got = read(sock, &target, sizeof(target));
473
474 if(got == 0)
475 break;
476 if(got < 0) {
477 perror("Debug leaking scalars child read failed");
478 abort();
479 }
480 if(got < sizeof(target)) {
481 perror("Debug leaking scalars child short read");
482 abort();
483 }
484 sv_dump(target);
485 PerlIO_flush(Perl_debug_log);
486
487 /* Write something back as synchronisation. */
488 got = write(sock, &target, sizeof(target));
489
490 if(got < 0) {
491 perror("Debug leaking scalars child write failed");
492 abort();
493 }
494 if(got < sizeof(target)) {
495 perror("Debug leaking scalars child short write");
496 abort();
497 }
498 }
499 _exit(0);
500 }
501 sock = fd[0];
502 close(fd[1]);
503 }
504#endif
505
ff0cee69
PP
506 /* We must account for everything. */
507
508 /* Destroy the main CV and syntax tree */
3280af22 509 if (PL_main_root) {
4e380990
DM
510 /* ensure comppad/curpad to refer to main's pad */
511 if (CvPADLIST(PL_main_cv)) {
512 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
513 }
3280af22
NIS
514 op_free(PL_main_root);
515 PL_main_root = Nullop;
a0d0e21e 516 }
3280af22
NIS
517 PL_curcop = &PL_compiling;
518 PL_main_start = Nullop;
519 SvREFCNT_dec(PL_main_cv);
520 PL_main_cv = Nullcv;
24d3c518 521 PL_dirty = TRUE;
ff0cee69 522
13621cfb
NIS
523 /* Tell PerlIO we are about to tear things apart in case
524 we have layers which are using resources that should
525 be cleaned up now.
526 */
527
528 PerlIO_destruct(aTHX);
529
3280af22 530 if (PL_sv_objcount) {
a0d0e21e
LW
531 /*
532 * Try to destruct global references. We do this first so that the
533 * destructors and destructees still exist. Some sv's might remain.
534 * Non-referenced objects are on their own.
535 */
a0d0e21e 536 sv_clean_objs();
bf9cdc68 537 PL_sv_objcount = 0;
8990e307
LW
538 }
539
5cd24f17 540 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS
541 SvREFCNT_dec(PL_warnhook);
542 PL_warnhook = Nullsv;
543 SvREFCNT_dec(PL_diehook);
544 PL_diehook = Nullsv;
5cd24f17 545
4b556e6c 546 /* call exit list functions */
3280af22 547 while (PL_exitlistlen-- > 0)
acfe0abc 548 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 549
3280af22 550 Safefree(PL_exitlist);
4b556e6c 551
1c4916e5
CB
552 PL_exitlist = NULL;
553 PL_exitlistlen = 0;
554
a0d0e21e 555 if (destruct_level == 0){
8990e307 556
a0d0e21e 557 DEBUG_P(debprofdump());
ac27b0f5 558
56a2bab7
NIS
559#if defined(PERLIO_LAYERS)
560 /* No more IO - including error messages ! */
561 PerlIO_cleanup(aTHX);
562#endif
563
a0d0e21e 564 /* The exit() function will do everything that needs doing. */
b47cad08 565 return STATUS_NATIVE_EXPORT;
a0d0e21e 566 }
5dd60ef7 567
551a8b83 568 /* jettison our possibly duplicated environment */
4b647fb0
DM
569 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
570 * so we certainly shouldn't free it here
571 */
2f42fcb0 572#ifndef PERL_MICRO
4b647fb0 573#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
50acdf95 574 if (environ != PL_origenviron && !PL_use_safe_putenv
4efc5df6
GS
575#ifdef USE_ITHREADS
576 /* only main thread can free environ[0] contents */
577 && PL_curinterp == aTHX
578#endif
579 )
580 {
551a8b83
JH
581 I32 i;
582
583 for (i = 0; environ[i]; i++)
4b420006 584 safesysfree(environ[i]);
0631ea03 585
4b420006
JH
586 /* Must use safesysfree() when working with environ. */
587 safesysfree(environ);
551a8b83
JH
588
589 environ = PL_origenviron;
590 }
591#endif
2f42fcb0 592#endif /* !PERL_MICRO */
551a8b83 593
804ffa60
DM
594 /* reset so print() ends up where we expect */
595 setdefout(Nullgv);
596
5f8cb046
DM
597#ifdef USE_ITHREADS
598 /* the syntax tree is shared between clones
599 * so op_free(PL_main_root) only ReREFCNT_dec's
600 * REGEXPs in the parent interpreter
601 * we need to manually ReREFCNT_dec for the clones
602 */
603 {
604 I32 i = AvFILLp(PL_regex_padav) + 1;
605 SV **ary = AvARRAY(PL_regex_padav);
606
607 while (i) {
35061a7e 608 SV *resv = ary[--i];
35061a7e
DM
609
610 if (SvFLAGS(resv) & SVf_BREAK) {
577e12cc 611 /* this is PL_reg_curpm, already freed
35061a7e
DM
612 * flag is set in regexec.c:S_regtry
613 */
614 SvFLAGS(resv) &= ~SVf_BREAK;
3a1ee7e8 615 }
1cc8b4c5
AB
616 else if(SvREPADTMP(resv)) {
617 SvREPADTMP_off(resv);
618 }
a560f29b
NC
619 else if(SvIOKp(resv)) {
620 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
5f8cb046
DM
621 ReREFCNT_dec(re);
622 }
623 }
624 }
625 SvREFCNT_dec(PL_regex_padav);
626 PL_regex_padav = Nullav;
627 PL_regex_pad = NULL;
628#endif
629
081fc587
AB
630 SvREFCNT_dec((SV*) PL_stashcache);
631 PL_stashcache = NULL;
632
5f05dabc
PP
633 /* loosen bonds of global variables */
634
3280af22
NIS
635 if(PL_rsfp) {
636 (void)PerlIO_close(PL_rsfp);
637 PL_rsfp = Nullfp;
8ebc5c01
PP
638 }
639
640 /* Filters for program text */
3280af22
NIS
641 SvREFCNT_dec(PL_rsfp_filters);
642 PL_rsfp_filters = Nullav;
8ebc5c01
PP
643
644 /* switches */
3280af22
NIS
645 PL_preprocess = FALSE;
646 PL_minus_n = FALSE;
647 PL_minus_p = FALSE;
648 PL_minus_l = FALSE;
649 PL_minus_a = FALSE;
650 PL_minus_F = FALSE;
651 PL_doswitches = FALSE;
599cee73 652 PL_dowarn = G_WARN_OFF;
3280af22
NIS
653 PL_doextract = FALSE;
654 PL_sawampersand = FALSE; /* must save all match strings */
3280af22
NIS
655 PL_unsafe = FALSE;
656
657 Safefree(PL_inplace);
658 PL_inplace = Nullch;
a7cb1f99 659 SvREFCNT_dec(PL_patchlevel);
3280af22
NIS
660
661 if (PL_e_script) {
662 SvREFCNT_dec(PL_e_script);
663 PL_e_script = Nullsv;
8ebc5c01
PP
664 }
665
bf9cdc68
RG
666 PL_perldb = 0;
667
8ebc5c01
PP
668 /* magical thingies */
669
7889fe52
NIS
670 SvREFCNT_dec(PL_ofs_sv); /* $, */
671 PL_ofs_sv = Nullsv;
5f05dabc 672
7889fe52
NIS
673 SvREFCNT_dec(PL_ors_sv); /* $\ */
674 PL_ors_sv = Nullsv;
8ebc5c01 675
3280af22
NIS
676 SvREFCNT_dec(PL_rs); /* $/ */
677 PL_rs = Nullsv;
dc92893f 678
d33b2eba
GS
679 PL_multiline = 0; /* $* */
680 Safefree(PL_osname); /* $^O */
681 PL_osname = Nullch;
5f05dabc 682
3280af22
NIS
683 SvREFCNT_dec(PL_statname);
684 PL_statname = Nullsv;
685 PL_statgv = Nullgv;
5f05dabc 686
8ebc5c01
PP
687 /* defgv, aka *_ should be taken care of elsewhere */
688
8ebc5c01 689 /* clean up after study() */
3280af22
NIS
690 SvREFCNT_dec(PL_lastscream);
691 PL_lastscream = Nullsv;
692 Safefree(PL_screamfirst);
693 PL_screamfirst = 0;
694 Safefree(PL_screamnext);
695 PL_screamnext = 0;
8ebc5c01 696
7d5ea4e7
GS
697 /* float buffer */
698 Safefree(PL_efloatbuf);
699 PL_efloatbuf = Nullch;
700 PL_efloatsize = 0;
701
8ebc5c01 702 /* startup and shutdown function lists */
3280af22 703 SvREFCNT_dec(PL_beginav);
5a837c8f 704 SvREFCNT_dec(PL_beginav_save);
3280af22 705 SvREFCNT_dec(PL_endav);
7d30b5c4 706 SvREFCNT_dec(PL_checkav);
ece599bd 707 SvREFCNT_dec(PL_checkav_save);
3280af22
NIS
708 SvREFCNT_dec(PL_initav);
709 PL_beginav = Nullav;
5a837c8f 710 PL_beginav_save = Nullav;
3280af22 711 PL_endav = Nullav;
7d30b5c4 712 PL_checkav = Nullav;
ece599bd 713 PL_checkav_save = Nullav;
3280af22 714 PL_initav = Nullav;
5618dfe8 715
8ebc5c01 716 /* shortcuts just get cleared */
3280af22 717 PL_envgv = Nullgv;
3280af22
NIS
718 PL_incgv = Nullgv;
719 PL_hintgv = Nullgv;
720 PL_errgv = Nullgv;
721 PL_argvgv = Nullgv;
722 PL_argvoutgv = Nullgv;
723 PL_stdingv = Nullgv;
bf49b057 724 PL_stderrgv = Nullgv;
3280af22
NIS
725 PL_last_in_gv = Nullgv;
726 PL_replgv = Nullgv;
bf9cdc68
RG
727 PL_DBgv = Nullgv;
728 PL_DBline = Nullgv;
729 PL_DBsub = Nullgv;
730 PL_DBsingle = Nullsv;
731 PL_DBtrace = Nullsv;
732 PL_DBsignal = Nullsv;
733 PL_DBassertion = Nullsv;
734 PL_DBcv = Nullcv;
735 PL_dbargs = Nullav;
5c831c24 736 PL_debstash = Nullhv;
8ebc5c01 737
7a1c5554
GS
738 SvREFCNT_dec(PL_argvout_stack);
739 PL_argvout_stack = Nullav;
8ebc5c01 740
5c831c24
GS
741 SvREFCNT_dec(PL_modglobal);
742 PL_modglobal = Nullhv;
743 SvREFCNT_dec(PL_preambleav);
744 PL_preambleav = Nullav;
745 SvREFCNT_dec(PL_subname);
746 PL_subname = Nullsv;
747 SvREFCNT_dec(PL_linestr);
748 PL_linestr = Nullsv;
749 SvREFCNT_dec(PL_pidstatus);
750 PL_pidstatus = Nullhv;
751 SvREFCNT_dec(PL_toptarget);
752 PL_toptarget = Nullsv;
753 SvREFCNT_dec(PL_bodytarget);
754 PL_bodytarget = Nullsv;
755 PL_formtarget = Nullsv;
756
d33b2eba 757 /* free locale stuff */
b9582b6a 758#ifdef USE_LOCALE_COLLATE
d33b2eba
GS
759 Safefree(PL_collation_name);
760 PL_collation_name = Nullch;
b9582b6a 761#endif
d33b2eba 762
b9582b6a 763#ifdef USE_LOCALE_NUMERIC
d33b2eba
GS
764 Safefree(PL_numeric_name);
765 PL_numeric_name = Nullch;
a453c169 766 SvREFCNT_dec(PL_numeric_radix_sv);
bf9cdc68 767 PL_numeric_radix_sv = Nullsv;
b9582b6a 768#endif
d33b2eba 769
5c831c24
GS
770 /* clear utf8 character classes */
771 SvREFCNT_dec(PL_utf8_alnum);
772 SvREFCNT_dec(PL_utf8_alnumc);
773 SvREFCNT_dec(PL_utf8_ascii);
774 SvREFCNT_dec(PL_utf8_alpha);
775 SvREFCNT_dec(PL_utf8_space);
776 SvREFCNT_dec(PL_utf8_cntrl);
777 SvREFCNT_dec(PL_utf8_graph);
778 SvREFCNT_dec(PL_utf8_digit);
779 SvREFCNT_dec(PL_utf8_upper);
780 SvREFCNT_dec(PL_utf8_lower);
781 SvREFCNT_dec(PL_utf8_print);
782 SvREFCNT_dec(PL_utf8_punct);
783 SvREFCNT_dec(PL_utf8_xdigit);
784 SvREFCNT_dec(PL_utf8_mark);
785 SvREFCNT_dec(PL_utf8_toupper);
4dbdbdc2 786 SvREFCNT_dec(PL_utf8_totitle);
5c831c24 787 SvREFCNT_dec(PL_utf8_tolower);
b4e400f9 788 SvREFCNT_dec(PL_utf8_tofold);
82686b01
JH
789 SvREFCNT_dec(PL_utf8_idstart);
790 SvREFCNT_dec(PL_utf8_idcont);
5c831c24
GS
791 PL_utf8_alnum = Nullsv;
792 PL_utf8_alnumc = Nullsv;
793 PL_utf8_ascii = Nullsv;
794 PL_utf8_alpha = Nullsv;
795 PL_utf8_space = Nullsv;
796 PL_utf8_cntrl = Nullsv;
797 PL_utf8_graph = Nullsv;
798 PL_utf8_digit = Nullsv;
799 PL_utf8_upper = Nullsv;
800 PL_utf8_lower = Nullsv;
801 PL_utf8_print = Nullsv;
802 PL_utf8_punct = Nullsv;
803 PL_utf8_xdigit = Nullsv;
804 PL_utf8_mark = Nullsv;
805 PL_utf8_toupper = Nullsv;
806 PL_utf8_totitle = Nullsv;
807 PL_utf8_tolower = Nullsv;
b4e400f9 808 PL_utf8_tofold = Nullsv;
82686b01
JH
809 PL_utf8_idstart = Nullsv;
810 PL_utf8_idcont = Nullsv;
5c831c24 811
971a9dd3
GS
812 if (!specialWARN(PL_compiling.cop_warnings))
813 SvREFCNT_dec(PL_compiling.cop_warnings);
5c831c24 814 PL_compiling.cop_warnings = Nullsv;
ac27b0f5
NIS
815 if (!specialCopIO(PL_compiling.cop_io))
816 SvREFCNT_dec(PL_compiling.cop_io);
817 PL_compiling.cop_io = Nullsv;
05ec9bb3
NIS
818 CopFILE_free(&PL_compiling);
819 CopSTASH_free(&PL_compiling);
5c831c24 820
a0d0e21e 821 /* Prepare to destruct main symbol table. */
5f05dabc 822
3280af22
NIS
823 hv = PL_defstash;
824 PL_defstash = 0;
a0d0e21e 825 SvREFCNT_dec(hv);
5c831c24
GS
826 SvREFCNT_dec(PL_curstname);
827 PL_curstname = Nullsv;
a0d0e21e 828
5a844595
GS
829 /* clear queued errors */
830 SvREFCNT_dec(PL_errors);
831 PL_errors = Nullsv;
832
a0d0e21e 833 FREETMPS;
0453d815 834 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
3280af22 835 if (PL_scopestack_ix != 0)
9014280d 836 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 837 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
3280af22
NIS
838 (long)PL_scopestack_ix);
839 if (PL_savestack_ix != 0)
9014280d 840 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 841 "Unbalanced saves: %ld more saves than restores\n",
3280af22
NIS
842 (long)PL_savestack_ix);
843 if (PL_tmps_floor != -1)
9014280d 844 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
3280af22 845 (long)PL_tmps_floor + 1);
a0d0e21e 846 if (cxstack_ix != -1)
9014280d 847 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
ff0cee69 848 (long)cxstack_ix + 1);
a0d0e21e 849 }
8990e307
LW
850
851 /* Now absolutely destruct everything, somehow or other, loops or no. */
d33b2eba 852 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
3280af22 853 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
5226ed68
JH
854
855 /* the 2 is for PL_fdpid and PL_strtab */
856 while (PL_sv_count > 2 && sv_clean_all())
857 ;
858
d33b2eba
GS
859 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
860 SvFLAGS(PL_fdpid) |= SVt_PVAV;
3280af22
NIS
861 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
862 SvFLAGS(PL_strtab) |= SVt_PVHV;
d33b2eba 863
d4777f27
GS
864 AvREAL_off(PL_fdpid); /* no surviving entries */
865 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
d33b2eba
GS
866 PL_fdpid = Nullav;
867
6c644e78
GS
868#ifdef HAVE_INTERP_INTERN
869 sys_intern_clear();
870#endif
871
6e72f9df
PP
872 /* Destruct the global string table. */
873 {
874 /* Yell and reset the HeVAL() slots that are still holding refcounts,
875 * so that sv_free() won't fail on them.
80459961
NC
876 * Now that the global string table is using a single hunk of memory
877 * for both HE and HEK, we either need to explicitly unshare it the
878 * correct way, or actually free things here.
6e72f9df 879 */
80459961
NC
880 I32 riter = 0;
881 const I32 max = HvMAX(PL_strtab);
882 HE **array = HvARRAY(PL_strtab);
883 HE *hent = array[0];
884
6e72f9df 885 for (;;) {
0453d815 886 if (hent && ckWARN_d(WARN_INTERNAL)) {
80459961 887 HE *next = HeNEXT(hent);
9014280d 888 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 889 "Unbalanced string table refcount: (%d) for \"%s\"",
6e72f9df 890 HeVAL(hent) - Nullsv, HeKEY(hent));
80459961
NC
891 Safefree(hent);
892 hent = next;
6e72f9df
PP
893 }
894 if (!hent) {
895 if (++riter > max)
896 break;
897 hent = array[riter];
898 }
899 }
80459961
NC
900
901 Safefree(array);
902 HvARRAY(PL_strtab) = 0;
903 HvTOTALKEYS(PL_strtab) = 0;
904 HvFILL(PL_strtab) = 0;
6e72f9df 905 }
3280af22 906 SvREFCNT_dec(PL_strtab);
6e72f9df 907
e652bb2f 908#ifdef USE_ITHREADS
c21d1a0f 909 /* free the pointer tables used for cloning */
a0739874 910 ptr_table_free(PL_ptr_table);
bf9cdc68 911 PL_ptr_table = (PTR_TBL_t*)NULL;
53186e96 912#endif
a0739874 913
d33b2eba
GS
914 /* free special SVs */
915
916 SvREFCNT(&PL_sv_yes) = 0;
917 sv_clear(&PL_sv_yes);
918 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 919 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS
920
921 SvREFCNT(&PL_sv_no) = 0;
922 sv_clear(&PL_sv_no);
923 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 924 SvFLAGS(&PL_sv_no) = 0;
01724ea0 925
9f375a43
DM
926 {
927 int i;
928 for (i=0; i<=2; i++) {
929 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
930 sv_clear(PERL_DEBUG_PAD(i));
931 SvANY(PERL_DEBUG_PAD(i)) = NULL;
932 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
933 }
934 }
935
0453d815 936 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
9014280d 937 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 938
eba0f806
DM
939#ifdef DEBUG_LEAKING_SCALARS
940 if (PL_sv_count != 0) {
941 SV* sva;
942 SV* sv;
943 register SV* svend;
944
945 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
946 svend = &sva[SvREFCNT(sva)];
947 for (sv = sva + 1; sv < svend; ++sv) {
948 if (SvTYPE(sv) != SVTYPEMASK) {
2aa47728
NC
949#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
950 ssize_t got;
951 SV *target;
952#endif
953
a548cda8 954 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
61b61456 955 " flags=0x%"UVxf
fd0854ff
DM
956 " refcnt=%"UVuf pTHX__FORMAT "\n"
957 "\tallocated at %s:%d %s %s%s\n",
958 sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
959 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
960 sv->sv_debug_line,
961 sv->sv_debug_inpad ? "for" : "by",
962 sv->sv_debug_optype ?
963 PL_op_name[sv->sv_debug_optype]: "(none)",
964 sv->sv_debug_cloned ? " (cloned)" : ""
965 );
2aa47728
NC
966
967#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
968 PerlIO_flush(Perl_debug_log);
969
970 got = write(sock, &sv, sizeof(sv));
971
972 if(got < 0) {
973 perror("Debug leaking scalars parent write failed");
974 abort();
975 }
976 if(got < sizeof(target)) {
977 perror("Debug leaking scalars parent short write");
978 abort();
979 }
980
981 got = read(sock, &target, sizeof(target));
982
983 if(got < 0) {
984 perror("Debug leaking scalars parent read failed");
985 abort();
986 }
987 if(got < sizeof(target)) {
988 perror("Debug leaking scalars parent short read");
989 abort();
990 }
991#endif
eba0f806
DM
992 }
993 }
994 }
995 }
2aa47728
NC
996#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
997 {
998 int status;
999 fd_set rset;
1000 /* Wait for up to 4 seconds for child to terminate.
1001 This seems to be the least effort way of timing out on reaping
1002 its exit status. */
1003 struct timeval waitfor = {4, 0};
1004
1005 shutdown(sock, 1);
1006 FD_ZERO(&rset);
1007 FD_SET(sock, &rset);
1008 select(sock + 1, &rset, NULL, NULL, &waitfor);
1009 waitpid(child, &status, WNOHANG);
1010 close(sock);
1011 }
1012#endif
eba0f806 1013#endif
bf9cdc68 1014 PL_sv_count = 0;
eba0f806
DM
1015
1016
56a2bab7 1017#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS
1018 /* No more IO - including error messages ! */
1019 PerlIO_cleanup(aTHX);
1020#endif
1021
9f4bd222
NIS
1022 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1023 as currently layers use it rather than Nullsv as a marker
1024 for no arg - and will try and SvREFCNT_dec it.
1025 */
1026 SvREFCNT(&PL_sv_undef) = 0;
1027 SvREADONLY_off(&PL_sv_undef);
1028
3280af22 1029 Safefree(PL_origfilename);
bf9cdc68 1030 PL_origfilename = Nullch;
3280af22 1031 Safefree(PL_reg_start_tmp);
bf9cdc68
RG
1032 PL_reg_start_tmp = (char**)NULL;
1033 PL_reg_start_tmpl = 0;
5c5e4c24
IZ
1034 if (PL_reg_curpm)
1035 Safefree(PL_reg_curpm);
82ba1be6 1036 Safefree(PL_reg_poscache);
dd28f7bb 1037 free_tied_hv_pool();
3280af22 1038 Safefree(PL_op_mask);
cf36064f 1039 Safefree(PL_psig_ptr);
bf9cdc68 1040 PL_psig_ptr = (SV**)NULL;
cf36064f 1041 Safefree(PL_psig_name);
bf9cdc68 1042 PL_psig_name = (SV**)NULL;
2c2666fc 1043 Safefree(PL_bitcount);
bf9cdc68 1044 PL_bitcount = Nullch;
ce08f86c 1045 Safefree(PL_psig_pend);
bf9cdc68
RG
1046 PL_psig_pend = (int*)NULL;
1047 PL_formfeed = Nullsv;
6e72f9df 1048 nuke_stacks();
bf9cdc68
RG
1049 PL_tainting = FALSE;
1050 PL_taint_warn = FALSE;
3280af22 1051 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
bf9cdc68 1052 PL_debug = 0;
ac27b0f5 1053
a0d0e21e 1054 DEBUG_P(debprofdump());
d33b2eba 1055
e5dd39fc 1056#ifdef USE_REENTRANT_API
10bc17b6 1057 Perl_reentrant_free(aTHX);
e5dd39fc
AB
1058#endif
1059
612f20c3
GS
1060 sv_free_arenas();
1061
fc36a67e
PP
1062 /* As the absolutely last thing, free the non-arena SV for mess() */
1063
3280af22 1064 if (PL_mess_sv) {
f350b448
NC
1065 /* we know that type == SVt_PVMG */
1066
9c63abab 1067 /* it could have accumulated taint magic */
f350b448
NC
1068 MAGIC* mg;
1069 MAGIC* moremagic;
1070 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1071 moremagic = mg->mg_moremagic;
1072 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1073 && mg->mg_len >= 0)
1074 Safefree(mg->mg_ptr);
1075 Safefree(mg);
9c63abab 1076 }
f350b448 1077
fc36a67e 1078 /* we know that type >= SVt_PV */
8bd4d4c5 1079 SvPV_free(PL_mess_sv);
3280af22
NIS
1080 Safefree(SvANY(PL_mess_sv));
1081 Safefree(PL_mess_sv);
1082 PL_mess_sv = Nullsv;
fc36a67e 1083 }
31d77e54 1084 return STATUS_NATIVE_EXPORT;
79072805
LW
1085}
1086
954c1994
GS
1087/*
1088=for apidoc perl_free
1089
1090Releases a Perl interpreter. See L<perlembed>.
1091
1092=cut
1093*/
1094
79072805 1095void
0cb96387 1096perl_free(pTHXx)
79072805 1097{
acfe0abc 1098#if defined(WIN32) || defined(NETWARE)
ce3e5b80 1099# if defined(PERL_IMPLICIT_SYS)
acfe0abc
GS
1100# ifdef NETWARE
1101 void *host = nw_internal_host;
1102# else
1103 void *host = w32_internal_host;
1104# endif
ce3e5b80 1105 PerlMem_free(aTHXx);
acfe0abc 1106# ifdef NETWARE
011f1a1a 1107 nw_delete_internal_host(host);
acfe0abc
GS
1108# else
1109 win32_delete_internal_host(host);
1110# endif
1c0ca838
GS
1111# else
1112 PerlMem_free(aTHXx);
1113# endif
acfe0abc
GS
1114#else
1115 PerlMem_free(aTHXx);
76e3520e 1116#endif
79072805
LW
1117}
1118
aebd1ac7
GA
1119#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
1120/* provide destructors to clean up the thread key when libperl is unloaded */
1121#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1122
110d3f98 1123#if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
aebd1ac7
GA
1124#pragma fini "perl_fini"
1125#endif
1126
0dbb1585
AL
1127static void
1128#if defined(__GNUC__)
1129__attribute__((destructor))
aebd1ac7 1130#endif
de009b76 1131perl_fini(void)
aebd1ac7 1132{
27da23d5 1133 dVAR;
aebd1ac7
GA
1134 if (PL_curinterp)
1135 FREE_THREAD_KEY;
1136}
1137
1138#endif /* WIN32 */
1139#endif /* THREADS */
1140
4b556e6c 1141void
864dbfa3 1142Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 1143{
3280af22
NIS
1144 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1145 PL_exitlist[PL_exitlistlen].fn = fn;
1146 PL_exitlist[PL_exitlistlen].ptr = ptr;
1147 ++PL_exitlistlen;
4b556e6c
JD
1148}
1149
56cf6df8
RGS
1150#ifdef HAS_PROCSELFEXE
1151/* This is a function so that we don't hold on to MAXPATHLEN
1152 bytes of stack longer than necessary
1153 */
1154STATIC void
e1ec3a88 1155S_procself_val(pTHX_ SV *sv, const char *arg0)
56cf6df8
RGS
1156{
1157 char buf[MAXPATHLEN];
1158 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1159
1160 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1161 includes a spurious NUL which will cause $^X to fail in system
1162 or backticks (this will prevent extensions from being built and
1163 many tests from working). readlink is not meant to add a NUL.
1164 Normal readlink works fine.
1165 */
1166 if (len > 0 && buf[len-1] == '\0') {
1167 len--;
1168 }
1169
1170 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1171 returning the text "unknown" from the readlink rather than the path
1172 to the executable (or returning an error from the readlink). Any valid
1173 path has a '/' in it somewhere, so use that to validate the result.
1174 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1175 */
1176 if (len > 0 && memchr(buf, '/', len)) {
1177 sv_setpvn(sv,buf,len);
1178 }
1179 else {
1180 sv_setpv(sv,arg0);
1181 }
1182}
1183#endif /* HAS_PROCSELFEXE */
b7975bdd
NC
1184
1185STATIC void
1186S_set_caret_X(pTHX) {
1187 GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
1188 if (tmpgv) {
1189#ifdef HAS_PROCSELFEXE
1190 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1191#else
1192#ifdef OS2
1193 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
1194#else
1195 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
1196#endif
1197#endif
1198 }
1199}
1200
954c1994
GS
1201/*
1202=for apidoc perl_parse
1203
1204Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1205
1206=cut
1207*/
1208
79072805 1209int
0cb96387 1210perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 1211{
27da23d5 1212 dVAR;
6224f72b 1213 I32 oldscope;
6224f72b 1214 int ret;
db36c5a1 1215 dJMPENV;
8d063cd8 1216
a687059c
LW
1217#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1218#ifdef IAMSUID
1219#undef IAMSUID
cea2e8a9 1220 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c 1221setuid perl scripts securely.\n");
ae3f3efd 1222#endif /* IAMSUID */
a687059c
LW
1223#endif
1224
b0891165
JH
1225#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1226 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
103dd899 1227 * This MUST be done before any hash stores or fetches take place.
008fb0c0
NC
1228 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1229 * yourself, it is your responsibility to provide a good random seed!
830b38bd 1230 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
008fb0c0
NC
1231 if (!PL_rehash_seed_set)
1232 PL_rehash_seed = get_hash_seed();
b0891165 1233 {
bed60192
JH
1234 char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1235
1236 if (s) {
1237 int i = atoi(s);
1238
1239 if (i == 1)
1240 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
008fb0c0 1241 PL_rehash_seed);
bed60192 1242 }
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;
7d8e7db3
JH
1259 UV mask =
1260 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
43c32782
JH
1261 /* Do the mask check only if the args seem like aligned. */
1262 UV aligned =
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
3581 */
3582
a687059c
LW
3583 /* On this access check to make sure the directories are readable,
3584 * there is actually a small window that the user could use to make
3585 * filename point to an a