4 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
5 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
6 * 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022
7 * by Larry Wall and others
9 * You may distribute under the terms of either the GNU General Public
10 * License or the Artistic License, as specified in the README file.
15 * A ship then new they built for him
16 * of mithril and of elven-glass
17 * --from Bilbo's song of EƤrendil
19 * [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
22 /* This file contains the top-level functions that are used to create, use
23 * and destroy a perl interpreter, plus the functions used by XS code to
24 * call back into perl. Note that it does not contain the actual main()
25 * function of the interpreter; that can be found in perlmain.c
27 * Note that at build time this file is also linked to as perlmini.c,
28 * and perlmini.o is then built with PERL_IS_MINIPERL defined, which is
29 * then used to create the miniperl executable, rather than perl.o.
32 #if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
33 # define USE_SITECUSTOMIZE
37 #define PERL_IN_PERL_C
39 #include "patchlevel.h" /* for local_patches */
42 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
49 char control[CMSG_SPACE(sizeof(int))];
62 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
64 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
65 # define validate_suid(rsfp) NOOP
67 # define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
70 #define CALL_BODY_SUB(myop) \
71 if (PL_op == (myop)) \
72 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
76 #define CALL_LIST_BODY(cv) \
77 PUSHMARK(PL_stack_sp); \
78 call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
81 S_init_tls_and_interp(PerlInterpreter *my_perl)
84 PERL_SET_INTERP(my_perl);
85 #if defined(USE_ITHREADS)
88 PERL_SET_THX(my_perl);
91 KEYWORD_PLUGIN_MUTEX_INIT;
96 MUTEX_INIT(&PL_dollarzero_mutex);
97 MUTEX_INIT(&PL_my_ctx_mutex);
100 #if defined(USE_ITHREADS)
103 /* This always happens for non-ithreads */
106 PERL_SET_THX(my_perl);
111 #ifndef PLATFORM_SYS_INIT_
112 # define PLATFORM_SYS_INIT_ NOOP
115 #ifndef PLATFORM_SYS_TERM_
116 # define PLATFORM_SYS_TERM_ NOOP
119 #ifndef PERL_SYS_INIT_BODY
120 # define PERL_SYS_INIT_BODY(c,v) \
121 MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT; PERLIO_INIT; \
122 MALLOC_INIT; PLATFORM_SYS_INIT_;
125 /* Generally add things last-in first-terminated. IO and memory terminations
126 * need to be generally last
128 * BEWARE that using PerlIO in these will be using freed memory, so may appear
129 * to work, but must NOT be retained in production code. */
130 #ifndef PERL_SYS_TERM_BODY
131 # define PERL_SYS_TERM_BODY() \
132 ENV_TERM; USER_PROP_MUTEX_TERM; LOCALE_TERM; \
133 HINTS_REFCNT_TERM; KEYWORD_PLUGIN_MUTEX_TERM; \
134 OP_CHECK_MUTEX_TERM; OP_REFCNT_TERM; \
135 PERLIO_TERM; MALLOC_TERM; \
139 /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
142 Perl_sys_init(int* argc, char*** argv)
145 PERL_ARGS_ASSERT_SYS_INIT;
147 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
148 PERL_UNUSED_ARG(argv);
149 PERL_SYS_INIT_BODY(argc, argv);
153 Perl_sys_init3(int* argc, char*** argv, char*** env)
156 PERL_ARGS_ASSERT_SYS_INIT3;
158 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
159 PERL_UNUSED_ARG(argv);
160 PERL_UNUSED_ARG(env);
161 PERL_SYS_INIT3_BODY(argc, argv, env);
167 if (!PL_veto_cleanup) {
168 PERL_SYS_TERM_BODY();
173 #ifdef PERL_IMPLICIT_SYS
175 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
176 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
177 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
178 struct IPerlDir* ipD, struct IPerlSock* ipS,
179 struct IPerlProc* ipP)
181 PerlInterpreter *my_perl;
183 PERL_ARGS_ASSERT_PERL_ALLOC_USING;
185 /* Newx() needs interpreter, so call malloc() instead */
186 my_perl = (PerlInterpreter*)(*ipM->pCalloc)(ipM, 1, sizeof(PerlInterpreter));
187 S_init_tls_and_interp(my_perl);
197 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
204 =for apidoc_section $embedding
206 =for apidoc perl_alloc
208 Allocates a new Perl interpreter. See L<perlembed>.
216 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_calloc(1, sizeof(PerlInterpreter));
218 S_init_tls_and_interp(my_perl);
219 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
222 #endif /* PERL_IMPLICIT_SYS */
225 =for apidoc perl_construct
227 Initializes a new Perl interpreter. See L<perlembed>.
233 perl_construct(pTHXx)
236 PERL_ARGS_ASSERT_PERL_CONSTRUCT;
240 PL_perl_destruct_level = 1;
242 PERL_UNUSED_ARG(my_perl);
243 if (PL_perl_destruct_level > 0)
246 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
248 #ifdef PERL_TRACE_OPS
249 Zero(PL_op_exec_cnt, OP_max+2, UV);
254 SvREADONLY_on(&PL_sv_placeholder);
255 SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
257 PL_sighandlerp = Perl_sighandler;
258 PL_sighandler1p = Perl_sighandler1;
259 PL_sighandler3p = Perl_sighandler3;
261 #ifdef PERL_USES_PL_PIDSTATUS
262 PL_pidstatus = newHV();
265 PL_rs = newSVpvs("\n");
269 #if !defined(NO_PERL_RAND_SEED) || !defined(NO_PERL_INTERNAL_HASH_SEED)
270 bool sensitive_env_vars_allowed =
271 (PerlProc_getuid() == PerlProc_geteuid() &&
272 PerlProc_getgid() == PerlProc_getegid()) ? TRUE : FALSE;
275 /* The seed set-up must be after init_stacks because it calls
276 * things that may put SVs on the stack.
278 #ifndef NO_PERL_RAND_SEED
279 if (sensitive_env_vars_allowed) {
282 if ((env_pv = PerlEnv_getenv("PERL_RAND_SEED")) &&
283 grok_number(env_pv, strlen(env_pv), &seed) == IS_NUMBER_IN_UV)
286 PL_srand_override_next = seed;
287 PERL_SRAND_OVERRIDE_NEXT_INIT();
292 /* This is NOT the state used for C<rand()>, this is only
293 * used in internal functionality */
294 #ifdef NO_PERL_INTERNAL_RAND_SEED
295 Perl_drand48_init_r(&PL_internal_random_state, seed());
301 !sensitive_env_vars_allowed ||
302 !(env_pv = PerlEnv_getenv("PERL_INTERNAL_RAND_SEED")) ||
303 grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV)
305 /* use a randomly generated seed */
308 Perl_drand48_init_r(&PL_internal_random_state, (U32)seed);
318 (void) uvchr_to_utf8_flags((U8 *) PL_TR_SPECIAL_HANDLING_UTF8,
320 UNICODE_ALLOW_ABOVE_IV_MAX);
322 #if defined(LOCAL_PATCH_COUNT)
323 PL_localpatches = local_patches; /* For possible -v */
326 #if defined(LIBM_LIB_VERSION)
328 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
329 * This switches them over to IEEE.
331 _LIB_VERSION = _IEEE_;
334 #ifdef HAVE_INTERP_INTERN
338 PerlIO_init(aTHX); /* Hook to IO system */
340 PL_fdpid = newAV(); /* for remembering popen pids by fd */
341 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
342 PL_errors = newSVpvs("");
343 SvPVCLEAR(PERL_DEBUG_PAD(0)); /* For regex debugging. */
344 SvPVCLEAR(PERL_DEBUG_PAD(1)); /* ext/re needs these */
345 SvPVCLEAR(PERL_DEBUG_PAD(2)); /* even without DEBUGGING. */
347 /* First entry is a list of empty elements. It needs to be initialised
348 else all hell breaks loose in S_find_uninit_var(). */
349 Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
350 PL_regex_pad = AvARRAY(PL_regex_padav);
351 Newxz(PL_stashpad, PL_stashpadmax, HV *);
353 #ifdef USE_REENTRANT_API
354 Perl_reentrant_init(aTHX);
356 if (PL_hash_seed_set == FALSE) {
357 /* Initialize the hash seed and state at startup. This must be
358 * done very early, before ANY hashes are constructed, and once
359 * setup is fixed for the lifetime of the process.
361 * If you decide to disable the seeding process you should choose
362 * a suitable seed yourself and define PERL_HASH_SEED to a well chosen
363 * string. See hv_func.h for details.
365 #if defined(USE_HASH_SEED)
366 /* get the hash seed from the environment or from an RNG */
367 Perl_get_hash_seed(aTHX_ PL_hash_seed);
369 /* they want a hard coded seed, check that it is long enough */
370 assert( strlen(PERL_HASH_SEED) >= PERL_HASH_SEED_BYTES );
373 /* now we use the chosen seed to initialize the state -
374 * in some configurations this may be a relatively speaking
375 * expensive operation, but we only have to do it once at startup */
376 PERL_HASH_SEED_STATE(PERL_HASH_SEED,PL_hash_state);
378 #ifdef PERL_USE_SINGLE_CHAR_HASH_CACHE
379 /* we can build a special cache for 0/1 byte keys, if people choose
380 * I suspect most of the time it is not worth it */
384 for (i=0;i<256;i++) {
386 PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[i],str,1);
388 PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[256],str,0);
391 /* at this point we have initialezed the hash function, and we can start
392 * constructing hashes */
393 PL_hash_seed_set= TRUE;
396 /* Allow PL_strtab to be pre-initialized before calling perl_construct.
397 * can use a custom optimized PL_strtab hash before calling perl_construct */
399 /* Note that strtab is a rather special HV. Assumptions are made
400 about not iterating on it, and not adding tie magic to it.
401 It is properly deallocated in perl_destruct() */
404 /* SHAREKEYS tells us that the hash has its keys shared with PL_strtab,
405 * which is not the case with PL_strtab itself */
406 HvSHAREKEYS_off(PL_strtab); /* mandatory */
407 hv_ksplit(PL_strtab, 1 << 11);
411 PL_compiling.cop_file = NULL;
412 PL_compiling.cop_warnings = NULL;
415 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
418 # ifdef USE_ENVIRON_ARRAY
420 PL_origenviron = environ;
424 /* Use sysconf(_SC_CLK_TCK) if available, if not
425 * available or if the sysconf() fails, use the HZ.
426 * The HZ if not originally defined has been by now
427 * been defined as CLK_TCK, if available. */
428 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
429 PL_clocktick = sysconf(_SC_CLK_TCK);
430 if (PL_clocktick <= 0)
434 PL_stashcache = newHV();
436 PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
439 if (!PL_mmap_page_size) {
440 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
442 SETERRNO(0, SS_NORMAL);
444 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
446 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
448 if ((long) PL_mmap_page_size < 0) {
449 Perl_croak(aTHX_ "panic: sysconf: %s",
450 errno ? Strerror(errno) : "pagesize unknown");
453 #elif defined(HAS_GETPAGESIZE)
454 PL_mmap_page_size = getpagesize();
455 #elif defined(I_SYS_PARAM) && defined(PAGESIZE)
456 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
458 if (PL_mmap_page_size <= 0)
459 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
460 (IV) PL_mmap_page_size);
462 #endif /* HAS_MMAP */
464 PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
466 PL_registered_mros = newHV();
467 /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
468 HvMAX(PL_registered_mros) = 0;
475 =for apidoc nothreadhook
477 Stub that provides thread hook for perl_destruct when there are
484 Perl_nothreadhook(pTHX)
490 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
492 Perl_dump_sv_child(pTHX_ SV *sv)
495 const int sock = PL_dumper_fd;
496 const int debug_fd = PerlIO_fileno(Perl_debug_log);
497 union control_un control;
500 struct cmsghdr *cmptr;
502 unsigned char buffer[256];
504 PERL_ARGS_ASSERT_DUMP_SV_CHILD;
506 if(sock == -1 || debug_fd == -1)
509 PerlIO_flush(Perl_debug_log);
511 /* All these shenanigans are to pass a file descriptor over to our child for
512 it to dump out to. We can't let it hold open the file descriptor when it
513 forks, as the file descriptor it will dump to can turn out to be one end
514 of pipe that some other process will wait on for EOF. (So as it would
515 be open, the wait would be forever.) */
517 msg.msg_control = control.control;
518 msg.msg_controllen = sizeof(control.control);
519 /* We're a connected socket so we don't need a destination */
525 cmptr = CMSG_FIRSTHDR(&msg);
526 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
527 cmptr->cmsg_level = SOL_SOCKET;
528 cmptr->cmsg_type = SCM_RIGHTS;
529 *((int *)CMSG_DATA(cmptr)) = 1;
531 vec[0].iov_base = (void*)&sv;
532 vec[0].iov_len = sizeof(sv);
533 got = sendmsg(sock, &msg, 0);
536 perror("Debug leaking scalars parent sendmsg failed");
539 if(got < sizeof(sv)) {
540 perror("Debug leaking scalars parent short sendmsg");
544 /* Return protocol is
546 unsigned char: length of location string (0 for empty)
547 unsigned char*: string (not terminated)
549 vec[0].iov_base = (void*)&returned_errno;
550 vec[0].iov_len = sizeof(returned_errno);
551 vec[1].iov_base = buffer;
554 got = readv(sock, vec, 2);
557 perror("Debug leaking scalars parent read failed");
558 PerlIO_flush(PerlIO_stderr());
561 if(got < sizeof(returned_errno) + 1) {
562 perror("Debug leaking scalars parent short read");
563 PerlIO_flush(PerlIO_stderr());
568 got = read(sock, buffer + 1, *buffer);
570 perror("Debug leaking scalars parent read 2 failed");
571 PerlIO_flush(PerlIO_stderr());
576 perror("Debug leaking scalars parent short read 2");
577 PerlIO_flush(PerlIO_stderr());
582 if (returned_errno || *buffer) {
583 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
584 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
585 returned_errno, Strerror(returned_errno));
591 =for apidoc perl_destruct
593 Shuts down a Perl interpreter. See L<perlembed> for a tutorial.
595 C<my_perl> points to the Perl interpreter. It must have been previously
596 created through the use of L</perl_alloc> and L</perl_construct>. It may
597 have been initialised through L</perl_parse>, and may have been used
598 through L</perl_run> and other means. This function should be called for
599 any Perl interpreter that has been constructed with L</perl_construct>,
600 even if subsequent operations on it failed, for example if L</perl_parse>
601 returned a non-zero value.
603 If the interpreter's C<PL_exit_flags> word has the
604 C<PERL_EXIT_DESTRUCT_END> flag set, then this function will execute code
605 in C<END> blocks before performing the rest of destruction. If it is
606 desired to make any use of the interpreter between L</perl_parse> and
607 L</perl_destruct> other than just calling L</perl_run>, then this flag
608 should be set early on. This matters if L</perl_run> will not be called,
609 or if anything else will be done in addition to calling L</perl_run>.
611 Returns a value be a suitable value to pass to the C library function
612 C<exit> (or to return from C<main>), to serve as an exit code indicating
613 the nature of the way the interpreter terminated. This takes into account
614 any failure of L</perl_parse> and any early exit from L</perl_run>.
615 The exit code is of the type required by the host operating system,
616 so because of differing exit code conventions it is not portable to
617 interpret specific numeric values as having specific meanings.
625 volatile signed char destruct_level; /* see possible values in intrpvar.h */
627 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
632 PERL_ARGS_ASSERT_PERL_DESTRUCT;
634 PERL_UNUSED_ARG(my_perl);
637 assert(PL_scopestack_ix == 1);
639 destruct_level = PL_perl_destruct_level;
641 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
644 if (strEQ(s, "-1")) { /* Special case: modperl folklore. */
648 if (grok_atoUV(s, &uv, NULL) && uv <= INT_MAX)
653 if (destruct_level < i) destruct_level = i;
654 #ifdef PERL_TRACK_MEMPOOL
655 /* RT #114496, for perl_free */
656 PL_perl_destruct_level = i;
661 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
667 if (PL_endav && !PL_minus_c) {
668 PERL_SET_PHASE(PERL_PHASE_END);
669 call_list(PL_scopestack_ix, PL_endav);
675 assert(PL_scopestack_ix == 0);
677 /* wait for all pseudo-forked children to finish */
678 PERL_WAIT_FOR_CHILDREN;
681 /* normally when we get here, PL_parser should be null due to having
682 * its original (null) value restored by SAVEt_PARSER during leaving
683 * scope (usually before run-time starts in fact).
684 * But if a thread is created within a BEGIN block, the parser is
685 * duped, but the SAVEt_PARSER savestack entry isn't. So PL_parser
686 * never gets cleaned up.
687 * Clean it up here instead. This is a bit of a hack.
690 /* stop parser_free() stomping on PL_curcop */
691 PL_parser->saved_curcop = PL_curcop;
692 parser_free(PL_parser);
696 /* Need to flush since END blocks can produce output */
697 /* flush stdout separately, since we can identify it */
700 PerlIO *stdo = PerlIO_stdout();
701 if (*stdo && PerlIO_flush(stdo)) {
702 PerlIO_restore_errno(stdo);
704 PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s\n",
713 #ifdef PERL_TRACE_OPS
714 /* dump OP-counts if $ENV{PERL_TRACE_OPS} > 0 */
716 const char * const ptoenv = PerlEnv_getenv("PERL_TRACE_OPS");
719 if (!ptoenv || !Perl_grok_atoUV(ptoenv, &uv, NULL)
723 PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
724 for (i = 0; i <= OP_max; ++i) {
725 if (PL_op_exec_cnt[i])
726 PerlIO_printf(Perl_debug_log, " %s: %" UVuf "\n", PL_op_name[i], PL_op_exec_cnt[i]);
728 /* Utility slot for easily doing little tracing experiments in the runloop: */
729 if (PL_op_exec_cnt[OP_max+1] != 0)
730 PerlIO_printf(Perl_debug_log, " SPECIAL: %" UVuf "\n", PL_op_exec_cnt[OP_max+1]);
731 PerlIO_printf(Perl_debug_log, "\n");
736 if (PL_threadhook(aTHX)) {
737 /* Threads hook has vetoed further cleanup */
738 PL_veto_cleanup = TRUE;
742 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
743 if (destruct_level != 0) {
744 /* Fork here to create a child. Our child's job is to preserve the
745 state of scalars prior to destruction, so that we can instruct it
746 to dump any scalars that we later find have leaked.
747 There's no subtlety in this code - it assumes POSIX, and it doesn't
751 if(PerlSock_socketpair_cloexec(AF_UNIX, SOCK_STREAM, 0, fd)) {
752 perror("Debug leaking scalars socketpair failed");
758 perror("Debug leaking scalars fork failed");
762 /* We are the child */
763 const int sock = fd[1];
764 const int debug_fd = PerlIO_fileno(Perl_debug_log);
767 /* Our success message is an integer 0, and a char 0 */
768 static const char success[sizeof(int) + 1] = {0};
772 /* We need to close all other file descriptors otherwise we end up
773 with interesting hangs, where the parent closes its end of a
774 pipe, and sits waiting for (another) child to terminate. Only
775 that child never terminates, because it never gets EOF, because
776 we also have the far end of the pipe open. We even need to
777 close the debugging fd, because sometimes it happens to be one
778 end of a pipe, and a process is waiting on the other end for
779 EOF. Normally it would be closed at some point earlier in
780 destruction, but if we happen to cause the pipe to remain open,
781 EOF never occurs, and we get an infinite hang. Hence all the
782 games to pass in a file descriptor if it's actually needed. */
784 f = sysconf(_SC_OPEN_MAX);
786 where = "sysconf failed";
797 union control_un control;
800 struct cmsghdr *cmptr;
804 msg.msg_control = control.control;
805 msg.msg_controllen = sizeof(control.control);
806 /* We're a connected socket so we don't need a source */
810 msg.msg_iovlen = C_ARRAY_LENGTH(vec);
812 vec[0].iov_base = (void*)⌖
813 vec[0].iov_len = sizeof(target);
815 got = recvmsg(sock, &msg, 0);
820 where = "recv failed";
823 if(got < sizeof(target)) {
824 where = "short recv";
828 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
832 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
833 where = "wrong cmsg_len";
836 if(cmptr->cmsg_level != SOL_SOCKET) {
837 where = "wrong cmsg_level";
840 if(cmptr->cmsg_type != SCM_RIGHTS) {
841 where = "wrong cmsg_type";
845 got_fd = *(int*)CMSG_DATA(cmptr);
846 /* For our last little bit of trickery, put the file descriptor
847 back into Perl_debug_log, as if we never actually closed it
849 if(got_fd != debug_fd) {
850 if (PerlLIO_dup2_cloexec(got_fd, debug_fd) == -1) {
857 PerlIO_flush(Perl_debug_log);
859 got = write(sock, &success, sizeof(success));
862 where = "write failed";
865 if(got < sizeof(success)) {
866 where = "short write";
873 int send_errno = errno;
874 unsigned char length = (unsigned char) strlen(where);
875 struct iovec failure[3] = {
876 {(void*)&send_errno, sizeof(send_errno)},
878 {(void*)where, length}
880 int got = writev(sock, failure, 3);
881 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
882 in the parent if we try to read from the socketpair after the
883 child has exited, even if there was data to read.
884 So sleep a bit to give the parent a fighting chance of
887 _exit((got == -1) ? errno : 0);
891 PL_dumper_fd = fd[0];
896 /* We must account for everything. */
898 /* Destroy the main CV and syntax tree */
899 /* Set PL_curcop now, because destroying ops can cause new SVs
900 to be generated in Perl_pad_swipe, and when running with
901 -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
902 op from which the filename structure member is copied. */
903 PL_curcop = &PL_compiling;
905 /* ensure comppad/curpad to refer to main's pad */
906 if (CvPADLIST(PL_main_cv)) {
907 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
908 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
910 op_free(PL_main_root);
913 PL_main_start = NULL;
914 /* note that PL_main_cv isn't usually actually freed at this point,
915 * due to the CvOUTSIDE refs from subs compiled within it. It will
916 * get freed once all the subs are freed in sv_clean_all(), for
917 * destruct_level > 0 */
918 SvREFCNT_dec(PL_main_cv);
920 PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
922 /* Tell PerlIO we are about to tear things apart in case
923 we have layers which are using resources that should
927 PerlIO_destruct(aTHX);
930 * Try to destruct global references. We do this first so that the
931 * destructors and destructees still exist. Some sv's might remain.
932 * Non-referenced objects are on their own.
936 /* unhook hooks which will soon be, or use, destroyed data */
937 SvREFCNT_dec(PL_warnhook);
939 SvREFCNT_dec(PL_diehook);
942 /* call exit list functions */
943 while (PL_exitlistlen-- > 0)
944 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
946 Safefree(PL_exitlist);
951 SvREFCNT_dec(PL_registered_mros);
953 if (destruct_level == 0) {
955 DEBUG_P(debprofdump());
957 #if defined(PERLIO_LAYERS)
958 /* No more IO - including error messages ! */
959 PerlIO_cleanup(aTHX);
962 CopFILE_free(&PL_compiling);
964 /* The exit() function will do everything that needs doing. */
968 /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */
971 /* the syntax tree is shared between clones
972 * so op_free(PL_main_root) only ReREFCNT_dec's
973 * REGEXPs in the parent interpreter
974 * we need to manually ReREFCNT_dec for the clones
977 I32 i = AvFILLp(PL_regex_padav);
978 SV **ary = AvARRAY(PL_regex_padav);
981 SvREFCNT_dec(ary[i]);
982 ary[i] = &PL_sv_undef;
988 SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
989 PL_stashcache = NULL;
991 /* loosen bonds of global variables */
993 /* XXX can PL_parser still be non-null here? */
994 if(PL_parser && PL_parser->rsfp) {
995 (void)PerlIO_close(PL_parser->rsfp);
996 PL_parser->rsfp = NULL;
1000 Safefree(PL_splitstr);
1010 PL_doswitches = FALSE;
1011 PL_dowarn = G_WARN_OFF;
1012 #ifdef PERL_SAWAMPERSAND
1013 PL_sawampersand = 0; /* must save all match strings */
1017 Safefree(PL_inplace);
1019 SvREFCNT_dec(PL_patchlevel);
1022 SvREFCNT_dec(PL_e_script);
1028 /* magical thingies */
1030 SvREFCNT_dec(PL_ofsgv); /* *, */
1033 SvREFCNT_dec(PL_ors_sv); /* $\ */
1036 SvREFCNT_dec(PL_rs); /* $/ */
1039 Safefree(PL_osname); /* $^O */
1042 SvREFCNT_dec(PL_statname);
1046 /* defgv, aka *_ should be taken care of elsewhere */
1049 Safefree(PL_efloatbuf);
1050 PL_efloatbuf = NULL;
1053 /* startup and shutdown function lists */
1054 SvREFCNT_dec(PL_beginav);
1055 SvREFCNT_dec(PL_beginav_save);
1056 SvREFCNT_dec(PL_endav);
1057 SvREFCNT_dec(PL_checkav);
1058 SvREFCNT_dec(PL_checkav_save);
1059 SvREFCNT_dec(PL_unitcheckav);
1060 SvREFCNT_dec(PL_unitcheckav_save);
1061 SvREFCNT_dec(PL_initav);
1063 PL_beginav_save = NULL;
1066 PL_checkav_save = NULL;
1067 PL_unitcheckav = NULL;
1068 PL_unitcheckav_save = NULL;
1071 /* shortcuts just get cleared */
1074 PL_argvoutgv = NULL;
1077 PL_last_in_gv = NULL;
1088 SvREFCNT_dec(PL_envgv);
1089 SvREFCNT_dec(PL_incgv);
1090 SvREFCNT_dec(PL_argvgv);
1091 SvREFCNT_dec(PL_replgv);
1092 SvREFCNT_dec(PL_DBgv);
1093 SvREFCNT_dec(PL_DBline);
1094 SvREFCNT_dec(PL_DBsub);
1103 SvREFCNT_dec(PL_argvout_stack);
1104 PL_argvout_stack = NULL;
1106 SvREFCNT_dec(PL_modglobal);
1107 PL_modglobal = NULL;
1108 SvREFCNT_dec(PL_preambleav);
1109 PL_preambleav = NULL;
1110 SvREFCNT_dec(PL_subname);
1112 #ifdef PERL_USES_PL_PIDSTATUS
1113 SvREFCNT_dec(PL_pidstatus);
1114 PL_pidstatus = NULL;
1116 SvREFCNT_dec(PL_toptarget);
1117 PL_toptarget = NULL;
1118 SvREFCNT_dec(PL_bodytarget);
1119 PL_bodytarget = NULL;
1120 PL_formtarget = NULL;
1122 /* free locale stuff */
1123 #ifdef USE_LOCALE_COLLATE
1124 Safefree(PL_collation_name);
1125 PL_collation_name = NULL;
1127 #if defined(USE_PL_CURLOCALES)
1128 for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) {
1129 Safefree(PL_curlocales[i]);
1130 PL_curlocales[i] = NULL;
1133 #ifdef USE_POSIX_2008_LOCALE
1135 /* This also makes sure we aren't using a locale object that gets freed
1137 if ( PL_cur_locale_obj != NULL
1138 && PL_cur_locale_obj != LC_GLOBAL_LOCALE
1139 && PL_cur_locale_obj != PL_C_locale_obj
1141 locale_t cur_locale = uselocale((locale_t) 0);
1142 if (cur_locale == PL_cur_locale_obj) {
1143 uselocale(LC_GLOBAL_LOCALE);
1146 freelocale(PL_cur_locale_obj);
1147 PL_cur_locale_obj = NULL;
1151 # ifdef USE_PL_CUR_LC_ALL
1153 if (PL_cur_LC_ALL) {
1154 DEBUG_L( PerlIO_printf(Perl_debug_log, "PL_cur_LC_ALL=%p\n", PL_cur_LC_ALL));
1155 Safefree(PL_cur_LC_ALL);
1156 PL_cur_LC_ALL = NULL;
1161 if (PL_scratch_locale_obj) {
1162 freelocale(PL_scratch_locale_obj);
1163 PL_scratch_locale_obj = NULL;
1165 # ifdef USE_LOCALE_NUMERIC
1166 if (PL_underlying_numeric_obj) {
1167 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1168 "%s:%d: Freeing %p\n", __FILE__, __LINE__,
1169 PL_underlying_numeric_obj));
1170 freelocale(PL_underlying_numeric_obj);
1171 PL_underlying_numeric_obj = (locale_t) NULL;
1175 #ifdef USE_LOCALE_NUMERIC
1176 Safefree(PL_numeric_name);
1177 PL_numeric_name = NULL;
1178 SvREFCNT_dec(PL_numeric_radix_sv);
1179 PL_numeric_radix_sv = NULL;
1180 SvREFCNT_dec(PL_underlying_radix_sv);
1181 PL_underlying_radix_sv = NULL;
1183 #ifdef USE_LOCALE_CTYPE
1184 Safefree(PL_ctype_name);
1185 PL_ctype_name = NULL;
1188 if (PL_setlocale_buf) {
1189 Safefree(PL_setlocale_buf);
1190 PL_setlocale_buf = NULL;
1193 if (PL_langinfo_buf) {
1194 Safefree(PL_langinfo_buf);
1195 PL_langinfo_buf = NULL;
1198 if (PL_stdize_locale_buf) {
1199 Safefree(PL_stdize_locale_buf);
1200 PL_stdize_locale_buf = NULL;
1203 #ifdef USE_LOCALE_CTYPE
1204 SvREFCNT_dec(PL_warn_locale);
1205 PL_warn_locale = NULL;
1208 SvREFCNT_dec(PL_AboveLatin1);
1209 PL_AboveLatin1 = NULL;
1210 SvREFCNT_dec(PL_Assigned_invlist);
1211 PL_Assigned_invlist = NULL;
1212 SvREFCNT_dec(PL_GCB_invlist);
1213 PL_GCB_invlist = NULL;
1214 SvREFCNT_dec(PL_HasMultiCharFold);
1215 PL_HasMultiCharFold = NULL;
1216 SvREFCNT_dec(PL_InMultiCharFold);
1217 PL_InMultiCharFold = NULL;
1218 SvREFCNT_dec(PL_Latin1);
1220 SvREFCNT_dec(PL_LB_invlist);
1221 PL_LB_invlist = NULL;
1222 SvREFCNT_dec(PL_SB_invlist);
1223 PL_SB_invlist = NULL;
1224 SvREFCNT_dec(PL_SCX_invlist);
1225 PL_SCX_invlist = NULL;
1226 SvREFCNT_dec(PL_UpperLatin1);
1227 PL_UpperLatin1 = NULL;
1228 SvREFCNT_dec(PL_in_some_fold);
1229 PL_in_some_fold = NULL;
1230 SvREFCNT_dec(PL_utf8_foldclosures);
1231 PL_utf8_foldclosures = NULL;
1232 SvREFCNT_dec(PL_utf8_idcont);
1233 PL_utf8_idcont = NULL;
1234 SvREFCNT_dec(PL_utf8_idstart);
1235 PL_utf8_idstart = NULL;
1236 SvREFCNT_dec(PL_utf8_perl_idcont);
1237 PL_utf8_perl_idcont = NULL;
1238 SvREFCNT_dec(PL_utf8_perl_idstart);
1239 PL_utf8_perl_idstart = NULL;
1240 SvREFCNT_dec(PL_utf8_xidcont);
1241 PL_utf8_xidcont = NULL;
1242 SvREFCNT_dec(PL_utf8_xidstart);
1243 PL_utf8_xidstart = NULL;
1244 SvREFCNT_dec(PL_WB_invlist);
1245 PL_WB_invlist = NULL;
1246 SvREFCNT_dec(PL_utf8_toupper);
1247 PL_utf8_toupper = NULL;
1248 SvREFCNT_dec(PL_utf8_totitle);
1249 PL_utf8_totitle = NULL;
1250 SvREFCNT_dec(PL_utf8_tolower);
1251 PL_utf8_tolower = NULL;
1252 SvREFCNT_dec(PL_utf8_tofold);
1253 PL_utf8_tofold = NULL;
1254 SvREFCNT_dec(PL_utf8_tosimplefold);
1255 PL_utf8_tosimplefold = NULL;
1256 SvREFCNT_dec(PL_utf8_charname_begin);
1257 PL_utf8_charname_begin = NULL;
1258 SvREFCNT_dec(PL_utf8_charname_continue);
1259 PL_utf8_charname_continue = NULL;
1260 SvREFCNT_dec(PL_utf8_mark);
1261 PL_utf8_mark = NULL;
1262 SvREFCNT_dec(PL_InBitmap);
1264 SvREFCNT_dec(PL_CCC_non0_non230);
1265 PL_CCC_non0_non230 = NULL;
1266 SvREFCNT_dec(PL_Private_Use);
1267 PL_Private_Use = NULL;
1269 for (i = 0; i < POSIX_CC_COUNT; i++) {
1270 SvREFCNT_dec(PL_XPosix_ptrs[i]);
1271 PL_XPosix_ptrs[i] = NULL;
1273 if (i != CC_CASED_) { /* A copy of Alpha */
1274 SvREFCNT_dec(PL_Posix_ptrs[i]);
1275 PL_Posix_ptrs[i] = NULL;
1279 free_and_set_cop_warnings(&PL_compiling, NULL);
1280 cophh_free(CopHINTHASH_get(&PL_compiling));
1281 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
1282 CopFILE_free(&PL_compiling);
1284 /* Prepare to destruct main symbol table. */
1287 /* break ref loop *:: <=> %:: */
1288 (void)hv_deletes(hv, "main::", G_DISCARD);
1291 SvREFCNT_dec(PL_curstname);
1292 PL_curstname = NULL;
1294 /* clear queued errors */
1295 SvREFCNT_dec(PL_errors);
1298 SvREFCNT_dec(PL_isarev);
1301 if (destruct_level >= 2) {
1302 if (PL_scopestack_ix != 0)
1303 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1304 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1305 (long)PL_scopestack_ix);
1306 if (PL_savestack_ix != 0)
1307 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1308 "Unbalanced saves: %ld more saves than restores\n",
1309 (long)PL_savestack_ix);
1310 if (PL_tmps_floor != -1)
1311 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1312 (long)PL_tmps_floor + 1);
1313 if (cxstack_ix != -1)
1314 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1315 (long)cxstack_ix + 1);
1319 SvREFCNT_dec(PL_regex_padav);
1320 PL_regex_padav = NULL;
1321 PL_regex_pad = NULL;
1325 /* the entries in this list are allocated via SV PVX's, so get freed
1326 * in sv_clean_all */
1327 Safefree(PL_my_cxt_list);
1330 /* Now absolutely destruct everything, somehow or other, loops or no. */
1332 /* the 2 is for PL_fdpid and PL_strtab */
1333 while (sv_clean_all() > 2)
1337 Safefree(PL_stashpad); /* must come after sv_clean_all */
1340 AvREAL_off(PL_fdpid); /* no surviving entries */
1341 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
1344 #ifdef HAVE_INTERP_INTERN
1348 /* constant strings */
1349 for (i = 0; i < SV_CONSTS_COUNT; i++) {
1350 SvREFCNT_dec(PL_sv_consts[i]);
1351 PL_sv_consts[i] = NULL;
1354 /* Destruct the global string table. */
1356 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1357 * so that sv_free() won't fail on them.
1358 * Now that the global string table is using a single hunk of memory
1359 * for both HE and HEK, we either need to explicitly unshare it the
1360 * correct way, or actually free things here.
1363 const I32 max = HvMAX(PL_strtab);
1364 HE * const * const array = HvARRAY(PL_strtab);
1365 HE *hent = array[0];
1368 if (hent && ckWARN_d(WARN_INTERNAL)) {
1369 HE * const next = HeNEXT(hent);
1370 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1371 "Unbalanced string table refcount: (%ld) for \"%s\"",
1372 (long)hent->he_valu.hent_refcount, HeKEY(hent));
1379 hent = array[riter];
1384 HvARRAY(PL_strtab) = 0;
1385 HvTOTALKEYS(PL_strtab) = 0;
1387 SvREFCNT_dec(PL_strtab);
1390 /* free the pointer tables used for cloning */
1391 ptr_table_free(PL_ptr_table);
1392 PL_ptr_table = (PTR_TBL_t*)NULL;
1395 /* free special SVs */
1397 SvREFCNT(&PL_sv_yes) = 0;
1398 sv_clear(&PL_sv_yes);
1399 SvANY(&PL_sv_yes) = NULL;
1400 SvFLAGS(&PL_sv_yes) = 0;
1402 SvREFCNT(&PL_sv_no) = 0;
1403 sv_clear(&PL_sv_no);
1404 SvANY(&PL_sv_no) = NULL;
1405 SvFLAGS(&PL_sv_no) = 0;
1407 SvREFCNT(&PL_sv_zero) = 0;
1408 sv_clear(&PL_sv_zero);
1409 SvANY(&PL_sv_zero) = NULL;
1410 SvFLAGS(&PL_sv_zero) = 0;
1414 for (i=0; i<=2; i++) {
1415 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1416 sv_clear(PERL_DEBUG_PAD(i));
1417 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1418 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1422 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1423 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1425 #ifdef DEBUG_LEAKING_SCALARS
1426 if (PL_sv_count != 0) {
1431 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1432 svend = &sva[SvREFCNT(sva)];
1433 for (sv = sva + 1; sv < svend; ++sv) {
1434 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
1435 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1437 " refcnt=%" UVuf pTHX__FORMAT "\n"
1438 "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");"
1439 "serial %" UVuf "\n",
1440 (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1442 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1444 sv->sv_debug_inpad ? "for" : "by",
1445 sv->sv_debug_optype ?
1446 PL_op_name[sv->sv_debug_optype]: "(none)",
1447 PTR2UV(sv->sv_debug_parent),
1450 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1451 Perl_dump_sv_child(aTHX_ sv);
1457 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1461 /* Wait for up to 4 seconds for child to terminate.
1462 This seems to be the least effort way of timing out on reaping
1464 struct timeval waitfor = {4, 0};
1465 int sock = PL_dumper_fd;
1469 FD_SET(sock, &rset);
1470 select(sock + 1, &rset, NULL, NULL, &waitfor);
1471 waitpid(child, &status, WNOHANG);
1476 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1482 #if defined(PERLIO_LAYERS)
1483 /* No more IO - including error messages ! */
1484 PerlIO_cleanup(aTHX);
1487 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1488 as currently layers use it rather than NULL as a marker
1489 for no arg - and will try and SvREFCNT_dec it.
1491 SvREFCNT(&PL_sv_undef) = 0;
1492 SvREADONLY_off(&PL_sv_undef);
1494 Safefree(PL_origfilename);
1495 PL_origfilename = NULL;
1496 Safefree(PL_reg_curpm);
1497 free_tied_hv_pool();
1498 Safefree(PL_op_mask);
1499 Safefree(PL_psig_name);
1500 PL_psig_name = (SV**)NULL;
1501 PL_psig_ptr = (SV**)NULL;
1503 /* We need to NULL PL_psig_pend first, so that
1504 signal handlers know not to use it */
1505 int *psig_save = PL_psig_pend;
1506 PL_psig_pend = (int*)NULL;
1507 Safefree(psig_save);
1510 TAINTING_set(FALSE);
1511 TAINT_WARN_set(FALSE);
1512 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
1514 DEBUG_P(debprofdump());
1518 #ifdef USE_REENTRANT_API
1519 Perl_reentrant_free(aTHX);
1522 /* These all point to HVs that are about to be blown away.
1523 Code in core and on CPAN assumes that if the interpreter is re-started
1524 that they will be cleanly NULL or pointing to a valid HV. */
1525 PL_custom_op_names = NULL;
1526 PL_custom_op_descs = NULL;
1527 PL_custom_ops = NULL;
1531 while (PL_regmatch_slab) {
1532 regmatch_slab *s = PL_regmatch_slab;
1533 PL_regmatch_slab = PL_regmatch_slab->next;
1537 /* As the absolutely last thing, free the non-arena SV for mess() */
1540 /* we know that type == SVt_PVMG */
1542 /* it could have accumulated taint magic */
1545 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1546 moremagic = mg->mg_moremagic;
1547 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1549 Safefree(mg->mg_ptr);
1553 /* we know that type >= SVt_PV */
1554 SvPV_free(PL_mess_sv);
1555 Safefree(SvANY(PL_mess_sv));
1556 Safefree(PL_mess_sv);
1563 =for apidoc perl_free
1565 Releases a Perl interpreter. See L<perlembed>.
1574 PERL_ARGS_ASSERT_PERL_FREE;
1576 if (PL_veto_cleanup)
1579 #ifdef PERL_TRACK_MEMPOOL
1582 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1583 * value as we're probably hunting memory leaks then
1585 if (PL_perl_destruct_level == 0) {
1586 const U32 old_debug = PL_debug;
1587 /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1588 thread at thread exit. */
1590 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1591 "free this thread's memory\n");
1592 PL_debug &= ~ DEBUG_m_FLAG;
1594 while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){
1595 char * next = (char *)(aTHXx->Imemory_debug_header.next);
1596 Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next;
1599 PL_debug = old_debug;
1605 # if defined(PERL_IMPLICIT_SYS)
1607 void *host = w32_internal_host;
1608 PerlMem_free(aTHXx);
1609 win32_delete_internal_host(host);
1612 PerlMem_free(aTHXx);
1615 PerlMem_free(aTHXx);
1619 #if defined(USE_ITHREADS)
1620 /* provide destructors to clean up the thread key when libperl is unloaded */
1621 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1623 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1624 #pragma fini "perl_fini"
1625 #elif defined(__sun) && !defined(__GNUC__)
1626 #pragma fini (perl_fini)
1630 #if defined(__GNUC__)
1631 __attribute__((destructor))
1636 PL_curinterp && !PL_veto_cleanup)
1641 #endif /* THREADS */
1644 =for apidoc call_atexit
1646 Add a function C<fn> to the list of functions to be called at global
1647 destruction. C<ptr> will be passed as an argument to C<fn>; it can point to a
1648 C<struct> so that you can pass anything you want.
1650 Note that under threads, C<fn> may run multiple times. This is because the
1651 list is executed each time the current or any descendent thread terminates.
1657 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1659 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1660 PL_exitlist[PL_exitlistlen].fn = fn;
1661 PL_exitlist[PL_exitlistlen].ptr = ptr;
1665 #ifdef USE_ENVIRON_ARRAY
1669 # ifdef USE_ITHREADS
1670 if (aTHX != PL_curinterp)
1676 size_t n_entries = 0, vars_size = 0;
1678 for (char **ep = environ; *ep; ++ep) {
1680 vars_size += strlen(*ep) + 1;
1683 /* To save memory, we store both the environ array and its values in a
1684 * single memory block. */
1685 char **new_environ = (char**)PerlMemShared_malloc(
1686 (sizeof(char*) * (n_entries + 1)) + vars_size
1688 char *vars = (char*)(new_environ + n_entries + 1);
1690 for (size_t i = 0, copied = 0; n_entries > i; ++i) {
1691 size_t len = strlen(environ[i]) + 1;
1692 new_environ[i] = (char *) CopyD(environ[i], vars + copied, len, char);
1695 new_environ[n_entries] = NULL;
1697 environ = new_environ;
1698 /* Store a pointer in a global variable to ensure it's always reachable so
1699 * LeakSanitizer/Valgrind won't complain about it. We can't ever free it.
1700 * Even if libc allocates a new environ, it's possible that some of its
1701 * values will still be pointing to the old environ.
1703 PL_my_environ = new_environ;
1708 =for apidoc perl_parse
1710 Tells a Perl interpreter to parse a Perl script. This performs most
1711 of the initialisation of a Perl interpreter. See L<perlembed> for
1714 C<my_perl> points to the Perl interpreter that is to parse the script.
1715 It must have been previously created through the use of L</perl_alloc>
1716 and L</perl_construct>. C<xsinit> points to a callback function that
1717 will be called to set up the ability for this Perl interpreter to load
1718 XS extensions, or may be null to perform no such setup.
1720 C<argc> and C<argv> supply a set of command-line arguments to the Perl
1721 interpreter, as would normally be passed to the C<main> function of
1722 a C program. C<argv[argc]> must be null. These arguments are where
1723 the script to parse is specified, either by naming a script file or by
1724 providing a script in a C<-e> option.
1725 If L<C<$0>|perlvar/$0> will be written to in the Perl interpreter, then
1726 the argument strings must be in writable memory, and so mustn't just be
1729 C<env> specifies a set of environment variables that will be used by
1730 this Perl interpreter. If non-null, it must point to a null-terminated
1731 array of environment strings. If null, the Perl interpreter will use
1732 the environment supplied by the C<environ> global variable.
1734 This function initialises the interpreter, and parses and compiles the
1735 script specified by the command-line arguments. This includes executing
1736 code in C<BEGIN>, C<UNITCHECK>, and C<CHECK> blocks. It does not execute
1737 C<INIT> blocks or the main program.
1739 Returns an integer of slightly tricky interpretation. The correct
1740 use of the return value is as a truth value indicating whether there
1741 was a failure in initialisation. If zero is returned, this indicates
1742 that initialisation was successful, and it is safe to proceed to call
1743 L</perl_run> and make other use of it. If a non-zero value is returned,
1744 this indicates some problem that means the interpreter wants to terminate.
1745 The interpreter should not be just abandoned upon such failure; the caller
1746 should proceed to shut the interpreter down cleanly with L</perl_destruct>
1747 and free it with L</perl_free>.
1749 For historical reasons, the non-zero return value also attempts to
1750 be a suitable value to pass to the C library function C<exit> (or to
1751 return from C<main>), to serve as an exit code indicating the nature
1752 of the way initialisation terminated. However, this isn't portable,
1753 due to differing exit code conventions. An attempt is made to return
1754 an exit code of the type required by the host operating system, but
1755 because it is constrained to be non-zero, it is not necessarily possible
1756 to indicate every type of exit. It is only reliable on Unix, where a
1757 zero exit code can be augmented with a set bit that will be ignored.
1758 In any case, this function is not the correct place to acquire an exit
1759 code: one should get that from L</perl_destruct>.
1764 #define SET_CURSTASH(newstash) \
1765 if (PL_curstash != newstash) { \
1766 SvREFCNT_dec(PL_curstash); \
1767 PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1771 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1777 PERL_ARGS_ASSERT_PERL_PARSE;
1778 #ifndef MULTIPLICITY
1779 PERL_UNUSED_ARG(my_perl);
1781 debug_hash_seed(false);
1784 struct NameTranslationInfo nti;
1785 __translate_amiga_to_unix_path_name(&argv[0],&nti);
1792 for(i = 0; i != argc; i++)
1794 assert(!argv[argc]);
1799 if (PL_origalen != 0) {
1800 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1803 /* Set PL_origalen be the sum of the contiguous argv[]
1804 * elements plus the size of the env in case that it is
1805 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1806 * as the maximum modifiable length of $0. In the worst case
1807 * the area we are able to modify is limited to the size of
1808 * the original argv[0]. (See below for 'contiguous', though.)
1810 const char *s = NULL;
1811 const UV mask = ~(UV)(PTRSIZE-1);
1812 /* Do the mask check only if the args seem like aligned. */
1814 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1816 /* See if all the arguments are contiguous in memory. Note
1817 * that 'contiguous' is a loose term because some platforms
1818 * align the argv[] and the envp[]. If the arguments look
1819 * like non-aligned, assume that they are 'strictly' or
1820 * 'traditionally' contiguous. If the arguments look like
1821 * aligned, we just check that they are within aligned
1822 * PTRSIZE bytes. As long as no system has something bizarre
1823 * like the argv[] interleaved with some other data, we are
1824 * fine. (Did I just evoke Murphy's Law?) --jhi */
1825 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1828 for (i = 1; i < PL_origargc; i++) {
1829 if ((PL_origargv[i] == s + 1
1831 || PL_origargv[i] == s + 2
1836 (PL_origargv[i] > s &&
1838 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1849 #ifdef USE_ENVIRON_ARRAY
1850 /* Can we grab env area too to be used as the area for $0? */
1851 if (s && PL_origenviron) {
1852 if ((PL_origenviron[0] == s + 1)
1855 (PL_origenviron[0] > s &&
1856 PL_origenviron[0] <=
1857 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1861 #ifndef OS2 /* ENVIRON is read by the kernel too. */
1862 s = PL_origenviron[0];
1866 /* Force copy of environment. */
1867 if (PL_origenviron == environ)
1870 for (i = 1; PL_origenviron[i]; i++) {
1871 if (PL_origenviron[i] == s + 1
1874 (PL_origenviron[i] > s &&
1875 PL_origenviron[i] <=
1876 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1879 s = PL_origenviron[i];
1887 #endif /* USE_ENVIRON_ARRAY */
1889 PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1894 /* Come here if running an undumped a.out. */
1896 PL_origfilename = savepv(argv[0]);
1897 PL_do_undump = FALSE;
1898 cxstack_ix = -1; /* start label stack again */
1900 assert (!TAINT_get);
1904 init_postdump_symbols(argc,argv,env);
1909 op_free(PL_main_root);
1910 PL_main_root = NULL;
1912 PL_main_start = NULL;
1913 SvREFCNT_dec(PL_main_cv);
1917 oldscope = PL_scopestack_ix;
1918 PL_dowarn = G_WARN_OFF;
1923 parse_body(env,xsinit);
1924 if (PL_unitcheckav) {
1925 call_list(oldscope, PL_unitcheckav);
1928 PERL_SET_PHASE(PERL_PHASE_CHECK);
1929 call_list(oldscope, PL_checkav);
1937 /* my_exit() was called */
1938 while (PL_scopestack_ix > oldscope)
1941 SET_CURSTASH(PL_defstash);
1942 if (PL_unitcheckav) {
1943 call_list(oldscope, PL_unitcheckav);
1946 PERL_SET_PHASE(PERL_PHASE_CHECK);
1947 call_list(oldscope, PL_checkav);
1952 * We do this here to avoid [perl #2754].
1953 * Note this may cause trouble with Module::Install.
1954 * See: [perl #132577].
1960 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1968 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1969 miniperl, and we need to see those flags reflected in the values here. */
1971 /* What this returns is subject to change. Use the public interface in Config.
1975 S_Internals_V(pTHX_ CV *cv)
1978 #ifdef LOCAL_PATCH_COUNT
1979 const int local_patch_count = LOCAL_PATCH_COUNT;
1981 const int local_patch_count = 0;
1983 const int entries = 3 + local_patch_count;
1985 /* NOTE - This list must remain sorted. Do not put any settings here
1986 * which affect binary compatibility */
1987 static const char non_bincompat_options[] =
1994 # ifdef NO_TAINT_SUPPORT
1997 # ifdef PERL_COPY_ON_WRITE
1998 " PERL_COPY_ON_WRITE"
2000 # ifdef PERL_DISABLE_PMC
2003 # ifdef PERL_DONT_CREATE_GVSV
2004 " PERL_DONT_CREATE_GVSV"
2006 # ifdef PERL_EXTERNAL_GLOB
2007 " PERL_EXTERNAL_GLOB"
2009 # ifdef PERL_IS_MINIPERL
2012 # ifdef PERL_MALLOC_WRAP
2015 # ifdef PERL_MEM_LOG
2018 # ifdef PERL_MEM_LOG_NOIMPL
2019 " PERL_MEM_LOG_NOIMPL"
2021 # ifdef PERL_OP_PARENT
2024 # ifdef PERL_PERTURB_KEYS_DETERMINISTIC
2025 " PERL_PERTURB_KEYS_DETERMINISTIC"
2027 # ifdef PERL_PERTURB_KEYS_DISABLED
2028 " PERL_PERTURB_KEYS_DISABLED"
2030 # ifdef PERL_PERTURB_KEYS_RANDOM
2031 " PERL_PERTURB_KEYS_RANDOM"
2033 # ifdef PERL_PRESERVE_IVUV
2034 " PERL_PRESERVE_IVUV"
2036 # ifdef PERL_RELOCATABLE_INCPUSH
2037 " PERL_RELOCATABLE_INCPUSH"
2039 # ifdef PERL_USE_DEVEL
2042 # ifdef PERL_USE_SAFE_PUTENV
2043 " PERL_USE_SAFE_PUTENV"
2046 # ifdef PERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES
2047 " PERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES"
2049 # ifdef SILENT_NO_TAINT_SUPPORT
2050 " SILENT_NO_TAINT_SUPPORT"
2052 # ifdef UNLINK_ALL_VERSIONS
2053 " UNLINK_ALL_VERSIONS"
2055 # ifdef USE_ATTRIBUTES_FOR_PERLIO
2056 " USE_ATTRIBUTES_FOR_PERLIO"
2058 # ifdef USE_FAST_STDIO
2064 # ifdef USE_LOCALE_CTYPE
2067 # ifdef WIN32_NO_REGISTRY
2070 # ifdef USE_PERL_ATOF
2073 # ifdef USE_SITECUSTOMIZE
2074 " USE_SITECUSTOMIZE"
2076 # ifdef USE_THREAD_SAFE_LOCALE
2077 " USE_THREAD_SAFE_LOCALE"
2079 # ifdef NO_PERL_RAND_SEED
2080 " NO_PERL_RAND_SEED"
2082 # ifdef NO_PERL_INTERNAL_RAND_SEED
2083 " NO_PERL_INTERNAL_RAND_SEED"
2086 PERL_UNUSED_ARG(cv);
2087 PERL_UNUSED_VAR(items);
2089 EXTEND(SP, entries);
2091 PUSHs(newSVpvn_flags(PL_bincompat_options, strlen(PL_bincompat_options),
2093 PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
2094 sizeof(non_bincompat_options) - 1, SVs_TEMP));
2096 #ifndef PERL_BUILD_DATE
2099 # define PERL_BUILD_DATE __DATE__ " " __TIME__
2101 # define PERL_BUILD_DATE __DATE__
2106 #ifdef PERL_BUILD_DATE
2107 PUSHs(Perl_newSVpvn_flags(aTHX_
2108 STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
2111 PUSHs(&PL_sv_undef);
2114 for (i = 1; i <= local_patch_count; i++) {
2115 /* This will be an undef, if PL_localpatches[i] is NULL. */
2116 PUSHs(newSVpvn_flags(PL_localpatches[i],
2117 PL_localpatches[i] == NULL ? 0 : strlen(PL_localpatches[i]),
2124 #define INCPUSH_UNSHIFT 0x01
2125 #define INCPUSH_ADD_OLD_VERS 0x02
2126 #define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04
2127 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08
2128 #define INCPUSH_NOT_BASEDIR 0x10
2129 #define INCPUSH_CAN_RELOCATE 0x20
2130 #define INCPUSH_ADD_SUB_DIRS \
2131 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
2134 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
2137 int argc = PL_origargc;
2138 char **argv = PL_origargv;
2139 const char *scriptname = NULL;
2140 bool dosearch = FALSE;
2142 bool doextract = FALSE;
2143 const char *cddir = NULL;
2144 bool minus_e = FALSE; /* both -e and -E */
2145 #ifdef USE_SITECUSTOMIZE
2146 bool minus_f = FALSE;
2148 SV *linestr_sv = NULL;
2149 bool add_read_e_script = FALSE;
2150 U32 lex_start_flags = 0;
2152 PERL_SET_PHASE(PERL_PHASE_START);
2158 for (argc--,argv++; argc > 0; argc--,argv++) {
2159 if (argv[0][0] != '-' || !argv[0][1])
2165 #ifndef PERL_STRICT_CR
2191 if ((s = moreswitches(s)))
2196 #if defined(SILENT_NO_TAINT_SUPPORT)
2197 /* silently ignore */
2198 #elif defined(NO_TAINT_SUPPORT)
2199 Perl_croak_nocontext("This perl was compiled without taint support. "
2200 "Cowardly refusing to run with -t or -T flags");
2202 CHECK_MALLOC_TOO_LATE_FOR('t');
2203 if( !TAINTING_get ) {
2204 TAINT_WARN_set(TRUE);
2211 #if defined(SILENT_NO_TAINT_SUPPORT)
2212 /* silently ignore */
2213 #elif defined(NO_TAINT_SUPPORT)
2214 Perl_croak_nocontext("This perl was compiled without taint support. "
2215 "Cowardly refusing to run with -t or -T flags");
2217 CHECK_MALLOC_TOO_LATE_FOR('T');
2219 TAINT_WARN_set(FALSE);
2228 forbid_setid('e', FALSE);
2231 PL_e_script = newSVpvs("");
2232 add_read_e_script = TRUE;
2235 sv_catpv(PL_e_script, s);
2237 sv_catpv(PL_e_script, argv[1]);
2241 Perl_croak(aTHX_ "No code specified for -%c", c);
2242 sv_catpvs(PL_e_script, "\n");
2246 #ifdef USE_SITECUSTOMIZE
2252 case 'I': /* -I handled both here and in moreswitches() */
2253 forbid_setid('I', FALSE);
2254 if (!*++s && (s=argv[1]) != NULL) {
2258 STRLEN len = strlen(s);
2259 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
2262 Perl_croak(aTHX_ "No directory specified for -I");
2265 forbid_setid('S', FALSE);
2274 opts_prog = newSVpvs("use Config; Config::_V()");
2278 opts_prog = Perl_newSVpvf(aTHX_
2279 "use Config; Config::config_vars(qw%c%s%c)",
2283 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
2284 /* don't look for script or read stdin */
2285 scriptname = BIT_BUCKET;
2297 if (!*++s || isSPACE(*s)) {
2301 /* catch use of gnu style long options.
2302 Both of these exit immediately. */
2303 if (strEQ(s, "version"))
2305 if (strEQ(s, "help"))
2310 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
2321 #ifndef SECURE_INTERNAL_GETENV
2324 (s = PerlEnv_getenv("PERL5OPT")))
2328 if (*s == '-' && *(s+1) == 'T') {
2329 #if defined(SILENT_NO_TAINT_SUPPORT)
2330 /* silently ignore */
2331 #elif defined(NO_TAINT_SUPPORT)
2332 Perl_croak_nocontext("This perl was compiled without taint support. "
2333 "Cowardly refusing to run with -t or -T flags");
2335 CHECK_MALLOC_TOO_LATE_FOR('T');
2337 TAINT_WARN_set(FALSE);
2341 char *popt_copy = NULL;
2354 if (!memCHRs("CDIMUdmtwW", *s))
2355 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2359 popt_copy = SvPVX(newSVpvn_flags(d, strlen(d), SVs_TEMP));
2360 s = popt_copy + (s - d);
2368 #if defined(SILENT_NO_TAINT_SUPPORT)
2369 /* silently ignore */
2370 #elif defined(NO_TAINT_SUPPORT)
2371 Perl_croak_nocontext("This perl was compiled without taint support. "
2372 "Cowardly refusing to run with -t or -T flags");
2374 if( !TAINTING_get) {
2375 TAINT_WARN_set(TRUE);
2387 #ifndef NO_PERL_INTERNAL_RAND_SEED
2388 /* If we're not set[ug]id, we might have honored
2389 PERL_INTERNAL_RAND_SEED in perl_construct().
2390 At this point command-line options have been parsed, so if
2391 we're now tainting and not set[ug]id re-seed.
2392 This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid,
2393 but avoids duplicating the logic from perl_construct().
2396 PerlProc_getuid() == PerlProc_geteuid() &&
2397 PerlProc_getgid() == PerlProc_getegid()) {
2398 Perl_drand48_init_r(&PL_internal_random_state, seed());
2402 debug_hash_seed(true);
2404 /* Set $^X early so that it can be used for relocatable paths in @INC */
2405 /* and for SITELIB_EXP in USE_SITECUSTOMIZE */
2406 assert (!TAINT_get);
2411 #if defined(USE_SITECUSTOMIZE)
2413 /* The games with local $! are to avoid setting errno if there is no
2414 sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2415 ie a q() operator with a NUL byte as a the delimiter. This avoids
2416 problems with pathnames containing (say) ' */
2417 # ifdef PERL_IS_MINIPERL
2418 AV *const inc = GvAV(PL_incgv);
2419 SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2422 /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2423 it should be reported immediately as a build failure. */
2424 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2426 "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; "
2427 "do {local $!; -f $f }"
2428 " and do $f || die $@ || qq '$f: $!' }",
2429 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
2432 /* SITELIB_EXP is a function call on Win32. */
2433 const char *const raw_sitelib = SITELIB_EXP;
2435 /* process .../.. if PERL_RELOCATABLE_INC is defined */
2436 SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2437 INCPUSH_CAN_RELOCATE);
2438 const char *const sitelib = SvPVX(sitelib_sv);
2439 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2441 "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2444 assert (SvREFCNT(sitelib_sv) == 1);
2445 SvREFCNT_dec(sitelib_sv);
2452 scriptname = argv[0];
2455 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2457 else if (scriptname == NULL) {
2461 assert (!TAINT_get);
2465 bool suidscript = FALSE;
2467 rsfp = open_script(scriptname, dosearch, &suidscript);
2469 rsfp = PerlIO_stdin();
2470 lex_start_flags = LEX_DONT_CLOSE_RSFP;
2473 validate_suid(rsfp);
2476 # if defined(SIGCHLD) || defined(SIGCLD)
2479 # define SIGCHLD SIGCLD
2481 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2482 if (sigstate == (Sighandler_t) SIG_IGN) {
2483 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2484 "Can't ignore signal CHLD, forcing to default");
2485 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2493 /* This will croak if suidscript is true, as -x cannot be used with
2495 forbid_setid('x', suidscript);
2496 /* Hence you can't get here if suidscript is true */
2498 linestr_sv = newSV_type(SVt_PV);
2499 lex_start_flags |= LEX_START_COPIED;
2500 find_beginning(linestr_sv, rsfp);
2501 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2502 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2506 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2507 CvUNIQUE_on(PL_compcv);
2509 CvPADLIST_set(PL_compcv, pad_new(0));
2511 PL_isarev = newHV();
2514 boot_core_UNIVERSAL();
2515 boot_core_builtin();
2517 newXS("Internals::V", S_Internals_V, __FILE__);
2520 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
2522 #if defined(VMS) || defined(WIN32) || defined(__CYGWIN__)
2528 # ifdef HAS_SOCKS5_INIT
2529 socks5_init(argv[0]);
2535 init_predump_symbols();
2536 /* init_postdump_symbols not currently designed to be called */
2537 /* more than once (ENV isn't cleared first, for example) */
2538 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2540 init_postdump_symbols(argc,argv,env);
2542 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2543 * or explicitly in some platforms.
2544 * PL_utf8locale is conditionally turned on by
2545 * locale.c:Perl_init_i18nl10n() if the environment
2546 * look like the user wants to use UTF-8. */
2547 # ifndef PERL_IS_MINIPERL
2549 /* Requires init_predump_symbols(). */
2550 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2555 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2556 * and the default open disciplines. */
2557 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2558 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2560 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2561 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2562 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2564 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2565 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2566 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2568 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2569 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2570 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2572 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2573 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2576 sv_setpvs(sv, ":utf8\0:utf8");
2578 sv_setpvs(sv, ":utf8\0");
2581 sv_setpvs(sv, "\0:utf8");
2590 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2591 if (strEQ(s, "unsafe"))
2592 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2593 else if (strEQ(s, "safe"))
2594 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2596 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2601 lex_start(linestr_sv, rsfp, lex_start_flags);
2602 SvREFCNT_dec(linestr_sv);
2604 PL_subname = newSVpvs("main");
2606 if (add_read_e_script)
2607 filter_add(read_e_script, NULL);
2609 /* now parse the script */
2610 if (minus_e == FALSE)
2611 PL_hints |= HINTS_DEFAULT; /* after init_main_stash ; need to be after init_predump_symbols */
2613 SETERRNO(0,SS_NORMAL);
2614 if (yyparse(GRAMPROG) || PL_parser->error_count) {
2615 abort_execution(NULL, PL_origfilename);
2617 CopLINE_set(PL_curcop, 0);
2618 SET_CURSTASH(PL_defstash);
2620 SvREFCNT_dec(PL_e_script);
2628 SAVECOPFILE(PL_curcop);
2629 SAVECOPLINE(PL_curcop);
2630 gv_check(PL_defstash);
2640 s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
2641 if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
2642 dump_mstats("after compilation:");
2647 PL_restartjmpenv = NULL;
2653 =for apidoc perl_run
2655 Tells a Perl interpreter to run its main program. See L<perlembed>
2658 C<my_perl> points to the Perl interpreter. It must have been previously
2659 created through the use of L</perl_alloc> and L</perl_construct>, and
2660 initialised through L</perl_parse>. This function should not be called
2661 if L</perl_parse> returned a non-zero value, indicating a failure in
2662 initialisation or compilation.
2664 This function executes code in C<INIT> blocks, and then executes the
2665 main program. The code to be executed is that established by the prior
2666 call to L</perl_parse>. If the interpreter's C<PL_exit_flags> word
2667 does not have the C<PERL_EXIT_DESTRUCT_END> flag set, then this function
2668 will also execute code in C<END> blocks. If it is desired to make any
2669 further use of the interpreter after calling this function, then C<END>
2670 blocks should be postponed to L</perl_destruct> time by setting that flag.
2672 Returns an integer of slightly tricky interpretation. The correct use
2673 of the return value is as a truth value indicating whether the program
2674 terminated non-locally. If zero is returned, this indicates that
2675 the program ran to completion, and it is safe to make other use of the
2676 interpreter (provided that the C<PERL_EXIT_DESTRUCT_END> flag was set as
2677 described above). If a non-zero value is returned, this indicates that
2678 the interpreter wants to terminate early. The interpreter should not be
2679 just abandoned because of this desire to terminate; the caller should
2680 proceed to shut the interpreter down cleanly with L</perl_destruct>
2681 and free it with L</perl_free>.
2683 For historical reasons, the non-zero return value also attempts to
2684 be a suitable value to pass to the C library function C<exit> (or to
2685 return from C<main>), to serve as an exit code indicating the nature of
2686 the way the program terminated. However, this isn't portable, due to
2687 differing exit code conventions. An attempt is made to return an exit
2688 code of the type required by the host operating system, but because
2689 it is constrained to be non-zero, it is not necessarily possible to
2690 indicate every type of exit. It is only reliable on Unix, where a zero
2691 exit code can be augmented with a set bit that will be ignored. In any
2692 case, this function is not the correct place to acquire an exit code:
2693 one should get that from L</perl_destruct>.
2705 PERL_ARGS_ASSERT_PERL_RUN;
2706 #ifndef MULTIPLICITY
2707 PERL_UNUSED_ARG(my_perl);
2710 oldscope = PL_scopestack_ix;
2718 cxstack_ix = -1; /* start context stack again */
2720 case 0: /* normal completion */
2724 case 2: /* my_exit() */
2725 while (PL_scopestack_ix > oldscope)
2728 SET_CURSTASH(PL_defstash);
2729 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2730 PL_endav && !PL_minus_c) {
2731 PERL_SET_PHASE(PERL_PHASE_END);
2732 call_list(oldscope, PL_endav);
2735 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2736 dump_mstats("after execution: ");
2742 POPSTACK_TO(PL_mainstack);
2745 PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2756 S_run_body(pTHX_ I32 oldscope)
2758 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2759 PL_sawampersand ? "Enabling" : "Omitting",
2760 (unsigned int)(PL_sawampersand)));
2762 if (!PL_restartop) {
2764 if (DEBUG_x_TEST || DEBUG_B_TEST)
2765 dump_all_perl(!DEBUG_B_TEST);
2767 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2771 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2774 if (PERLDB_SINGLE && PL_DBsingle)
2777 PERL_SET_PHASE(PERL_PHASE_INIT);
2778 call_list(oldscope, PL_initav);
2780 #ifdef PERL_DEBUG_READONLY_OPS
2781 if (PL_main_root && PL_main_root->op_slabbed)
2782 Slab_to_ro(OpSLAB(PL_main_root));
2788 PERL_SET_PHASE(PERL_PHASE_RUN);
2792 /* this complements the "EXECUTING..." debug we emit above.
2793 * it will show up when an eval fails in the main program level
2794 * and the code continues after the error.
2797 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nCONTINUING...\n\n"));
2799 PL_restartjmpenv = NULL;
2800 PL_op = PL_restartop;
2804 else if (PL_main_start) {
2805 CvDEPTH(PL_main_cv) = 1;
2806 PL_op = PL_main_start;
2810 NOT_REACHED; /* NOTREACHED */
2814 =for apidoc_section $SV
2818 Returns the SV of the specified Perl scalar. C<flags> are passed to
2819 L</C<gv_fetchpv>>. If C<GV_ADD> is set and the
2820 Perl variable does not exist then it will be created. If C<flags> is zero
2821 and the variable does not exist then NULL is returned.
2827 Perl_get_sv(pTHX_ const char *name, I32 flags)
2831 PERL_ARGS_ASSERT_GET_SV;
2833 gv = gv_fetchpv(name, flags, SVt_PV);
2840 =for apidoc_section $AV
2844 Returns the AV of the specified Perl global or package array with the given
2845 name (so it won't work on lexical variables). C<flags> are passed
2846 to C<gv_fetchpv>. If C<GV_ADD> is set and the
2847 Perl variable does not exist then it will be created. If C<flags> is zero
2848 and the variable does not exist then NULL is returned.
2850 Perl equivalent: C<@{"$name"}>.
2856 Perl_get_av(pTHX_ const char *name, I32 flags)
2858 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2860 PERL_ARGS_ASSERT_GET_AV;
2870 =for apidoc_section $HV
2874 Returns the HV of the specified Perl hash. C<flags> are passed to
2875 C<gv_fetchpv>. If C<GV_ADD> is set and the
2876 Perl variable does not exist then it will be created. If C<flags> is zero
2877 and the variable does not exist then C<NULL> is returned.
2883 Perl_get_hv(pTHX_ const char *name, I32 flags)
2885 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2887 PERL_ARGS_ASSERT_GET_HV;
2897 =for apidoc_section $CV
2900 =for apidoc_item get_cvn_flags
2901 =for apidoc_item |CV *|get_cvs|"string"|I32 flags
2903 These return the CV of the specified Perl subroutine. C<flags> are passed to
2904 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2905 exist then it will be declared (which has the same effect as saying
2906 C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist,
2907 then NULL is returned.
2909 The forms differ only in how the subroutine is specified.. With C<get_cvs>,
2910 the name is a literal C string, enclosed in double quotes. With C<get_cv>, the
2911 name is given by the C<name> parameter, which must be a NUL-terminated C
2912 string. With C<get_cvn_flags>, the name is also given by the C<name>
2913 parameter, but it is a Perl string (possibly containing embedded NUL bytes),
2914 and its length in bytes is contained in the C<len> parameter.
2916 =for apidoc Amnh||GV_ADD
2922 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2924 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2926 PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2928 if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV)
2929 return (CV*)SvRV((SV *)gv);
2931 /* XXX this is probably not what they think they're getting.
2932 * It has the same effect as "sub name;", i.e. just a forward
2934 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2935 return newSTUB(gv,0);
2942 /* Nothing in core calls this now, but we can't replace it with a macro and
2943 move it to mathoms.c as a macro would evaluate name twice. */
2945 Perl_get_cv(pTHX_ const char *name, I32 flags)
2947 PERL_ARGS_ASSERT_GET_CV;
2949 return get_cvn_flags(name, strlen(name), flags);
2952 /* Be sure to refetch the stack pointer after calling these routines. */
2956 =for apidoc_section $callback
2958 =for apidoc call_argv
2960 Performs a callback to the specified named and package-scoped Perl subroutine
2961 with C<argv> (a C<NULL>-terminated array of strings) as arguments. See
2964 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2970 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2972 /* See G_* flags in cop.h */
2973 /* null terminated arg list */
2977 PERL_ARGS_ASSERT_CALL_ARGV;
2981 mXPUSHs(newSVpv(*argv,0));
2985 return call_pv(sub_name, flags);
2991 Performs a callback to the specified Perl sub. See L<perlcall>.
2997 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2998 /* name of the subroutine */
2999 /* See G_* flags in cop.h */
3001 PERL_ARGS_ASSERT_CALL_PV;
3003 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
3007 =for apidoc call_method
3009 Performs a callback to the specified Perl method. The blessed object must
3010 be on the stack. See L<perlcall>.
3016 Perl_call_method(pTHX_ const char *methname, I32 flags)
3017 /* name of the subroutine */
3018 /* See G_* flags in cop.h */
3022 PERL_ARGS_ASSERT_CALL_METHOD;
3024 len = strlen(methname);
3025 sv = flags & G_METHOD_NAMED
3026 ? sv_2mortal(newSVpvn_share(methname, len,0))
3027 : newSVpvn_flags(methname, len, SVs_TEMP);
3029 return call_sv(sv, flags | G_METHOD);
3032 /* May be called with any of a CV, a GV, or an SV containing the name. */
3036 Performs a callback to the Perl sub specified by the SV.
3038 If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
3039 SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
3040 or C<SvPV(sv)> will be used as the name of the sub to call.
3042 If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
3043 C<SvPV(sv)> will be used as the name of the method to call.
3045 If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
3046 the name of the method to call.
3048 Some other values are treated specially for internal use and should
3053 =for apidoc Amnh||G_METHOD
3054 =for apidoc Amnh||G_METHOD_NAMED
3060 Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
3061 /* See G_* flags in cop.h */
3063 LOGOP myop; /* fake syntax tree node */
3066 volatile I32 retval = 0;
3067 bool oldcatch = CATCH_GET;
3069 OP* const oldop = PL_op;
3072 PERL_ARGS_ASSERT_CALL_SV;
3074 if (flags & G_DISCARD) {
3078 if (!(flags & G_WANT)) {
3079 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
3084 Zero(&myop, 1, LOGOP);
3085 if (!(flags & G_NOARGS))
3086 myop.op_flags |= OPf_STACKED;
3087 myop.op_flags |= OP_GIMME_REVERSE(flags);
3091 if (!(flags & G_METHOD_NAMED)) {
3099 if (PERLDB_SUB && PL_curstash != PL_debstash
3100 /* Handle first BEGIN of -d. */
3101 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
3102 /* Try harder, since this may have been a sighandler, thus
3103 * curstash may be meaningless. */
3104 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
3105 && !(flags & G_NODEBUG))
3106 myop.op_private |= OPpENTERSUB_DB;
3108 if (flags & (G_METHOD|G_METHOD_NAMED)) {
3109 Zero(&method_op, 1, METHOP);
3110 method_op.op_next = (OP*)&myop;
3111 PL_op = (OP*)&method_op;
3112 if ( flags & G_METHOD_NAMED ) {
3113 method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
3114 method_op.op_type = OP_METHOD_NAMED;
3115 method_op.op_u.op_meth_sv = sv;
3117 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
3118 method_op.op_type = OP_METHOD;
3120 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
3121 myop.op_type = OP_ENTERSUB;
3124 if (!(flags & G_EVAL)) {
3126 CALL_BODY_SUB((OP*)&myop);
3127 retval = PL_stack_sp - (PL_stack_base + oldmark);
3128 CATCH_SET(oldcatch);
3132 myop.op_other = (OP*)&myop;
3134 old_cxix = cxstack_ix;
3135 create_eval_scope(NULL, flags|G_FAKINGEVAL);
3143 CALL_BODY_SUB((OP*)&myop);
3144 retval = PL_stack_sp - (PL_stack_base + oldmark);
3145 if (!(flags & G_KEEPERR)) {
3153 /* my_exit() was called */
3154 SET_CURSTASH(PL_defstash);
3158 NOT_REACHED; /* NOTREACHED */
3161 PL_restartjmpenv = NULL;
3162 PL_op = PL_restartop;
3166 PL_stack_sp = PL_stack_base + oldmark;
3167 if ((flags & G_WANT) == G_LIST)
3171 *++PL_stack_sp = &PL_sv_undef;
3176 /* if we croaked, depending on how we croaked the eval scope
3177 * may or may not have already been popped */
3178 if (cxstack_ix > old_cxix) {
3179 assert(cxstack_ix == old_cxix + 1);
3180 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3181 delete_eval_scope();
3186 if (flags & G_DISCARD) {
3187 PL_stack_sp = PL_stack_base + oldmark;
3196 /* Eval a string. The G_EVAL flag is always assumed. */
3201 Tells Perl to C<eval> the string in the SV. It supports the same flags
3202 as C<call_sv>, with the obvious exception of C<G_EVAL>. See L<perlcall>.
3204 The C<G_RETHROW> flag can be used if you only need eval_sv() to
3205 execute code specified by a string, but not catch any errors.
3207 =for apidoc Amnh||G_RETHROW
3212 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
3214 /* See G_* flags in cop.h */
3216 UNOP myop; /* fake syntax tree node */
3217 volatile I32 oldmark;
3218 volatile I32 retval = 0;
3220 OP* const oldop = PL_op;
3223 PERL_ARGS_ASSERT_EVAL_SV;
3225 if (flags & G_DISCARD) {
3232 Zero(&myop, 1, UNOP);
3235 oldmark = SP - PL_stack_base;
3241 if (!(flags & G_NOARGS))
3242 myop.op_flags = OPf_STACKED;
3243 myop.op_type = OP_ENTEREVAL;
3244 myop.op_flags |= OP_GIMME_REVERSE(flags);
3245 if (flags & G_KEEPERR)
3246 myop.op_flags |= OPf_SPECIAL;
3248 if (flags & G_RE_REPARSING)
3249 myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
3251 /* fail now; otherwise we could fail after the JMPENV_PUSH but
3252 * before a cx_pusheval(), which corrupts the stack after a croak */
3253 TAINT_PROPER("eval_sv()");
3259 if (PL_op == (OP*)(&myop)) {
3260 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
3262 goto fail; /* failed in compilation */
3265 retval = PL_stack_sp - (PL_stack_base + oldmark);
3266 if (!(flags & G_KEEPERR)) {
3274 /* my_exit() was called */
3275 SET_CURSTASH(PL_defstash);
3279 NOT_REACHED; /* NOTREACHED */
3282 PL_restartjmpenv = NULL;
3283 PL_op = PL_restartop;
3288 if (flags & G_RETHROW) {
3293 PL_stack_sp = PL_stack_base + oldmark;
3294 if ((flags & G_WANT) == G_LIST)
3298 *++PL_stack_sp = &PL_sv_undef;
3304 if (flags & G_DISCARD) {
3305 PL_stack_sp = PL_stack_base + oldmark;
3317 Tells Perl to C<eval> the given string in scalar context and return an SV* result.
3323 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
3325 SV* sv = newSVpv(p, 0);
3327 PERL_ARGS_ASSERT_EVAL_PV;
3329 if (croak_on_error) {
3331 eval_sv(sv, G_SCALAR | G_RETHROW);
3334 eval_sv(sv, G_SCALAR);
3347 /* Require a module. */
3350 =for apidoc_section $embedding
3352 =for apidoc require_pv
3354 Tells Perl to C<require> the file named by the string argument. It is
3355 analogous to the Perl code C<eval "require '$file'">. It's even
3356 implemented that way; consider using load_module instead.
3361 Perl_require_pv(pTHX_ const char *pv)
3366 PERL_ARGS_ASSERT_REQUIRE_PV;
3368 PUSHSTACKi(PERLSI_REQUIRE);
3369 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3370 eval_sv(sv_2mortal(sv), G_DISCARD);
3375 S_usage(pTHX) /* XXX move this out into a module ? */
3377 /* This message really ought to be max 23 lines.
3378 * Removed -h because the user already knows that option. Others? */
3380 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3381 minimum of 509 character string literals. */
3382 static const char * const usage_msg[] = {
3383 " -0[octal/hexadecimal] specify record separator (\\0, if no argument)\n"
3384 " -a autosplit mode with -n or -p (splits $_ into @F)\n"
3385 " -C[number/list] enables the listed Unicode features\n"
3386 " -c check syntax only (runs BEGIN and CHECK blocks)\n"
3387 " -d[t][:MOD] run program under debugger or module Devel::MOD\n"
3388 " -D[number/letters] set debugging flags (argument is a bit mask or alphabets)\n",
3389 " -e commandline one line of program (several -e's allowed, omit programfile)\n"
3390 " -E commandline like -e, but enables all optional features\n"
3391 " -f don't do $sitelib/sitecustomize.pl at startup\n"
3392 " -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
3393 " -g read all input in one go (slurp), rather than line-by-line (alias for -0777)\n"
3394 " -i[extension] edit <> files in place (makes backup if extension supplied)\n"
3395 " -Idirectory specify @INC/#include directory (several -I's allowed)\n",
3396 " -l[octnum] enable line ending processing, specifies line terminator\n"
3397 " -[mM][-]module execute \"use/no module...\" before executing program\n"
3398 " -n assume \"while (<>) { ... }\" loop around program\n"
3399 " -p assume loop like -n but print line also, like sed\n"
3400 " -s enable rudimentary parsing for switches after programfile\n"
3401 " -S look for programfile using PATH environment variable\n",
3402 " -t enable tainting warnings\n"
3403 " -T enable tainting checks\n"
3404 " -u dump core after parsing program\n"
3405 " -U allow unsafe operations\n"
3406 " -v print version, patchlevel and license\n"
3407 " -V[:configvar] print configuration summary (or a single Config.pm variable)\n",
3408 " -w enable many useful warnings\n"
3409 " -W enable all warnings\n"
3410 " -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
3411 " -X disable all warnings\n"
3413 "Run 'perldoc perl' for more help with Perl.\n\n",
3416 const char * const *p = usage_msg;
3417 PerlIO *out = PerlIO_stdout();
3420 "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3423 PerlIO_puts(out, *p++);
3427 /* convert a string of -D options (or digits) into an int.
3428 * sets *s to point to the char after the options */
3432 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3434 static const char * const usage_msgd[] = {
3435 " Debugging flag values: (see also -d)\n"
3436 " p Tokenizing and parsing (with v, displays parse stack)\n"
3437 " s Stack snapshots (with v, displays all stacks)\n"
3438 " l Context (loop) stack processing\n"
3439 " t Trace execution\n"
3440 " o Method and overloading resolution\n",
3441 " c String/numeric conversions\n"
3442 " P Print profiling info, source file input state\n"
3443 " m Memory and SV allocation\n"
3444 " f Format processing\n"
3445 " r Regular expression parsing and execution\n"
3446 " x Syntax tree dump\n",
3447 " u Tainting checks\n"
3448 " X Scratchpad allocation\n"
3450 " S Op slab allocation\n"
3452 " R Include reference counts of dumped variables (eg when using -Ds)\n",
3453 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3454 " v Verbose: use in conjunction with other flags\n"
3455 " C Copy On Write\n"
3456 " A Consistency checks on internal structures\n"
3457 " q quiet - currently only suppresses the 'EXECUTING' message\n"
3458 " M trace smart match resolution\n"
3459 " B dump suBroutine definitions, including special Blocks like BEGIN\n",
3460 " L trace some locale setting information--for Perl core development\n",
3461 " i trace PerlIO layer processing\n",
3462 " y trace y///, tr/// compilation and execution\n",
3463 " h Show (h)ash randomization debug output"
3464 " (changes to PL_hash_rand_bits)\n",
3469 PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3473 * If adding new options add them to the END of debopts[].
3474 * If you remove an option replace it with a '?'.
3475 * If there is a free slot available marked with '?' feel
3476 * free to reuse it for something else.
3478 * Regardles remember to update DEBUG_MASK in perl.h, and
3479 * update the documentation above AND in pod/perlrun.pod.
3481 * Note that the ? indicates an unused slot. As the code below
3482 * indicates the position in this list is important. You cannot
3483 * change the order or delete a character from the list without
3484 * impacting the definitions of all the other flags in perl.h
3485 * However because the logic is guarded by isWORDCHAR we can
3486 * fill in holes with non-wordchar characters instead. */
3487 static const char debopts[] = "psltocPmfrxuUhXDSTRJvCAqMBLiy";
3489 for (; isWORDCHAR(**s); (*s)++) {
3490 const char * const d = strchr(debopts,**s);
3492 uv |= 1 << (d - debopts);
3493 else if (ckWARN_d(WARN_DEBUGGING))
3494 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3495 "invalid option -D%c, use -D'' to see choices\n", **s);
3498 else if (isDIGIT(**s)) {
3499 const char* e = *s + strlen(*s);
3500 if (grok_atoUV(*s, &uv, &e))
3502 for (; isWORDCHAR(**s); (*s)++) ;
3504 else if (givehelp) {
3505 const char *const *p = usage_msgd;
3506 while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3508 return (int)uv; /* ignore any UV->int conversion loss */
3512 /* This routine handles any switches that can be given during run */
3515 Perl_moreswitches(pTHX_ const char *s)
3518 const char option = *s; /* used to remember option in -m/-M code */
3520 PERL_ARGS_ASSERT_MORESWITCHES;
3528 SvREFCNT_dec(PL_rs);
3529 if (s[1] == 'x' && s[2]) {
3530 const char *e = s+=2;
3536 flags = PERL_SCAN_SILENT_ILLDIGIT;
3537 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3538 if (s + numlen < e) {
3539 /* Continue to treat -0xFOO as -0 -xFOO
3540 * (ie NUL as the input record separator, and -x with FOO
3541 * as the directory argument)
3543 * hex support for -0 was only added in 5.8.1, hence this
3544 * heuristic to distinguish between it and '-0' clustered with
3545 * '-x' with an argument. The text following '-0x' is only
3546 * processed as the IRS specified in hexadecimal if all
3547 * characters are valid hex digits. */
3552 PL_rs = newSV((STRLEN)(UVCHR_SKIP(rschar) + 1));
3553 tmps = (U8*)SvPVCLEAR_FRESH(PL_rs);
3554 uvchr_to_utf8(tmps, rschar);
3555 SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
3560 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3561 if (rschar & ~((U8)~0))
3562 PL_rs = &PL_sv_undef;
3563 else if (!rschar && numlen >= 2)
3564 PL_rs = newSVpvs("");
3566 char ch = (char)rschar;
3567 PL_rs = newSVpvn(&ch, 1);
3570 sv_setsv(get_sv("/", GV_ADD), PL_rs);
3575 PL_unicode = parse_unicode_opts( (const char **)&s );
3576 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3584 const char *start = ++s;
3585 while (*s && !isSPACE(*s)) ++s;
3586 Safefree(PL_splitstr);
3587 PL_splitstr = savepvn(start, s - start);
3600 forbid_setid('d', FALSE);
3603 /* -dt indicates to the debugger that threads will be used */
3604 if (*s == 't' && !isWORDCHAR(s[1])) {
3606 my_setenv("PERL5DB_THREADED", "1");
3609 /* The following permits -d:Mod to accepts arguments following an =
3610 in the fashion that -MSome::Mod does. */
3611 if (*s == ':' || *s == '=') {
3618 sv = newSVpvs("no Devel::");
3620 sv = newSVpvs("use Devel::");
3624 end = s + strlen(s);
3626 /* We now allow -d:Module=Foo,Bar and -d:-Module */
3627 while(isWORDCHAR(*s) || *s==':') ++s;
3629 sv_catpvn(sv, start, end - start);
3631 sv_catpvn(sv, start, s-start);
3632 /* Don't use NUL as q// delimiter here, this string goes in the
3634 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3637 my_setenv("PERL5DB", SvPV_nolen_const(sv));
3641 PL_perldb = PERLDB_ALL;
3648 forbid_setid('D', FALSE);
3650 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3651 #else /* !DEBUGGING */
3652 if (ckWARN_d(WARN_DEBUGGING))
3653 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3654 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3655 for (s++; isWORDCHAR(*s); s++) ;
3658 NOT_REACHED; /* NOTREACHED */
3661 SvREFCNT_dec(PL_rs);
3662 PL_rs = &PL_sv_undef;
3663 sv_setsv(get_sv("/", GV_ADD), PL_rs);
3670 NOT_REACHED; /* NOTREACHED */
3673 Safefree(PL_inplace);
3675 const char * const start = ++s;
3676 while (*s && !isSPACE(*s))
3679 PL_inplace = savepvn(start, s - start);
3682 case 'I': /* -I handled both here and in parse_body() */
3683 forbid_setid('I', FALSE);
3685 while (*s && isSPACE(*s))
3690 /* ignore trailing spaces (possibly followed by other switches) */
3692 for (e = p; *e && !isSPACE(*e); e++) ;
3696 } while (*p && *p != '-');
3698 INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3704 Perl_croak(aTHX_ "No directory specified for -I");
3710 SvREFCNT_dec(PL_ors_sv);
3716 PL_ors_sv = newSVpvs("\n");
3717 numlen = 3 + (*s == '0');
3718 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3722 if (RsPARA(PL_rs)) {
3723 PL_ors_sv = newSVpvs("\n\n");
3726 PL_ors_sv = newSVsv(PL_rs);
3731 forbid_setid('M', FALSE); /* XXX ? */
3734 forbid_setid('m', FALSE); /* XXX ? */
3739 const char *use = "use ";
3741 /* -M-foo == 'no foo' */
3742 /* Leading space on " no " is deliberate, to make both
3743 possibilities the same length. */
3744 if (*s == '-') { use = " no "; ++s; }
3745 sv = newSVpvn(use,4);
3747 /* We allow -M'Module qw(Foo Bar)' */
3748 while(isWORDCHAR(*s) || *s==':') {
3757 Perl_croak(aTHX_ "Module name required with -%c option",
3760 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3761 "contains single ':'",
3762 (int)(s - start), start, option);
3763 end = s + strlen(s);
3765 sv_catpvn(sv, start, end - start);
3766 if (option == 'm') {
3768 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3769 sv_catpvs( sv, " ()");
3772 sv_catpvn(sv, start, s-start);
3773 /* Use NUL as q''-delimiter. */
3774 sv_catpvs(sv, " split(/,/,q\0");
3776 sv_catpvn(sv, s, end - s);
3777 sv_catpvs(sv, "\0)");
3780 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3783 Perl_croak(aTHX_ "Missing argument to -%c", option);
3794 forbid_setid('s', FALSE);
3795 PL_doswitches = TRUE;
3800 #if defined(SILENT_NO_TAINT_SUPPORT)
3801 /* silently ignore */
3802 #elif defined(NO_TAINT_SUPPORT)
3803 Perl_croak_nocontext("This perl was compiled without taint support. "
3804 "Cowardly refusing to run with -t or -T flags");
3812 PL_do_undump = TRUE;
3822 if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3823 PL_dowarn |= G_WARN_ON;
3828 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3829 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
3833 PL_dowarn = G_WARN_ALL_OFF;
3834 free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
3841 if (s[0] == '-') /* Additional switches on #! line. */
3846 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3852 #ifdef ALTERNATE_SHEBANG
3853 case 'S': /* OS/2 needs -S on "extproc" line. */
3856 case 'e': case 'f': case 'x': case 'E':
3857 #ifndef ALTERNATE_SHEBANG
3861 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3864 "Unrecognized switch: -%.1s (-h will show valid options)",s
3874 PerlIO * PIO_stdout;
3876 const char * const level_str = "v" PERL_VERSION_STRING;
3877 const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
3878 #ifdef PERL_PATCHNUM
3880 # ifdef PERL_GIT_UNCOMMITTED_CHANGES
3881 static const char num [] = PERL_PATCHNUM "*";
3883 static const char num [] = PERL_PATCHNUM;
3886 const STRLEN num_len = sizeof(num)-1;
3887 /* A very advanced compiler would fold away the strnEQ
3888 and this whole conditional, but most (all?) won't do it.
3889 SV level could also be replaced by with preprocessor
3892 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3893 /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3894 of the interp so it might contain format characters
3896 level = newSVpvn(num, num_len);
3898 level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
3902 SV* level = newSVpvn(level_str, level_len);
3903 #endif /* #ifdef PERL_PATCHNUM */
3904 PIO_stdout = PerlIO_stdout();
3905 PerlIO_printf(PIO_stdout,
3906 "\nThis is perl " STRINGIFY(PERL_REVISION)
3907 ", version " STRINGIFY(PERL_VERSION)
3908 ", subversion " STRINGIFY(PERL_SUBVERSION)
3909 " (%" SVf ") built for " ARCHNAME, SVfARG(level)
3911 SvREFCNT_dec_NN(level);
3913 #if defined(LOCAL_PATCH_COUNT)
3914 if (LOCAL_PATCH_COUNT > 0)
3915 PerlIO_printf(PIO_stdout,
3916 "\n(with %d registered patch%s, "
3917 "see perl -V for more detail)",
3919 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3922 PerlIO_printf(PIO_stdout,
3923 "\n\nCopyright 1987-2022, Larry Wall\n");
3925 PerlIO_printf(PIO_stdout,
3926 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3927 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3930 PerlIO_printf(PIO_stdout,
3931 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3934 PerlIO_printf(PIO_stdout,
3935 "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3938 PerlIO_printf(PIO_stdout,
3939 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3941 #ifdef BINARY_BUILD_NOTICE
3942 BINARY_BUILD_NOTICE;
3944 PerlIO_printf(PIO_stdout,
3946 Perl may be copied only under the terms of either the Artistic License or the\n\
3947 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3948 Complete documentation for Perl, including FAQ lists, should be found on\n\
3949 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3950 Internet, point your browser at https://www.perl.org/, the Perl Home Page.\n\n");
3954 /* compliments of Tom Christiansen */
3956 /* unexec() can be found in the Gnu emacs distribution */
3957 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3960 #include <lib$routines.h>
3964 Perl_my_unexec(pTHX)
3967 SV * prog = newSVpv(BIN_EXP, 0);
3968 SV * file = newSVpv(PL_origfilename, 0);
3972 sv_catpvs(prog, "/perl");
3973 sv_catpvs(file, ".perldump");
3975 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3976 /* unexec prints msg to stderr in case of failure */
3977 PerlProc_exit(status);
3979 PERL_UNUSED_CONTEXT;
3981 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3982 # elif defined(WIN32) || defined(__CYGWIN__)
3983 Perl_croak_nocontext("dump is not supported");
3985 ABORT(); /* for use with undump */
3990 /* initialize curinterp */
3995 # define PERLVAR(prefix,var,type)
3996 # define PERLVARA(prefix,var,n,type)
3997 # if defined(MULTIPLICITY)
3998 # define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init;
3999 # define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init;
4001 # define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init;
4002 # define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init;
4004 # include "intrpvar.h"
4010 # define PERLVAR(prefix,var,type)
4011 # define PERLVARA(prefix,var,n,type)
4012 # define PERLVARI(prefix,var,type,init) PL_##var = init;
4013 # define PERLVARIC(prefix,var,type,init) PL_##var = init;
4014 # include "intrpvar.h"
4024 S_init_main_stash(pTHX)
4029 PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(hv);
4030 /* We know that the string "main" will be in the global shared string
4031 table, so it's a small saving to use it rather than allocate another
4033 PL_curstname = newSVpvs_share("main");
4034 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
4035 /* If we hadn't caused another reference to "main" to be in the shared
4036 string table above, then it would be worth reordering these two,
4037 because otherwise all we do is delete "main" from it as a consequence
4038 of the SvREFCNT_dec, only to add it again with hv_name_set */
4039 SvREFCNT_dec(GvHV(gv));
4040 hv_name_sets(PL_defstash, "main", 0);
4041 GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
4043 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
4045 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
4046 GvMULTI_on(PL_incgv);
4047 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
4048 SvREFCNT_inc_simple_void(PL_hintgv);
4049 GvMULTI_on(PL_hintgv);
4050 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
4051 SvREFCNT_inc_simple_void(PL_defgv);
4052 PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
4053 SvREFCNT_inc_simple_void(PL_errgv);
4054 GvMULTI_on(PL_errgv);
4055 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
4056 SvREFCNT_inc_simple_void(PL_replgv);
4057 GvMULTI_on(PL_replgv);
4058 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
4059 #ifdef PERL_DONT_CREATE_GVSV
4060 (void)gv_SVadd(PL_errgv);
4062 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
4064 CopSTASH_set(&PL_compiling, PL_defstash);
4065 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
4066 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
4068 /* We must init $/ before switches are processed. */
4069 sv_setpvs(get_sv("/", GV_ADD), "\n");
4073 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
4076 PerlIO *rsfp = NULL;
4080 PERL_ARGS_ASSERT_OPEN_SCRIPT;
4083 PL_origfilename = savepvs("-e");
4088 /* if find_script() returns, it returns a malloc()-ed value */
4089 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
4090 s = scriptname + strlen(scriptname);
4092 if (strBEGINs(scriptname, "/dev/fd/")
4093 && isDIGIT(scriptname[8])
4094 && grok_atoUV(scriptname + 8, &uv, &s)
4095 && uv <= PERL_INT_MAX
4100 * Tell apart "normal" usage of fdscript, e.g.
4101 * with bash on FreeBSD:
4102 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
4103 * from usage in suidperl.
4104 * Does any "normal" usage leave garbage after the number???
4105 * Is it a mistake to use a similar /dev/fd/ construct for
4110 * Be supersafe and do some sanity-checks.
4111 * Still, can we be sure we got the right thing?
4114 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
4117 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
4119 scriptname = savepv(s + 1);
4120 Safefree(PL_origfilename);
4121 PL_origfilename = (char *)scriptname;
4126 CopFILE_free(PL_curcop);
4127 CopFILE_set(PL_curcop, PL_origfilename);
4128 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
4129 scriptname = (char *)"";
4130 if (fdscript >= 0) {
4131 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
4133 else if (!*scriptname) {
4134 forbid_setid(0, *suidscript);
4138 #ifdef FAKE_BIT_BUCKET
4139 /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
4140 * is called) and still have the "-e" work. (Believe it or not,
4141 * a /dev/null is required for the "-e" to work because source
4142 * filter magic is used to implement it. ) This is *not* a general
4143 * replacement for a /dev/null. What we do here is create a temp
4144 * file (an empty file), open up that as the script, and then
4145 * immediately close and unlink it. Close enough for jazz. */
4146 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
4147 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
4148 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
4149 char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
4150 FAKE_BIT_BUCKET_TEMPLATE
4152 const char * const err = "Failed to create a fake bit bucket";
4153 if (strEQ(scriptname, BIT_BUCKET)) {
4154 int tmpfd = Perl_my_mkstemp_cloexec(tmpname);
4156 scriptname = tmpname;
4159 Perl_croak(aTHX_ err);
4162 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
4163 #ifdef FAKE_BIT_BUCKET
4164 if ( strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX)
4165 && strlen(scriptname) == sizeof(tmpname) - 1)
4169 scriptname = BIT_BUCKET;
4173 /* PSz 16 Sep 03 Keep neat error message */
4175 Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno));
4177 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4178 CopFILE(PL_curcop), Strerror(errno));
4180 fd = PerlIO_fileno(rsfp);
4183 (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
4184 && S_ISDIR(tmpstatbuf.st_mode)))
4185 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4192 /* In the days of suidperl, we refused to execute a setuid script stored on
4193 * a filesystem mounted nosuid and/or noexec. This meant that we probed for the
4194 * existence of the appropriate filesystem-statting function, and behaved
4195 * accordingly. But even though suidperl is long gone, we must still include
4196 * those probes for the benefit of modules like Filesys::Df, which expect the
4197 * results of those probes to be stored in %Config; see RT#126368. So mention
4198 * the relevant cpp symbols here, to ensure that metaconfig will include their
4199 * probes in the generated Configure:
4201 * I_SYSSTATVFS HAS_FSTATVFS
4203 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
4204 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
4208 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4209 /* Don't even need this function. */
4212 S_validate_suid(pTHX_ PerlIO *rsfp)
4214 const Uid_t my_uid = PerlProc_getuid();
4215 const Uid_t my_euid = PerlProc_geteuid();
4216 const Gid_t my_gid = PerlProc_getgid();
4217 const Gid_t my_egid = PerlProc_getegid();
4219 PERL_ARGS_ASSERT_VALIDATE_SUID;
4221 if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
4222 int fd = PerlIO_fileno(rsfp);
4224 if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
4225 Perl_croak_nocontext( "Illegal suidscript");
4227 if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
4229 (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
4232 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4233 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4234 /* not set-id, must be wrapped */
4237 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4240 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
4245 PERL_ARGS_ASSERT_FIND_BEGINNING;
4247 /* skip forward in input to the real script? */
4250 if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
4251 Perl_croak(aTHX_ "No Perl script found in input\n");
4253 } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
4254 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
4255 while (*s && !(isSPACE (*s) || *s == '#')) s++;
4257 while (*s == ' ' || *s == '\t') s++;
4259 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4260 || s2[-1] == '_') s2--;
4261 if (strBEGINs(s2-4,"perl"))
4262 while ((s = moreswitches(s)))
4271 /* no need to do anything here any more if we don't
4273 #ifndef NO_TAINT_SUPPORT
4274 const Uid_t my_uid = PerlProc_getuid();
4275 const Uid_t my_euid = PerlProc_geteuid();
4276 const Gid_t my_gid = PerlProc_getgid();
4277 const Gid_t my_egid = PerlProc_getegid();
4279 PERL_UNUSED_CONTEXT;
4281 /* Should not happen: */
4282 CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
4283 TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
4287 * Should go by suidscript, not uid!=euid: why disallow
4288 * system("ls") in scripts run from setuid things?
4289 * Or, is this run before we check arguments and set suidscript?
4290 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4291 * (We never have suidscript, can we be sure to have fdscript?)
4292 * Or must then go by UID checks? See comments in forbid_setid also.
4296 /* This is used very early in the lifetime of the program,
4297 * before even the options are parsed, so PL_tainting has
4298 * not been initialized properly. */
4300 Perl_doing_taint(int argc, char *argv[], char *envp[])
4302 #ifndef PERL_IMPLICIT_SYS
4303 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4304 * before we have an interpreter-- and the whole point of this
4305 * function is to be called at such an early stage. If you are on
4306 * a system with PERL_IMPLICIT_SYS but you do have a concept of
4307 * "tainted because running with altered effective ids', you'll
4308 * have to add your own checks somewhere in here. The most known
4309 * sample of 'implicitness' is Win32, which doesn't have much of
4310 * concept of 'uids'. */
4311 Uid_t uid = PerlProc_getuid();
4312 Uid_t euid = PerlProc_geteuid();
4313 Gid_t gid = PerlProc_getgid();
4314 Gid_t egid = PerlProc_getegid();
4321 if (uid && (euid != uid || egid != gid))
4323 #endif /* !PERL_IMPLICIT_SYS */
4324 /* This is a really primitive check; environment gets ignored only
4325 * if -T are the first chars together; otherwise one gets
4326 * "Too late" message. */
4327 if ( argc > 1 && argv[1][0] == '-'
4328 && isALPHA_FOLD_EQ(argv[1][1], 't'))
4333 /* Passing the flag as a single char rather than a string is a slight space
4334 optimisation. The only message that isn't /^-.$/ is
4335 "program input from stdin", which is substituted in place of '\0', which
4336 could never be a command line flag. */
4338 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4340 char string[3] = "-x";
4341 const char *message = "program input from stdin";
4343 PERL_UNUSED_CONTEXT;
4349 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4350 if (PerlProc_getuid() != PerlProc_geteuid())
4351 Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4352 if (PerlProc_getgid() != PerlProc_getegid())
4353 Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4354 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4356 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4360 Perl_init_dbargs(pTHX)
4362 AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4367 /* Someone has already created it.
4368 It might have entries, and if we just turn off AvREAL(), they will
4369 "leak" until global destruction. */
4371 if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4372 Perl_croak(aTHX_ "Cannot set tied @DB::args");
4374 AvREIFY_only(PL_dbargs);
4378 Perl_init_debugger(pTHX)
4380 HV * const ostash = PL_curstash;
4383 PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4385 Perl_init_dbargs(aTHX);
4386 PL_DBgv = MUTABLE_GV(
4387 SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4389 PL_DBline = MUTABLE_GV(
4390 SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4392 PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4393 gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4395 PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4396 if (!SvIOK(PL_DBsingle))
4397 sv_setiv(PL_DBsingle, 0);
4398 mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4399 mg->mg_private = DBVARMG_SINGLE;
4400 SvSETMAGIC(PL_DBsingle);
4402 PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4403 if (!SvIOK(PL_DBtrace))
4404 sv_setiv(PL_DBtrace, 0);
4405 mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4406 mg->mg_private = DBVARMG_TRACE;
4407 SvSETMAGIC(PL_DBtrace);
4409 PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4410 if (!SvIOK(PL_DBsignal))
4411 sv_setiv(PL_DBsignal, 0);
4412 mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4413 mg->mg_private = DBVARMG_SIGNAL;
4414 SvSETMAGIC(PL_DBsignal);
4416 SvREFCNT_dec(PL_curstash);
4417 PL_curstash = ostash;
4420 #ifndef STRESS_REALLOC
4421 #define REASONABLE(size) (size)
4422 #define REASONABLE_but_at_least(size,min) (size)
4424 #define REASONABLE(size) (1) /* unreasonable */
4425 #define REASONABLE_but_at_least(size,min) (min)
4429 Perl_init_stacks(pTHX)
4433 /* start with 128-item stack and 8K cxstack */
4434 PL_curstackinfo = new_stackinfo(REASONABLE(128),
4435 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4436 PL_curstackinfo->si_type = PERLSI_MAIN;
4437 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
4438 PL_curstackinfo->si_stack_hwm = 0;
4440 PL_curstack = PL_curstackinfo->si_stack;
4441 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
4443 PL_stack_base = AvARRAY(PL_curstack);
4444 PL_stack_sp = PL_stack_base;
4445 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4447 Newxz(PL_tmps_stack,REASONABLE(128),SV*);
4450 PL_tmps_max = REASONABLE(128);
4452 Newxz(PL_markstack,REASONABLE(32),I32);
4453 PL_markstack_ptr = PL_markstack;
4454 PL_markstack_max = PL_markstack + REASONABLE(32);
4458 Newxz(PL_scopestack,REASONABLE(32),I32);
4460 Newxz(PL_scopestack_name,REASONABLE(32),const char*);
4462 PL_scopestack_ix = 0;
4463 PL_scopestack_max = REASONABLE(32);
4465 size = REASONABLE_but_at_least(128,SS_MAXPUSH);
4466 Newxz(PL_savestack, size, ANY);
4467 PL_savestack_ix = 0;
4468 /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */
4469 PL_savestack_max = size - SS_MAXPUSH;
4477 while (PL_curstackinfo->si_next)
4478 PL_curstackinfo = PL_curstackinfo->si_next;
4479 while (PL_curstackinfo) {
4480 PERL_SI *p = PL_curstackinfo->si_prev;
4481 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4482 Safefree(PL_curstackinfo->si_cxstack);
4483 Safefree(PL_curstackinfo);
4484 PL_curstackinfo = p;
4486 Safefree(PL_tmps_stack);
4487 Safefree(PL_markstack);
4488 Safefree(PL_scopestack);
4490 Safefree(PL_scopestack_name);
4492 Safefree(PL_savestack);
4496 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4498 GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4499 AV *const isa = GvAVn(gv);
4502 PERL_ARGS_ASSERT_POPULATE_ISA;
4504 if(AvFILLp(isa) != -1)
4507 /* NOTE: No support for tied ISA */
4509 va_start(args, len);
4511 const char *const parent = va_arg(args, const char*);
4516 parent_len = va_arg(args, size_t);
4518 /* Arguments are supplied with a trailing :: */
4519 assert(parent_len > 2);
4520 assert(parent[parent_len - 1] == ':');
4521 assert(parent[parent_len - 2] == ':');
4522 av_push(isa, newSVpvn(parent, parent_len - 2));
4523 (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4530 S_init_predump_symbols(pTHX)
4535 sv_setpvs(get_sv("\"", GV_ADD), " ");
4536 PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4539 /* Historically, PVIOs were blessed into IO::Handle, unless
4540 FileHandle was loaded, in which case they were blessed into
4541 that. Action at a distance.
4542 However, if we simply bless into IO::Handle, we break code
4543 that assumes that PVIOs will have (among others) a seek
4544 method. IO::File inherits from IO::Handle and IO::Seekable,
4545 and provides the needed methods. But if we simply bless into
4546 it, then we break code that assumed that by loading
4547 IO::Handle, *it* would work.
4548 So a compromise is to set up the correct @IO::File::ISA,
4549 so that code that does C<use IO::Handle>; will still work.
4552 Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4553 STR_WITH_LEN("IO::Handle::"),
4554 STR_WITH_LEN("IO::Seekable::"),
4555 STR_WITH_LEN("Exporter::"),
4558 PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4559 GvMULTI_on(PL_stdingv);
4560 io = GvIOp(PL_stdingv);
4561 IoTYPE(io) = IoTYPE_RDONLY;
4562 IoIFP(io) = PerlIO_stdin();
4563 tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4565 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4567 tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4570 IoTYPE(io) = IoTYPE_WRONLY;
4571 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4573 tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4575 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4577 PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4578 GvMULTI_on(PL_stderrgv);
4579 io = GvIOp(PL_stderrgv);
4580 IoTYPE(io) = IoTYPE_WRONLY;
4581 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4582 tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4584 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4586 PL_statname = newSVpvs(""); /* last filename we did stat on */
4590 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4592 PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4594 argc--,argv++; /* skip name of script */
4595 if (PL_doswitches) {
4596 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4600 if (argv[0][1] == '-' && !argv[0][2]) {
4604 if ((s = strchr(argv[0], '='))) {
4605 const char *const start_name = argv[0] + 1;
4606 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4607 TRUE, SVt_PV)), s + 1);
4610 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4613 if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4614 SvREFCNT_inc_simple_void_NN(PL_argvgv);
4615 GvMULTI_on(PL_argvgv);
4616 av_clear(GvAVn(PL_argvgv));
4617 for (; argc > 0; argc--,argv++) {
4618 SV * const sv = newSVpv(argv[0],0);
4619 av_push(GvAV(PL_argvgv),sv);
4620 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4621 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4624 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4625 (void)sv_utf8_decode(sv);
4629 if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4630 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4631 "-i used with no filenames on the command line, "
4632 "reading from STDIN");
4636 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4640 PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4642 PL_toptarget = newSV_type(SVt_PVIV);
4643 SvPVCLEAR(PL_toptarget);
4644 PL_bodytarget = newSV_type(SVt_PVIV);
4645 SvPVCLEAR(PL_bodytarget);
4646 PL_formtarget = PL_bodytarget;
4650 init_argv_symbols(argc,argv);
4652 if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4653 sv_setpv(GvSV(tmpgv),PL_origfilename);
4655 if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4657 bool env_is_not_environ;
4658 SvREFCNT_inc_simple_void_NN(PL_envgv);
4659 GvMULTI_on(PL_envgv);
4660 hv = GvHVn(PL_envgv);
4661 hv_magic(hv, NULL, PERL_MAGIC_env);
4663 #if defined(USE_ENVIRON_ARRAY) || defined(WIN32)
4664 /* Note that if the supplied env parameter is actually a copy
4665 of the global environ then it may now point to free'd memory
4666 if the environment has been modified since. To avoid this
4667 problem we treat env==NULL as meaning 'use the default'
4671 env_is_not_environ = env != environ;
4672 if (env_is_not_environ
4673 # ifdef USE_ITHREADS
4674 && PL_curinterp == aTHX
4682 char **env_copy = env;
4689 count = env_copy - env;
4691 if (count > PERL_HASH_DEFAULT_HvMAX) {
4692 /* This might be an over-estimate (due to dups and other skips),
4693 * but if so, likely it won't hurt much.
4694 * A straw poll of login environments I have suggests that
4695 * between 23 and 52 environment variables are typical (and no
4696 * dups). As the default hash size is 8 buckets, expanding in
4697 * advance saves between 2 and 3 splits in the loop below. */
4698 hv_ksplit(hv, count);
4702 for (; *env; env++) {
4703 char *old_var = *env;
4704 char *s = strchr(old_var, '=');
4708 if (!s || s == old_var)
4713 /* It's tempting to think that this hv_exists/hv_store pair should
4714 * be replaced with a single hv_fetch with the LVALUE flag true.
4715 * However, hv has magic, and if you follow the code in hv_common
4716 * then for LVALUE fetch it recurses once, whereas exists and
4717 * store do not recurse. Hence internally there would be no
4718 * difference in the complexity of the code run. Moreover, all
4719 * calls pass through "is there magic?" special case code, which
4720 * in turn has its own #ifdef ENV_IS_CASELESS special case special
4721 * case. Hence this code shouldn't change, as doing so won't give
4722 * any meaningful speedup, and might well add bugs. */
4724 if (hv_exists(hv, old_var, nlen)) {
4726 const char *name = savepvn(old_var, nlen);
4728 /* make sure we use the same value as getenv(), otherwise code that
4729 uses getenv() (like setlocale()) might see a different value to %ENV
4731 sv = newSVpv(PerlEnv_getenv(name), 0);
4733 /* keep a count of the dups of this name so we can de-dup environ later */
4734 dup = hv_fetch(dups, name, nlen, TRUE);
4742 sv = newSVpv(s+1, 0);
4744 (void)hv_store(hv, old_var, nlen, sv, 0);
4745 if (env_is_not_environ)
4748 if (HvTOTALKEYS(dups)) {
4749 /* environ has some duplicate definitions, remove them */
4752 while ((entry = hv_iternext_flags(dups, 0))) {
4754 const char *name = HePV(entry, nlen);
4755 IV count = SvIV(HeVAL(entry));
4757 SV **valp = hv_fetch(hv, name, nlen, 0);
4761 /* try to remove any duplicate names, depending on the
4762 * implementation used in my_setenv() the iteration might
4763 * not be necessary, but let's be safe.
4765 for (i = 0; i < count; ++i)
4768 /* and set it back to the value we set $ENV{name} to */
4769 my_setenv(name, SvPV_nolen(*valp));
4772 SvREFCNT_dec_NN(dups);
4774 #endif /* USE_ENVIRON_ARRAY */
4775 #endif /* !PERL_MICRO */
4779 /* touch @F array to prevent spurious warnings 20020415 MJD */
4781 (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4786 S_init_perllib(pTHX)
4789 const char *perl5lib = NULL;
4792 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4796 if (!TAINTING_get) {
4798 perl5lib = PerlEnv_getenv("PERL5LIB");
4799 if (perl5lib && *perl5lib != '\0')
4800 incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4802 s = PerlEnv_getenv("PERLLIB");
4804 incpush_use_sep(s, 0, 0);
4807 /* Treat PERL5?LIB as a possible search list logical name -- the
4808 * "natural" VMS idiom for a Unix path string. We allow each
4809 * element to be a set of |-separated directories for compatibility.
4813 if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4815 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4816 } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4818 while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
4819 incpush_use_sep(buf, 0, 0);
4824 #ifndef PERL_IS_MINIPERL
4825 /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4826 (and not the architecture specific directories from $ENV{PERL5LIB}) */
4828 #include "perl_inc_macro.h"
4829 /* Use the ~-expanded versions of APPLLIB (undocumented),
4830 SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4833 INCPUSH_SITEARCH_EXP
4835 INCPUSH_PERL_VENDORARCH_EXP
4836 INCPUSH_PERL_VENDORLIB_EXP
4839 INCPUSH_PERL_OTHERLIBDIRS
4841 INCPUSH_APPLLIB_OLD_EXP
4842 INCPUSH_SITELIB_STEM
4843 INCPUSH_PERL_VENDORLIB_STEM
4844 INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY
4846 #endif /* !PERL_IS_MINIPERL */
4848 if (!TAINTING_get) {
4849 #if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT)
4850 const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC");
4851 if (unsafe && strEQ(unsafe, "1"))
4853 S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4858 # define PERLLIB_SEP ';'
4859 #elif defined(__VMS)
4860 # define PERLLIB_SEP PL_perllib_sep
4862 # define PERLLIB_SEP ':'
4864 #ifndef PERLLIB_MANGLE
4865 # define PERLLIB_MANGLE(s,n) (s)
4868 #ifndef PERL_IS_MINIPERL
4869 /* Push a directory onto @INC if it exists.
4870 Generate a new SV if we do this, to save needing to copy the SV we push
4873 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4877 PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4879 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4880 S_ISDIR(tmpstatbuf.st_mode)) {
4882 dir = newSVsv(stem);
4884 /* Truncate dir back to stem. */
4885 SvCUR_set(dir, SvCUR(stem));
4892 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4894 const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4897 PERL_ARGS_ASSERT_MAYBERELOCATE;
4900 /* I am not convinced that this is valid when PERLLIB_MANGLE is
4901 defined to so something (in os2/os2.c), but the code has been
4902 this way, ignoring any possible changed of length, since
4903 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4905 libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4911 if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4913 while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */
4914 sv_usepvn(libdir,unix,len);
4917 PerlIO_printf(Perl_error_log,
4918 "Failed to unixify @INC element \"%s\"\n",
4919 SvPV_nolen_const(libdir));
4923 /* Do the if() outside the #ifdef to avoid warnings about an unused
4926 #ifdef PERL_RELOCATABLE_INC
4928 * Relocatable include entries are marked with a leading .../
4931 * 0: Remove that leading ".../"
4932 * 1: Remove trailing executable name (anything after the last '/')
4933 * from the perl path to give a perl prefix
4935 * While the @INC element starts "../" and the prefix ends with a real
4936 * directory (ie not . or ..) chop that real directory off the prefix
4937 * and the leading "../" from the @INC element. ie a logical "../"
4939 * Finally concatenate the prefix and the remainder of the @INC element
4940 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4941 * generates /usr/local/lib/perl5
4943 const char *libpath = SvPVX(libdir);
4944 STRLEN libpath_len = SvCUR(libdir);
4945 if (memBEGINs(libpath, libpath_len, ".../")) {
4947 SV * const caret_X = get_sv("\030", 0);
4948 /* Going to use the SV just as a scratch buffer holding a C
4954 /* $^X is *the* source of taint if tainting is on, hence
4955 SvPOK() won't be true. */
4957 assert(SvPOKp(caret_X));
4958 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4960 /* Firstly take off the leading .../
4961 If all else fail we'll do the paths relative to the current
4963 sv_chop(libdir, libpath + 4);
4964 /* Don't use SvPV as we're intentionally bypassing taining,
4965 mortal copies that the mg_get of tainting creates, and
4966 corruption that seems to come via the save stack.
4967 I guess that the save stack isn't correctly set up yet. */
4968 libpath = SvPVX(libdir);
4969 libpath_len = SvCUR(libdir);
4971 prefix = SvPVX(prefix_sv);
4972 lastslash = (char *) my_memrchr(prefix, '/',
4973 SvEND(prefix_sv) - prefix);
4975 /* First time in with the *lastslash = '\0' we just wipe off
4976 the trailing /perl from (say) /usr/foo/bin/perl
4980 while ((*lastslash = '\0'), /* Do that, come what may. */
4981 ( memBEGINs(libpath, libpath_len, "../")
4983 (char *) my_memrchr(prefix, '/',
4984 SvEND(prefix_sv) - prefix))))
4986 if (lastslash[1] == '\0'
4987 || (lastslash[1] == '.'
4988 && (lastslash[2] == '/' /* ends "/." */
4989 || (lastslash[2] == '/'
4990 && lastslash[3] == '/' /* or "/.." */
4992 /* Prefix ends "/" or "/." or "/..", any of which
4993 are fishy, so don't do any more logical cleanup.
4997 /* Remove leading "../" from path */
5000 /* Next iteration round the loop removes the last
5001 directory name from prefix by writing a '\0' in
5002 the while clause. */
5004 /* prefix has been terminated with a '\0' to the correct
5005 length. libpath points somewhere into the libdir SV.
5006 We need to join the 2 with '/' and drop the result into
5008 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
5009 SvREFCNT_dec(libdir);
5010 /* And this is the new libdir. */
5013 (PerlProc_getuid() != PerlProc_geteuid() ||
5014 PerlProc_getgid() != PerlProc_getegid())) {
5015 /* Need to taint relocated paths if running set ID */
5016 SvTAINTED_on(libdir);
5019 SvREFCNT_dec(prefix_sv);
5027 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
5029 #ifndef PERL_IS_MINIPERL
5030 const U8 using_sub_dirs
5031 = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
5032 |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
5033 const U8 add_versioned_sub_dirs
5034 = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
5035 const U8 add_archonly_sub_dirs
5036 = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
5037 #ifdef PERL_INC_VERSION_LIST
5038 const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
5041 const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
5042 const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
5043 AV *const inc = GvAVn(PL_incgv);
5045 PERL_ARGS_ASSERT_INCPUSH;
5048 /* Could remove this vestigial extra block, if we don't mind a lot of
5049 re-indenting diff noise. */
5051 SV *const libdir = mayberelocate(dir, len, flags);
5052 /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
5053 arranged to unshift #! line -I onto the front of @INC. However,
5054 -I can add version and architecture specific libraries, and they
5055 need to go first. The old code assumed that it was always
5056 pushing. Hence to make it work, need to push the architecture
5057 (etc) libraries onto a temporary array, then "unshift" that onto
5058 the front of @INC. */
5059 #ifndef PERL_IS_MINIPERL
5060 AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
5063 * BEFORE pushing libdir onto @INC we may first push version- and
5064 * archname-specific sub-directories.
5066 if (using_sub_dirs) {
5067 SV *subdir = newSVsv(libdir);
5068 #ifdef PERL_INC_VERSION_LIST
5069 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
5070 const char * const incverlist[] = { PERL_INC_VERSION_LIST };
5071 const char * const *incver;
5074 if (add_versioned_sub_dirs) {
5075 /* .../version/archname if -d .../version/archname */
5076 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
5077 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
5079 /* .../version if -d .../version */
5080 sv_catpvs(subdir, "/" PERL_FS_VERSION);
5081 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
5084 #ifdef PERL_INC_VERSION_LIST
5086 for (incver = incverlist; *incver; incver++) {
5087 /* .../xxx if -d .../xxx */
5088 Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
5089 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
5094 if (add_archonly_sub_dirs) {
5095 /* .../archname if -d .../archname */
5096 sv_catpvs(subdir, "/" ARCHNAME);
5097 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
5101 assert (SvREFCNT(subdir) == 1);
5102 SvREFCNT_dec(subdir);
5104 #endif /* !PERL_IS_MINIPERL */
5105 /* finally add this lib directory at the end of @INC */
5107 #ifdef PERL_IS_MINIPERL
5108 const Size_t extra = 0;
5110 Size_t extra = av_count(av);
5112 av_unshift(inc, extra + push_basedir);
5114 av_store(inc, extra, libdir);
5115 #ifndef PERL_IS_MINIPERL
5117 /* av owns a reference, av_store() expects to be donated a
5118 reference, and av expects to be sane when it's cleared.
5119 If I wanted to be naughty and wrong, I could peek inside the
5120 implementation of av_clear(), realise that it uses
5121 SvREFCNT_dec() too, so av's array could be a run of NULLs,
5122 and so directly steal from it (with a memcpy() to inc, and
5123 then memset() to NULL them out. But people copy code from the
5124 core expecting it to be best practise, so let's use the API.
5125 Although studious readers will note that I'm not checking any
5127 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
5132 else if (push_basedir) {
5133 av_push(inc, libdir);
5136 if (!push_basedir) {
5137 assert (SvREFCNT(libdir) == 1);
5138 SvREFCNT_dec(libdir);
5144 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
5148 /* This logic has been broken out from S_incpush(). It may be possible to
5151 PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
5153 /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
5154 * argument to incpush_use_sep. This allows creation of relocatable
5155 * Perl distributions that patch the binary at install time. Those
5156 * distributions will have to provide their own relocation tools; this
5157 * is not a feature otherwise supported by core Perl.
5159 #ifndef PERL_RELOCATABLE_INCPUSH
5166 /* Break at all separators */
5167 while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
5169 /* skip any consecutive separators */
5171 /* Uncomment the next line for PATH semantics */
5172 /* But you'll need to write tests */
5173 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
5175 incpush(p, (STRLEN)(s - p), flags);
5180 incpush(p, (STRLEN)(end - p), flags);
5185 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
5188 volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
5194 PERL_ARGS_ASSERT_CALL_LIST;
5196 while (av_count(paramList) > 0) {
5197 cv = MUTABLE_CV(av_shift(paramList));
5199 if (paramList == PL_beginav) {
5200 /* save PL_beginav for compiler */
5201 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
5203 else if (paramList == PL_checkav) {
5204 /* save PL_checkav for compiler */
5205 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
5207 else if (paramList == PL_unitcheckav) {
5208 /* save PL_unitcheckav for compiler */
5209 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
5219 (void)SvPV_const(atsv, len);
5221 PL_curcop = &PL_compiling;
5222 CopLINE_set(PL_curcop, oldline);
5223 if (paramList == PL_beginav)
5224 sv_catpvs(atsv, "BEGIN failed--compilation aborted");
5226 Perl_sv_catpvf(aTHX_ atsv,
5227 "%s failed--call queue aborted",
5228 paramList == PL_checkav ? "CHECK"
5229 : paramList == PL_initav ? "INIT"
5230 : paramList == PL_unitcheckav ? "UNITCHECK"
5232 while (PL_scopestack_ix > oldscope)
5235 Perl_croak(aTHX_ "%" SVf, SVfARG(atsv));
5242 /* my_exit() was called */
5243 while (PL_scopestack_ix > oldscope)
5246 SET_CURSTASH(PL_defstash);
5247 PL_curcop = &PL_compiling;
5248 CopLINE_set(PL_curcop, oldline);
5251 NOT_REACHED; /* NOTREACHED */
5254 PL_curcop = &PL_compiling;
5255 CopLINE_set(PL_curcop, oldline);
5258 PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
5269 A wrapper for the C library L<exit(3)>, honoring what L<perlapi/PL_exit_flags>
5276 Perl_my_exit(pTHX_ U32 status)
5278 if (PL_exit_flags & PERL_EXIT_ABORT) {
5281 if (PL_exit_flags & PERL_EXIT_WARN) {
5282 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
5283 Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status);
5284 PL_exit_flags &= ~PERL_EXIT_ABORT;
5294 STATUS_EXIT_SET(status);
5301 =for apidoc my_failure_exit
5303 Exit the running Perl process with an error.
5305 On non-VMS platforms, this is essentially equivalent to L</C<my_exit>>, using
5306 C<errno>, but forces an en error code of 255 if C<errno> is 0.
5308 On VMS, it takes care to set the appropriate severity bits in the exit status.
5314 Perl_my_failure_exit(pTHX)
5317 /* We have been called to fall on our sword. The desired exit code
5318 * should be already set in STATUS_UNIX, but could be shifted over
5319 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
5322 * If an error code has not been set, then force the issue.
5324 if (MY_POSIX_EXIT) {
5326 /* According to the die_exit.t tests, if errno is non-zero */
5327 /* It should be used for the error status. */
5329 if (errno == EVMSERR) {
5330 STATUS_NATIVE = vaxc$errno;
5333 /* According to die_exit.t tests, if the child_exit code is */
5334 /* also zero, then we need to exit with a code of 255 */
5335 if ((errno != 0) && (errno < 256))
5336 STATUS_UNIX_EXIT_SET(errno);
5337 else if (STATUS_UNIX < 255) {
5338 STATUS_UNIX_EXIT_SET(255);
5343 /* The exit code could have been set by $? or vmsish which
5344 * means that it may not have fatal set. So convert
5345 * success/warning codes to fatal with out changing
5346 * the POSIX status code. The severity makes VMS native
5347 * status handling work, while UNIX mode programs use the
5350 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
5351 STATUS_NATIVE &= STS$M_COND_ID;
5352 STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
5356 /* Traditionally Perl on VMS always expects a Fatal Error. */
5357 if (vaxc$errno & 1) {
5359 /* So force success status to failure */
5360 if (STATUS_NATIVE & 1)
5365 STATUS_UNIX = EINTR; /* In case something cares */
5370 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5372 /* Encode the severity code */
5373 severity = STATUS_NATIVE & STS$M_SEVERITY;
5374 STATUS_UNIX = (severity ? severity : 1) << 8;
5376 /* Perl expects this to be a fatal error */
5377 if (severity != STS$K_SEVERE)
5387 STATUS_UNIX_SET(eno);
5389 exitstatus = STATUS_UNIX >> 8;
5390 if (exitstatus & 255)
5391 STATUS_UNIX_SET(exitstatus);
5393 STATUS_UNIX_SET(255);
5396 if (PL_exit_flags & PERL_EXIT_ABORT) {
5399 if (PL_exit_flags & PERL_EXIT_WARN) {
5400 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
5401 Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue);
5402 PL_exit_flags &= ~PERL_EXIT_ABORT;
5408 S_my_exit_jump(pTHX)
5411 SvREFCNT_dec(PL_e_script);
5415 POPSTACK_TO(PL_mainstack);
5416 if (cxstack_ix >= 0) {
5418 cx_popblock(cxstack);
5426 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5428 const char * const p = SvPVX_const(PL_e_script);
5429 const char * const e = SvEND(PL_e_script);
5430 const char *nl = (char *) memchr(p, '\n', e - p);
5432 PERL_UNUSED_ARG(idx);
5433 PERL_UNUSED_ARG(maxlen);
5435 nl = (nl) ? nl+1 : e;
5437 filter_del(read_e_script);
5440 sv_catpvn(buf_sv, p, nl-p);
5441 sv_chop(PL_e_script, nl);
5445 /* removes boilerplate code at the end of each boot_Module xsub */
5447 Perl_xs_boot_epilog(pTHX_ const I32 ax)
5450 call_list(PL_scopestack_ix, PL_unitcheckav);
5455 * ex: set ts=8 sts=4 sw=4 et: