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