This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[perl #119811] Remove %DB::lsub
[perl5.git] / perl.c
CommitLineData
4b88f280 1#line 2 "perl.c"
a0d0e21e
LW		 2/* perl.c
3 *
737f4459 4 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
2eee27d7 5 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
010d7370 6 * by Larry Wall and others
a687059c 7 *
352d5a3a
LW		 8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
a687059c 10 *
8d063cd8
LW		 11 */
12
a0d0e21e 13/*
4ac71550
TC		 14 * A ship then new they built for him
15 * of mithril and of elven-glass
cdad3b53 16 * --from Bilbo's song of Eärendil
4ac71550
TC		 17 *
18 * [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
a0d0e21e 19 */
45d8adaa 20
166f8a29
DM		 21/* This file contains the top-level functions that are used to create, use
22 * and destroy a perl interpreter, plus the functions used by XS code to
23 * call back into perl. Note that it does not contain the actual main()
ddfa107c 24 * function of the interpreter; that can be found in perlmain.c
166f8a29
DM		 25 */
26
c44493f1 27#if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
43c0c913
NC		 28# define USE_SITECUSTOMIZE
29#endif
30
378cc40b 31#include "EXTERN.h"
864dbfa3 32#define PERL_IN_PERL_C
378cc40b 33#include "perl.h"
e3321bb0 34#include "patchlevel.h" /* for local_patches */
4a5df386 35#include "XSUB.h"
378cc40b 36
011f1a1a
JH		 37#ifdef NETWARE
38#include "nwutil.h"
011f1a1a
JH		 39#endif
40
2982a345
NC		 41#ifdef USE_KERN_PROC_PATHNAME
42# include <sys/sysctl.h>
43#endif
44
ae60cb46
NC		 45#ifdef USE_NSGETEXECUTABLEPATH
46# include <mach-o/dyld.h>
47#endif
48
2aa47728 49#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
bf357333
NC		 50# ifdef I_SYSUIO
51# include <sys/uio.h>
52# endif
53
54union control_un {
55 struct cmsghdr cm;
56 char control[CMSG_SPACE(sizeof(int))];
57};
58
2aa47728
NC		 59#endif
60
5311654c
JH		 61#ifndef HZ
62# ifdef CLK_TCK
63# define HZ CLK_TCK
64# else
65# define HZ 60
66# endif
67#endif
68
7114a2d2 69#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
20ce7b12 70char *getenv (char *); /* Usually in <stdlib.h> */
54310121 71#endif
72
acfe0abc 73static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
0cb96387 74
cc69b689 75#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
b24bc095 76# define validate_suid(rsfp) NOOP
cc69b689 77#else
b24bc095 78# define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
a687059c 79#endif
8d063cd8 80
d6f07c05
AL		 81#define CALL_BODY_SUB(myop) \
82 if (PL_op == (myop)) \
139d0ce6 83 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
d6f07c05
AL		 84 if (PL_op) \
85 CALLRUNOPS(aTHX);
86
87#define CALL_LIST_BODY(cv) \
88 PUSHMARK(PL_stack_sp); \
9a8aa25b 89 call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
d6f07c05 90
e6827a76 91static void
daa7d858 92S_init_tls_and_interp(PerlInterpreter *my_perl)
e6827a76 93{
27da23d5 94 dVAR;
e6827a76
NC		 95 if (!PL_curinterp) {
96 PERL_SET_INTERP(my_perl);
3db8f154 97#if defined(USE_ITHREADS)
e6827a76
NC		 98 INIT_THREADS;
99 ALLOC_THREAD_KEY;
100 PERL_SET_THX(my_perl);
101 OP_REFCNT_INIT;
e8570548 102 OP_CHECK_MUTEX_INIT;
71ad1b0c 103 HINTS_REFCNT_INIT;
e6827a76 104 MUTEX_INIT(&PL_dollarzero_mutex);
016af4f1
DM		 105 MUTEX_INIT(&PL_my_ctx_mutex);
106# endif
e6827a76 107 }
c0bce9aa
NC		 108#if defined(USE_ITHREADS)
109 else
110#else
111 /* This always happens for non-ithreads */
112#endif
113 {
e6827a76
NC		 114 PERL_SET_THX(my_perl);
115 }
116}
06d86050 117
cbec8ebe
DM		 118
119/* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
120
121void
122Perl_sys_init(int* argc, char*** argv)
123{
4fc0badb 124 dVAR;
7918f24d
NC		 125
126 PERL_ARGS_ASSERT_SYS_INIT;
127
cbec8ebe
DM		 128 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
129 PERL_UNUSED_ARG(argv);
130 PERL_SYS_INIT_BODY(argc, argv);
131}
132
133void
134Perl_sys_init3(int* argc, char*** argv, char*** env)
135{
4fc0badb 136 dVAR;
7918f24d
NC		 137
138 PERL_ARGS_ASSERT_SYS_INIT3;
139
cbec8ebe
DM		 140 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
141 PERL_UNUSED_ARG(argv);
142 PERL_UNUSED_ARG(env);
143 PERL_SYS_INIT3_BODY(argc, argv, env);
144}
145
146void
d0820ef1 147Perl_sys_term()
cbec8ebe 148{
4fc0badb 149 dVAR;
bf81751b
DM		 150 if (!PL_veto_cleanup) {
151 PERL_SYS_TERM_BODY();
152 }
cbec8ebe
DM		 153}
154
155
32e30700
GS		 156#ifdef PERL_IMPLICIT_SYS
157PerlInterpreter *
7766f137
GS		 158perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
159 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
32e30700
GS		 160 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
161 struct IPerlDir* ipD, struct IPerlSock* ipS,
162 struct IPerlProc* ipP)
163{
164 PerlInterpreter *my_perl;
7918f24d
NC		 165
166 PERL_ARGS_ASSERT_PERL_ALLOC_USING;
167
9f653bb5 168 /* Newx() needs interpreter, so call malloc() instead */
32e30700 169 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
e6827a76 170 S_init_tls_and_interp(my_perl);
32e30700
GS		 171 Zero(my_perl, 1, PerlInterpreter);
172 PL_Mem = ipM;
7766f137
GS		 173 PL_MemShared = ipMS;
174 PL_MemParse = ipMP;
32e30700
GS		 175 PL_Env = ipE;
176 PL_StdIO = ipStd;
177 PL_LIO = ipLIO;
178 PL_Dir = ipD;
179 PL_Sock = ipS;
180 PL_Proc = ipP;
7cb608b5 181 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
7766f137 182
32e30700
GS		 183 return my_perl;
184}
185#else
954c1994
GS		 186
187/*
ccfc67b7
JH		 188=head1 Embedding Functions
189
954c1994
GS		 190=for apidoc perl_alloc
191
192Allocates a new Perl interpreter. See L<perlembed>.
193
194=cut
195*/
196
93a17b20 197PerlInterpreter *
cea2e8a9 198perl_alloc(void)
79072805 199{
cea2e8a9 200 PerlInterpreter *my_perl;
79072805 201
9f653bb5 202 /* Newx() needs interpreter, so call malloc() instead */
e8ee3774 203 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 204
e6827a76 205 S_init_tls_and_interp(my_perl);
7cb608b5 206#ifndef PERL_TRACK_MEMPOOL
07409e01 207 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
7cb608b5
NC		 208#else
209 Zero(my_perl, 1, PerlInterpreter);
210 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
211 return my_perl;
212#endif
79072805 213}
32e30700 214#endif /* PERL_IMPLICIT_SYS */
79072805 215
954c1994
GS		 216/*
217=for apidoc perl_construct
218
219Initializes a new Perl interpreter. See L<perlembed>.
220
221=cut
222*/
223
79072805 224void
0cb96387 225perl_construct(pTHXx)
79072805 226{
27da23d5 227 dVAR;
7918f24d
NC		 228
229 PERL_ARGS_ASSERT_PERL_CONSTRUCT;
230
8990e307 231#ifdef MULTIPLICITY
54aff467 232 init_interp();
ac27b0f5 233 PL_perl_destruct_level = 1;
54aff467 234#else
7918f24d 235 PERL_UNUSED_ARG(my_perl);
54aff467
GS		 236 if (PL_perl_destruct_level > 0)
237 init_interp();
238#endif
34caed6d
DM		 239 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
240
75d476e2
S		 241#ifdef PERL_TRACE_OPS
242 Zero(PL_op_exec_cnt, OP_max+2, UV);
243#endif
244
0d96b528 245 init_constants();
34caed6d
DM		 246
247 SvREADONLY_on(&PL_sv_placeholder);
fe54beba 248 SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
34caed6d
DM		 249
250 PL_sighandlerp = (Sighandler_t) Perl_sighandler;
ca0c25f6 251#ifdef PERL_USES_PL_PIDSTATUS
34caed6d 252 PL_pidstatus = newHV();
ca0c25f6 253#endif
79072805 254
396482e1 255 PL_rs = newSVpvs("\n");
dc92893f 256
cea2e8a9 257 init_stacks();
79072805 258
748a9306 259 init_ids();
a5f75d66 260
312caa8e 261 JMPENV_BOOTSTRAP;
f86702cc 262 STATUS_ALL_SUCCESS;
263
0672f40e 264 init_i18nl10n(1);
36477c24 265 SET_NUMERIC_STANDARD();
0b5b802d 266
ab821d7f 267#if defined(LOCAL_PATCH_COUNT)
3280af22 268 PL_localpatches = local_patches; /* For possible -v */
ab821d7f 269#endif
270
52853b95
GS		 271#ifdef HAVE_INTERP_INTERN
272 sys_intern_init();
273#endif
274
3a1ee7e8 275 PerlIO_init(aTHX); /* Hook to IO system */
760ac839 276
3280af22
NIS		 277 PL_fdpid = newAV(); /* for remembering popen pids by fd */
278 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
396482e1 279 PL_errors = newSVpvs("");
76f68e9b
MHM		 280 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
281 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
282 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
1fcf4c12 283#ifdef USE_ITHREADS
402d2eb1
NC		 284 /* First entry is a list of empty elements. It needs to be initialised
285 else all hell breaks loose in S_find_uninit_var(). */
286 Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
13137afc 287 PL_regex_pad = AvARRAY(PL_regex_padav);
d4d03940 288 Newxz(PL_stashpad, PL_stashpadmax, HV *);
1fcf4c12 289#endif
e5dd39fc 290#ifdef USE_REENTRANT_API
59bd0823 291 Perl_reentrant_init(aTHX);
e5dd39fc 292#endif
7dc86639
YO		 293#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
294 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
295 * This MUST be done before any hash stores or fetches take place.
296 * If you set PL_hash_seed (and presumably also PL_hash_seed_set)
297 * yourself, it is your responsibility to provide a good random seed!
298 * You can also define PERL_HASH_SEED in compile time, see hv.h.
299 *
300 * XXX: fix this comment */
301 if (PL_hash_seed_set == FALSE) {
302 Perl_get_hash_seed(aTHX_ PL_hash_seed);
303 PL_hash_seed_set= TRUE;
304 }
305#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
3d47000e
AB		 306
307 /* Note that strtab is a rather special HV. Assumptions are made
308 about not iterating on it, and not adding tie magic to it.
309 It is properly deallocated in perl_destruct() */
310 PL_strtab = newHV();
311
3d47000e
AB		 312 HvSHAREKEYS_off(PL_strtab); /* mandatory */
313 hv_ksplit(PL_strtab, 512);
314
a38ab475
RZ		 315 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
316
0631ea03
AB		 317#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
318 _dyld_lookup_and_bind
319 ("__environ", (unsigned long *) &environ_pointer, NULL);
320#endif /* environ */
321
2f42fcb0
JH		 322#ifndef PERL_MICRO
323# ifdef USE_ENVIRON_ARRAY
0631ea03 324 PL_origenviron = environ;
2f42fcb0 325# endif
0631ea03
AB		 326#endif
327
5311654c 328 /* Use sysconf(_SC_CLK_TCK) if available, if not
dbc1d986 329 * available or if the sysconf() fails, use the HZ.
27da23d5
JH		 330 * The HZ if not originally defined has been by now
331 * been defined as CLK_TCK, if available. */
b6c36746 332#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
5311654c
JH		 333 PL_clocktick = sysconf(_SC_CLK_TCK);
334 if (PL_clocktick <= 0)
335#endif
336 PL_clocktick = HZ;
337
081fc587
AB		 338 PL_stashcache = newHV();
339
e8e3635e 340 PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
1e8125c6 341 PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING);
d7aa5382 342
27da23d5
JH		 343#ifdef HAS_MMAP
344 if (!PL_mmap_page_size) {
345#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
346 {
347 SETERRNO(0, SS_NORMAL);
348# ifdef _SC_PAGESIZE
349 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
350# else
351 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
352# endif
353 if ((long) PL_mmap_page_size < 0) {
354 if (errno) {
44f8325f 355 SV * const error = ERRSV;
d4c19fe8 356 SvUPGRADE(error, SVt_PV);
0510663f 357 Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
27da23d5
JH		 358 }
359 else
360 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
361 }
362 }
363#else
364# ifdef HAS_GETPAGESIZE
365 PL_mmap_page_size = getpagesize();
366# else
367# if defined(I_SYS_PARAM) && defined(PAGESIZE)
368 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
369# endif
370# endif
371#endif
372 if (PL_mmap_page_size <= 0)
373 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
374 (IV) PL_mmap_page_size);
375 }
376#endif /* HAS_MMAP */
377
378#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
379 PL_timesbase.tms_utime = 0;
380 PL_timesbase.tms_stime = 0;
381 PL_timesbase.tms_cutime = 0;
382 PL_timesbase.tms_cstime = 0;
383#endif
384
7d113631
NC		 385 PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
386
a3e6e81e 387 PL_registered_mros = newHV();
9e169432
NC		 388 /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
389 HvMAX(PL_registered_mros) = 0;
a3e6e81e 390
8990e307 391 ENTER;
79072805
LW		 392}
393
954c1994 394/*
62375a60
NIS		 395=for apidoc nothreadhook
396
397Stub that provides thread hook for perl_destruct when there are
398no threads.
399
400=cut
401*/
402
403int
4e9e3734 404Perl_nothreadhook(pTHX)
62375a60 405{
96a5add6 406 PERL_UNUSED_CONTEXT;
62375a60
NIS		 407 return 0;
408}
409
41e4abd8
NC		 410#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
411void
412Perl_dump_sv_child(pTHX_ SV *sv)
413{
414 ssize_t got;
bf357333
NC		 415 const int sock = PL_dumper_fd;
416 const int debug_fd = PerlIO_fileno(Perl_debug_log);
bf357333
NC		 417 union control_un control;
418 struct msghdr msg;
808ad2d0 419 struct iovec vec[2];
bf357333 420 struct cmsghdr *cmptr;
808ad2d0
NC		 421 int returned_errno;
422 unsigned char buffer[256];
41e4abd8 423
7918f24d
NC		 424 PERL_ARGS_ASSERT_DUMP_SV_CHILD;
425
bf357333 426 if(sock == -1 || debug_fd == -1)
41e4abd8
NC		 427 return;
428
429 PerlIO_flush(Perl_debug_log);
430
bf357333
NC		 431 /* All these shenanigans are to pass a file descriptor over to our child for
432 it to dump out to. We can't let it hold open the file descriptor when it
433 forks, as the file descriptor it will dump to can turn out to be one end
434 of pipe that some other process will wait on for EOF. (So as it would
b293a5f8 435 be open, the wait would be forever.) */
bf357333
NC		 436
437 msg.msg_control = control.control;
438 msg.msg_controllen = sizeof(control.control);
439 /* We're a connected socket so we don't need a destination */
440 msg.msg_name = NULL;
441 msg.msg_namelen = 0;
442 msg.msg_iov = vec;
808ad2d0 443 msg.msg_iovlen = 1;
bf357333
NC		 444
445 cmptr = CMSG_FIRSTHDR(&msg);
446 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
447 cmptr->cmsg_level = SOL_SOCKET;
448 cmptr->cmsg_type = SCM_RIGHTS;
449 *((int *)CMSG_DATA(cmptr)) = 1;
450
451 vec[0].iov_base = (void*)&sv;
452 vec[0].iov_len = sizeof(sv);
453 got = sendmsg(sock, &msg, 0);
41e4abd8
NC		 454
455 if(got < 0) {
bf357333 456 perror("Debug leaking scalars parent sendmsg failed");
41e4abd8
NC		 457 abort();
458 }
bf357333
NC		 459 if(got < sizeof(sv)) {
460 perror("Debug leaking scalars parent short sendmsg");
41e4abd8
NC		 461 abort();
462 }
463
808ad2d0
NC		 464 /* Return protocol is
465 int: errno value
466 unsigned char: length of location string (0 for empty)
467 unsigned char*: string (not terminated)
468 */
469 vec[0].iov_base = (void*)&returned_errno;
470 vec[0].iov_len = sizeof(returned_errno);
471 vec[1].iov_base = buffer;
472 vec[1].iov_len = 1;
473
474 got = readv(sock, vec, 2);
41e4abd8
NC		 475
476 if(got < 0) {
477 perror("Debug leaking scalars parent read failed");
808ad2d0 478 PerlIO_flush(PerlIO_stderr());
41e4abd8
NC		 479 abort();
480 }
808ad2d0 481 if(got < sizeof(returned_errno) + 1) {
41e4abd8 482 perror("Debug leaking scalars parent short read");
808ad2d0 483 PerlIO_flush(PerlIO_stderr());
41e4abd8
NC		 484 abort();
485 }
486
808ad2d0
NC		 487 if (*buffer) {
488 got = read(sock, buffer + 1, *buffer);
489 if(got < 0) {
490 perror("Debug leaking scalars parent read 2 failed");
491 PerlIO_flush(PerlIO_stderr());
492 abort();
493 }
494
495 if(got < *buffer) {
496 perror("Debug leaking scalars parent short read 2");
497 PerlIO_flush(PerlIO_stderr());
498 abort();
499 }
500 }
501
502 if (returned_errno || *buffer) {
503 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
504 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
0c0d42ff 505 returned_errno, Strerror(returned_errno));
41e4abd8
NC		 506 }
507}
508#endif
509
62375a60 510/*
954c1994
GS		 511=for apidoc perl_destruct
512
513Shuts down a Perl interpreter. See L<perlembed>.
514
515=cut
516*/
517
31d77e54 518int
0cb96387 519perl_destruct(pTHXx)
79072805 520{
27da23d5 521 dVAR;
be2ea8ed 522 VOL signed char destruct_level; /* see possible values in intrpvar.h */
a0d0e21e 523 HV *hv;
2aa47728 524#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
2aa47728
NC		 525 pid_t child;
526#endif
9c0b6888 527 int i;
8990e307 528
7918f24d
NC		 529 PERL_ARGS_ASSERT_PERL_DESTRUCT;
530#ifndef MULTIPLICITY
ed6c66dd 531 PERL_UNUSED_ARG(my_perl);
7918f24d 532#endif
9d4ba2ae 533
3d22c4f0
GG		 534 assert(PL_scopestack_ix == 1);
535
7766f137
GS		 536 /* wait for all pseudo-forked children to finish */
537 PERL_WAIT_FOR_CHILDREN;
538
3280af22 539 destruct_level = PL_perl_destruct_level;
36e77d41 540#if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL)
4633a7c4 541 {
9d4ba2ae
AL		 542 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
543 if (s) {
36e77d41
DD		 544 const int i = atoi(s);
545#ifdef DEBUGGING
546 if (destruct_level < i) destruct_level = i;
547#endif
548#ifdef PERL_TRACK_MEMPOOL
549 /* RT #114496, for perl_free */
550 PL_perl_destruct_level = i;
551#endif
5f05dabc 552 }
4633a7c4
LW		 553 }
554#endif
555
27da23d5 556 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
f3faeb53
AB		 557 dJMPENV;
558 int x = 0;
559
560 JMPENV_PUSH(x);
1b6737cc 561 PERL_UNUSED_VAR(x);
9ebf26ad 562 if (PL_endav && !PL_minus_c) {
ca7b837b 563 PERL_SET_PHASE(PERL_PHASE_END);
f3faeb53 564 call_list(PL_scopestack_ix, PL_endav);
9ebf26ad 565 }
f3faeb53 566 JMPENV_POP;
26f423df 567 }
f3faeb53 568 LEAVE;
a0d0e21e 569 FREETMPS;
3d22c4f0 570 assert(PL_scopestack_ix == 0);
a0d0e21e 571
e00b64d4 572 /* Need to flush since END blocks can produce output */
f13a2bc0 573 my_fflush_all();
e00b64d4 574
75d476e2
S		 575#ifdef PERL_TRACE_OPS
576 /* If we traced all Perl OP usage, report and clean up */
577 PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
578 for (i = 0; i <= OP_max; ++i) {
579 PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
580 PL_op_exec_cnt[i] = 0;
581 }
582 /* Utility slot for easily doing little tracing experiments in the runloop: */
583 if (PL_op_exec_cnt[OP_max+1] != 0)
584 PerlIO_printf(Perl_debug_log, " SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]);
585 PerlIO_printf(Perl_debug_log, "\n");
586#endif
587
588
16c91539 589 if (PL_threadhook(aTHX)) {
62375a60 590 /* Threads hook has vetoed further cleanup */
c301d606 591 PL_veto_cleanup = TRUE;
37038d91 592 return STATUS_EXIT;
62375a60
NIS		 593 }
594
2aa47728
NC		 595#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
596 if (destruct_level != 0) {
597 /* Fork here to create a child. Our child's job is to preserve the
598 state of scalars prior to destruction, so that we can instruct it
599 to dump any scalars that we later find have leaked.
600 There's no subtlety in this code - it assumes POSIX, and it doesn't
601 fail gracefully */
602 int fd[2];
603
604 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
605 perror("Debug leaking scalars socketpair failed");
606 abort();
607 }
608
609 child = fork();
610 if(child == -1) {
611 perror("Debug leaking scalars fork failed");
612 abort();
613 }
614 if (!child) {
615 /* We are the child */
3125a5a4
NC		 616 const int sock = fd[1];
617 const int debug_fd = PerlIO_fileno(Perl_debug_log);
618 int f;
808ad2d0
NC		 619 const char *where;
620 /* Our success message is an integer 0, and a char 0 */
b61433a9 621 static const char success[sizeof(int) + 1] = {0};
3125a5a4 622
2aa47728 623 close(fd[0]);
2aa47728 624
3125a5a4
NC		 625 /* We need to close all other file descriptors otherwise we end up
626 with interesting hangs, where the parent closes its end of a
627 pipe, and sits waiting for (another) child to terminate. Only
628 that child never terminates, because it never gets EOF, because
bf357333
NC		 629 we also have the far end of the pipe open. We even need to
630 close the debugging fd, because sometimes it happens to be one
631 end of a pipe, and a process is waiting on the other end for
632 EOF. Normally it would be closed at some point earlier in
633 destruction, but if we happen to cause the pipe to remain open,
634 EOF never occurs, and we get an infinite hang. Hence all the
635 games to pass in a file descriptor if it's actually needed. */
3125a5a4
NC		 636
637 f = sysconf(_SC_OPEN_MAX);
638 if(f < 0) {
808ad2d0
NC		 639 where = "sysconf failed";
640 goto abort;
3125a5a4
NC		 641 }
642 while (f--) {
643 if (f == sock)
644 continue;
3125a5a4
NC		 645 close(f);
646 }
647
2aa47728
NC		 648 while (1) {
649 SV *target;
bf357333
NC		 650 union control_un control;
651 struct msghdr msg;
652 struct iovec vec[1];
653 struct cmsghdr *cmptr;
654 ssize_t got;
655 int got_fd;
656
657 msg.msg_control = control.control;
658 msg.msg_controllen = sizeof(control.control);
659 /* We're a connected socket so we don't need a source */
660 msg.msg_name = NULL;
661 msg.msg_namelen = 0;
662 msg.msg_iov = vec;
663 msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
664
665 vec[0].iov_base = (void*)&target;
666 vec[0].iov_len = sizeof(target);
667
668 got = recvmsg(sock, &msg, 0);
2aa47728
NC		 669
670 if(got == 0)
671 break;
672 if(got < 0) {
808ad2d0
NC		 673 where = "recv failed";
674 goto abort;
2aa47728
NC		 675 }
676 if(got < sizeof(target)) {
808ad2d0
NC		 677 where = "short recv";
678 goto abort;
2aa47728 679 }
bf357333 680
808ad2d0
NC		 681 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
682 where = "no cmsg";
683 goto abort;
684 }
685 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
686 where = "wrong cmsg_len";
687 goto abort;
688 }
689 if(cmptr->cmsg_level != SOL_SOCKET) {
690 where = "wrong cmsg_level";
691 goto abort;
692 }
693 if(cmptr->cmsg_type != SCM_RIGHTS) {
694 where = "wrong cmsg_type";
695 goto abort;
696 }
bf357333
NC		 697
698 got_fd = *(int*)CMSG_DATA(cmptr);
699 /* For our last little bit of trickery, put the file descriptor
700 back into Perl_debug_log, as if we never actually closed it
701 */
808ad2d0
NC		 702 if(got_fd != debug_fd) {
703 if (dup2(got_fd, debug_fd) == -1) {
704 where = "dup2";
705 goto abort;
706 }
707 }
2aa47728 708 sv_dump(target);
bf357333 709
2aa47728
NC		 710 PerlIO_flush(Perl_debug_log);
711
808ad2d0 712 got = write(sock, &success, sizeof(success));
2aa47728
NC		 713
714 if(got < 0) {
808ad2d0
NC		 715 where = "write failed";
716 goto abort;
2aa47728 717 }
808ad2d0
NC		 718 if(got < sizeof(success)) {
719 where = "short write";
720 goto abort;
2aa47728
NC		 721 }
722 }
723 _exit(0);
808ad2d0
NC		 724 abort:
725 {
726 int send_errno = errno;
727 unsigned char length = (unsigned char) strlen(where);
728 struct iovec failure[3] = {
729 {(void*)&send_errno, sizeof(send_errno)},
730 {&length, 1},
731 {(void*)where, length}
732 };
733 int got = writev(sock, failure, 3);
734 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
735 in the parent if we try to read from the socketpair after the
736 child has exited, even if there was data to read.
737 So sleep a bit to give the parent a fighting chance of
738 reading the data. */
739 sleep(2);
740 _exit((got == -1) ? errno : 0);
741 }
bf357333 742 /* End of child. */
2aa47728 743 }
41e4abd8 744 PL_dumper_fd = fd[0];
2aa47728
NC		 745 close(fd[1]);
746 }
747#endif
748
ff0cee69 749 /* We must account for everything. */
750
751 /* Destroy the main CV and syntax tree */
37e77c23
FC		 752 /* Set PL_curcop now, because destroying ops can cause new SVs
753 to be generated in Perl_pad_swipe, and when running with
754 -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
755 op from which the filename structure member is copied. */
17fbfdf6 756 PL_curcop = &PL_compiling;
3280af22 757 if (PL_main_root) {
4e380990
DM		 758 /* ensure comppad/curpad to refer to main's pad */
759 if (CvPADLIST(PL_main_cv)) {
760 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
325e1816 761 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
4e380990 762 }
3280af22 763 op_free(PL_main_root);
5f66b61c 764 PL_main_root = NULL;
a0d0e21e 765 }
5f66b61c 766 PL_main_start = NULL;
aac9d523
DM		 767 /* note that PL_main_cv isn't usually actually freed at this point,
768 * due to the CvOUTSIDE refs from subs compiled within it. It will
769 * get freed once all the subs are freed in sv_clean_all(), for
770 * destruct_level > 0 */
3280af22 771 SvREFCNT_dec(PL_main_cv);
601f1833 772 PL_main_cv = NULL;
ca7b837b 773 PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
ff0cee69 774
13621cfb
NIS		 775 /* Tell PerlIO we are about to tear things apart in case
776 we have layers which are using resources that should
777 be cleaned up now.
778 */
779
780 PerlIO_destruct(aTHX);
781
ddf23d4a
S		 782 /*
783 * Try to destruct global references. We do this first so that the
784 * destructors and destructees still exist. Some sv's might remain.
785 * Non-referenced objects are on their own.
786 */
787 sv_clean_objs();
8990e307 788
5cd24f17 789 /* unhook hooks which will soon be, or use, destroyed data */
3280af22 790 SvREFCNT_dec(PL_warnhook);
a0714e2c 791 PL_warnhook = NULL;
3280af22 792 SvREFCNT_dec(PL_diehook);
a0714e2c 793 PL_diehook = NULL;
5cd24f17 794
4b556e6c 795 /* call exit list functions */
3280af22 796 while (PL_exitlistlen-- > 0)
acfe0abc 797 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 798
3280af22 799 Safefree(PL_exitlist);
4b556e6c 800
1c4916e5
CB		 801 PL_exitlist = NULL;
802 PL_exitlistlen = 0;
803
a3e6e81e
NC		 804 SvREFCNT_dec(PL_registered_mros);
805
551a8b83 806 /* jettison our possibly duplicated environment */
4b647fb0
DM		 807 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
808 * so we certainly shouldn't free it here
809 */
2f42fcb0 810#ifndef PERL_MICRO
4b647fb0 811#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
50acdf95 812 if (environ != PL_origenviron && !PL_use_safe_putenv
4efc5df6
GS		 813#ifdef USE_ITHREADS
814 /* only main thread can free environ[0] contents */
815 && PL_curinterp == aTHX
816#endif
817 )
818 {
551a8b83
JH		 819 I32 i;
820
821 for (i = 0; environ[i]; i++)
4b420006 822 safesysfree(environ[i]);
0631ea03 823
4b420006
JH		 824 /* Must use safesysfree() when working with environ. */
825 safesysfree(environ);
551a8b83
JH		 826
827 environ = PL_origenviron;
828 }
829#endif
2f42fcb0 830#endif /* !PERL_MICRO */
551a8b83 831
30985c42
JH		 832 if (destruct_level == 0) {
833
834 DEBUG_P(debprofdump());
835
836#if defined(PERLIO_LAYERS)
837 /* No more IO - including error messages ! */
838 PerlIO_cleanup(aTHX);
839#endif
840
841 CopFILE_free(&PL_compiling);
30985c42
JH		 842
843 /* The exit() function will do everything that needs doing. */
844 return STATUS_EXIT;
845 }
846
9fa9f06b
KW		 847 /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */
848
5f8cb046
DM		 849#ifdef USE_ITHREADS
850 /* the syntax tree is shared between clones
851 * so op_free(PL_main_root) only ReREFCNT_dec's
852 * REGEXPs in the parent interpreter
853 * we need to manually ReREFCNT_dec for the clones
854 */
0547a729
DM		 855 {
856 I32 i = AvFILLp(PL_regex_padav);
857 SV **ary = AvARRAY(PL_regex_padav);
858
859 for (; i; i--) {
860 SvREFCNT_dec(ary[i]);
861 ary[i] = &PL_sv_undef;
862 }
863 }
5f8cb046
DM		 864#endif
865
0547a729 866
ad64d0ec 867 SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
081fc587
AB		 868 PL_stashcache = NULL;
869
5f05dabc 870 /* loosen bonds of global variables */
871
2f9285f8
DM		 872 /* XXX can PL_parser still be non-null here? */
873 if(PL_parser && PL_parser->rsfp) {
874 (void)PerlIO_close(PL_parser->rsfp);
875 PL_parser->rsfp = NULL;
8ebc5c01 876 }
877
84386e14
RGS		 878 if (PL_minus_F) {
879 Safefree(PL_splitstr);
880 PL_splitstr = NULL;
881 }
882
8ebc5c01 883 /* switches */
3280af22
NIS		 884 PL_minus_n = FALSE;
885 PL_minus_p = FALSE;
886 PL_minus_l = FALSE;
887 PL_minus_a = FALSE;
888 PL_minus_F = FALSE;
889 PL_doswitches = FALSE;
599cee73 890 PL_dowarn = G_WARN_OFF;
1a904fc8 891#ifdef PERL_SAWAMPERSAND
d3b97530 892 PL_sawampersand = 0; /* must save all match strings */
1a904fc8 893#endif
3280af22
NIS		 894 PL_unsafe = FALSE;
895
896 Safefree(PL_inplace);
bd61b366 897 PL_inplace = NULL;
a7cb1f99 898 SvREFCNT_dec(PL_patchlevel);
1e8125c6 899 SvREFCNT_dec(PL_apiversion);
3280af22
NIS		 900
901 if (PL_e_script) {
902 SvREFCNT_dec(PL_e_script);
a0714e2c 903 PL_e_script = NULL;
8ebc5c01 904 }
905
bf9cdc68
RG		 906 PL_perldb = 0;
907
8ebc5c01 908 /* magical thingies */
909
e23d9e2f
CS		 910 SvREFCNT_dec(PL_ofsgv); /* *, */
911 PL_ofsgv = NULL;
5f05dabc 912
7889fe52 913 SvREFCNT_dec(PL_ors_sv); /* $\ */
a0714e2c 914 PL_ors_sv = NULL;
8ebc5c01 915
3280af22 916 SvREFCNT_dec(PL_rs); /* $/ */
a0714e2c 917 PL_rs = NULL;
dc92893f 918
d33b2eba 919 Safefree(PL_osname); /* $^O */
bd61b366 920 PL_osname = NULL;
5f05dabc 921
3280af22 922 SvREFCNT_dec(PL_statname);
a0714e2c
SS		 923 PL_statname = NULL;
924 PL_statgv = NULL;
5f05dabc 925
8ebc5c01 926 /* defgv, aka *_ should be taken care of elsewhere */
927
7d5ea4e7
GS		 928 /* float buffer */
929 Safefree(PL_efloatbuf);
bd61b366 930 PL_efloatbuf = NULL;
7d5ea4e7
GS		 931 PL_efloatsize = 0;
932
8ebc5c01 933 /* startup and shutdown function lists */
3280af22 934 SvREFCNT_dec(PL_beginav);
5a837c8f 935 SvREFCNT_dec(PL_beginav_save);
3280af22 936 SvREFCNT_dec(PL_endav);
7d30b5c4 937 SvREFCNT_dec(PL_checkav);
ece599bd 938 SvREFCNT_dec(PL_checkav_save);
3c10abe3
AG		 939 SvREFCNT_dec(PL_unitcheckav);
940 SvREFCNT_dec(PL_unitcheckav_save);
3280af22 941 SvREFCNT_dec(PL_initav);
7d49f689
NC		 942 PL_beginav = NULL;
943 PL_beginav_save = NULL;
944 PL_endav = NULL;
945 PL_checkav = NULL;
946 PL_checkav_save = NULL;
3c10abe3
AG		 947 PL_unitcheckav = NULL;
948 PL_unitcheckav_save = NULL;
7d49f689 949 PL_initav = NULL;
5618dfe8 950
8ebc5c01 951 /* shortcuts just get cleared */
a0714e2c
SS		 952 PL_incgv = NULL;
953 PL_hintgv = NULL;
954 PL_errgv = NULL;
955 PL_argvgv = NULL;
956 PL_argvoutgv = NULL;
957 PL_stdingv = NULL;
958 PL_stderrgv = NULL;
959 PL_last_in_gv = NULL;
960 PL_replgv = NULL;
a0714e2c
SS		 961 PL_DBsingle = NULL;
962 PL_DBtrace = NULL;
963 PL_DBsignal = NULL;
601f1833 964 PL_DBcv = NULL;
7d49f689 965 PL_dbargs = NULL;
5c284bb0 966 PL_debstash = NULL;
8ebc5c01 967
cf93a474 968 SvREFCNT_dec(PL_envgv);
8cece913
FC		 969 SvREFCNT_dec(PL_DBgv);
970 SvREFCNT_dec(PL_DBline);
971 SvREFCNT_dec(PL_DBsub);
cf93a474 972 PL_envgv = NULL;
8cece913
FC		 973 PL_DBgv = NULL;
974 PL_DBline = NULL;
975 PL_DBsub = NULL;
976
7a1c5554 977 SvREFCNT_dec(PL_argvout_stack);
7d49f689 978 PL_argvout_stack = NULL;
8ebc5c01 979
5c831c24 980 SvREFCNT_dec(PL_modglobal);
5c284bb0 981 PL_modglobal = NULL;
5c831c24 982 SvREFCNT_dec(PL_preambleav);
7d49f689 983 PL_preambleav = NULL;
5c831c24 984 SvREFCNT_dec(PL_subname);
a0714e2c 985 PL_subname = NULL;
ca0c25f6 986#ifdef PERL_USES_PL_PIDSTATUS
5c831c24 987 SvREFCNT_dec(PL_pidstatus);
5c284bb0 988 PL_pidstatus = NULL;
ca0c25f6 989#endif
5c831c24 990 SvREFCNT_dec(PL_toptarget);
a0714e2c 991 PL_toptarget = NULL;
5c831c24 992 SvREFCNT_dec(PL_bodytarget);
a0714e2c
SS		 993 PL_bodytarget = NULL;
994 PL_formtarget = NULL;
5c831c24 995
d33b2eba 996 /* free locale stuff */
b9582b6a 997#ifdef USE_LOCALE_COLLATE
d33b2eba 998 Safefree(PL_collation_name);
bd61b366 999 PL_collation_name = NULL;
b9582b6a 1000#endif
d33b2eba 1001
b9582b6a 1002#ifdef USE_LOCALE_NUMERIC
d33b2eba 1003 Safefree(PL_numeric_name);
bd61b366 1004 PL_numeric_name = NULL;
a453c169 1005 SvREFCNT_dec(PL_numeric_radix_sv);
a0714e2c 1006 PL_numeric_radix_sv = NULL;
b9582b6a 1007#endif
d33b2eba 1008
9c0b6888
KW		 1009 /* clear character classes */
1010 for (i = 0; i < POSIX_SWASH_COUNT; i++) {
1011 SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
1012 PL_utf8_swash_ptrs[i] = NULL;
1013 }
5c831c24
GS		 1014 SvREFCNT_dec(PL_utf8_mark);
1015 SvREFCNT_dec(PL_utf8_toupper);
4dbdbdc2 1016 SvREFCNT_dec(PL_utf8_totitle);
5c831c24 1017 SvREFCNT_dec(PL_utf8_tolower);
b4e400f9 1018 SvREFCNT_dec(PL_utf8_tofold);
82686b01
JH		 1019 SvREFCNT_dec(PL_utf8_idstart);
1020 SvREFCNT_dec(PL_utf8_idcont);
2726813d 1021 SvREFCNT_dec(PL_utf8_foldclosures);
9fa9f06b
KW		 1022 SvREFCNT_dec(PL_AboveLatin1);
1023 SvREFCNT_dec(PL_UpperLatin1);
1024 SvREFCNT_dec(PL_Latin1);
1025 SvREFCNT_dec(PL_NonL1NonFinalFold);
1026 SvREFCNT_dec(PL_HasMultiCharFold);
a0714e2c
SS		 1027 PL_utf8_mark = NULL;
1028 PL_utf8_toupper = NULL;
1029 PL_utf8_totitle = NULL;
1030 PL_utf8_tolower = NULL;
1031 PL_utf8_tofold = NULL;
1032 PL_utf8_idstart = NULL;
1033 PL_utf8_idcont = NULL;
2726813d 1034 PL_utf8_foldclosures = NULL;
9fa9f06b
KW		 1035 PL_AboveLatin1 = NULL;
1036 PL_HasMultiCharFold = NULL;
1037 PL_Latin1 = NULL;
1038 PL_NonL1NonFinalFold = NULL;
1039 PL_UpperLatin1 = NULL;
86f72d56 1040 for (i = 0; i < POSIX_CC_COUNT; i++) {
30f9bdb0
KW		 1041 SvREFCNT_dec(PL_Posix_ptrs[i]);
1042 PL_Posix_ptrs[i] = NULL;
1043
86f72d56
KW		 1044 SvREFCNT_dec(PL_L1Posix_ptrs[i]);
1045 PL_L1Posix_ptrs[i] = NULL;
cac6e0ca
KW		 1046
1047 SvREFCNT_dec(PL_XPosix_ptrs[i]);
1048 PL_XPosix_ptrs[i] = NULL;
86f72d56 1049 }
5c831c24 1050
971a9dd3 1051 if (!specialWARN(PL_compiling.cop_warnings))
72dc9ed5 1052 PerlMemShared_free(PL_compiling.cop_warnings);
a0714e2c 1053 PL_compiling.cop_warnings = NULL;
20439bc7
Z		 1054 cophh_free(CopHINTHASH_get(&PL_compiling));
1055 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
05ec9bb3 1056 CopFILE_free(&PL_compiling);
5c831c24 1057
a0d0e21e 1058 /* Prepare to destruct main symbol table. */
5f05dabc 1059
3280af22 1060 hv = PL_defstash;
ca556bcd
DM		 1061 /* break ref loop *:: <=> %:: */
1062 (void)hv_delete(hv, "main::", 6, G_DISCARD);
3280af22 1063 PL_defstash = 0;
a0d0e21e 1064 SvREFCNT_dec(hv);
5c831c24 1065 SvREFCNT_dec(PL_curstname);
a0714e2c 1066 PL_curstname = NULL;
a0d0e21e 1067
5a844595
GS		 1068 /* clear queued errors */
1069 SvREFCNT_dec(PL_errors);
a0714e2c 1070 PL_errors = NULL;
5a844595 1071
dd69841b
BB		 1072 SvREFCNT_dec(PL_isarev);
1073
a0d0e21e 1074 FREETMPS;
9b387841 1075 if (destruct_level >= 2) {
3280af22 1076 if (PL_scopestack_ix != 0)
9b387841
NC		 1077 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1078 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1079 (long)PL_scopestack_ix);
3280af22 1080 if (PL_savestack_ix != 0)
9b387841
NC		 1081 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1082 "Unbalanced saves: %ld more saves than restores\n",
1083 (long)PL_savestack_ix);
3280af22 1084 if (PL_tmps_floor != -1)
9b387841
NC		 1085 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1086 (long)PL_tmps_floor + 1);
a0d0e21e 1087 if (cxstack_ix != -1)
9b387841
NC		 1088 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1089 (long)cxstack_ix + 1);
a0d0e21e 1090 }
8990e307 1091
0547a729
DM		 1092#ifdef USE_ITHREADS
1093 SvREFCNT_dec(PL_regex_padav);
1094 PL_regex_padav = NULL;
1095 PL_regex_pad = NULL;
1096#endif
1097
776df701 1098#ifdef PERL_IMPLICIT_CONTEXT
57bb2458
JH		 1099 /* the entries in this list are allocated via SV PVX's, so get freed
1100 * in sv_clean_all */
1101 Safefree(PL_my_cxt_list);
776df701 1102#endif
57bb2458 1103
8990e307 1104 /* Now absolutely destruct everything, somehow or other, loops or no. */
5226ed68
JH		 1105
1106 /* the 2 is for PL_fdpid and PL_strtab */
d17ea597 1107 while (sv_clean_all() > 2)
5226ed68
JH		 1108 ;
1109
23083432
FC		 1110#ifdef USE_ITHREADS
1111 Safefree(PL_stashpad); /* must come after sv_clean_all */
1112#endif
1113
d4777f27
GS		 1114 AvREAL_off(PL_fdpid); /* no surviving entries */
1115 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
7d49f689 1116 PL_fdpid = NULL;
d33b2eba 1117
6c644e78
GS		 1118#ifdef HAVE_INTERP_INTERN
1119 sys_intern_clear();
1120#endif
1121
a38ab475
RZ		 1122 /* constant strings */
1123 for (i = 0; i < SV_CONSTS_COUNT; i++) {
1124 SvREFCNT_dec(PL_sv_consts[i]);
1125 PL_sv_consts[i] = NULL;
1126 }
1127
6e72f9df 1128 /* Destruct the global string table. */
1129 {
1130 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1131 * so that sv_free() won't fail on them.
80459961
NC		 1132 * Now that the global string table is using a single hunk of memory
1133 * for both HE and HEK, we either need to explicitly unshare it the
1134 * correct way, or actually free things here.
6e72f9df 1135 */
80459961
NC		 1136 I32 riter = 0;
1137 const I32 max = HvMAX(PL_strtab);
c4420975 1138 HE * const * const array = HvARRAY(PL_strtab);
80459961
NC		 1139 HE *hent = array[0];
1140
6e72f9df 1141 for (;;) {
0453d815 1142 if (hent && ckWARN_d(WARN_INTERNAL)) {
44f8325f 1143 HE * const next = HeNEXT(hent);
9014280d 1144 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
44f8325f 1145 "Unbalanced string table refcount: (%ld) for \"%s\"",
de616631 1146 (long)hent->he_valu.hent_refcount, HeKEY(hent));
80459961
NC		 1147 Safefree(hent);
1148 hent = next;
6e72f9df 1149 }
1150 if (!hent) {
1151 if (++riter > max)
1152 break;
1153 hent = array[riter];
1154 }
1155 }
80459961
NC		 1156
1157 Safefree(array);
1158 HvARRAY(PL_strtab) = 0;
1159 HvTOTALKEYS(PL_strtab) = 0;
6e72f9df 1160 }
3280af22 1161 SvREFCNT_dec(PL_strtab);
6e72f9df 1162
e652bb2f 1163#ifdef USE_ITHREADS
c21d1a0f 1164 /* free the pointer tables used for cloning */
a0739874 1165 ptr_table_free(PL_ptr_table);
bf9cdc68 1166 PL_ptr_table = (PTR_TBL_t*)NULL;
53186e96 1167#endif
a0739874 1168
d33b2eba
GS		 1169 /* free special SVs */
1170
1171 SvREFCNT(&PL_sv_yes) = 0;
1172 sv_clear(&PL_sv_yes);
1173 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 1174 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS		 1175
1176 SvREFCNT(&PL_sv_no) = 0;
1177 sv_clear(&PL_sv_no);
1178 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 1179 SvFLAGS(&PL_sv_no) = 0;
01724ea0 1180
9f375a43
DM		 1181 {
1182 int i;
1183 for (i=0; i<=2; i++) {
1184 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1185 sv_clear(PERL_DEBUG_PAD(i));
1186 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1187 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1188 }
1189 }
1190
0453d815 1191 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
9014280d 1192 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 1193
eba0f806
DM		 1194#ifdef DEBUG_LEAKING_SCALARS
1195 if (PL_sv_count != 0) {
1196 SV* sva;
1197 SV* sv;
eb578fdb 1198 SV* svend;
eba0f806 1199
ad64d0ec 1200 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
eba0f806
DM		 1201 svend = &sva[SvREFCNT(sva)];
1202 for (sv = sva + 1; sv < svend; ++sv) {
e4787c0c 1203 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
a548cda8 1204 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
61b61456 1205 " flags=0x%"UVxf
fd0854ff 1206 " refcnt=%"UVuf pTHX__FORMAT "\n"
cd676548
DM		 1207 "\tallocated at %s:%d %s %s (parent 0x%"UVxf");"
1208 "serial %"UVuf"\n",
574b8821
NC		 1209 (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1210 pTHX__VALUE,
fd0854ff
DM		 1211 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1212 sv->sv_debug_line,
1213 sv->sv_debug_inpad ? "for" : "by",
1214 sv->sv_debug_optype ?
1215 PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1216 PTR2UV(sv->sv_debug_parent),
cbe56f1d 1217 sv->sv_debug_serial
fd0854ff 1218 );
2aa47728 1219#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
41e4abd8 1220 Perl_dump_sv_child(aTHX_ sv);
2aa47728 1221#endif
eba0f806
DM		 1222 }
1223 }
1224 }
1225 }
2aa47728
NC		 1226#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1227 {
1228 int status;
1229 fd_set rset;
1230 /* Wait for up to 4 seconds for child to terminate.
1231 This seems to be the least effort way of timing out on reaping
1232 its exit status. */
1233 struct timeval waitfor = {4, 0};
41e4abd8 1234 int sock = PL_dumper_fd;
2aa47728
NC		 1235
1236 shutdown(sock, 1);
1237 FD_ZERO(&rset);
1238 FD_SET(sock, &rset);
1239 select(sock + 1, &rset, NULL, NULL, &waitfor);
1240 waitpid(child, &status, WNOHANG);
1241 close(sock);
1242 }
1243#endif
eba0f806 1244#endif
77abb4c6
NC		 1245#ifdef DEBUG_LEAKING_SCALARS_ABORT
1246 if (PL_sv_count)
1247 abort();
1248#endif
bf9cdc68 1249 PL_sv_count = 0;
eba0f806 1250
56a2bab7 1251#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS		 1252 /* No more IO - including error messages ! */
1253 PerlIO_cleanup(aTHX);
1254#endif
1255
9f4bd222 1256 /* sv_undef needs to stay immortal until after PerlIO_cleanup
a0714e2c 1257 as currently layers use it rather than NULL as a marker
9f4bd222
NIS		 1258 for no arg - and will try and SvREFCNT_dec it.
1259 */
1260 SvREFCNT(&PL_sv_undef) = 0;
1261 SvREADONLY_off(&PL_sv_undef);
1262
3280af22 1263 Safefree(PL_origfilename);
bd61b366 1264 PL_origfilename = NULL;
43c5f42d 1265 Safefree(PL_reg_curpm);
dd28f7bb 1266 free_tied_hv_pool();
3280af22 1267 Safefree(PL_op_mask);
cf36064f 1268 Safefree(PL_psig_name);
bf9cdc68 1269 PL_psig_name = (SV**)NULL;
d525a7b2 1270 PL_psig_ptr = (SV**)NULL;
31c91b43
LR		 1271 {
1272 /* We need to NULL PL_psig_pend first, so that
1273 signal handlers know not to use it */
1274 int *psig_save = PL_psig_pend;
1275 PL_psig_pend = (int*)NULL;
1276 Safefree(psig_save);
1277 }
6e72f9df 1278 nuke_stacks();
284167a5
S		 1279 TAINTING_set(FALSE);
1280 TAINT_WARN_set(FALSE);
3280af22 1281 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
bf9cdc68 1282 PL_debug = 0;
ac27b0f5 1283
a0d0e21e 1284 DEBUG_P(debprofdump());
d33b2eba 1285
e5dd39fc 1286#ifdef USE_REENTRANT_API
10bc17b6 1287 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 1288#endif
1289
612f20c3
GS		 1290 sv_free_arenas();
1291
5d9a96ca
DM		 1292 while (PL_regmatch_slab) {
1293 regmatch_slab *s = PL_regmatch_slab;
1294 PL_regmatch_slab = PL_regmatch_slab->next;
1295 Safefree(s);
1296 }
1297
fc36a67e 1298 /* As the absolutely last thing, free the non-arena SV for mess() */
1299
3280af22 1300 if (PL_mess_sv) {
f350b448
NC		 1301 /* we know that type == SVt_PVMG */
1302
9c63abab 1303 /* it could have accumulated taint magic */
f350b448
NC		 1304 MAGIC* mg;
1305 MAGIC* moremagic;
1306 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1307 moremagic = mg->mg_moremagic;
1308 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1309 && mg->mg_len >= 0)
1310 Safefree(mg->mg_ptr);
1311 Safefree(mg);
9c63abab 1312 }
f350b448 1313
fc36a67e 1314 /* we know that type >= SVt_PV */
8bd4d4c5 1315 SvPV_free(PL_mess_sv);
3280af22
NIS		 1316 Safefree(SvANY(PL_mess_sv));
1317 Safefree(PL_mess_sv);
a0714e2c 1318 PL_mess_sv = NULL;
fc36a67e 1319 }
37038d91 1320 return STATUS_EXIT;
79072805
LW		 1321}
1322
954c1994
GS		 1323/*
1324=for apidoc perl_free
1325
1326Releases a Perl interpreter. See L<perlembed>.
1327
1328=cut
1329*/
1330
79072805 1331void
0cb96387 1332perl_free(pTHXx)
79072805 1333{
5174512c
NC		 1334 dVAR;
1335
7918f24d
NC		 1336 PERL_ARGS_ASSERT_PERL_FREE;
1337
c301d606
DM		 1338 if (PL_veto_cleanup)
1339 return;
1340
7cb608b5 1341#ifdef PERL_TRACK_MEMPOOL
55ef9aae
MHM		 1342 {
1343 /*
1344 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1345 * value as we're probably hunting memory leaks then
1346 */
36e77d41 1347 if (PL_perl_destruct_level == 0) {
4fd0a9b8 1348 const U32 old_debug = PL_debug;
55ef9aae
MHM		 1349 /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1350 thread at thread exit. */
4fd0a9b8
NC		 1351 if (DEBUG_m_TEST) {
1352 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1353 "free this thread's memory\n");
1354 PL_debug &= ~ DEBUG_m_FLAG;
1355 }
55ef9aae
MHM		 1356 while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
1357 safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
4fd0a9b8 1358 PL_debug = old_debug;
55ef9aae
MHM		 1359 }
1360 }
7cb608b5
NC		 1361#endif
1362
acfe0abc 1363#if defined(WIN32) || defined(NETWARE)
ce3e5b80 1364# if defined(PERL_IMPLICIT_SYS)
b36c9a52 1365 {
acfe0abc 1366# ifdef NETWARE
7af12a34 1367 void *host = nw_internal_host;
7af12a34 1368 PerlMem_free(aTHXx);
7af12a34 1369 nw_delete_internal_host(host);
acfe0abc 1370# else
bdb50480
NC		 1371 void *host = w32_internal_host;
1372 PerlMem_free(aTHXx);
7af12a34 1373 win32_delete_internal_host(host);
acfe0abc 1374# endif
7af12a34 1375 }
1c0ca838
GS		 1376# else
1377 PerlMem_free(aTHXx);
1378# endif
acfe0abc
GS		 1379#else
1380 PerlMem_free(aTHXx);
76e3520e 1381#endif
79072805
LW		 1382}
1383
b7f7fff6 1384#if defined(USE_ITHREADS)
aebd1ac7
GA		 1385/* provide destructors to clean up the thread key when libperl is unloaded */
1386#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1387
826955bd 1388#if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
aebd1ac7 1389#pragma fini "perl_fini"
666ad1ec
GA		 1390#elif defined(__sun) && !defined(__GNUC__)
1391#pragma fini (perl_fini)
aebd1ac7
GA		 1392#endif
1393
0dbb1585
AL		 1394static void
1395#if defined(__GNUC__)
1396__attribute__((destructor))
aebd1ac7 1397#endif
de009b76 1398perl_fini(void)
aebd1ac7 1399{
27da23d5 1400 dVAR;
5c64bffd
NC		 1401 if (
1402#ifdef PERL_GLOBAL_STRUCT_PRIVATE
1403 my_vars &&
1404#endif
1405 PL_curinterp && !PL_veto_cleanup)
aebd1ac7
GA		 1406 FREE_THREAD_KEY;
1407}
1408
1409#endif /* WIN32 */
1410#endif /* THREADS */
1411
4b556e6c 1412void
864dbfa3 1413Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 1414{
97aff369 1415 dVAR;
3280af22
NIS		 1416 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1417 PL_exitlist[PL_exitlistlen].fn = fn;
1418 PL_exitlist[PL_exitlistlen].ptr = ptr;
1419 ++PL_exitlistlen;
4b556e6c
JD		 1420}
1421
b7975bdd
NC		 1422STATIC void
1423S_set_caret_X(pTHX) {
97aff369 1424 dVAR;
fafc274c 1425 GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
b7975bdd 1426 if (tmpgv) {
0f1723e1 1427 SV *const caret_x = GvSV(tmpgv);
82552a95
NC		 1428#if defined(OS2)
1429 sv_setpv(caret_x, os2_execname(aTHX));
1430#else
2982a345
NC		 1431# ifdef USE_KERN_PROC_PATHNAME
1432 size_t size = 0;
1433 int mib[4];
1434 mib[0] = CTL_KERN;
1435 mib[1] = KERN_PROC;
1436 mib[2] = KERN_PROC_PATHNAME;
1437 mib[3] = -1;
1438
1439 if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
1440 && size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
1441 sv_grow(caret_x, size);
1442
1443 if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
1444 && size > 2) {
1445 SvPOK_only(caret_x);
1446 SvCUR_set(caret_x, size - 1);
1447 SvTAINT(caret_x);
1448 return;
1449 }
1450 }
ae60cb46
NC		 1451# elif defined(USE_NSGETEXECUTABLEPATH)
1452 char buf[1];
1453 uint32_t size = sizeof(buf);
ae60cb46
NC		 1454
1455 _NSGetExecutablePath(buf, &size);
1456 if (size < MAXPATHLEN * MAXPATHLEN) {
1457 sv_grow(caret_x, size);
1458 if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
1459 char *const tidied = realpath(SvPVX(caret_x), NULL);
1460 if (tidied) {
1461 sv_setpv(caret_x, tidied);
1462 free(tidied);
1463 } else {
1464 SvPOK_only(caret_x);
1465 SvCUR_set(caret_x, size);
1466 }
1467 return;
1468 }
1469 }
2982a345 1470# elif defined(HAS_PROCSELFEXE)
700dd4f8
NC		 1471 char buf[MAXPATHLEN];
1472 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1473
1474 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1475 includes a spurious NUL which will cause $^X to fail in system
1476 or backticks (this will prevent extensions from being built and
1477 many tests from working). readlink is not meant to add a NUL.
1478 Normal readlink works fine.
1479 */
1480 if (len > 0 && buf[len-1] == '\0') {
1481 len--;
1482 }
1483
1484 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1485 returning the text "unknown" from the readlink rather than the path
1486 to the executable (or returning an error from the readlink). Any
1487 valid path has a '/' in it somewhere, so use that to validate the
1488 result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1489 */
1490 if (len > 0 && memchr(buf, '/', len)) {
1491 sv_setpvn(caret_x, buf, len);
82552a95 1492 return;
700dd4f8 1493 }
82552a95
NC		 1494# endif
1495 /* Fallback to this: */
0f1723e1 1496 sv_setpv(caret_x, PL_origargv[0]);
b7975bdd 1497#endif
b7975bdd
NC		 1498 }
1499}
1500
954c1994
GS		 1501/*
1502=for apidoc perl_parse
1503
1504Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1505
1506=cut
1507*/
1508
03d9f026
FC		 1509#define SET_CURSTASH(newstash) \
1510 if (PL_curstash != newstash) { \
1511 SvREFCNT_dec(PL_curstash); \
1512 PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1513 }
1514
79072805 1515int
0cb96387 1516perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 1517{
27da23d5 1518 dVAR;
6224f72b 1519 I32 oldscope;
6224f72b 1520 int ret;
db36c5a1 1521 dJMPENV;
8d063cd8 1522
7918f24d
NC		 1523 PERL_ARGS_ASSERT_PERL_PARSE;
1524#ifndef MULTIPLICITY
ed6c66dd 1525 PERL_UNUSED_ARG(my_perl);
7918f24d 1526#endif
7dc86639 1527#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG)
b0891165 1528 {
7dc86639
YO		 1529 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1530
1531 if (s && (atoi(s) == 1)) {
1532 unsigned char *seed= PERL_HASH_SEED;
1533 unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
1534 PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
1535 while (seed < seed_end) {
1536 PerlIO_printf(Perl_debug_log, "%02x", *seed++);
1537 }
6a5b4183
YO		 1538#ifdef PERL_HASH_RANDOMIZE_KEYS
1539 PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
1540 PL_HASH_RAND_BITS_ENABLED,
1541 PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
1542#endif
7dc86639
YO		 1543 PerlIO_printf(Perl_debug_log, "\n");
1544 }
b0891165
JH		 1545 }
1546#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
3280af22 1547 PL_origargc = argc;
e2975953 1548 PL_origargv = argv;
a0d0e21e 1549
a2722ac9
GA		 1550 if (PL_origalen != 0) {
1551 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1552 }
1553 else {
3cb9023d
JH		 1554 /* Set PL_origalen be the sum of the contiguous argv[]
1555 * elements plus the size of the env in case that it is
e9137a8e 1556 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
3cb9023d
JH		 1557 * as the maximum modifiable length of $0. In the worst case
1558 * the area we are able to modify is limited to the size of
43c32782 1559 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d 1560 * --jhi */
e1ec3a88 1561 const char *s = NULL;
54bfe034 1562 int i;
1b6737cc 1563 const UV mask =
7d8e7db3 1564 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
43c32782 1565 /* Do the mask check only if the args seem like aligned. */
1b6737cc 1566 const UV aligned =
43c32782
JH		 1567 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1568
1569 /* See if all the arguments are contiguous in memory. Note
1570 * that 'contiguous' is a loose term because some platforms
1571 * align the argv[] and the envp[]. If the arguments look
1572 * like non-aligned, assume that they are 'strictly' or
1573 * 'traditionally' contiguous. If the arguments look like
1574 * aligned, we just check that they are within aligned
1575 * PTRSIZE bytes. As long as no system has something bizarre
1576 * like the argv[] interleaved with some other data, we are
1577 * fine. (Did I just evoke Murphy's Law?) --jhi */
c8941eeb
JH		 1578 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1579 while (*s) s++;
1580 for (i = 1; i < PL_origargc; i++) {
1581 if ((PL_origargv[i] == s + 1
43c32782 1582#ifdef OS2
c8941eeb 1583 || PL_origargv[i] == s + 2
43c32782 1584#endif
c8941eeb
JH		 1585 )
1586 ||
1587 (aligned &&
1588 (PL_origargv[i] > s &&
1589 PL_origargv[i] <=
1590 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1591 )
1592 {
1593 s = PL_origargv[i];
1594 while (*s) s++;
1595 }
1596 else
1597 break;
54bfe034 1598 }
54bfe034 1599 }
a4a109c2
JD		 1600
1601#ifndef PERL_USE_SAFE_PUTENV
3cb9023d 1602 /* Can we grab env area too to be used as the area for $0? */
a4a109c2 1603 if (s && PL_origenviron && !PL_use_safe_putenv) {
9d419b5f 1604 if ((PL_origenviron[0] == s + 1)
43c32782
JH		 1605 ||
1606 (aligned &&
1607 (PL_origenviron[0] > s &&
1608 PL_origenviron[0] <=
1609 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1610 )
1611 {
9d419b5f 1612#ifndef OS2 /* ENVIRON is read by the kernel too. */
43c32782
JH		 1613 s = PL_origenviron[0];
1614 while (*s) s++;
1615#endif
bd61b366 1616 my_setenv("NoNe SuCh", NULL);
43c32782
JH		 1617 /* Force copy of environment. */
1618 for (i = 1; PL_origenviron[i]; i++) {
1619 if (PL_origenviron[i] == s + 1
1620 ||
1621 (aligned &&
1622 (PL_origenviron[i] > s &&
1623 PL_origenviron[i] <=
1624 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1625 )
1626 {
1627 s = PL_origenviron[i];
1628 while (*s) s++;
1629 }
1630 else
1631 break;
54bfe034 1632 }
43c32782 1633 }
54bfe034 1634 }
a4a109c2
JD		 1635#endif /* !defined(PERL_USE_SAFE_PUTENV) */
1636
2d2af554 1637 PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
54bfe034
JH		 1638 }
1639
3280af22 1640 if (PL_do_undump) {
a0d0e21e
LW		 1641
1642 /* Come here if running an undumped a.out. */
1643
3280af22
NIS		 1644 PL_origfilename = savepv(argv[0]);
1645 PL_do_undump = FALSE;
a0d0e21e 1646 cxstack_ix = -1; /* start label stack again */
748a9306 1647 init_ids();
284167a5 1648 assert (!TAINT_get);
b7975bdd
NC		 1649 TAINT;
1650 S_set_caret_X(aTHX);
1651 TAINT_NOT;
a0d0e21e
LW		 1652 init_postdump_symbols(argc,argv,env);
1653 return 0;
1654 }
1655
3280af22 1656 if (PL_main_root) {
3280af22 1657 op_free(PL_main_root);
5f66b61c 1658 PL_main_root = NULL;
ff0cee69 1659 }
5f66b61c 1660 PL_main_start = NULL;
3280af22 1661 SvREFCNT_dec(PL_main_cv);
601f1833 1662 PL_main_cv = NULL;
79072805 1663
3280af22
NIS		 1664 time(&PL_basetime);
1665 oldscope = PL_scopestack_ix;
599cee73 1666 PL_dowarn = G_WARN_OFF;
f86702cc 1667
14dd3ad8 1668 JMPENV_PUSH(ret);
6224f72b 1669 switch (ret) {
312caa8e 1670 case 0:
14dd3ad8 1671 parse_body(env,xsinit);
9ebf26ad 1672 if (PL_unitcheckav) {
3c10abe3 1673 call_list(oldscope, PL_unitcheckav);
9ebf26ad
FR		 1674 }
1675 if (PL_checkav) {
ca7b837b 1676 PERL_SET_PHASE(PERL_PHASE_CHECK);
7d30b5c4 1677 call_list(oldscope, PL_checkav);
9ebf26ad 1678 }
14dd3ad8
GS		 1679 ret = 0;
1680 break;
6224f72b
GS		 1681 case 1:
1682 STATUS_ALL_FAILURE;
1683 /* FALL THROUGH */
1684 case 2:
1685 /* my_exit() was called */
3280af22 1686 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1687 LEAVE;
1688 FREETMPS;
03d9f026 1689 SET_CURSTASH(PL_defstash);
9ebf26ad 1690 if (PL_unitcheckav) {
3c10abe3 1691 call_list(oldscope, PL_unitcheckav);
9ebf26ad
FR		 1692 }
1693 if (PL_checkav) {
ca7b837b 1694 PERL_SET_PHASE(PERL_PHASE_CHECK);
7d30b5c4 1695 call_list(oldscope, PL_checkav);
9ebf26ad 1696 }
37038d91 1697 ret = STATUS_EXIT;
14dd3ad8 1698 break;
6224f72b 1699 case 3:
bf49b057 1700 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1701 ret = 1;
1702 break;
6224f72b 1703 }
14dd3ad8
GS		 1704 JMPENV_POP;
1705 return ret;
1706}
1707
4a5df386
NC		 1708/* This needs to stay in perl.c, as perl.c is compiled with different flags for
1709 miniperl, and we need to see those flags reflected in the values here. */
1710
1711/* What this returns is subject to change. Use the public interface in Config.
1712 */
1713static void
1714S_Internals_V(pTHX_ CV *cv)
1715{
1716 dXSARGS;
1717#ifdef LOCAL_PATCH_COUNT
1718 const int local_patch_count = LOCAL_PATCH_COUNT;
1719#else
1720 const int local_patch_count = 0;
1721#endif
2dc296d2 1722 const int entries = 3 + local_patch_count;
4a5df386 1723 int i;
fe1c5936 1724 static const char non_bincompat_options[] =
4a5df386
NC		 1725# ifdef DEBUGGING
1726 " DEBUGGING"
1727# endif
1728# ifdef NO_MATHOMS
0d311fbe 1729 " NO_MATHOMS"
4a5df386 1730# endif
59b86f4b
DM		 1731# ifdef NO_HASH_SEED
1732 " NO_HASH_SEED"
1733# endif
3b0e4ee2
MB		 1734# ifdef NO_TAINT_SUPPORT
1735 " NO_TAINT_SUPPORT"
1736# endif
4a5df386
NC		 1737# ifdef PERL_DISABLE_PMC
1738 " PERL_DISABLE_PMC"
1739# endif
1740# ifdef PERL_DONT_CREATE_GVSV
1741 " PERL_DONT_CREATE_GVSV"
1742# endif
9a044a43
NC		 1743# ifdef PERL_EXTERNAL_GLOB
1744 " PERL_EXTERNAL_GLOB"
1745# endif
59b86f4b
DM		 1746# ifdef PERL_HASH_FUNC_SIPHASH
1747 " PERL_HASH_FUNC_SIPHASH"
1748# endif
1749# ifdef PERL_HASH_FUNC_SDBM
1750 " PERL_HASH_FUNC_SDBM"
1751# endif
1752# ifdef PERL_HASH_FUNC_DJB2
1753 " PERL_HASH_FUNC_DJB2"
1754# endif
1755# ifdef PERL_HASH_FUNC_SUPERFAST
1756 " PERL_HASH_FUNC_SUPERFAST"
1757# endif
1758# ifdef PERL_HASH_FUNC_MURMUR3
1759 " PERL_HASH_FUNC_MURMUR3"
1760# endif
1761# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1762 " PERL_HASH_FUNC_ONE_AT_A_TIME"
1763# endif
1764# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1765 " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1766# endif
1767# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1768 " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1769# endif
4a5df386
NC		 1770# ifdef PERL_IS_MINIPERL
1771 " PERL_IS_MINIPERL"
1772# endif
1773# ifdef PERL_MALLOC_WRAP
1774 " PERL_MALLOC_WRAP"
1775# endif
1776# ifdef PERL_MEM_LOG
1777 " PERL_MEM_LOG"
1778# endif
1779# ifdef PERL_MEM_LOG_NOIMPL
1780 " PERL_MEM_LOG_NOIMPL"
1781# endif
2542212d
DM		 1782# ifdef PERL_NEW_COPY_ON_WRITE
1783 " PERL_NEW_COPY_ON_WRITE"
1784# endif
59b86f4b
DM		 1785# ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1786 " PERL_PERTURB_KEYS_DETERMINISTIC"
1787# endif
1788# ifdef PERL_PERTURB_KEYS_DISABLED
1789 " PERL_PERTURB_KEYS_DISABLED"
1790# endif
1791# ifdef PERL_PERTURB_KEYS_RANDOM
1792 " PERL_PERTURB_KEYS_RANDOM"
1793# endif
c3cf41ec
NC		 1794# ifdef PERL_PRESERVE_IVUV
1795 " PERL_PRESERVE_IVUV"
1796# endif
c051e30b
NC		 1797# ifdef PERL_RELOCATABLE_INCPUSH
1798 " PERL_RELOCATABLE_INCPUSH"
1799# endif
4a5df386
NC		 1800# ifdef PERL_USE_DEVEL
1801 " PERL_USE_DEVEL"
1802# endif
1803# ifdef PERL_USE_SAFE_PUTENV
1804 " PERL_USE_SAFE_PUTENV"
1805# endif
a3749cf3
NC		 1806# ifdef UNLINK_ALL_VERSIONS
1807 " UNLINK_ALL_VERSIONS"
1808# endif
de618ee4
NC		 1809# ifdef USE_ATTRIBUTES_FOR_PERLIO
1810 " USE_ATTRIBUTES_FOR_PERLIO"
1811# endif
4a5df386
NC		 1812# ifdef USE_FAST_STDIO
1813 " USE_FAST_STDIO"
1814# endif
59b86f4b
DM		 1815# ifdef USE_HASH_SEED_EXPLICIT
1816 " USE_HASH_SEED_EXPLICIT"
1817# endif
98548bdf
NC		 1818# ifdef USE_LOCALE
1819 " USE_LOCALE"
1820# endif
98548bdf
NC		 1821# ifdef USE_LOCALE_CTYPE
1822 " USE_LOCALE_CTYPE"
1823# endif
5a8d8935
NC		 1824# ifdef USE_PERL_ATOF
1825 " USE_PERL_ATOF"
1826# endif
0d311fbe
NC		 1827# ifdef USE_SITECUSTOMIZE
1828 " USE_SITECUSTOMIZE"
1829# endif
4a5df386
NC		 1830 ;
1831 PERL_UNUSED_ARG(cv);
1832 PERL_UNUSED_ARG(items);
1833
1834 EXTEND(SP, entries);
1835
1836 PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
1837 PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
1838 sizeof(non_bincompat_options) - 1, SVs_TEMP));
1839
1840#ifdef __DATE__
1841# ifdef __TIME__
1842 PUSHs(Perl_newSVpvn_flags(aTHX_
1843 STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__),
1844 SVs_TEMP));
1845# else
1846 PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
1847 SVs_TEMP));
1848# endif
1849#else
1850 PUSHs(&PL_sv_undef);
1851#endif
1852
4a5df386
NC		 1853 for (i = 1; i <= local_patch_count; i++) {
1854 /* This will be an undef, if PL_localpatches[i] is NULL. */
1855 PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
1856 }
1857
1858 XSRETURN(entries);
1859}
1860
be71fc8f
NC		 1861#define INCPUSH_UNSHIFT 0x01
1862#define INCPUSH_ADD_OLD_VERS 0x02
1863#define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04
1864#define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08
1865#define INCPUSH_NOT_BASEDIR 0x10
1866#define INCPUSH_CAN_RELOCATE 0x20
1e3208d8
NC		 1867#define INCPUSH_ADD_SUB_DIRS \
1868 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
e28f3139 1869
312caa8e 1870STATIC void *
14dd3ad8 1871S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1872{
27da23d5 1873 dVAR;
2f9285f8 1874 PerlIO *rsfp;
312caa8e 1875 int argc = PL_origargc;
8f42b153 1876 char **argv = PL_origargv;
e1ec3a88 1877 const char *scriptname = NULL;
312caa8e 1878 VOL bool dosearch = FALSE;
eb578fdb 1879 char c;
737c24fc 1880 bool doextract = FALSE;
bd61b366 1881 const char *cddir = NULL;
ab019eaa 1882#ifdef USE_SITECUSTOMIZE
20ef40cf 1883 bool minus_f = FALSE;
ab019eaa 1884#endif
95670bde 1885 SV *linestr_sv = NULL;
5486870f 1886 bool add_read_e_script = FALSE;
87606032 1887 U32 lex_start_flags = 0;
009d90df 1888
ca7b837b 1889 PERL_SET_PHASE(PERL_PHASE_START);
9ebf26ad 1890
6224f72b 1891 init_main_stash();
54310121 1892
c7030b81
NC		 1893 {
1894 const char *s;
6224f72b
GS		 1895 for (argc--,argv++; argc > 0; argc--,argv++) {
1896 if (argv[0][0] != '-' || !argv[0][1])
1897 break;
6224f72b
GS		 1898 s = argv[0]+1;
1899 reswitch:
47f56822 1900 switch ((c = *s)) {
729a02f2 1901 case 'C':
1d5472a9
GS		 1902#ifndef PERL_STRICT_CR
1903 case '\r':
1904#endif
6224f72b
GS		 1905 case ' ':
1906 case '0':
1907 case 'F':
1908 case 'a':
1909 case 'c':
1910 case 'd':
1911 case 'D':
1912 case 'h':
1913 case 'i':
1914 case 'l':
1915 case 'M':
1916 case 'm':
1917 case 'n':
1918 case 'p':
1919 case 's':
1920 case 'u':
1921 case 'U':
1922 case 'v':
599cee73
PM		 1923 case 'W':
1924 case 'X':
6224f72b 1925 case 'w':
97bd5664 1926 if ((s = moreswitches(s)))
6224f72b
GS		 1927 goto reswitch;
1928 break;
33b78306 1929
1dbad523 1930 case 't':
284167a5
S		 1931#if SILENT_NO_TAINT_SUPPORT
1932 /* silently ignore */
1933#elif NO_TAINT_SUPPORT
3231f579 1934 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
S		 1935 "Cowardly refusing to run with -t or -T flags");
1936#else
22f7c9c9 1937 CHECK_MALLOC_TOO_LATE_FOR('t');
284167a5
S		 1938 if( !TAINTING_get ) {
1939 TAINT_WARN_set(TRUE);
1940 TAINTING_set(TRUE);
317ea90d 1941 }
284167a5 1942#endif
317ea90d
MS		 1943 s++;
1944 goto reswitch;
6224f72b 1945 case 'T':
284167a5
S		 1946#if SILENT_NO_TAINT_SUPPORT
1947 /* silently ignore */
1948#elif NO_TAINT_SUPPORT
3231f579 1949 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
S		 1950 "Cowardly refusing to run with -t or -T flags");
1951#else
22f7c9c9 1952 CHECK_MALLOC_TOO_LATE_FOR('T');
284167a5
S		 1953 TAINTING_set(TRUE);
1954 TAINT_WARN_set(FALSE);
1955#endif
6224f72b
GS		 1956 s++;
1957 goto reswitch;
f86702cc 1958
bc9b29db
RH		 1959 case 'E':
1960 PL_minus_E = TRUE;
1961 /* FALL THROUGH */
6224f72b 1962 case 'e':
f20b2998 1963 forbid_setid('e', FALSE);
3280af22 1964 if (!PL_e_script) {
396482e1 1965 PL_e_script = newSVpvs("");
5486870f 1966 add_read_e_script = TRUE;
6224f72b
GS		 1967 }
1968 if (*++s)
3280af22 1969 sv_catpv(PL_e_script, s);
6224f72b 1970 else if (argv[1]) {
3280af22 1971 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1972 argc--,argv++;
1973 }
1974 else
47f56822 1975 Perl_croak(aTHX_ "No code specified for -%c", c);
396482e1 1976 sv_catpvs(PL_e_script, "\n");
6224f72b 1977 break;
afe37c7d 1978
20ef40cf 1979 case 'f':
f5542d3a 1980#ifdef USE_SITECUSTOMIZE
20ef40cf 1981 minus_f = TRUE;
f5542d3a 1982#endif
20ef40cf
GA		 1983 s++;
1984 goto reswitch;
1985
6224f72b 1986 case 'I': /* -I handled both here and in moreswitches() */
f20b2998 1987 forbid_setid('I', FALSE);
bd61b366 1988 if (!*++s && (s=argv[1]) != NULL) {
6224f72b
GS		 1989 argc--,argv++;
1990 }
6224f72b 1991 if (s && *s) {
0df16ed7 1992 STRLEN len = strlen(s);
55b4bc1c 1993 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
0df16ed7
GS		 1994 }
1995 else
a67e862a 1996 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b 1997 break;
6224f72b 1998 case 'S':
f20b2998 1999 forbid_setid('S', FALSE);
6224f72b
GS		 2000 dosearch = TRUE;
2001 s++;
2002 goto reswitch;
2003 case 'V':
7edfd0ef
NC		 2004 {
2005 SV *opts_prog;
2006
7edfd0ef 2007 if (*++s != ':') {
37ca4a5b 2008 opts_prog = newSVpvs("use Config; Config::_V()");
7edfd0ef
NC		 2009 }
2010 else {
2011 ++s;
2012 opts_prog = Perl_newSVpvf(aTHX_
37ca4a5b 2013 "use Config; Config::config_vars(qw%c%s%c)",
7edfd0ef
NC		 2014 0, s, 0);
2015 s += strlen(s);
2016 }
37ca4a5b 2017 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
7edfd0ef
NC		 2018 /* don't look for script or read stdin */
2019 scriptname = BIT_BUCKET;
2020 goto reswitch;
6224f72b 2021 }
6224f72b 2022 case 'x':
737c24fc 2023 doextract = TRUE;
6224f72b 2024 s++;
304334da 2025 if (*s)
f4c556ac 2026 cddir = s;
6224f72b
GS		 2027 break;
2028 case 0:
2029 break;
2030 case '-':
2031 if (!*++s || isSPACE(*s)) {
2032 argc--,argv++;
2033 goto switch_end;
2034 }
ee8bc8b7
NC		 2035 /* catch use of gnu style long options.
2036 Both of these exit immediately. */
2037 if (strEQ(s, "version"))
2038 minus_v();
2039 if (strEQ(s, "help"))
2040 usage();
6224f72b
GS		 2041 s--;
2042 /* FALL THROUGH */
2043 default:
cea2e8a9 2044 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 2045 }
2046 }
c7030b81
NC		 2047 }
2048
6224f72b 2049 switch_end:
54310121 2050
c7030b81
NC		 2051 {
2052 char *s;
2053
f675dbe5
CB		 2054 if (
2055#ifndef SECURE_INTERNAL_GETENV
284167a5 2056 !TAINTING_get &&
f675dbe5 2057#endif
cf756827 2058 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 2059 {
74288ac8
GS		 2060 while (isSPACE(*s))
2061 s++;
317ea90d 2062 if (*s == '-' && *(s+1) == 'T') {
284167a5
S		 2063#if SILENT_NO_TAINT_SUPPORT
2064 /* silently ignore */
2065#elif NO_TAINT_SUPPORT
3231f579 2066 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
S		 2067 "Cowardly refusing to run with -t or -T flags");
2068#else
22f7c9c9 2069 CHECK_MALLOC_TOO_LATE_FOR('T');
284167a5
S		 2070 TAINTING_set(TRUE);
2071 TAINT_WARN_set(FALSE);
2072#endif
317ea90d 2073 }
74288ac8 2074 else {
bd61b366 2075 char *popt_copy = NULL;
74288ac8 2076 while (s && *s) {
54913509 2077 const char *d;
74288ac8
GS		 2078 while (isSPACE(*s))
2079 s++;
2080 if (*s == '-') {
2081 s++;
2082 if (isSPACE(*s))
2083 continue;
2084 }
4ea8f8fb 2085 d = s;
74288ac8
GS		 2086 if (!*s)
2087 break;
2b622f1a 2088 if (!strchr("CDIMUdmtwW", *s))
cea2e8a9 2089 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 2090 while (++s && *s) {
2091 if (isSPACE(*s)) {
cf756827 2092 if (!popt_copy) {
bfa6c418
NC		 2093 popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2094 s = popt_copy + (s - d);
2095 d = popt_copy;
cf756827 2096 }
4ea8f8fb
MS		 2097 *s++ = '\0';
2098 break;
2099 }
2100 }
1c4db469 2101 if (*d == 't') {
284167a5
S		 2102#if SILENT_NO_TAINT_SUPPORT
2103 /* silently ignore */
2104#elif NO_TAINT_SUPPORT
3231f579 2105 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
S		 2106 "Cowardly refusing to run with -t or -T flags");
2107#else
2108 if( !TAINTING_get) {
2109 TAINT_WARN_set(TRUE);
2110 TAINTING_set(TRUE);
317ea90d 2111 }
284167a5 2112#endif
1c4db469 2113 } else {
97bd5664 2114 moreswitches(d);
1c4db469 2115 }
6224f72b 2116 }
6224f72b
GS		 2117 }
2118 }
c7030b81 2119 }
a0d0e21e 2120
c29067d7
CH		 2121 /* Set $^X early so that it can be used for relocatable paths in @INC */
2122 /* and for SITELIB_EXP in USE_SITECUSTOMIZE */
284167a5 2123 assert (!TAINT_get);
c29067d7
CH		 2124 TAINT;
2125 S_set_caret_X(aTHX);
2126 TAINT_NOT;
2127
43c0c913 2128#if defined(USE_SITECUSTOMIZE)
20ef40cf 2129 if (!minus_f) {
43c0c913 2130 /* The games with local $! are to avoid setting errno if there is no
fc81b718
NC		 2131 sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2132 ie a q() operator with a NUL byte as a the delimiter. This avoids
2133 problems with pathnames containing (say) ' */
43c0c913
NC		 2134# ifdef PERL_IS_MINIPERL
2135 AV *const inc = GvAV(PL_incgv);
2136 SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2137
2138 if (inc0) {
15870c5c
NC		 2139 /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2140 it should be reported immediately as a build failure. */
43c0c913
NC		 2141 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2142 Perl_newSVpvf(aTHX_
15870c5c 2143 "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }",
fc81b718
NC		 2144 0, *inc0, 0,
2145 0, *inc0, 0));
43c0c913
NC		 2146 }
2147# else
2148 /* SITELIB_EXP is a function call on Win32. */
c29067d7 2149 const char *const raw_sitelib = SITELIB_EXP;
bac5c4fc
JD		 2150 if (raw_sitelib) {
2151 /* process .../.. if PERL_RELOCATABLE_INC is defined */
2152 SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2153 INCPUSH_CAN_RELOCATE);
2154 const char *const sitelib = SvPVX(sitelib_sv);
2155 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2156 Perl_newSVpvf(aTHX_
2157 "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2158 0, sitelib, 0,
2159 0, sitelib, 0));
2160 assert (SvREFCNT(sitelib_sv) == 1);
2161 SvREFCNT_dec(sitelib_sv);
2162 }
43c0c913 2163# endif
20ef40cf
GA		 2164 }
2165#endif
2166
6224f72b
GS		 2167 if (!scriptname)
2168 scriptname = argv[0];
3280af22 2169 if (PL_e_script) {
6224f72b
GS		 2170 argc++,argv--;
2171 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2172 }
bd61b366 2173 else if (scriptname == NULL) {
6224f72b
GS		 2174#ifdef MSDOS
2175 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
97bd5664 2176 moreswitches("h");
6224f72b
GS		 2177#endif
2178 scriptname = "-";
2179 }
2180
284167a5 2181 assert (!TAINT_get);
2cace6ac 2182 init_perllib();
6224f72b 2183
a52eba0e 2184 {
f20b2998 2185 bool suidscript = FALSE;
829372d3 2186
8d113837 2187 rsfp = open_script(scriptname, dosearch, &suidscript);
c0b3891a
NC		 2188 if (!rsfp) {
2189 rsfp = PerlIO_stdin();
87606032 2190 lex_start_flags = LEX_DONT_CLOSE_RSFP;
c0b3891a 2191 }
6224f72b 2192
b24bc095 2193 validate_suid(rsfp);
6224f72b 2194
64ca3a65 2195#ifndef PERL_MICRO
a52eba0e
NC		 2196# if defined(SIGCHLD) || defined(SIGCLD)
2197 {
2198# ifndef SIGCHLD
2199# define SIGCHLD SIGCLD
2200# endif
2201 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2202 if (sigstate == (Sighandler_t) SIG_IGN) {
a2a5de95
NC		 2203 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2204 "Can't ignore signal CHLD, forcing to default");
a52eba0e
NC		 2205 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2206 }
0b5b802d 2207 }
a52eba0e 2208# endif
64ca3a65 2209#endif
0b5b802d 2210
737c24fc 2211 if (doextract) {
faef540c 2212
f20b2998 2213 /* This will croak if suidscript is true, as -x cannot be used with
faef540c
NC		 2214 setuid scripts. */
2215 forbid_setid('x', suidscript);
f20b2998 2216 /* Hence you can't get here if suidscript is true */
faef540c 2217
95670bde
NC		 2218 linestr_sv = newSV_type(SVt_PV);
2219 lex_start_flags |= LEX_START_COPIED;
2f9285f8 2220 find_beginning(linestr_sv, rsfp);
a52eba0e
NC		 2221 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2222 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2223 }
f4c556ac 2224 }
6224f72b 2225
ea726b52 2226 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3280af22
NIS		 2227 CvUNIQUE_on(PL_compcv);
2228
dd2155a4 2229 CvPADLIST(PL_compcv) = pad_new(0);
6224f72b 2230
dd69841b
BB		 2231 PL_isarev = newHV();
2232
0c4f7ff0 2233 boot_core_PerlIO();
6224f72b 2234 boot_core_UNIVERSAL();
e1a479c5 2235 boot_core_mro();
4a5df386 2236 newXS("Internals::V", S_Internals_V, __FILE__);
6224f72b
GS		 2237
2238 if (xsinit)
acfe0abc 2239 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 2240#ifndef PERL_MICRO
739a0b84 2241#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
c5be433b 2242 init_os_extras();
6224f72b 2243#endif
64ca3a65 2244#endif
6224f72b 2245
29209bc5 2246#ifdef USE_SOCKS
1b9c9cf5
DH		 2247# ifdef HAS_SOCKS5_INIT
2248 socks5_init(argv[0]);
2249# else
29209bc5 2250 SOCKSinit(argv[0]);
1b9c9cf5 2251# endif
ac27b0f5 2252#endif
29209bc5 2253
6224f72b
GS		 2254 init_predump_symbols();
2255 /* init_postdump_symbols not currently designed to be called */
2256 /* more than once (ENV isn't cleared first, for example) */
2257 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 2258 if (!PL_do_undump)
6224f72b
GS		 2259 init_postdump_symbols(argc,argv,env);
2260
27da23d5
JH		 2261 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2262 * or explicitly in some platforms.
085a54d9 2263 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 2264 * look like the user wants to use UTF-8. */
a0fd4948 2265#if defined(__SYMBIAN32__)
27da23d5
JH		 2266 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2267#endif
e27b5b51 2268# ifndef PERL_IS_MINIPERL
06e66572
JH		 2269 if (PL_unicode) {
2270 /* Requires init_predump_symbols(). */
a05d7ebb 2271 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH		 2272 IO* io;
2273 PerlIO* fp;
2274 SV* sv;
2275
a05d7ebb 2276 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 2277 * and the default open disciplines. */
a05d7ebb
JH		 2278 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2279 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2280 (fp = IoIFP(io)))
2281 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2282 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2283 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2284 (fp = IoOFP(io)))
2285 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2286 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2287 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2288 (fp = IoOFP(io)))
2289 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2290 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
fafc274c
NC		 2291 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2292 SVt_PV)))) {
a05d7ebb
JH		 2293 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2294 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2295 if (in) {
2296 if (out)
76f68e9b 2297 sv_setpvs(sv, ":utf8\0:utf8");
a05d7ebb 2298 else
76f68e9b 2299 sv_setpvs(sv, ":utf8\0");
a05d7ebb
JH		 2300 }
2301 else if (out)
76f68e9b 2302 sv_setpvs(sv, "\0:utf8");
a05d7ebb
JH		 2303 SvSETMAGIC(sv);
2304 }
b310b053
JH		 2305 }
2306 }
e27b5b51 2307#endif
b310b053 2308
c7030b81
NC		 2309 {
2310 const char *s;
4ffa73a3
JH		 2311 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2312 if (strEQ(s, "unsafe"))
2313 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2314 else if (strEQ(s, "safe"))
2315 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2316 else
2317 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2318 }
c7030b81 2319 }
4ffa73a3 2320
81d86705 2321#ifdef PERL_MAD
c7030b81
NC		 2322 {
2323 const char *s;
284167a5 2324 if (!TAINTING_get &&
2cc12391 2325 (s = PerlEnv_getenv("PERL_XMLDUMP"))) {
81d86705
NC		 2326 PL_madskills = 1;
2327 PL_minus_c = 1;
2328 if (!s || !s[0])
2329 PL_xmlfp = PerlIO_stdout();
2330 else {
2331 PL_xmlfp = PerlIO_open(s, "w");
2332 if (!PL_xmlfp)
2333 Perl_croak(aTHX_ "Can't open %s", s);
2334 }
1a9a51d4 2335 my_setenv("PERL_XMLDUMP", NULL); /* hide from subprocs */
81d86705 2336 }
c7030b81
NC		 2337 }
2338
2339 {
2340 const char *s;
81d86705
NC		 2341 if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2342 PL_madskills = atoi(s);
1a9a51d4 2343 my_setenv("PERL_MADSKILLS", NULL); /* hide from subprocs */
81d86705 2344 }
c7030b81 2345 }
81d86705
NC		 2346#endif
2347
87606032 2348 lex_start(linestr_sv, rsfp, lex_start_flags);
d2687c98 2349 SvREFCNT_dec(linestr_sv);
95670bde 2350
219f7226 2351 PL_subname = newSVpvs("main");
6224f72b 2352
5486870f
DM		 2353 if (add_read_e_script)
2354 filter_add(read_e_script, NULL);
2355
6224f72b
GS		 2356 /* now parse the script */
2357
93189314 2358 SETERRNO(0,SS_NORMAL);
28ac2b49 2359 if (yyparse(GRAMPROG) || PL_parser->error_count) {
3280af22 2360 if (PL_minus_c)
cea2e8a9 2361 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 2362 else {
cea2e8a9 2363 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 2364 PL_origfilename);
6224f72b
GS		 2365 }
2366 }
57843af0 2367 CopLINE_set(PL_curcop, 0);
03d9f026 2368 SET_CURSTASH(PL_defstash);
3280af22
NIS		 2369 if (PL_e_script) {
2370 SvREFCNT_dec(PL_e_script);
a0714e2c 2371 PL_e_script = NULL;
6224f72b
GS		 2372 }
2373
3280af22 2374 if (PL_do_undump)
6224f72b
GS		 2375 my_unexec();
2376
57843af0
GS		 2377 if (isWARN_ONCE) {
2378 SAVECOPFILE(PL_curcop);
2379 SAVECOPLINE(PL_curcop);
3280af22 2380 gv_check(PL_defstash);
57843af0 2381 }
6224f72b
GS		 2382
2383 LEAVE;
2384 FREETMPS;
2385
2386#ifdef MYMALLOC
f6a607bc
RGS		 2387 {
2388 const char *s;
6224f72b
GS		 2389 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2390 dump_mstats("after compilation:");
f6a607bc 2391 }
6224f72b
GS		 2392#endif
2393
2394 ENTER;
febb3a6d 2395 PL_restartjmpenv = NULL;
3280af22 2396 PL_restartop = 0;
312caa8e 2397 return NULL;
6224f72b
GS		 2398}
2399
954c1994
GS		 2400/*
2401=for apidoc perl_run
2402
2403Tells a Perl interpreter to run. See L<perlembed>.
2404
2405=cut
2406*/
2407
6224f72b 2408int
0cb96387 2409perl_run(pTHXx)
6224f72b 2410{
97aff369 2411 dVAR;
6224f72b 2412 I32 oldscope;
14dd3ad8 2413 int ret = 0;
db36c5a1 2414 dJMPENV;
6224f72b 2415
7918f24d
NC		 2416 PERL_ARGS_ASSERT_PERL_RUN;
2417#ifndef MULTIPLICITY
ed6c66dd 2418 PERL_UNUSED_ARG(my_perl);
7918f24d 2419#endif
9d4ba2ae 2420
3280af22 2421 oldscope = PL_scopestack_ix;
96e176bf
CL		 2422#ifdef VMS
2423 VMSISH_HUSHED = 0;
2424#endif
6224f72b 2425
14dd3ad8 2426 JMPENV_PUSH(ret);
6224f72b
GS		 2427 switch (ret) {
2428 case 1:
2429 cxstack_ix = -1; /* start context stack again */
312caa8e 2430 goto redo_body;
14dd3ad8 2431 case 0: /* normal completion */
14dd3ad8
GS		 2432 redo_body:
2433 run_body(oldscope);
14dd3ad8
GS		 2434 /* FALL THROUGH */
2435 case 2: /* my_exit() */
3280af22 2436 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 2437 LEAVE;
2438 FREETMPS;
03d9f026 2439 SET_CURSTASH(PL_defstash);
3a1ee7e8 2440 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
9ebf26ad 2441 PL_endav && !PL_minus_c) {
ca7b837b 2442 PERL_SET_PHASE(PERL_PHASE_END);
31d77e54 2443 call_list(oldscope, PL_endav);
9ebf26ad 2444 }
6224f72b
GS		 2445#ifdef MYMALLOC
2446 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2447 dump_mstats("after execution: ");
2448#endif
37038d91 2449 ret = STATUS_EXIT;
14dd3ad8 2450 break;
6224f72b 2451 case 3:
312caa8e
CS		 2452 if (PL_restartop) {
2453 POPSTACK_TO(PL_mainstack);
2454 goto redo_body;
6224f72b 2455 }
5637ef5b 2456 PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
312caa8e 2457 FREETMPS;
14dd3ad8
GS		 2458 ret = 1;
2459 break;
6224f72b
GS		 2460 }
2461
14dd3ad8
GS		 2462 JMPENV_POP;
2463 return ret;
312caa8e
CS		 2464}
2465
dd374669 2466STATIC void
14dd3ad8
GS		 2467S_run_body(pTHX_ I32 oldscope)
2468{
97aff369 2469 dVAR;
d3b97530
DM		 2470 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2471 PL_sawampersand ? "Enabling" : "Omitting",
2472 (unsigned int)(PL_sawampersand)));
6224f72b 2473
3280af22 2474 if (!PL_restartop) {
81d86705
NC		 2475#ifdef PERL_MAD
2476 if (PL_xmlfp) {
2477 xmldump_all();
2478 exit(0); /* less likely to core dump than my_exit(0) */
2479 }
2480#endif
cf2782cd 2481#ifdef DEBUGGING
f0e3f042
CS		 2482 if (DEBUG_x_TEST || DEBUG_B_TEST)
2483 dump_all_perl(!DEBUG_B_TEST);
ecae49c0
NC		 2484 if (!DEBUG_q_TEST)
2485 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
cf2782cd 2486#endif
6224f72b 2487
3280af22 2488 if (PL_minus_c) {
bf49b057 2489 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
6224f72b
GS		 2490 my_exit(0);
2491 }
3280af22 2492 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 2493 sv_setiv(PL_DBsingle, 1);
9ebf26ad 2494 if (PL_initav) {
ca7b837b 2495 PERL_SET_PHASE(PERL_PHASE_INIT);
3280af22 2496 call_list(oldscope, PL_initav);
9ebf26ad 2497 }
f1fac472 2498#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC		 2499 if (PL_main_root && PL_main_root->op_slabbed)
2500 Slab_to_ro(OpSLAB(PL_main_root));
f1fac472 2501#endif
6224f72b
GS		 2502 }
2503
2504 /* do it */
2505
ca7b837b 2506 PERL_SET_PHASE(PERL_PHASE_RUN);
9ebf26ad 2507
3280af22 2508 if (PL_restartop) {
febb3a6d 2509 PL_restartjmpenv = NULL;
533c011a 2510 PL_op = PL_restartop;
3280af22 2511 PL_restartop = 0;
cea2e8a9 2512 CALLRUNOPS(aTHX);
6224f72b 2513 }
3280af22
NIS		 2514 else if (PL_main_start) {
2515 CvDEPTH(PL_main_cv) = 1;
533c011a 2516 PL_op = PL_main_start;
cea2e8a9 2517 CALLRUNOPS(aTHX);
6224f72b 2518 }
f6b3007c 2519 my_exit(0);
118e2215 2520 assert(0); /* NOTREACHED */
6224f72b
GS		 2521}
2522
954c1994 2523/*
ccfc67b7
JH		 2524=head1 SV Manipulation Functions
2525
954c1994
GS		 2526=for apidoc p||get_sv
2527
64ace3f8
NC		 2528Returns the SV of the specified Perl scalar. C<flags> are passed to
2529C<gv_fetchpv>. If C<GV_ADD> is set and the
2530Perl variable does not exist then it will be created. If C<flags> is zero
2531and the variable does not exist then NULL is returned.
954c1994
GS		 2532
2533=cut
2534*/
2535
6224f72b 2536SV*
64ace3f8 2537Perl_get_sv(pTHX_ const char *name, I32 flags)
6224f72b
GS		 2538{
2539 GV *gv;
7918f24d
NC		 2540
2541 PERL_ARGS_ASSERT_GET_SV;
2542
64ace3f8 2543 gv = gv_fetchpv(name, flags, SVt_PV);
6224f72b
GS		 2544 if (gv)
2545 return GvSV(gv);
a0714e2c 2546 return NULL;
6224f72b
GS		 2547}
2548
954c1994 2549/*
ccfc67b7
JH		 2550=head1 Array Manipulation Functions
2551
954c1994
GS		 2552=for apidoc p||get_av
2553
f0b90de1
SF		 2554Returns the AV of the specified Perl global or package array with the given
2555name (so it won't work on lexical variables). C<flags> are passed
2556to C<gv_fetchpv>. If C<GV_ADD> is set and the
cbfd0a87
NC		 2557Perl variable does not exist then it will be created. If C<flags> is zero
2558and the variable does not exist then NULL is returned.
954c1994 2559
f0b90de1
SF		 2560Perl equivalent: C<@{"$name"}>.
2561
954c1994
GS		 2562=cut
2563*/
2564
6224f72b 2565AV*
cbfd0a87 2566Perl_get_av(pTHX_ const char *name, I32 flags)
6224f72b 2567{
cbfd0a87 2568 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
7918f24d
NC		 2569
2570 PERL_ARGS_ASSERT_GET_AV;
2571
cbfd0a87 2572 if (flags)
6224f72b
GS		 2573 return GvAVn(gv);
2574 if (gv)
2575 return GvAV(gv);
7d49f689 2576 return NULL;
6224f72b
GS		 2577}
2578
954c1994 2579/*
ccfc67b7
JH		 2580=head1 Hash Manipulation Functions
2581
954c1994
GS		 2582=for apidoc p||get_hv
2583
6673a63c
NC		 2584Returns the HV of the specified Perl hash. C<flags> are passed to
2585C<gv_fetchpv>. If C<GV_ADD> is set and the
2586Perl variable does not exist then it will be created. If C<flags> is zero
2587and the variable does not exist then NULL is returned.
954c1994
GS		 2588
2589=cut
2590*/
2591
6224f72b 2592HV*
6673a63c 2593Perl_get_hv(pTHX_ const char *name, I32 flags)
6224f72b 2594{
6673a63c 2595 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
7918f24d
NC		 2596
2597 PERL_ARGS_ASSERT_GET_HV;
2598
6673a63c 2599 if (flags)
a0d0e21e
LW		 2600 return GvHVn(gv);
2601 if (gv)
2602 return GvHV(gv);
5c284bb0 2603 return NULL;
a0d0e21e
LW		 2604}
2605
954c1994 2606/*
ccfc67b7
JH		 2607=head1 CV Manipulation Functions
2608
780a5241
NC		 2609=for apidoc p||get_cvn_flags
2610
2611Returns the CV of the specified Perl subroutine. C<flags> are passed to
2612C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2613exist then it will be declared (which has the same effect as saying
2614C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
2615then NULL is returned.
2616
954c1994
GS		 2617=for apidoc p||get_cv
2618
780a5241 2619Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
954c1994
GS		 2620
2621=cut
2622*/
2623
a0d0e21e 2624CV*
780a5241 2625Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
a0d0e21e 2626{
780a5241 2627 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
7918f24d
NC		 2628
2629 PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2630
334dda80
FC		 2631 /* XXX this is probably not what they think they're getting.
2632 * It has the same effect as "sub name;", i.e. just a forward
2633 * declaration! */
780a5241 2634 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
186a5ba8 2635 return newSTUB(gv,0);
780a5241 2636 }
a0d0e21e 2637 if (gv)
8ebc5c01 2638 return GvCVu(gv);
601f1833 2639 return NULL;
a0d0e21e
LW		 2640}
2641
2c67934f
NC		 2642/* Nothing in core calls this now, but we can't replace it with a macro and
2643 move it to mathoms.c as a macro would evaluate name twice. */
780a5241
NC		 2644CV*
2645Perl_get_cv(pTHX_ const char *name, I32 flags)
2646{
7918f24d
NC		 2647 PERL_ARGS_ASSERT_GET_CV;
2648
780a5241
NC		 2649 return get_cvn_flags(name, strlen(name), flags);
2650}
2651
79072805
LW		 2652/* Be sure to refetch the stack pointer after calling these routines. */
2653
954c1994 2654/*
ccfc67b7
JH		 2655
2656=head1 Callback Functions
2657
954c1994
GS		 2658=for apidoc p||call_argv
2659
f0b90de1
SF		 2660Performs a callback to the specified named and package-scoped Perl subroutine
2661with C<argv> (a NULL-terminated array of strings) as arguments. See L<perlcall>.
2662
2663Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
954c1994
GS		 2664
2665=cut
2666*/
2667
a0d0e21e 2668I32
5aaab254 2669Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
ac27b0f5 2670
8ac85365
NIS		 2671 /* See G_* flags in cop.h */
2672 /* null terminated arg list */
8990e307 2673{
97aff369 2674 dVAR;
a0d0e21e 2675 dSP;
8990e307 2676
7918f24d
NC		 2677 PERL_ARGS_ASSERT_CALL_ARGV;
2678
924508f0 2679 PUSHMARK(SP);
a0d0e21e 2680 if (argv) {
8990e307 2681 while (*argv) {
6e449a3a 2682 mXPUSHs(newSVpv(*argv,0));
8990e307
LW		 2683 argv++;
2684 }
a0d0e21e 2685 PUTBACK;
8990e307 2686 }
864dbfa3 2687 return call_pv(sub_name, flags);
8990e307
LW		 2688}
2689
954c1994
GS		 2690/*
2691=for apidoc p||call_pv
2692
2693Performs a callback to the specified Perl sub. See L<perlcall>.
2694
2695=cut
2696*/
2697
a0d0e21e 2698I32
864dbfa3 2699Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 2700 /* name of the subroutine */
2701 /* See G_* flags in cop.h */
a0d0e21e 2702{
7918f24d
NC		 2703 PERL_ARGS_ASSERT_CALL_PV;
2704
0da0e728 2705 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
a0d0e21e
LW		 2706}
2707
954c1994
GS		 2708/*
2709=for apidoc p||call_method
2710
2711Performs a callback to the specified Perl method. The blessed object must
2712be on the stack. See L<perlcall>.
2713
2714=cut
2715*/
2716
a0d0e21e 2717I32
864dbfa3 2718Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 2719 /* name of the subroutine */
2720 /* See G_* flags in cop.h */
a0d0e21e 2721{
46ca9bac 2722 STRLEN len;
c106c2be 2723 SV* sv;
7918f24d
NC		 2724 PERL_ARGS_ASSERT_CALL_METHOD;
2725
46ca9bac 2726 len = strlen(methname);
c106c2be
RZ		 2727 sv = flags & G_METHOD_NAMED
2728 ? sv_2mortal(newSVpvn_share(methname, len,0))
2729 : newSVpvn_flags(methname, len, SVs_TEMP);
46ca9bac 2730
c106c2be 2731 return call_sv(sv, flags | G_METHOD);
a0d0e21e
LW		 2732}
2733
2734/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 2735/*
2736=for apidoc p||call_sv
2737
2738Performs a callback to the Perl sub whose name is in the SV. See
2739L<perlcall>.
2740
2741=cut
2742*/
2743
a0d0e21e 2744I32
001d637e 2745Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
8ac85365 2746 /* See G_* flags in cop.h */
a0d0e21e 2747{
27da23d5 2748 dVAR; dSP;
a0d0e21e 2749 LOGOP myop; /* fake syntax tree node */
c106c2be
RZ		 2750 UNOP method_unop;
2751 SVOP method_svop;
aa689395 2752 I32 oldmark;
8ea43dc8 2753 VOL I32 retval = 0;
a0d0e21e 2754 I32 oldscope;
54310121 2755 bool oldcatch = CATCH_GET;
6224f72b 2756 int ret;
c4420975 2757 OP* const oldop = PL_op;
db36c5a1 2758 dJMPENV;
1e422769 2759
7918f24d
NC		 2760 PERL_ARGS_ASSERT_CALL_SV;
2761
a0d0e21e
LW		 2762 if (flags & G_DISCARD) {
2763 ENTER;
2764 SAVETMPS;
2765 }
2f8edad0
NC		 2766 if (!(flags & G_WANT)) {
2767 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2768 */
2769 flags |= G_SCALAR;
2770 }
a0d0e21e 2771
aa689395 2772 Zero(&myop, 1, LOGOP);
f51d4af5 2773 if (!(flags & G_NOARGS))
aa689395 2774 myop.op_flags |= OPf_STACKED;
4f911530 2775 myop.op_flags |= OP_GIMME_REVERSE(flags);
462e5cf6 2776 SAVEOP();
533c011a 2777 PL_op = (OP*)&myop;
aa689395 2778
3280af22 2779 EXTEND(PL_stack_sp, 1);
c106c2be
RZ		 2780 if (!(flags & G_METHOD_NAMED))
2781 *++PL_stack_sp = sv;
aa689395 2782 oldmark = TOPMARK;
3280af22 2783 oldscope = PL_scopestack_ix;
a0d0e21e 2784
3280af22 2785 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 2786 /* Handle first BEGIN of -d. */
3280af22 2787 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 2788 /* Try harder, since this may have been a sighandler, thus
2789 * curstash may be meaningless. */
ea726b52 2790 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
491527d0 2791 && !(flags & G_NODEBUG))
5ff48db8 2792 myop.op_private |= OPpENTERSUB_DB;
a0d0e21e 2793
c106c2be
RZ		 2794 if (flags & (G_METHOD|G_METHOD_NAMED)) {
2795 if ( flags & G_METHOD_NAMED ) {
2796 Zero(&method_svop, 1, SVOP);
2797 method_svop.op_next = (OP*)&myop;
2798 method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
2799 method_svop.op_type = OP_METHOD_NAMED;
2800 method_svop.op_sv = sv;
2801 PL_op = (OP*)&method_svop;
2802 } else {
2803 Zero(&method_unop, 1, UNOP);
2804 method_unop.op_next = (OP*)&myop;
2805 method_unop.op_ppaddr = PL_ppaddr[OP_METHOD];
2806 method_unop.op_type = OP_METHOD;
2807 PL_op = (OP*)&method_unop;
2808 }
2809 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2810 myop.op_type = OP_ENTERSUB;
2811
968b3946
GS		 2812 }
2813
312caa8e 2814 if (!(flags & G_EVAL)) {
0cdb2077 2815 CATCH_SET(TRUE);
d6f07c05 2816 CALL_BODY_SUB((OP*)&myop);
312caa8e 2817 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 2818 CATCH_SET(oldcatch);
312caa8e
CS		 2819 }
2820 else {
d78bda3d 2821 myop.op_other = (OP*)&myop;
3280af22 2822 PL_markstack_ptr--;
edb2152a 2823 create_eval_scope(flags|G_FAKINGEVAL);
3280af22 2824 PL_markstack_ptr++;
a0d0e21e 2825
14dd3ad8 2826 JMPENV_PUSH(ret);
edb2152a 2827
6224f72b
GS		 2828 switch (ret) {
2829 case 0:
14dd3ad8 2830 redo_body:
d6f07c05 2831 CALL_BODY_SUB((OP*)&myop);
312caa8e 2832 retval = PL_stack_sp - (PL_stack_base + oldmark);
8433848b 2833 if (!(flags & G_KEEPERR)) {
ab69dbc2 2834 CLEAR_ERRSV();
8433848b 2835 }
a0d0e21e 2836 break;
6224f72b 2837 case 1:
f86702cc 2838 STATUS_ALL_FAILURE;
a0d0e21e 2839 /* FALL THROUGH */
6224f72b 2840 case 2:
a0d0e21e 2841 /* my_exit() was called */
03d9f026 2842 SET_CURSTASH(PL_defstash);
a0d0e21e 2843 FREETMPS;
14dd3ad8 2844 JMPENV_POP;
f86702cc 2845 my_exit_jump();
118e2215 2846 assert(0); /* NOTREACHED */
6224f72b 2847 case 3:
3280af22 2848 if (PL_restartop) {
febb3a6d 2849 PL_restartjmpenv = NULL;
533c011a 2850 PL_op = PL_restartop;
3280af22 2851 PL_restartop = 0;
312caa8e 2852 goto redo_body;
a0d0e21e 2853 }
3280af22 2854 PL_stack_sp = PL_stack_base + oldmark;
51ce5529 2855 if ((flags & G_WANT) == G_ARRAY)
a0d0e21e
LW		 2856 retval = 0;
2857 else {
2858 retval = 1;
3280af22 2859 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2860 }
312caa8e 2861 break;
a0d0e21e 2862 }
a0d0e21e 2863
edb2152a
NC		 2864 if (PL_scopestack_ix > oldscope)
2865 delete_eval_scope();
14dd3ad8 2866 JMPENV_POP;
a0d0e21e 2867 }
1e422769 2868
a0d0e21e 2869 if (flags & G_DISCARD) {
3280af22 2870 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2871 retval = 0;
2872 FREETMPS;
2873 LEAVE;
2874 }
533c011a 2875 PL_op = oldop;
a0d0e21e
LW		 2876 return retval;
2877}
2878
6e72f9df 2879/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2880
954c1994
GS		 2881/*
2882=for apidoc p||eval_sv
2883
be064c4a
DM		 2884Tells Perl to C<eval> the string in the SV. It supports the same flags
2885as C<call_sv>, with the obvious exception of G_EVAL. See L<perlcall>.
954c1994
GS		 2886
2887=cut
2888*/
2889
a0d0e21e 2890I32
864dbfa3 2891Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2892
8ac85365 2893 /* See G_* flags in cop.h */
a0d0e21e 2894{
97aff369 2895 dVAR;
924508f0 2896 dSP;
a0d0e21e 2897 UNOP myop; /* fake syntax tree node */
8ea43dc8
SP		 2898 VOL I32 oldmark = SP - PL_stack_base;
2899 VOL I32 retval = 0;
6224f72b 2900 int ret;
c4420975 2901 OP* const oldop = PL_op;
db36c5a1 2902 dJMPENV;
84902520 2903
7918f24d
NC		 2904 PERL_ARGS_ASSERT_EVAL_SV;
2905
4633a7c4
LW		 2906 if (flags & G_DISCARD) {
2907 ENTER;
2908 SAVETMPS;
2909 }
2910
462e5cf6 2911 SAVEOP();
533c011a 2912 PL_op = (OP*)&myop;
5ff48db8 2913 Zero(&myop, 1, UNOP);
3280af22
NIS		 2914 EXTEND(PL_stack_sp, 1);
2915 *++PL_stack_sp = sv;
79072805 2916
4633a7c4
LW		 2917 if (!(flags & G_NOARGS))
2918 myop.op_flags = OPf_STACKED;
6e72f9df 2919 myop.op_type = OP_ENTEREVAL;
4f911530 2920 myop.op_flags |= OP_GIMME_REVERSE(flags);
6e72f9df 2921 if (flags & G_KEEPERR)
2922 myop.op_flags |= OPf_SPECIAL;
a1941760
DM		 2923
2924 if (flags & G_RE_REPARSING)
2925 myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
4633a7c4 2926
dedbcade
DM		 2927 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2928 * before a PUSHEVAL, which corrupts the stack after a croak */
2929 TAINT_PROPER("eval_sv()");
2930
14dd3ad8 2931 JMPENV_PUSH(ret);
6224f72b
GS		 2932 switch (ret) {
2933 case 0:
14dd3ad8 2934 redo_body:
2ba65d5f
DM		 2935 if (PL_op == (OP*)(&myop)) {
2936 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
2937 if (!PL_op)
2938 goto fail; /* failed in compilation */
2939 }
4aca2f62 2940 CALLRUNOPS(aTHX);
312caa8e 2941 retval = PL_stack_sp - (PL_stack_base + oldmark);
8433848b 2942 if (!(flags & G_KEEPERR)) {
ab69dbc2 2943 CLEAR_ERRSV();
8433848b 2944 }
4633a7c4 2945 break;
6224f72b 2946 case 1:
f86702cc 2947 STATUS_ALL_FAILURE;
4633a7c4 2948 /* FALL THROUGH */
6224f72b 2949 case 2:
4633a7c4 2950 /* my_exit() was called */
03d9f026 2951 SET_CURSTASH(PL_defstash);
4633a7c4 2952 FREETMPS;
14dd3ad8 2953 JMPENV_POP;
f86702cc 2954 my_exit_jump();
118e2215 2955 assert(0); /* NOTREACHED */
6224f72b 2956 case 3:
3280af22 2957 if (PL_restartop) {
febb3a6d 2958 PL_restartjmpenv = NULL;
533c011a 2959 PL_op = PL_restartop;
3280af22 2960 PL_restartop = 0;
312caa8e 2961 goto redo_body;
4633a7c4 2962 }
4aca2f62 2963 fail:
3280af22 2964 PL_stack_sp = PL_stack_base + oldmark;
51ce5529 2965 if ((flags & G_WANT) == G_ARRAY)
4633a7c4
LW		 2966 retval = 0;
2967 else {
2968 retval = 1;
3280af22 2969 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2970 }
312caa8e 2971 break;
4633a7c4
LW		 2972 }
2973
14dd3ad8 2974 JMPENV_POP;
4633a7c4 2975 if (flags & G_DISCARD) {
3280af22 2976 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2977 retval = 0;
2978 FREETMPS;
2979 LEAVE;
2980 }
533c011a 2981 PL_op = oldop;
4633a7c4
LW		 2982 return retval;
2983}
2984
954c1994
GS		 2985/*
2986=for apidoc p||eval_pv
2987
2988Tells Perl to C<eval> the given string and return an SV* result.
2989
2990=cut
2991*/
2992
137443ea 2993SV*
864dbfa3 2994Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2995{
97aff369 2996 dVAR;
137443ea 2997 SV* sv = newSVpv(p, 0);
2998
7918f24d
NC		 2999 PERL_ARGS_ASSERT_EVAL_PV;
3000
864dbfa3 3001 eval_sv(sv, G_SCALAR);
137443ea 3002 SvREFCNT_dec(sv);
3003
ed1786ad
DD		 3004 {
3005 dSP;
3006 sv = POPs;
3007 PUTBACK;
3008 }
137443ea 3009
eed484f9
DD		 3010 /* just check empty string or undef? */
3011 if (croak_on_error) {
3012 SV * const errsv = ERRSV;
3013 if(SvTRUE_NN(errsv))
3014 /* replace with croak_sv? */
3015 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
2d8e6c8d 3016 }
137443ea 3017
3018 return sv;
3019}
3020
4633a7c4
LW		 3021/* Require a module. */
3022
954c1994 3023/*
ccfc67b7
JH		 3024=head1 Embedding Functions
3025
954c1994
GS		 3026=for apidoc p||require_pv
3027
7d3fb230
BS		 3028Tells Perl to C<require> the file named by the string argument. It is
3029analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 3030implemented that way; consider using load_module instead.
954c1994 3031
7d3fb230 3032=cut */
954c1994 3033
4633a7c4 3034void
864dbfa3 3035Perl_require_pv(pTHX_ const char *pv)
4633a7c4 3036{
97aff369 3037 dVAR;
d3acc0f7 3038 dSP;
97aff369 3039 SV* sv;
7918f24d
NC		 3040
3041 PERL_ARGS_ASSERT_REQUIRE_PV;
3042
e788e7d3 3043 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7 3044 PUTBACK;
be41e5d9
NC		 3045 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3046 eval_sv(sv_2mortal(sv), G_DISCARD);
d3acc0f7
JP		 3047 SPAGAIN;
3048 POPSTACK;
79072805
LW		 3049}
3050
76e3520e 3051STATIC void
b6f82619 3052S_usage(pTHX) /* XXX move this out into a module ? */
4633a7c4 3053{
ab821d7f 3054 /* This message really ought to be max 23 lines.
75c72d73 3055 * Removed -h because the user already knows that option. Others? */
fb73857a 3056
1566c39d
NC		 3057 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3058 minimum of 509 character string literals. */
27da23d5 3059 static const char * const usage_msg[] = {
1566c39d
NC		 3060" -0[octal] specify record separator (\\0, if no argument)\n"
3061" -a autosplit mode with -n or -p (splits $_ into @F)\n"
3062" -C[number/list] enables the listed Unicode features\n"
3063" -c check syntax only (runs BEGIN and CHECK blocks)\n"
3064" -d[:debugger] run program under debugger\n"
3065" -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n",
3066" -e program one line of program (several -e's allowed, omit programfile)\n"
3067" -E program like -e, but enables all optional features\n"
3068" -f don't do $sitelib/sitecustomize.pl at startup\n"
3069" -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
3070" -i[extension] edit <> files in place (makes backup if extension supplied)\n"
3071" -Idirectory specify @INC/#include directory (several -I's allowed)\n",
3072" -l[octal] enable line ending processing, specifies line terminator\n"
3073" -[mM][-]module execute \"use/no module...\" before executing program\n"
3074" -n assume \"while (<>) { ... }\" loop around program\n"
3075" -p assume loop like -n but print line also, like sed\n"
3076" -s enable rudimentary parsing for switches after programfile\n"
3077" -S look for programfile using PATH environment variable\n",
3078" -t enable tainting warnings\n"
3079" -T enable tainting checks\n"
3080" -u dump core after parsing program\n"
3081" -U allow unsafe operations\n"
3082" -v print version, patchlevel and license\n"
3083" -V[:variable] print configuration summary (or a single Config.pm variable)\n",
60eaec42 3084" -w enable many useful warnings\n"
1566c39d
NC		 3085" -W enable all warnings\n"
3086" -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
3087" -X disable all warnings\n"
3088" \n"
3089"Run 'perldoc perl' for more help with Perl.\n\n",
fb73857a 3090NULL
3091};
27da23d5 3092 const char * const *p = usage_msg;
1566c39d 3093 PerlIO *out = PerlIO_stdout();
fb73857a 3094
1566c39d
NC		 3095 PerlIO_printf(out,
3096 "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
b6f82619 3097 PL_origargv[0]);
fb73857a 3098 while (*p)
1566c39d 3099 PerlIO_puts(out, *p++);
b6f82619 3100 my_exit(0);
4633a7c4
LW		 3101}
3102
b4ab917c
DM		 3103/* convert a string of -D options (or digits) into an int.
3104 * sets *s to point to the char after the options */
3105
3106#ifdef DEBUGGING
3107int
e1ec3a88 3108Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
b4ab917c 3109{
27da23d5 3110 static const char * const usage_msgd[] = {
651b8f1a
NC		 3111 " Debugging flag values: (see also -d)\n"
3112 " p Tokenizing and parsing (with v, displays parse stack)\n"
3113 " s Stack snapshots (with v, displays all stacks)\n"
3114 " l Context (loop) stack processing\n"
3115 " t Trace execution\n"
3116 " o Method and overloading resolution\n",
3117 " c String/numeric conversions\n"
3118 " P Print profiling info, source file input state\n"
3119 " m Memory and SV allocation\n"
3120 " f Format processing\n"
3121 " r Regular expression parsing and execution\n"
3122 " x Syntax tree dump\n",
3123 " u Tainting checks\n"
3124 " H Hash dump -- usurps values()\n"
3125 " X Scratchpad allocation\n"
3126 " D Cleaning up\n"
56967202 3127 " S Op slab allocation\n"
651b8f1a
NC		 3128 " T Tokenising\n"
3129 " R Include reference counts of dumped variables (eg when using -Ds)\n",
3130 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3131 " v Verbose: use in conjunction with other flags\n"
3132 " C Copy On Write\n"
3133 " A Consistency checks on internal structures\n"
3134 " q quiet - currently only suppresses the 'EXECUTING' message\n"
3135 " M trace smart match resolution\n"
3136 " B dump suBroutine definitions, including special Blocks like BEGIN\n",
e6e64d9b
JC		 3137 NULL
3138 };
b4ab917c 3139 int i = 0;
7918f24d
NC		 3140
3141 PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3142
b4ab917c
DM		 3143 if (isALPHA(**s)) {
3144 /* if adding extra options, remember to update DEBUG_MASK */
cc8773c0 3145 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
b4ab917c 3146
0eb30aeb 3147 for (; isWORDCHAR(**s); (*s)++) {
c4420975 3148 const char * const d = strchr(debopts,**s);
b4ab917c
DM		 3149 if (d)
3150 i |= 1 << (d - debopts);
3151 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC		 3152 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3153 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM		 3154 }
3155 }
e6e64d9b 3156 else if (isDIGIT(**s)) {
b4ab917c 3157 i = atoi(*s);
0eb30aeb 3158 for (; isWORDCHAR(**s); (*s)++) ;
b4ab917c 3159 }
ddcf8bc1 3160 else if (givehelp) {
06e869a4 3161 const char *const *p = usage_msgd;
651b8f1a 3162 while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
e6e64d9b 3163 }
b4ab917c
DM		 3164# ifdef EBCDIC
3165 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3166 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3167 "-Dp not implemented on this platform\n");
3168# endif
3169 return i;
3170}
3171#endif
3172
79072805
LW		 3173/* This routine handles any switches that can be given during run */
3174
c7030b81
NC		 3175const char *
3176Perl_moreswitches(pTHX_ const char *s)
79072805 3177{
27da23d5 3178 dVAR;
84c133a0 3179 UV rschar;
0544e6df 3180 const char option = *s; /* used to remember option in -m/-M code */
79072805 3181
7918f24d
NC		 3182 PERL_ARGS_ASSERT_MORESWITCHES;
3183
79072805
LW		 3184 switch (*s) {
3185 case '0':
a863c7d1 3186 {
f2095865 3187 I32 flags = 0;
a3b680e6 3188 STRLEN numlen;
f2095865
JH		 3189
3190 SvREFCNT_dec(PL_rs);
3191 if (s[1] == 'x' && s[2]) {
a3b680e6 3192 const char *e = s+=2;
f2095865
JH		 3193 U8 *tmps;
3194
a3b680e6
AL		 3195 while (*e)
3196 e++;
f2095865
JH		 3197 numlen = e - s;
3198 flags = PERL_SCAN_SILENT_ILLDIGIT;
3199 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3200 if (s + numlen < e) {
3201 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3202 numlen = 0;
3203 s--;
3204 }
396482e1 3205 PL_rs = newSVpvs("");
c5661c80 3206 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 3207 tmps = (U8*)SvPVX(PL_rs);
3208 uvchr_to_utf8(tmps, rschar);
3209 SvCUR_set(PL_rs, UNISKIP(rschar));
3210 SvUTF8_on(PL_rs);
3211 }
3212 else {
3213 numlen = 4;
3214 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3215 if (rschar & ~((U8)~0))
3216 PL_rs = &PL_sv_undef;
3217 else if (!rschar && numlen >= 2)
396482e1 3218 PL_rs = newSVpvs("");
f2095865
JH		 3219 else {
3220 char ch = (char)rschar;
3221 PL_rs = newSVpvn(&ch, 1);
3222 }
3223 }
64ace3f8 3224 sv_setsv(get_sv("/", GV_ADD), PL_rs);
f2095865 3225 return s + numlen;
a863c7d1 3226 }
46487f74 3227 case 'C':
a05d7ebb 3228 s++;
dd374669 3229 PL_unicode = parse_unicode_opts( (const char **)&s );
5a22a2bb
NC		 3230 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3231 PL_utf8cache = -1;
46487f74 3232 return s;
2304df62 3233 case 'F':
5fc691f1 3234 PL_minus_a = TRUE;
3280af22 3235 PL_minus_F = TRUE;
24ffa309 3236 PL_minus_n = TRUE;
ebce5377
RGS		 3237 PL_splitstr = ++s;
3238 while (*s && !isSPACE(*s)) ++s;
e49e380e 3239 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
2304df62 3240 return s;
79072805 3241 case 'a':
3280af22 3242 PL_minus_a = TRUE;
24ffa309 3243 PL_minus_n = TRUE;
79072805
LW		 3244 s++;
3245 return s;
3246 case 'c':
3280af22 3247 PL_minus_c = TRUE;
79072805
LW		 3248 s++;
3249 return s;
3250 case 'd':
f20b2998 3251 forbid_setid('d', FALSE);
4633a7c4 3252 s++;
2cbb2ee1
RGS		 3253
3254 /* -dt indicates to the debugger that threads will be used */
0eb30aeb 3255 if (*s == 't' && !isWORDCHAR(s[1])) {
2cbb2ee1
RGS		 3256 ++s;
3257 my_setenv("PERL5DB_THREADED", "1");
3258 }
3259
70c94a19
RR		 3260 /* The following permits -d:Mod to accepts arguments following an =
3261 in the fashion that -MSome::Mod does. */
3262 if (*s == ':' || *s == '=') {
b19934fb
NC		 3263 const char *start;
3264 const char *end;
3265 SV *sv;
3266
3267 if (*++s == '-') {
3268 ++s;
3269 sv = newSVpvs("no Devel::");
3270 } else {
3271 sv = newSVpvs("use Devel::");
3272 }
3273
3274 start = s;
3275 end = s + strlen(s);
f85893a1 3276
b19934fb 3277 /* We now allow -d:Module=Foo,Bar and -d:-Module */
0eb30aeb 3278 while(isWORDCHAR(*s) || *s==':') ++s;
70c94a19 3279 if (*s != '=')
f85893a1 3280 sv_catpvn(sv, start, end - start);
70c94a19
RR		 3281 else {
3282 sv_catpvn(sv, start, s-start);
95a2b409
RGS		 3283 /* Don't use NUL as q// delimiter here, this string goes in the
3284 * environment. */
3285 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
70c94a19 3286 }
f85893a1 3287 s = end;
184f32ec 3288 my_setenv("PERL5DB", SvPV_nolen_const(sv));
c4db126b 3289 SvREFCNT_dec(sv);
4633a7c4 3290 }
ed094faf 3291 if (!PL_perldb) {
3280af22 3292 PL_perldb = PERLDB_ALL;
a0d0e21e 3293 init_debugger();
ed094faf 3294 }
79072805
LW		 3295 return s;
3296 case 'D':
0453d815 3297 {
79072805 3298#ifdef DEBUGGING
f20b2998 3299 forbid_setid('D', FALSE);
b4ab917c 3300 s++;
dd374669 3301 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
12a43e32 3302#else /* !DEBUGGING */
0453d815 3303 if (ckWARN_d(WARN_DEBUGGING))
9014280d 3304 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
e6e64d9b 3305 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
0eb30aeb 3306 for (s++; isWORDCHAR(*s); s++) ;
79072805 3307#endif
79072805 3308 return s;
0453d815 3309 }
4633a7c4 3310 case 'h':
b6f82619 3311 usage();
79072805 3312 case 'i':
43c5f42d 3313 Safefree(PL_inplace);
c030f24b
GH		 3314#if defined(__CYGWIN__) /* do backup extension automagically */
3315 if (*(s+1) == '\0') {
c86a4f2e 3316 PL_inplace = savepvs(".bak");
c030f24b
GH		 3317 return s+1;
3318 }
3319#endif /* __CYGWIN__ */
5ef5d758 3320 {
d4c19fe8 3321 const char * const start = ++s;
5ef5d758
NC		 3322 while (*s && !isSPACE(*s))
3323 ++s;
3324
3325 PL_inplace = savepvn(start, s - start);
3326 }
7b8d334a 3327 if (*s) {
5ef5d758 3328 ++s;
7b8d334a 3329 if (*s == '-') /* Additional switches on #! line. */
5ef5d758 3330 s++;
7b8d334a 3331 }
fb73857a 3332 return s;
4e49a025 3333 case 'I': /* -I handled both here and in parse_body() */
f20b2998 3334 forbid_setid('I', FALSE);
fb73857a 3335 ++s;
3336 while (*s && isSPACE(*s))
3337 ++s;
3338 if (*s) {
c7030b81 3339 const char *e, *p;
0df16ed7
GS		 3340 p = s;
3341 /* ignore trailing spaces (possibly followed by other switches) */
3342 do {
3343 for (e = p; *e && !isSPACE(*e); e++) ;
3344 p = e;
3345 while (isSPACE(*p))
3346 p++;
3347 } while (*p && *p != '-');
55b4bc1c 3348 incpush(s, e-s,
e28f3139 3349 INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
0df16ed7
GS		 3350 s = p;
3351 if (*s == '-')
3352 s++;
79072805
LW		 3353 }
3354 else
a67e862a 3355 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 3356 return s;
79072805 3357 case 'l':
3280af22 3358 PL_minus_l = TRUE;
79072805 3359 s++;
7889fe52
NIS		 3360 if (PL_ors_sv) {
3361 SvREFCNT_dec(PL_ors_sv);
a0714e2c 3362 PL_ors_sv = NULL;
7889fe52 3363 }
79072805 3364 if (isDIGIT(*s)) {
53305cf1 3365 I32 flags = 0;
a3b680e6 3366 STRLEN numlen;
396482e1 3367 PL_ors_sv = newSVpvs("\n");
53305cf1
NC		 3368 numlen = 3 + (*s == '0');
3369 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 3370 s += numlen;
3371 }
3372 else {
8bfdd7d9 3373 if (RsPARA(PL_rs)) {
396482e1 3374 PL_ors_sv = newSVpvs("\n\n");
7889fe52
NIS		 3375 }
3376 else {
8bfdd7d9 3377 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 3378 }
79072805
LW		 3379 }
3380 return s;
1a30305b 3381 case 'M':
f20b2998 3382 forbid_setid('M', FALSE); /* XXX ? */
1a30305b 3383 /* FALL THROUGH */
3384 case 'm':
f20b2998 3385 forbid_setid('m', FALSE); /* XXX ? */
1a30305b 3386 if (*++s) {
c7030b81 3387 const char *start;
b64cb68c 3388 const char *end;
11343788 3389 SV *sv;
e1ec3a88 3390 const char *use = "use ";
0544e6df 3391 bool colon = FALSE;
a5f75d66 3392 /* -M-foo == 'no foo' */
d0043bd1
NC		 3393 /* Leading space on " no " is deliberate, to make both
3394 possibilities the same length. */
3395 if (*s == '-') { use = " no "; ++s; }
3396 sv = newSVpvn(use,4);
a5f75d66 3397 start = s;
1a30305b 3398 /* We allow -M'Module qw(Foo Bar)' */
0eb30aeb 3399 while(isWORDCHAR(*s) || *s==':') {
0544e6df
RB		 3400 if( *s++ == ':' ) {
3401 if( *s == ':' )
3402 s++;
3403 else
3404 colon = TRUE;
3405 }
3406 }
3407 if (s == start)
3408 Perl_croak(aTHX_ "Module name required with -%c option",
3409 option);
3410 if (colon)
3411 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3412 "contains single ':'",
63da6837 3413 (int)(s - start), start, option);
b64cb68c 3414 end = s + strlen(s);
c07a80fd 3415 if (*s != '=') {
b64cb68c 3416 sv_catpvn(sv, start, end - start);
0544e6df 3417 if (option == 'm') {
c07a80fd 3418 if (*s != '\0')
cea2e8a9 3419 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
396482e1 3420 sv_catpvs( sv, " ()");
c07a80fd 3421 }
3422 } else {
11343788 3423 sv_catpvn(sv, start, s-start);
b64cb68c
NC		 3424 /* Use NUL as q''-delimiter. */
3425 sv_catpvs(sv, " split(/,/,q\0");
3426 ++s;
3427 sv_catpvn(sv, s, end - s);
396482e1 3428 sv_catpvs(sv, "\0)");
c07a80fd 3429 }
b64cb68c 3430 s = end;
29a861e7 3431 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
1a30305b 3432 }
3433 else
0544e6df 3434 Perl_croak(aTHX_ "Missing argument to -%c", option);
1a30305b 3435 return s;
79072805 3436 case 'n':
3280af22 3437 PL_minus_n = TRUE;
79072805
LW		 3438 s++;
3439 return s;
3440 case 'p':
3280af22 3441 PL_minus_p = TRUE;
79072805
LW		 3442 s++;
3443 return s;
3444 case 's':
f20b2998 3445 forbid_setid('s', FALSE);
3280af22 3446 PL_doswitches = TRUE;
79072805
LW		 3447 s++;
3448 return s;
6537fe72 3449 case 't':
27a6968b 3450 case 'T':
284167a5
S		 3451#if SILENT_NO_TAINT_SUPPORT
3452 /* silently ignore */
3453#elif NO_TAINT_SUPPORT
3231f579 3454 Perl_croak_nocontext("This perl was compiled without taint support. "
284167a5
S		 3455 "Cowardly refusing to run with -t or -T flags");
3456#else
3457 if (!TAINTING_get)
27a6968b 3458 TOO_LATE_FOR(*s);
284167a5 3459#endif
6537fe72 3460 s++;
463ee0b2 3461 return s;
79072805 3462 case 'u':
3280af22 3463 PL_do_undump = TRUE;
79072805
LW		 3464 s++;
3465 return s;
3466 case 'U':
3280af22 3467 PL_unsafe = TRUE;
79072805
LW		 3468 s++;
3469 return s;
3470 case 'v':
c4bc78d9
NC		 3471 minus_v();
3472 case 'w':
3473 if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3474 PL_dowarn |= G_WARN_ON;
3475 }
3476 s++;
3477 return s;
3478 case 'W':
3479 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3480 if (!specialWARN(PL_compiling.cop_warnings))
3481 PerlMemShared_free(PL_compiling.cop_warnings);
3482 PL_compiling.cop_warnings = pWARN_ALL ;
3483 s++;
3484 return s;
3485 case 'X':
3486 PL_dowarn = G_WARN_ALL_OFF;
3487 if (!specialWARN(PL_compiling.cop_warnings))
3488 PerlMemShared_free(PL_compiling.cop_warnings);
3489 PL_compiling.cop_warnings = pWARN_NONE ;
3490 s++;
3491 return s;
3492 case '*':
3493 case ' ':
3494 while( *s == ' ' )
3495 ++s;
3496 if (s[0] == '-') /* Additional switches on #! line. */
3497 return s+1;
3498 break;
3499 case '-':
3500 case 0:
3501#if defined(WIN32) || !defined(PERL_STRICT_CR)
3502 case '\r':
3503#endif
3504 case '\n':
3505 case '\t':
3506 break;
3507#ifdef ALTERNATE_SHEBANG
3508 case 'S': /* OS/2 needs -S on "extproc" line. */
3509 break;
3510#endif
4bb78d63
CB		 3511 case 'e': case 'f': case 'x': case 'E':
3512#ifndef ALTERNATE_SHEBANG
3513 case 'S':
3514#endif
3515 case 'V':
c4bc78d9 3516 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
b7e077d0
FC		 3517 default:
3518 Perl_croak(aTHX_
3519 "Unrecognized switch: -%.1s (-h will show valid options)",s
3520 );
c4bc78d9
NC		 3521 }
3522 return NULL;
3523}
3524
3525
3526STATIC void
3527S_minus_v(pTHX)
3528{
fc3381af 3529 PerlIO * PIO_stdout;
d7aa5382 3530 if (!sv_derived_from(PL_patchlevel, "version"))
ac0e6a2f 3531 upg_version(PL_patchlevel, TRUE);
46807d8e
YO		 3532 {
3533 SV* level= vstringify(PL_patchlevel);
3534#ifdef PERL_PATCHNUM
23d483e2
NC		 3535# ifdef PERL_GIT_UNCOMMITTED_CHANGES
3536 SV *num = newSVpvs(PERL_PATCHNUM "*");
3537# else
3538 SV *num = newSVpvs(PERL_PATCHNUM);
3539# endif
fc3381af
DD		 3540 {
3541 STRLEN level_len, num_len;
3542 char * level_str, * num_str;
3543 num_str = SvPV(num, num_len);
3544 level_str = SvPV(level, level_len);
3545 if (num_len>=level_len && strnEQ(num_str,level_str,level_len)) {
3546 SvREFCNT_dec(level);
3547 level= num;
3548 } else {
3549 Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
3550 SvREFCNT_dec(num);
3551 }
46807d8e
YO		 3552 }
3553 #endif
fc3381af
DD		 3554 PIO_stdout = PerlIO_stdout();
3555 PerlIO_printf(PIO_stdout,
ded326e4
DG		 3556 "\nThis is perl " STRINGIFY(PERL_REVISION)
3557 ", version " STRINGIFY(PERL_VERSION)
3558 ", subversion " STRINGIFY(PERL_SUBVERSION)
3559 " (%"SVf") built for " ARCHNAME, level
3560 );
46807d8e
YO		 3561 SvREFCNT_dec(level);
3562 }
fb73857a 3563#if defined(LOCAL_PATCH_COUNT)
3564 if (LOCAL_PATCH_COUNT > 0)
fc3381af 3565 PerlIO_printf(PIO_stdout,
b0e47665
GS		 3566 "\n(with %d registered patch%s, "
3567 "see perl -V for more detail)",
bb7a0f54 3568 LOCAL_PATCH_COUNT,
b0e47665 3569 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 3570#endif
1a30305b 3571
fc3381af 3572 PerlIO_printf(PIO_stdout,
d907e2e9 3573 "\n\nCopyright 1987-2013, Larry Wall\n");
79072805 3574#ifdef MSDOS
fc3381af 3575 PerlIO_printf(PIO_stdout,
b0e47665 3576 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 3577#endif
3578#ifdef DJGPP
fc3381af 3579 PerlIO_printf(PIO_stdout,
b0e47665
GS		 3580 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3581 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 3582#endif
79072805 3583#ifdef OS2
fc3381af 3584 PerlIO_printf(PIO_stdout,
b0e47665 3585 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 3586 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 3587#endif
9d116dd7 3588#ifdef OEMVS
fc3381af 3589 PerlIO_printf(PIO_stdout,
b0e47665 3590 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 3591#endif
495c5fdc 3592#ifdef __VOS__
fc3381af 3593 PerlIO_printf(PIO_stdout,
c0fcb8c5 3594 "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
495c5fdc 3595#endif
a1a0e61e 3596#ifdef POSIX_BC
fc3381af 3597 PerlIO_printf(PIO_stdout,
b0e47665 3598 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 3599#endif
e1caacb4 3600#ifdef UNDER_CE
fc3381af
DD		 3601 PerlIO_printf(PIO_stdout,
3602 "WINCE port by Rainer Keuchel, 2001-2002\n"
3603 "Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 3604 wce_hitreturn();
3605#endif
a0fd4948 3606#ifdef __SYMBIAN32__
fc3381af 3607 PerlIO_printf(PIO_stdout,
27da23d5
JH		 3608 "Symbian port by Nokia, 2004-2005\n");
3609#endif
baed7233
DL		 3610#ifdef BINARY_BUILD_NOTICE
3611 BINARY_BUILD_NOTICE;
3612#endif
fc3381af 3613 PerlIO_printf(PIO_stdout,
b0e47665 3614 "\n\
79072805 3615Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 3616GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687 3617Complete documentation for Perl, including FAQ lists, should be found on\n\
a0288114 3618this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
c9e30dd8 3619Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
7ca617d0 3620 my_exit(0);
79072805
LW		 3621}
3622
3623/* compliments of Tom Christiansen */
3624
3625/* unexec() can be found in the Gnu emacs distribution */
ee580363 3626/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805 3627
25bbd826
CB		 3628#ifdef VMS
3629#include <lib$routines.h>
3630#endif
3631
79072805 3632void
864dbfa3 3633Perl_my_unexec(pTHX)
79072805 3634{
b37c2d43 3635 PERL_UNUSED_CONTEXT;
79072805 3636#ifdef UNEXEC
b37c2d43
AL		 3637 SV * prog = newSVpv(BIN_EXP, 0);
3638 SV * file = newSVpv(PL_origfilename, 0);
ee580363 3639 int status = 1;
79072805
LW		 3640 extern int etext;
3641
396482e1 3642 sv_catpvs(prog, "/perl");
396482e1 3643 sv_catpvs(file, ".perldump");
79072805 3644
ee580363
GS		 3645 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3646 /* unexec prints msg to stderr in case of failure */
6ad3d225 3647 PerlProc_exit(status);
79072805 3648#else
a5f75d66 3649# ifdef VMS
a5f75d66 3650 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
84d78eb7
YO		 3651# elif defined(WIN32) || defined(__CYGWIN__)
3652 Perl_croak(aTHX_ "dump is not supported");
aa689395 3653# else
79072805 3654 ABORT(); /* for use with undump */
aa689395 3655# endif
a5f75d66 3656#endif
79072805
LW		 3657}
3658
cb68f92d
GS		 3659/* initialize curinterp */
3660STATIC void
cea2e8a9 3661S_init_interp(pTHX)
cb68f92d 3662{
97aff369 3663 dVAR;
acfe0abc 3664#ifdef MULTIPLICITY
115ff745
NC		 3665# define PERLVAR(prefix,var,type)
3666# define PERLVARA(prefix,var,n,type)
acfe0abc 3667# if defined(PERL_IMPLICIT_CONTEXT)
115ff745
NC		 3668# define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init;
3669# define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init;
3967c732 3670# else
115ff745
NC		 3671# define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init;
3672# define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 3673# endif
acfe0abc 3674# include "intrpvar.h"
acfe0abc
GS		 3675# undef PERLVAR
3676# undef PERLVARA
3677# undef PERLVARI
3678# undef PERLVARIC
3679#else
115ff745
NC		 3680# define PERLVAR(prefix,var,type)
3681# define PERLVARA(prefix,var,n,type)
3682# define PERLVARI(prefix,var,type,init) PL_##var = init;
3683# define PERLVARIC(prefix,var,type,init) PL_##var = init;
acfe0abc 3684# include "intrpvar.h"
acfe0abc
GS		 3685# undef PERLVAR
3686# undef PERLVARA
3687# undef PERLVARI
3688# undef PERLVARIC
cb68f92d
GS		 3689#endif
3690
cb68f92d
GS		 3691}
3692
76e3520e 3693STATIC void
cea2e8a9 3694S_init_main_stash(pTHX)
79072805 3695{
97aff369 3696 dVAR;
463ee0b2 3697 GV *gv;
6e72f9df 3698
03d9f026 3699 PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
23579a14
NC		 3700 /* We know that the string "main" will be in the global shared string
3701 table, so it's a small saving to use it rather than allocate another
3702 8 bytes. */
18916d0d 3703 PL_curstname = newSVpvs_share("main");
fafc274c 3704 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
23579a14
NC		 3705 /* If we hadn't caused another reference to "main" to be in the shared
3706 string table above, then it would be worth reordering these two,
3707 because otherwise all we do is delete "main" from it as a consequence
3708 of the SvREFCNT_dec, only to add it again with hv_name_set */
adbc6bb1 3709 SvREFCNT_dec(GvHV(gv));
23579a14 3710 hv_name_set(PL_defstash, "main", 4, 0);
85fbaab2 3711 GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
463ee0b2 3712 SvREADONLY_on(gv);
fafc274c
NC		 3713 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3714 SVt_PVAV)));
5a5094bd 3715 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3280af22 3716 GvMULTI_on(PL_incgv);
fafc274c 3717 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3280af22 3718 GvMULTI_on(PL_hintgv);
fafc274c 3719 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
5a5094bd 3720 SvREFCNT_inc_simple_void(PL_defgv);
fafc274c 3721 PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
5a5094bd 3722 SvREFCNT_inc_simple_void(PL_errgv);
3280af22 3723 GvMULTI_on(PL_errgv);
fafc274c 3724 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3280af22 3725 GvMULTI_on(PL_replgv);
cea2e8a9 3726 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
c69033f2
NC		 3727#ifdef PERL_DONT_CREATE_GVSV
3728 gv_SVadd(PL_errgv);
3729#endif
38a03e6e 3730 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
ab69dbc2 3731 CLEAR_ERRSV();
03d9f026 3732 SET_CURSTASH(PL_defstash);
11faa288 3733 CopSTASH_set(&PL_compiling, PL_defstash);
5c1737d1
NC		 3734 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3735 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3736 SVt_PVHV));
4633a7c4 3737 /* We must init $/ before switches are processed. */
64ace3f8 3738 sv_setpvs(get_sv("/", GV_ADD), "\n");
79072805
LW		 3739}
3740
8d113837
NC		 3741STATIC PerlIO *
3742S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
79072805 3743{
fdf5d70d 3744 int fdscript = -1;
8d113837 3745 PerlIO *rsfp = NULL;
27da23d5 3746 dVAR;
1dfef69b 3747 Stat_t tmpstatbuf;
1b24ed4b 3748
7918f24d
NC		 3749 PERL_ARGS_ASSERT_OPEN_SCRIPT;
3750
3280af22 3751 if (PL_e_script) {
8afc33d6 3752 PL_origfilename = savepvs("-e");
96436eeb 3753 }
6c4ab083
GS		 3754 else {
3755 /* if find_script() returns, it returns a malloc()-ed value */
dd374669 3756 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 3757
3758 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
e1ec3a88 3759 const char *s = scriptname + 8;
fdf5d70d 3760 fdscript = atoi(s);
6c4ab083
GS		 3761 while (isDIGIT(*s))
3762 s++;
3763 if (*s) {
ae3f3efd
PS		 3764 /* PSz 18 Feb 04
3765 * Tell apart "normal" usage of fdscript, e.g.
3766 * with bash on FreeBSD:
3767 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3768 * from usage in suidperl.
3769 * Does any "normal" usage leave garbage after the number???
3770 * Is it a mistake to use a similar /dev/fd/ construct for
3771 * suidperl?
3772 */
f20b2998 3773 *suidscript = TRUE;
ae3f3efd
PS		 3774 /* PSz 20 Feb 04
3775 * Be supersafe and do some sanity-checks.
3776 * Still, can we be sure we got the right thing?
3777 */
3778 if (*s != '/') {
3779 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3780 }
3781 if (! *(s+1)) {
3782 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3783 }
6c4ab083 3784 scriptname = savepv(s + 1);
3280af22 3785 Safefree(PL_origfilename);
dd374669 3786 PL_origfilename = (char *)scriptname;
6c4ab083
GS		 3787 }
3788 }
3789 }
3790
05ec9bb3 3791 CopFILE_free(PL_curcop);
57843af0 3792 CopFILE_set(PL_curcop, PL_origfilename);
770526c1 3793 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
dd374669 3794 scriptname = (char *)"";
fdf5d70d 3795 if (fdscript >= 0) {
8d113837 3796 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
96436eeb 3797 }
79072805 3798 else if (!*scriptname) {
cdd8118e 3799 forbid_setid(0, *suidscript);
c0b3891a 3800 return NULL;
79072805 3801 }
96436eeb 3802 else {
9c12f1e5
RGS		 3803#ifdef FAKE_BIT_BUCKET
3804 /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3805 * is called) and still have the "-e" work. (Believe it or not,
3806 * a /dev/null is required for the "-e" to work because source
3807 * filter magic is used to implement it. ) This is *not* a general
3808 * replacement for a /dev/null. What we do here is create a temp
3809 * file (an empty file), open up that as the script, and then
3810 * immediately close and unlink it. Close enough for jazz. */
3811#define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3812#define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3813#define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3814 char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3815 FAKE_BIT_BUCKET_TEMPLATE
3816 };
3817 const char * const err = "Failed to create a fake bit bucket";
3818 if (strEQ(scriptname, BIT_BUCKET)) {
3819#ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3820 int tmpfd = mkstemp(tmpname);
3821 if (tmpfd > -1) {
3822 scriptname = tmpname;
3823 close(tmpfd);
3824 } else
3825 Perl_croak(aTHX_ err);
3826#else
3827# ifdef HAS_MKTEMP
3828 scriptname = mktemp(tmpname);
3829 if (!scriptname)
3830 Perl_croak(aTHX_ err);
3831# endif
3832#endif
3833 }
3834#endif
8d113837 3835 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
9c12f1e5
RGS		 3836#ifdef FAKE_BIT_BUCKET
3837 if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3838 sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3839 && strlen(scriptname) == sizeof(tmpname) - 1) {
3840 unlink(scriptname);
3841 }
3842 scriptname = BIT_BUCKET;
3843#endif
96436eeb 3844 }
8d113837 3845 if (!rsfp) {
447218f8 3846 /* PSz 16 Sep 03 Keep neat error message */
b1681ed3
RGS		 3847 if (PL_e_script)
3848 Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3849 else
3850 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3851 CopFILE(PL_curcop), Strerror(errno));
13281fa4 3852 }
a7c81930
NC		 3853#if defined(HAS_FCNTL) && defined(F_SETFD)
3854 /* ensure close-on-exec */
3855 fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
3856#endif
1dfef69b
RS		 3857
3858 if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
3859 && S_ISDIR(tmpstatbuf.st_mode))
3860 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3861 CopFILE(PL_curcop),
0c0d42ff 3862 Strerror(EISDIR));
1dfef69b 3863
8d113837 3864 return rsfp;
79072805 3865}
8d063cd8 3866
7b89560d
JH		 3867/* Mention
3868 * I_SYSSTATVFS HAS_FSTATVFS
3869 * I_SYSMOUNT
c890dc6c 3870 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3871 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3872 * here so that metaconfig picks them up. */
3873
104d25b7 3874
cc69b689 3875#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
ec2019ad 3876/* Don't even need this function. */
cc69b689 3877#else
ec2019ad
NC		 3878STATIC void
3879S_validate_suid(pTHX_ PerlIO *rsfp)
3880{
dfff4baf
BF		 3881 const Uid_t my_uid = PerlProc_getuid();
3882 const Uid_t my_euid = PerlProc_geteuid();
3883 const Gid_t my_gid = PerlProc_getgid();
3884 const Gid_t my_egid = PerlProc_getegid();
985213f2 3885
ac076a5c
NC		 3886 PERL_ARGS_ASSERT_VALIDATE_SUID;
3887
985213f2 3888 if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
a2e578da
MHM		 3889 dVAR;
3890
2f9285f8 3891 PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
985213f2 3892 if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3893 ||
985213f2 3894 (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3895 )
b28d0864 3896 if (!PL_do_undump)
cea2e8a9 3897 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c 3898FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
a687059c 3899 /* not set-id, must be wrapped */
a687059c 3900 }
79072805 3901}
cc69b689 3902#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
13281fa4 3903
76e3520e 3904STATIC void
2f9285f8 3905S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
79072805 3906{
97aff369 3907 dVAR;
c7030b81 3908 const char *s;
eb578fdb 3909 const char *s2;
33b78306 3910
7918f24d
NC		 3911 PERL_ARGS_ASSERT_FIND_BEGINNING;
3912
33b78306
LW		 3913 /* skip forward in input to the real script? */
3914
737c24fc 3915 do {
2f9285f8 3916 if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
cea2e8a9 3917 Perl_croak(aTHX_ "No Perl script found in input\n");
4f0c37ba 3918 s2 = s;
737c24fc
Z		 3919 } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3920 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
3921 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3922 s2 = s;
3923 while (*s == ' ' || *s == '\t') s++;
3924 if (*s++ == '-') {
3925 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3926 || s2[-1] == '_') s2--;
3927 if (strnEQ(s2-4,"perl",4))
3928 while ((s = moreswitches(s)))
3929 ;
83025b21
LW		 3930 }
3931}
3932
afe37c7d 3933
76e3520e 3934STATIC void
cea2e8a9 3935S_init_ids(pTHX)
352d5a3a 3936{
284167a5
S		 3937 /* no need to do anything here any more if we don't
3938 * do tainting. */
3939#if !NO_TAINT_SUPPORT
97aff369 3940 dVAR;
dfff4baf
BF		 3941 const Uid_t my_uid = PerlProc_getuid();
3942 const Uid_t my_euid = PerlProc_geteuid();
3943 const Gid_t my_gid = PerlProc_getgid();
3944 const Gid_t my_egid = PerlProc_getegid();
985213f2 3945
22f7c9c9 3946 /* Should not happen: */
985213f2 3947 CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
284167a5
S		 3948 TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
3949#endif
ae3f3efd
PS		 3950 /* BUG */
3951 /* PSz 27 Feb 04
3952 * Should go by suidscript, not uid!=euid: why disallow
3953 * system("ls") in scripts run from setuid things?
3954 * Or, is this run before we check arguments and set suidscript?
3955 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3956 * (We never have suidscript, can we be sure to have fdscript?)
3957 * Or must then go by UID checks? See comments in forbid_setid also.
3958 */
748a9306 3959}
79072805 3960
a0643315
JH		 3961/* This is used very early in the lifetime of the program,
3962 * before even the options are parsed, so PL_tainting has
b0891165 3963 * not been initialized properly. */
af419de7 3964bool
8f42b153 3965Perl_doing_taint(int argc, char *argv[], char *envp[])
22f7c9c9 3966{
c3446a78
JH		 3967#ifndef PERL_IMPLICIT_SYS
3968 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3969 * before we have an interpreter-- and the whole point of this
3970 * function is to be called at such an early stage. If you are on
3971 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3972 * "tainted because running with altered effective ids', you'll
3973 * have to add your own checks somewhere in here. The two most
3974 * known samples of 'implicitness' are Win32 and NetWare, neither
3975 * of which has much of concept of 'uids'. */
dfff4baf
BF		 3976 Uid_t uid = PerlProc_getuid();
3977 Uid_t euid = PerlProc_geteuid();
3978 Gid_t gid = PerlProc_getgid();
3979 Gid_t egid = PerlProc_getegid();
6867be6d 3980 (void)envp;
22f7c9c9
JH		 3981
3982#ifdef VMS
af419de7 3983 uid |= gid << 16;
22f7c9c9
JH		 3984 euid |= egid << 16;
3985#endif
3986 if (uid && (euid != uid || egid != gid))
3987 return 1;
c3446a78 3988#endif /* !PERL_IMPLICIT_SYS */
af419de7
JH		 3989 /* This is a really primitive check; environment gets ignored only
3990 * if -T are the first chars together; otherwise one gets
3991 * "Too late" message. */
22f7c9c9
JH		 3992 if ( argc > 1 && argv[1][0] == '-'
3993 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3994 return 1;
3995 return 0;
3996}
22f7c9c9 3997
d0bafe7e
NC		 3998/* Passing the flag as a single char rather than a string is a slight space
3999 optimisation. The only message that isn't /^-.$/ is
4000 "program input from stdin", which is substituted in place of '\0', which
4001 could never be a command line flag. */
76e3520e 4002STATIC void
f20b2998 4003S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
bbce6d69 4004{
97aff369 4005 dVAR;
d0bafe7e
NC		 4006 char string[3] = "-x";
4007 const char *message = "program input from stdin";
4008
4009 if (flag) {
4010 string[1] = flag;
4011 message = string;
4012 }
4013
ae3f3efd 4014#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
985213f2 4015 if (PerlProc_getuid() != PerlProc_geteuid())
d0bafe7e 4016 Perl_croak(aTHX_ "No %s allowed while running setuid", message);
985213f2 4017 if (PerlProc_getgid() != PerlProc_getegid())
d0bafe7e 4018 Perl_croak(aTHX_ "No %s allowed while running setgid", message);
ae3f3efd 4019#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
f20b2998 4020 if (suidscript)
d0bafe7e 4021 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
bbce6d69 4022}
4023
1ee4443e 4024void
5b235299
NC		 4025Perl_init_dbargs(pTHX)
4026{
4027 AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4028 GV_ADDMULTI,
4029 SVt_PVAV))));
4030
4031 if (AvREAL(args)) {
4032 /* Someone has already created it.
4033 It might have entries, and if we just turn off AvREAL(), they will
4034 "leak" until global destruction. */
4035 av_clear(args);
3df49e2a 4036 if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
7355df7e 4037 Perl_croak(aTHX_ "Cannot set tied @DB::args");
5b235299 4038 }
af80dd86 4039 AvREIFY_only(PL_dbargs);
5b235299
NC		 4040}
4041
4042void
1ee4443e 4043Perl_init_debugger(pTHX)
748a9306 4044{
97aff369 4045 dVAR;
c4420975 4046 HV * const ostash = PL_curstash;
1ee4443e 4047
03d9f026 4048 PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
5b235299
NC		 4049
4050 Perl_init_dbargs(aTHX);
8cece913
FC		 4051 PL_DBgv = MUTABLE_GV(
4052 SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4053 );
4054 PL_DBline = MUTABLE_GV(
4055 SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4056 );
4057 PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4058 gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4059 ));
5c1737d1 4060 PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4c0f30d6
NC		 4061 if (!SvIOK(PL_DBsingle))
4062 sv_setiv(PL_DBsingle, 0);
5c1737d1 4063 PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4c0f30d6
NC		 4064 if (!SvIOK(PL_DBtrace))
4065 sv_setiv(PL_DBtrace, 0);
5c1737d1 4066 PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4c0f30d6
NC		 4067 if (!SvIOK(PL_DBsignal))
4068 sv_setiv(PL_DBsignal, 0);
03d9f026 4069 SvREFCNT_dec(PL_curstash);
1ee4443e 4070 PL_curstash = ostash;
352d5a3a
LW		 4071}
4072
2ce36478
SM		 4073#ifndef STRESS_REALLOC
4074#define REASONABLE(size) (size)
4075#else
4076#define REASONABLE(size) (1) /* unreasonable */
4077#endif
4078
11343788 4079void
cea2e8a9 4080Perl_init_stacks(pTHX)
79072805 4081{
97aff369 4082 dVAR;
e336de0d 4083 /* start with 128-item stack and 8K cxstack */
3280af22 4084 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 4085 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 4086 PL_curstackinfo->si_type = PERLSI_MAIN;
4087 PL_curstack = PL_curstackinfo->si_stack;
4088 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 4089
3280af22
NIS		 4090 PL_stack_base = AvARRAY(PL_curstack);
4091 PL_stack_sp = PL_stack_base;
4092 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 4093
a02a5408 4094 Newx(PL_tmps_stack,REASONABLE(128),SV*);
3280af22
NIS		 4095 PL_tmps_floor = -1;
4096 PL_tmps_ix = -1;
4097 PL_tmps_max = REASONABLE(128);
8990e307 4098
a02a5408 4099 Newx(PL_markstack,REASONABLE(32),I32);
3280af22
NIS		 4100 PL_markstack_ptr = PL_markstack;
4101 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 4102
ce2f7c3b 4103 SET_MARK_OFFSET;
e336de0d 4104
a02a5408 4105 Newx(PL_scopestack,REASONABLE(32),I32);
d343c3ef
GG		 4106#ifdef DEBUGGING
4107 Newx(PL_scopestack_name,REASONABLE(32),const char*);
4108#endif
3280af22
NIS		 4109 PL_scopestack_ix = 0;
4110 PL_scopestack_max = REASONABLE(32);
79072805 4111
a02a5408 4112 Newx(PL_savestack,REASONABLE(128),ANY);
3280af22
NIS		 4113 PL_savestack_ix = 0;
4114 PL_savestack_max = REASONABLE(128);
378cc40b 4115}
33b78306 4116
2ce36478
SM		 4117#undef REASONABLE
4118
76e3520e 4119STATIC void
cea2e8a9 4120S_nuke_stacks(pTHX)
6e72f9df 4121{
97aff369 4122 dVAR;
3280af22
NIS		 4123 while (PL_curstackinfo->si_next)
4124 PL_curstackinfo = PL_curstackinfo->si_next;
4125 while (PL_curstackinfo) {
4126 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 4127 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 4128 Safefree(PL_curstackinfo->si_cxstack);
4129 Safefree(PL_curstackinfo);
4130 PL_curstackinfo = p;
e336de0d 4131 }
3280af22
NIS		 4132 Safefree(PL_tmps_stack);
4133 Safefree(PL_markstack);
4134 Safefree(PL_scopestack);
58780814
GG		 4135#ifdef DEBUGGING
4136 Safefree(PL_scopestack_name);
4137#endif
3280af22 4138 Safefree(PL_savestack);
378cc40b 4139}
33b78306 4140
74e8ce34
NC		 4141void
4142Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4143{
4144 GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4145 AV *const isa = GvAVn(gv);
4146 va_list args;
4147
4148 PERL_ARGS_ASSERT_POPULATE_ISA;
4149
4150 if(AvFILLp(isa) != -1)
4151 return;
4152
4153 /* NOTE: No support for tied ISA */
4154
4155 va_start(args, len);
4156 do {
4157 const char *const parent = va_arg(args, const char*);
4158 size_t parent_len;
4159
4160 if (!parent)
4161 break;
4162 parent_len = va_arg(args, size_t);
4163
4164 /* Arguments are supplied with a trailing :: */
4165 assert(parent_len > 2);
4166 assert(parent[parent_len - 1] == ':');
4167 assert(parent[parent_len - 2] == ':');
4168 av_push(isa, newSVpvn(parent, parent_len - 2));
4169 (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4170 } while (1);
4171 va_end(args);
4172}
4173
8990e307 4174
76e3520e 4175STATIC void
cea2e8a9 4176S_init_predump_symbols(pTHX)
45d8adaa 4177{
97aff369 4178 dVAR;
93a17b20 4179 GV *tmpgv;
af8c498a 4180 IO *io;
79072805 4181
64ace3f8 4182 sv_setpvs(get_sv("\"", GV_ADD), " ");
e23d9e2f
CS		 4183 PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4184
d963bf01
NC		 4185
4186 /* Historically, PVIOs were blessed into IO::Handle, unless
4187 FileHandle was loaded, in which case they were blessed into
4188 that. Action at a distance.
4189 However, if we simply bless into IO::Handle, we break code
4190 that assumes that PVIOs will have (among others) a seek
4191 method. IO::File inherits from IO::Handle and IO::Seekable,
4192 and provides the needed methods. But if we simply bless into
4193 it, then we break code that assumed that by loading
4194 IO::Handle, *it* would work.
4195 So a compromise is to set up the correct @IO::File::ISA,
4196 so that code that does C<use IO::Handle>; will still work.
4197 */
4198
74e8ce34
NC		 4199 Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4200 STR_WITH_LEN("IO::Handle::"),
4201 STR_WITH_LEN("IO::Seekable::"),
4202 STR_WITH_LEN("Exporter::"),
4203 NULL);
d963bf01 4204
fafc274c 4205 PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3280af22 4206 GvMULTI_on(PL_stdingv);
af8c498a 4207 io = GvIOp(PL_stdingv);
a04651f4 4208 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 4209 IoIFP(io) = PerlIO_stdin();
fafc274c 4210 tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
a5f75d66 4211 GvMULTI_on(tmpgv);
a45c7426 4212 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
79072805 4213
fafc274c 4214 tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
a5f75d66 4215 GvMULTI_on(tmpgv);
af8c498a 4216 io = GvIOp(tmpgv);
a04651f4 4217 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 4218 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 4219 setdefout(tmpgv);
fafc274c 4220 tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
a5f75d66 4221 GvMULTI_on(tmpgv);
a45c7426 4222 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
79072805 4223
fafc274c 4224 PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
bf49b057
GS		 4225 GvMULTI_on(PL_stderrgv);
4226 io = GvIOp(PL_stderrgv);
a04651f4 4227 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 4228 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
fafc274c 4229 tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
a5f75d66 4230 GvMULTI_on(tmpgv);
a45c7426 4231 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
79072805 4232
de61bf2a 4233 PL_statname = newSVpvs(""); /* last filename we did stat on */
79072805 4234}
33b78306 4235
a11ec5a9 4236void
5aaab254 4237Perl_init_argv_symbols(pTHX_ int argc, char **argv)
33b78306 4238{
97aff369 4239 dVAR;
7918f24d
NC		 4240
4241 PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4242
79072805 4243 argc--,argv++; /* skip name of script */
3280af22 4244 if (PL_doswitches) {
79072805 4245 for (; argc > 0 && **argv == '-'; argc--,argv++) {
aec46f14 4246 char *s;
79072805
LW		 4247 if (!argv[0][1])
4248 break;
379d538a 4249 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 4250 argc--,argv++;
4251 break;
4252 }
155aba94 4253 if ((s = strchr(argv[0], '='))) {
b3d904f3
NC		 4254 const char *const start_name = argv[0] + 1;
4255 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4256 TRUE, SVt_PV)), s + 1);
79072805
LW		 4257 }
4258 else
71315bf2 4259 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
fe14fcc3 4260 }
79072805 4261 }
fafc274c 4262 if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
a11ec5a9 4263 GvMULTI_on(PL_argvgv);
a11ec5a9
RGS		 4264 av_clear(GvAVn(PL_argvgv));
4265 for (; argc > 0; argc--,argv++) {
aec46f14 4266 SV * const sv = newSVpv(argv[0],0);
b188953e 4267 av_push(GvAV(PL_argvgv),sv);
ce81ff12
JH		 4268 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4269 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4270 SvUTF8_on(sv);
4271 }
a05d7ebb
JH		 4272 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4273 (void)sv_utf8_decode(sv);
a11ec5a9
RGS		 4274 }
4275 }
82f96200
JL		 4276
4277 if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4278 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4279 "-i used with no filenames on the command line, "
4280 "reading from STDIN");
a11ec5a9
RGS		 4281}
4282
4283STATIC void
5aaab254 4284S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
a11ec5a9 4285{
27da23d5 4286 dVAR;
a11ec5a9 4287 GV* tmpgv;
a11ec5a9 4288
7918f24d
NC		 4289 PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4290
f2da823f 4291 PL_toptarget = newSV_type(SVt_PVIV);
76f68e9b 4292 sv_setpvs(PL_toptarget, "");
f2da823f 4293 PL_bodytarget = newSV_type(SVt_PVIV);
76f68e9b 4294 sv_setpvs(PL_bodytarget, "");
3280af22 4295 PL_formtarget = PL_bodytarget;
79072805 4296
bbce6d69 4297 TAINT;
a11ec5a9
RGS		 4298
4299 init_argv_symbols(argc,argv);
4300
fafc274c 4301 if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
3280af22 4302 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 4303 }
fafc274c 4304 if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
79072805 4305 HV *hv;
e17132c1 4306 bool env_is_not_environ;
cf93a474 4307 SvREFCNT_inc_simple_void_NN(PL_envgv);
3280af22
NIS		 4308 GvMULTI_on(PL_envgv);
4309 hv = GvHVn(PL_envgv);
a0714e2c 4310 hv_magic(hv, NULL, PERL_MAGIC_env);
2f42fcb0 4311#ifndef PERL_MICRO
fa6a1c44 4312#ifdef USE_ENVIRON_ARRAY
4633a7c4
LW		 4313 /* Note that if the supplied env parameter is actually a copy
4314 of the global environ then it may now point to free'd memory
4315 if the environment has been modified since. To avoid this
4316 problem we treat env==NULL as meaning 'use the default'
4317 */
4318 if (!env)
4319 env = environ;
e17132c1
JD		 4320 env_is_not_environ = env != environ;
4321 if (env_is_not_environ
4efc5df6
GS		 4322# ifdef USE_ITHREADS
4323 && PL_curinterp == aTHX
4324# endif
4325 )
4326 {
bd61b366 4327 environ[0] = NULL;
4efc5df6 4328 }
9b4eeda5 4329 if (env) {
9d27dca9 4330 char *s, *old_var;
27da23d5 4331 SV *sv;
764df951 4332 for (; *env; env++) {
9d27dca9
MT		 4333 old_var = *env;
4334
4335 if (!(s = strchr(old_var,'=')) || s == old_var)
79072805 4336 continue;
9d27dca9 4337
7da0e383 4338#if defined(MSDOS) && !defined(DJGPP)
61968511 4339 *s = '\0';
9d27dca9 4340 (void)strupr(old_var);
61968511 4341 *s = '=';
137443ea 4342#endif
61968511 4343 sv = newSVpv(s+1, 0);
9d27dca9 4344 (void)hv_store(hv, old_var, s - old_var, sv, 0);
e17132c1 4345 if (env_is_not_environ)
61968511 4346 mg_set(sv);
764df951 4347 }
9b4eeda5 4348 }
103a7189 4349#endif /* USE_ENVIRON_ARRAY */
2f42fcb0 4350#endif /* !PERL_MICRO */
79072805 4351 }
bbce6d69 4352 TAINT_NOT;
2710853f
MJD		 4353
4354 /* touch @F array to prevent spurious warnings 20020415 MJD */
4355 if (PL_minus_a) {
cbfd0a87 4356 (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
2710853f 4357 }
33b78306 4358}
34de22dd 4359
76e3520e 4360STATIC void
2cace6ac 4361S_init_perllib(pTHX)
34de22dd 4362{
97aff369 4363 dVAR;
32910c7a 4364#ifndef VMS
929e5b34 4365 const char *perl5lib = NULL;
32910c7a 4366#endif
35ba5ce9 4367 const char *s;
a7560424 4368#if defined(WIN32) && !defined(PERL_IS_MINIPERL)
e6a0bbf8
NC		 4369 STRLEN len;
4370#endif
4371
284167a5 4372 if (!TAINTING_get) {
552a7a9b 4373#ifndef VMS
32910c7a 4374 perl5lib = PerlEnv_getenv("PERL5LIB");
88f5bc07
AB		 4375/*
4376 * It isn't possible to delete an environment variable with
42a3dd3a
RGS		 4377 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4378 * case we treat PERL5LIB as undefined if it has a zero-length value.
88f5bc07
AB		 4379 */
4380#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
32910c7a 4381 if (perl5lib && *perl5lib != '\0')
88f5bc07 4382#else
32910c7a 4383 if (perl5lib)
88f5bc07 4384#endif
32910c7a 4385 incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
2cace6ac 4386 else {
4705144d
NC		 4387 s = PerlEnv_getenv("PERLLIB");
4388 if (s)
50d61629 4389 incpush_use_sep(s, 0, 0);
4705144d 4390 }
552a7a9b 4391#else /* VMS */
4392 /* Treat PERL5?LIB as a possible search list logical name -- the
4393 * "natural" VMS idiom for a Unix path string. We allow each
4394 * element to be a set of |-separated directories for compatibility.
4395 */
4396 char buf[256];
4397 int idx = 0;
4398 if (my_trnlnm("PERL5LIB",buf,0))
e28f3139 4399 do {
2cace6ac 4400 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
e28f3139 4401 } while (my_trnlnm("PERL5LIB",buf,++idx));
f05b5874 4402 else {
e28f3139 4403 while (my_trnlnm("PERLLIB",buf,idx++))
50d61629 4404 incpush_use_sep(buf, 0, 0);
f05b5874 4405 }
552a7a9b 4406#endif /* VMS */
85e6fe83 4407 }
34de22dd 4408
b0e687f7
NC		 4409#ifndef PERL_IS_MINIPERL
4410 /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4411 (and not the architecture specific directories from $ENV{PERL5LIB}) */
4412
c90c0ff4 4413/* Use the ~-expanded versions of APPLLIB (undocumented),
826e305c 4414 SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
df5cef82 4415*/
4633a7c4 4416#ifdef APPLLIB_EXP
be71fc8f
NC		 4417 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4418 INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
16d20bd9 4419#endif
4633a7c4 4420
65f19062 4421#ifdef SITEARCH_EXP
3b290362
GS		 4422 /* sitearch is always relative to sitelib on Windows for
4423 * DLL-based path intuition to work correctly */
4424# if !defined(WIN32)
be71fc8f
NC		 4425 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4426 INCPUSH_CAN_RELOCATE);
65f19062
GS		 4427# endif
4428#endif
4429
4633a7c4 4430#ifdef SITELIB_EXP
65f19062 4431# if defined(WIN32)
574c798a 4432 /* this picks up sitearch as well */
e6a0bbf8 4433 s = win32_get_sitelib(PERL_FS_VERSION, &len);
1fa74d9f 4434 if (s)
e6a0bbf8 4435 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
65f19062 4436# else
50d61629 4437 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
65f19062
GS		 4438# endif
4439#endif
189d1e8d 4440
65f19062 4441#ifdef PERL_VENDORARCH_EXP
4ea817c6 4442 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS		 4443 * DLL-based path intuition to work correctly */
4444# if !defined(WIN32)
be71fc8f
NC		 4445 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4446 INCPUSH_CAN_RELOCATE);
65f19062 4447# endif
4b03c463 4448#endif
65f19062
GS		 4449
4450#ifdef PERL_VENDORLIB_EXP
4451# if defined(WIN32)
e28f3139 4452 /* this picks up vendorarch as well */
e6a0bbf8 4453 s = win32_get_vendorlib(PERL_FS_VERSION, &len);
1fa74d9f 4454 if (s)
e6a0bbf8 4455 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
65f19062 4456# else
be71fc8f
NC		 4457 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4458 INCPUSH_CAN_RELOCATE);
65f19062 4459# endif
a3635516 4460#endif
65f19062 4461
b9ba2fad 4462#ifdef ARCHLIB_EXP
2cace6ac 4463 S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
b9ba2fad
NC		 4464#endif
4465
4466#ifndef PRIVLIB_EXP
4467# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4468#endif
4469
4470#if defined(WIN32)
2cace6ac
NC		 4471 s = win32_get_privlib(PERL_FS_VERSION, &len);
4472 if (s)
4473 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
b9ba2fad 4474#else
04c9eecc 4475# ifdef NETWARE
2cace6ac 4476 S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
04c9eecc 4477# else
2cace6ac 4478 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
04c9eecc 4479# endif
b9ba2fad
NC		 4480#endif
4481
3b777bb4 4482#ifdef PERL_OTHERLIBDIRS
1e3208d8
NC		 4483 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4484 INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
2cace6ac
NC		 4485 |INCPUSH_CAN_RELOCATE);
4486#endif
2cace6ac 4487
284167a5 4488 if (!TAINTING_get) {
2cace6ac 4489#ifndef VMS
2cace6ac
NC		 4490/*
4491 * It isn't possible to delete an environment variable with
4492 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4493 * case we treat PERL5LIB as undefined if it has a zero-length value.
4494 */
4495#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
32910c7a 4496 if (perl5lib && *perl5lib != '\0')
2cace6ac 4497#else
32910c7a 4498 if (perl5lib)
2cace6ac 4499#endif
32910c7a
NC		 4500 incpush_use_sep(perl5lib, 0,
4501 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
2cace6ac
NC		 4502#else /* VMS */
4503 /* Treat PERL5?LIB as a possible search list logical name -- the
4504 * "natural" VMS idiom for a Unix path string. We allow each
4505 * element to be a set of |-separated directories for compatibility.
4506 */
4507 char buf[256];
4508 int idx = 0;
4509 if (my_trnlnm("PERL5LIB",buf,0))
4510 do {
be71fc8f
NC		 4511 incpush_use_sep(buf, 0,
4512 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
2cace6ac
NC		 4513 } while (my_trnlnm("PERL5LIB",buf,++idx));
4514#endif /* VMS */
a26c0e28 4515 }
2cace6ac
NC		 4516
4517/* Use the ~-expanded versions of APPLLIB (undocumented),
826e305c 4518 SITELIB and VENDORLIB for older versions
2cace6ac
NC		 4519*/
4520#ifdef APPLLIB_EXP
be71fc8f
NC		 4521 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4522 |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
2cace6ac
NC		 4523#endif
4524
2cace6ac
NC		 4525#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4526 /* Search for version-specific dirs below here */
be71fc8f
NC		 4527 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4528 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
2cace6ac
NC		 4529#endif
4530
4531
4532#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4533 /* Search for version-specific dirs below here */
be71fc8f
NC		 4534 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4535 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
2cace6ac
NC		 4536#endif
4537
4538#ifdef PERL_OTHERLIBDIRS
1e3208d8
NC		 4539 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4540 INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4541 |INCPUSH_CAN_RELOCATE);
3b777bb4 4542#endif
b0e687f7 4543#endif /* !PERL_IS_MINIPERL */
3b777bb4 4544
284167a5 4545 if (!TAINTING_get)
55b4bc1c 4546 S_incpush(aTHX_ STR_WITH_LEN("."), 0);
774d564b 4547}
4548
739a0b84 4549#if defined(DOSISH) || defined(__SYMBIAN32__)
774d564b 4550# define PERLLIB_SEP ';'
4551#else
4552# if defined(VMS)
4553# define PERLLIB_SEP '|'
4554# else
e37778c2 4555# define PERLLIB_SEP ':'
774d564b 4556# endif
4557#endif
4558#ifndef PERLLIB_MANGLE
4559# define PERLLIB_MANGLE(s,n) (s)
ac27b0f5 4560#endif
774d564b 4561
59d6f6a4 4562#ifndef PERL_IS_MINIPERL
ad17a1ae
NC		 4563/* Push a directory onto @INC if it exists.
4564 Generate a new SV if we do this, to save needing to copy the SV we push
4565 onto @INC */
4566STATIC SV *
7ffdaae6 4567S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
ad17a1ae 4568{
97aff369 4569 dVAR;
ad17a1ae 4570 Stat_t tmpstatbuf;
7918f24d
NC		 4571
4572 PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4573
848ef955 4574 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
ad17a1ae 4575 S_ISDIR(tmpstatbuf.st_mode)) {
3a9a9ba7 4576 av_push(av, dir);
7ffdaae6
NC		 4577 dir = newSVsv(stem);
4578 } else {
4579 /* Truncate dir back to stem. */
4580 SvCUR_set(dir, SvCUR(stem));
ad17a1ae
NC		 4581 }
4582 return dir;
4583}
59d6f6a4 4584#endif
ad17a1ae 4585
c29067d7
CH		 4586STATIC SV *
4587S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
774d564b 4588{
6434436b 4589 const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
c29067d7 4590 SV *libdir;
774d564b 4591
c29067d7 4592 PERL_ARGS_ASSERT_MAYBERELOCATE;
08d0d8ab 4593 assert(len > 0);
3a9a9ba7 4594
d2898d73
EB		 4595 /* I am not convinced that this is valid when PERLLIB_MANGLE is
4596 defined to so something (in os2/os2.c), but the code has been
4597 this way, ignoring any possible changed of length, since
4598 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4599 it be. */
4600 libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
774d564b 4601
81600524 4602#ifdef VMS
db12e2d3 4603 {
81600524 4604 char *unix;
81600524
CB		 4605
4606 if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4607 len = strlen(unix);
4608 while (unix[len-1] == '/') len--; /* Cosmetic */
4609 sv_usepvn(libdir,unix,len);
4610 }
4611 else
4612 PerlIO_printf(Perl_error_log,
4613 "Failed to unixify @INC element \"%s\"\n",
9dfa9235 4614 SvPV_nolen_const(libdir));
db12e2d3 4615 }
81600524
CB		 4616#endif
4617
dd374669
AL		 4618 /* Do the if() outside the #ifdef to avoid warnings about an unused
4619 parameter. */
4620 if (canrelocate) {
88fe16b2
NC		 4621#ifdef PERL_RELOCATABLE_INC
4622 /*
4623 * Relocatable include entries are marked with a leading .../
4624 *
4625 * The algorithm is
4626 * 0: Remove that leading ".../"
4627 * 1: Remove trailing executable name (anything after the last '/')
4628 * from the perl path to give a perl prefix
4629 * Then
4630 * While the @INC element starts "../" and the prefix ends with a real
4631 * directory (ie not . or ..) chop that real directory off the prefix
4632 * and the leading "../" from the @INC element. ie a logical "../"
4633 * cleanup
4634 * Finally concatenate the prefix and the remainder of the @INC element
4635 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4636 * generates /usr/local/lib/perl5
4637 */
890ce7af 4638 const char *libpath = SvPVX(libdir);
88fe16b2
NC		 4639 STRLEN libpath_len = SvCUR(libdir);
4640 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4641 /* Game on! */
890ce7af 4642 SV * const caret_X = get_sv("\030", 0);
88fe16b2
NC		 4643 /* Going to use the SV just as a scratch buffer holding a C
4644 string: */
4645 SV *prefix_sv;
4646 char *prefix;
4647 char *lastslash;
4648
4649 /* $^X is *the* source of taint if tainting is on, hence
4650 SvPOK() won't be true. */
4651 assert(caret_X);
4652 assert(SvPOKp(caret_X));
a663657d
NC		 4653 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4654 SvUTF8(caret_X));
88fe16b2
NC		 4655 /* Firstly take off the leading .../
4656 If all else fail we'll do the paths relative to the current
4657 directory. */
4658 sv_chop(libdir, libpath + 4);
4659 /* Don't use SvPV as we're intentionally bypassing taining,
4660 mortal copies that the mg_get of tainting creates, and
4661 corruption that seems to come via the save stack.
4662 I guess that the save stack isn't correctly set up yet. */
4663 libpath = SvPVX(libdir);
4664 libpath_len = SvCUR(libdir);
4665
4666 /* This would work more efficiently with memrchr, but as it's
4667 only a GNU extension we'd need to probe for it and
4668 implement our own. Not hard, but maybe not worth it? */
4669
4670 prefix = SvPVX(prefix_sv);
4671 lastslash = strrchr(prefix, '/');
4672
4673 /* First time in with the *lastslash = '\0' we just wipe off
4674 the trailing /perl from (say) /usr/foo/bin/perl
4675 */
4676 if (lastslash) {
4677 SV *tempsv;
4678 while ((*lastslash = '\0'), /* Do that, come what may. */
4679 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4680 && (lastslash = strrchr(prefix, '/')))) {
4681 if (lastslash[1] == '\0'
4682 || (lastslash[1] == '.'
4683 && (lastslash[2] == '/' /* ends "/." */
4684 || (lastslash[2] == '/'
4685 && lastslash[3] == '/' /* or "/.." */
4686 )))) {
4687 /* Prefix ends "/" or "/." or "/..", any of which
4688 are fishy, so don't do any more logical cleanup.
4689 */
4690 break;
4691 }
4692 /* Remove leading "../" from path */
4693 libpath += 3;
4694 libpath_len -= 3;
4695 /* Next iteration round the loop removes the last
4696 directory name from prefix by writing a '\0' in
4697 the while clause. */
4698 }
4699 /* prefix has been terminated with a '\0' to the correct
4700 length. libpath points somewhere into the libdir SV.
4701 We need to join the 2 with '/' and drop the result into
4702 libdir. */
4703 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4704 SvREFCNT_dec(libdir);
4705 /* And this is the new libdir. */
4706 libdir = tempsv;
284167a5 4707 if (TAINTING_get &&
985213f2
AB		 4708 (PerlProc_getuid() != PerlProc_geteuid() ||
4709 PerlProc_getgid() != PerlProc_getegid())) {
486ec47a 4710 /* Need to taint relocated paths if running set ID */
88fe16b2
NC		 4711 SvTAINTED_on(libdir);
4712 }
4713 }
4714 SvREFCNT_dec(prefix_sv);
4715 }
88fe16b2 4716#endif
dd374669 4717 }
c29067d7 4718 return libdir;
c29067d7
CH		 4719}
4720
4721STATIC void
4722S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4723{
4724 dVAR;
4725#ifndef PERL_IS_MINIPERL
4726 const U8 using_sub_dirs
4727 = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4728 |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4729 const U8 add_versioned_sub_dirs
4730 = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4731 const U8 add_archonly_sub_dirs
4732 = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4733#ifdef PERL_INC_VERSION_LIST
4734 const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
4735#endif
4736#endif
4737 const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
4738 const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4739 AV *const inc = GvAVn(PL_incgv);
4740
4741 PERL_ARGS_ASSERT_INCPUSH;
4742 assert(len > 0);
4743
4744 /* Could remove this vestigial extra block, if we don't mind a lot of
4745 re-indenting diff noise. */
4746 {
5a702b9a 4747 SV *const libdir = mayberelocate(dir, len, flags);
c29067d7
CH		 4748 /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4749 arranged to unshift #! line -I onto the front of @INC. However,
4750 -I can add version and architecture specific libraries, and they
4751 need to go first. The old code assumed that it was always
4752 pushing. Hence to make it work, need to push the architecture
4753 (etc) libraries onto a temporary array, then "unshift" that onto
4754 the front of @INC. */
4755#ifndef PERL_IS_MINIPERL
4756 AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
c29067d7 4757
774d564b 4758 /*
4759 * BEFORE pushing libdir onto @INC we may first push version- and
4760 * archname-specific sub-directories.
4761 */
ee80e7be 4762 if (using_sub_dirs) {
5a702b9a 4763 SV *subdir = newSVsv(libdir);
29d82f8d 4764#ifdef PERL_INC_VERSION_LIST
8353b874 4765 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
c4420975
AL		 4766 const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4767 const char * const *incver;
29d82f8d 4768#endif
7ffdaae6 4769
1e3208d8 4770 if (add_versioned_sub_dirs) {
9c8a64f0 4771 /* .../version/archname if -d .../version/archname */
e51b748d 4772 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
7ffdaae6 4773 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4b03c463 4774
9c8a64f0 4775 /* .../version if -d .../version */
e51b748d 4776 sv_catpvs(subdir, "/" PERL_FS_VERSION);
7ffdaae6 4777 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
29d82f8d 4778 }
9c8a64f0 4779
9c8a64f0 4780#ifdef PERL_INC_VERSION_LIST
ccc2aad8 4781 if (addoldvers) {
9c8a64f0
GS		 4782 for (incver = incverlist; *incver; incver++) {
4783 /* .../xxx if -d .../xxx */
e51b748d 4784 Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
7ffdaae6 4785 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
9c8a64f0
GS		 4786 }
4787 }
29d82f8d 4788#endif
c992324b 4789
1e3208d8 4790 if (add_archonly_sub_dirs) {
c992324b 4791 /* .../archname if -d .../archname */
e51b748d 4792 sv_catpvs(subdir, "/" ARCHNAME);
7ffdaae6 4793 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
c992324b
NC		 4794
4795 }
10cc20f6
NC		 4796
4797 assert (SvREFCNT(subdir) == 1);
4798 SvREFCNT_dec(subdir);
774d564b 4799 }
59d6f6a4 4800#endif /* !PERL_IS_MINIPERL */
20189146
RGS		 4801 /* finally add this lib directory at the end of @INC */
4802 if (unshift) {
76895e89 4803#ifdef PERL_IS_MINIPERL
c70927a6 4804 const Size_t extra = 0;
76895e89 4805#else
c70927a6 4806 Size_t extra = av_len(av) + 1;
76895e89 4807#endif
a26c0e28
NC		 4808 av_unshift(inc, extra + push_basedir);
4809 if (push_basedir)
4810 av_store(inc, extra, libdir);
76895e89 4811#ifndef PERL_IS_MINIPERL
3a9a9ba7
NC		 4812 while (extra--) {
4813 /* av owns a reference, av_store() expects to be donated a
4814 reference, and av expects to be sane when it's cleared.
4815 If I wanted to be naughty and wrong, I could peek inside the
4816 implementation of av_clear(), realise that it uses
4817 SvREFCNT_dec() too, so av's array could be a run of NULLs,
4818 and so directly steal from it (with a memcpy() to inc, and
4819 then memset() to NULL them out. But people copy code from the
4820 core expecting it to be best practise, so let's use the API.
4821 Although studious readers will note that I'm not checking any
4822 return codes. */
4823 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4824 }
4825 SvREFCNT_dec(av);
59d6f6a4 4826#endif
20189146 4827 }
a26c0e28 4828 else if (push_basedir) {
3a9a9ba7 4829 av_push(inc, libdir);
20189146 4830 }
a26c0e28
NC		 4831
4832 if (!push_basedir) {
4833 assert (SvREFCNT(libdir) == 1);
4834 SvREFCNT_dec(libdir);
4835 }
774d564b 4836 }
34de22dd 4837}
93a17b20 4838
55b4bc1c 4839STATIC void
50d61629 4840S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
55b4bc1c 4841{
50d61629
NC		 4842 const char *s;
4843 const char *end;
55b4bc1c
NC		 4844 /* This logic has been broken out from S_incpush(). It may be possible to
4845 simplify it. */
4846
4705144d
NC		 4847 PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4848
f31c6eed
JD		 4849 /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
4850 * argument to incpush_use_sep. This allows creation of relocatable
4851 * Perl distributions that patch the binary at install time. Those
4852 * distributions will have to provide their own relocation tools; this
4853 * is not a feature otherwise supported by core Perl.
4854 */
4855#ifndef PERL_RELOCATABLE_INCPUSH
50d61629 4856 if (!len)
f31c6eed 4857#endif
50d61629
NC		 4858 len = strlen(p);
4859
4860 end = p + len;
4861
55b4bc1c 4862 /* Break at all separators */
e42f52dd 4863 while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
50d61629
NC		 4864 if (s == p) {
4865 /* skip any consecutive separators */
55b4bc1c 4866
55b4bc1c 4867 /* Uncomment the next line for PATH semantics */
50d61629 4868 /* But you'll need to write tests */
55b4bc1c 4869 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
50d61629 4870 } else {
55b4bc1c 4871 incpush(p, (STRLEN)(s - p), flags);
55b4bc1c 4872 }
50d61629 4873 p = s + 1;
55b4bc1c 4874 }
50d61629
NC		 4875 if (p != end)
4876 incpush(p, (STRLEN)(end - p), flags);
4877
55b4bc1c 4878}
199100c8 4879
93a17b20 4880void
864dbfa3 4881Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 4882{
27da23d5 4883 dVAR;
971a9dd3 4884 SV *atsv;
5f40764f 4885 volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
312caa8e 4886 CV *cv;
22921e25 4887 STRLEN len;
6224f72b 4888 int ret;
db36c5a1 4889 dJMPENV;
93a17b20 4890
7918f24d
NC		 4891 PERL_ARGS_ASSERT_CALL_LIST;
4892
e1ec3a88 4893 while (av_len(paramList) >= 0) {
ea726b52 4894 cv = MUTABLE_CV(av_shift(paramList));
ece599bd
RGS		 4895 if (PL_savebegin) {
4896 if (paramList == PL_beginav) {
059a8bb7 4897 /* save PL_beginav for compiler */
ad64d0ec 4898 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
ece599bd
RGS		 4899 }
4900 else if (paramList == PL_checkav) {
4901 /* save PL_checkav for compiler */
ad64d0ec 4902 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
ece599bd 4903 }
3c10abe3
AG		 4904 else if (paramList == PL_unitcheckav) {
4905 /* save PL_unitcheckav for compiler */
ad64d0ec 4906 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
3c10abe3 4907 }
059a8bb7 4908 } else {
81d86705
NC		 4909 if (!PL_madskills)
4910 SAVEFREESV(cv);
059a8bb7 4911 }
14dd3ad8 4912 JMPENV_PUSH(ret);
6224f72b 4913 switch (ret) {
312caa8e 4914 case 0:
81d86705
NC		 4915#ifdef PERL_MAD
4916 if (PL_madskills)
4917 PL_madskills |= 16384;
4918#endif
d6f07c05 4919 CALL_LIST_BODY(cv);
81d86705
NC		 4920#ifdef PERL_MAD
4921 if (PL_madskills)
4922 PL_madskills &= ~16384;
4923#endif
971a9dd3 4924 atsv = ERRSV;
10516c54 4925 (void)SvPV_const(atsv, len);
312caa8e
CS		 4926 if (len) {
4927 PL_curcop = &PL_compiling;
57843af0 4928 CopLINE_set(PL_curcop, oldline);
312caa8e 4929 if (paramList == PL_beginav)
396482e1 4930 sv_catpvs(atsv, "BEGIN failed--compilation aborted");
312caa8e 4931 else
4f25aa18
GS		 4932 Perl_sv_catpvf(aTHX_ atsv,
4933 "%s failed--call queue aborted",
7d30b5c4 4934 paramList == PL_checkav ? "CHECK"
4f25aa18 4935 : paramList == PL_initav ? "INIT"
3c10abe3 4936 : paramList == PL_unitcheckav ? "UNITCHECK"
4f25aa18 4937 : "END");
312caa8e
CS		 4938 while (PL_scopestack_ix > oldscope)
4939 LEAVE;
14dd3ad8 4940 JMPENV_POP;
be2597df 4941 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
a0d0e21e 4942 }
85e6fe83 4943 break;
6224f72b 4944 case 1:
f86702cc 4945 STATUS_ALL_FAILURE;
85e6fe83 4946 /* FALL THROUGH */
6224f72b 4947 case 2:
85e6fe83 4948 /* my_exit() was called */
3280af22 4949 while (PL_scopestack_ix > oldscope)
2ae324a7 4950 LEAVE;
84902520 4951 FREETMPS;
03d9f026 4952 SET_CURSTASH(PL_defstash);
3280af22 4953 PL_curcop = &PL_compiling;
57843af0 4954 CopLINE_set(PL_curcop, oldline);
14dd3ad8 4955 JMPENV_POP;
f86702cc 4956 my_exit_jump();
118e2215 4957 assert(0); /* NOTREACHED */
6224f72b 4958 case 3:
312caa8e
CS		 4959 if (PL_restartop) {
4960 PL_curcop = &PL_compiling;
57843af0 4961 CopLINE_set(PL_curcop, oldline);
312caa8e 4962 JMPENV_JUMP(3);
85e6fe83 4963 }
5637ef5b 4964 PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
312caa8e
CS		 4965 FREETMPS;
4966 break;
8990e307 4967 }
14dd3ad8 4968 JMPENV_POP;
93a17b20 4969 }
93a17b20 4970}
93a17b20 4971
f86702cc 4972void
864dbfa3 4973Perl_my_exit(pTHX_ U32 status)
f86702cc 4974{
97aff369 4975 dVAR;
6136213b
JGM		 4976 if (PL_exit_flags & PERL_EXIT_ABORT) {
4977 abort();
4978 }
4979 if (PL_exit_flags & PERL_EXIT_WARN) {
4980 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
4981 Perl_warn(aTHX_ "Unexpected exit %u", status);
4982 PL_exit_flags &= ~PERL_EXIT_ABORT;
4983 }
f86702cc 4984 switch (status) {
4985 case 0:
4986 STATUS_ALL_SUCCESS;
4987 break;
4988 case 1:
4989 STATUS_ALL_FAILURE;
4990 break;
4991 default:
6ac6a52b 4992 STATUS_EXIT_SET(status);
f86702cc 4993 break;
4994 }
4995 my_exit_jump();
4996}
4997
4998void
864dbfa3 4999Perl_my_failure_exit(pTHX)
f86702cc 5000{
97aff369 5001 dVAR;
f86702cc 5002#ifdef VMS
fb38d079
JM		 5003 /* We have been called to fall on our sword. The desired exit code
5004 * should be already set in STATUS_UNIX, but could be shifted over
0968cdad
JM		 5005 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
5006 * that code is set.
fb38d079
JM		 5007 *
5008 * If an error code has not been set, then force the issue.
5009 */
0968cdad
JM		 5010 if (MY_POSIX_EXIT) {
5011
e08e1e1d
JM		 5012 /* According to the die_exit.t tests, if errno is non-zero */
5013 /* It should be used for the error status. */
0968cdad 5014
e08e1e1d
JM		 5015 if (errno == EVMSERR) {
5016 STATUS_NATIVE = vaxc$errno;
5017 } else {
0968cdad 5018
e08e1e1d
JM		 5019 /* According to die_exit.t tests, if the child_exit code is */
5020 /* also zero, then we need to exit with a code of 255 */
5021 if ((errno != 0) && (errno < 256))
5022 STATUS_UNIX_EXIT_SET(errno);
5023 else if (STATUS_UNIX < 255) {
0968cdad 5024 STATUS_UNIX_EXIT_SET(255);
e08e1e1d
JM		 5025 }
5026
0968cdad 5027 }
e08e1e1d
JM		 5028
5029 /* The exit code could have been set by $? or vmsish which
5030 * means that it may not have fatal set. So convert
5031 * success/warning codes to fatal with out changing
5032 * the POSIX status code. The severity makes VMS native
5033 * status handling work, while UNIX mode programs use the
5034 * the POSIX exit codes.
5035 */
5036 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
5037 STATUS_NATIVE &= STS$M_COND_ID;
5038 STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
5039 }
0968cdad
JM		 5040 }
5041 else {
5042 /* Traditionally Perl on VMS always expects a Fatal Error. */
5043 if (vaxc$errno & 1) {
5044
5045 /* So force success status to failure */
5046 if (STATUS_NATIVE & 1)
5047 STATUS_ALL_FAILURE;
5048 }
5049 else {
5050 if (!vaxc$errno) {
5051 STATUS_UNIX = EINTR; /* In case something cares */
5052 STATUS_ALL_FAILURE;
5053 }
5054 else {
5055 int severity;
5056 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5057
5058 /* Encode the severity code */
5059 severity = STATUS_NATIVE & STS$M_SEVERITY;
5060 STATUS_UNIX = (severity ? severity : 1) << 8;
5061
5062 /* Perl expects this to be a fatal error */
5063 if (severity != STS$K_SEVERE)
5064 STATUS_ALL_FAILURE;
5065 }
5066 }
5067 }
fb38d079 5068
f86702cc 5069#else
9b599b2a 5070 int exitstatus;
f86702cc 5071 if (errno & 255)
e5218da5 5072 STATUS_UNIX_SET(errno);
9b599b2a 5073 else {
e5218da5 5074 exitstatus = STATUS_UNIX >> 8;
9b599b2a 5075 if (exitstatus & 255)
e5218da5 5076 STATUS_UNIX_SET(exitstatus);
9b599b2a 5077 else
e5218da5 5078 STATUS_UNIX_SET(255);
9b599b2a 5079 }
f86702cc 5080#endif
6136213b
JGM		 5081 if (PL_exit_flags & PERL_EXIT_ABORT) {
5082 abort();
5083 }
5084 if (PL_exit_flags & PERL_EXIT_WARN) {
5085 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
5086 Perl_warn(aTHX_ "Unexpected exit failure %u", PL_statusvalue);
5087 PL_exit_flags &= ~PERL_EXIT_ABORT;
5088 }
f86702cc 5089 my_exit_jump();
93a17b20
LW		 5090}
5091
76e3520e 5092STATIC void
cea2e8a9 5093S_my_exit_jump(pTHX)
f86702cc 5094{
27da23d5 5095 dVAR;
f86702cc 5096
3280af22
NIS		 5097 if (PL_e_script) {
5098 SvREFCNT_dec(PL_e_script);
a0714e2c 5099 PL_e_script = NULL;
f86702cc 5100 }
5101
3280af22 5102 POPSTACK_TO(PL_mainstack);
f97a0ef2
RH		 5103 dounwind(-1);
5104 LEAVE_SCOPE(0);
ff0cee69 5105
6224f72b 5106 JMPENV_JUMP(2);
f86702cc 5107}
873ef191 5108
0cb96387 5109static I32
acfe0abc 5110read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
873ef191 5111{
97aff369 5112 dVAR;
9d4ba2ae
AL		 5113 const char * const p = SvPVX_const(PL_e_script);
5114 const char *nl = strchr(p, '\n');
5115
5116 PERL_UNUSED_ARG(idx);
5117 PERL_UNUSED_ARG(maxlen);
dd374669 5118
3280af22 5119 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 5120 if (nl-p == 0) {
0cb96387 5121 filter_del(read_e_script);
873ef191 5122 return 0;
7dfe3f66 5123 }
873ef191 5124 sv_catpvn(buf_sv, p, nl-p);
3280af22 5125 sv_chop(PL_e_script, nl);
873ef191
GS		 5126 return 1;
5127}
66610fdd
RGS		 5128
5129/*
5130 * Local variables:
5131 * c-indentation-style: bsd
5132 * c-basic-offset: 4
14d04a33 5133 * indent-tabs-mode: nil
66610fdd
RGS		 5134 * End:
5135 *
14d04a33 5136 * ex: set ts=8 sts=4 sw=4 et:
37442d52 5137 */
Unnamed repository; edit this file 'description' to name the repository.