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 /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
114 Perl_sys_init(int* argc, char*** argv)
117 PERL_ARGS_ASSERT_SYS_INIT;
119 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
120 PERL_UNUSED_ARG(argv);
121 PERL_SYS_INIT_BODY(argc, argv);
125 Perl_sys_init3(int* argc, char*** argv, char*** env)
128 PERL_ARGS_ASSERT_SYS_INIT3;
130 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
131 PERL_UNUSED_ARG(argv);
132 PERL_UNUSED_ARG(env);
133 PERL_SYS_INIT3_BODY(argc, argv, env);
139 if (!PL_veto_cleanup) {
140 PERL_SYS_TERM_BODY();
145 #ifdef PERL_IMPLICIT_SYS
147 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
148 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
149 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
150 struct IPerlDir* ipD, struct IPerlSock* ipS,
151 struct IPerlProc* ipP)
153 PerlInterpreter *my_perl;
155 PERL_ARGS_ASSERT_PERL_ALLOC_USING;
157 /* Newx() needs interpreter, so call malloc() instead */
158 my_perl = (PerlInterpreter*)(*ipM->pCalloc)(ipM, 1, sizeof(PerlInterpreter));
159 S_init_tls_and_interp(my_perl);
169 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
176 =for apidoc_section $embedding
178 =for apidoc perl_alloc
180 Allocates a new Perl interpreter. See L<perlembed>.
188 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_calloc(1, sizeof(PerlInterpreter));
190 S_init_tls_and_interp(my_perl);
191 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
194 #endif /* PERL_IMPLICIT_SYS */
197 =for apidoc perl_construct
199 Initializes a new Perl interpreter. See L<perlembed>.
205 perl_construct(pTHXx)
208 PERL_ARGS_ASSERT_PERL_CONSTRUCT;
212 PL_perl_destruct_level = 1;
214 PERL_UNUSED_ARG(my_perl);
215 if (PL_perl_destruct_level > 0)
218 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
220 #ifdef PERL_TRACE_OPS
221 Zero(PL_op_exec_cnt, OP_max+2, UV);
226 SvREADONLY_on(&PL_sv_placeholder);
227 SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
229 PL_sighandlerp = Perl_sighandler;
230 PL_sighandler1p = Perl_sighandler1;
231 PL_sighandler3p = Perl_sighandler3;
233 #ifdef PERL_USES_PL_PIDSTATUS
234 PL_pidstatus = newHV();
237 PL_rs = newSVpvs("\n");
241 /* The PERL_INTERNAL_RAND_SEED set-up must be after init_stacks because it calls
242 * things that may put SVs on the stack.
245 #ifdef NO_PERL_INTERNAL_RAND_SEED
246 Perl_drand48_init_r(&PL_internal_random_state, seed());
251 if (PerlProc_getuid() != PerlProc_geteuid() ||
252 PerlProc_getgid() != PerlProc_getegid() ||
253 !(env_pv = PerlEnv_getenv("PERL_INTERNAL_RAND_SEED")) ||
254 grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV) {
257 Perl_drand48_init_r(&PL_internal_random_state, (U32)seed);
267 (void) uvchr_to_utf8_flags((U8 *) PL_TR_SPECIAL_HANDLING_UTF8,
269 UNICODE_ALLOW_ABOVE_IV_MAX);
271 #if defined(LOCAL_PATCH_COUNT)
272 PL_localpatches = local_patches; /* For possible -v */
275 #if defined(LIBM_LIB_VERSION)
277 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
278 * This switches them over to IEEE.
280 _LIB_VERSION = _IEEE_;
283 #ifdef HAVE_INTERP_INTERN
287 PerlIO_init(aTHX); /* Hook to IO system */
289 PL_fdpid = newAV(); /* for remembering popen pids by fd */
290 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
291 PL_errors = newSVpvs("");
292 SvPVCLEAR(PERL_DEBUG_PAD(0)); /* For regex debugging. */
293 SvPVCLEAR(PERL_DEBUG_PAD(1)); /* ext/re needs these */
294 SvPVCLEAR(PERL_DEBUG_PAD(2)); /* even without DEBUGGING. */
296 /* First entry is a list of empty elements. It needs to be initialised
297 else all hell breaks loose in S_find_uninit_var(). */
298 Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
299 PL_regex_pad = AvARRAY(PL_regex_padav);
300 Newxz(PL_stashpad, PL_stashpadmax, HV *);
302 #ifdef USE_REENTRANT_API
303 Perl_reentrant_init(aTHX);
305 if (PL_hash_seed_set == FALSE) {
306 /* Initialize the hash seed and state at startup. This must be
307 * done very early, before ANY hashes are constructed, and once
308 * setup is fixed for the lifetime of the process.
310 * If you decide to disable the seeding process you should choose
311 * a suitable seed yourself and define PERL_HASH_SEED to a well chosen
312 * string. See hv_func.h for details.
314 #if defined(USE_HASH_SEED)
315 /* get the hash seed from the environment or from an RNG */
316 Perl_get_hash_seed(aTHX_ PL_hash_seed);
318 /* they want a hard coded seed, check that it is long enough */
319 assert( strlen(PERL_HASH_SEED) >= PERL_HASH_SEED_BYTES );
322 /* now we use the chosen seed to initialize the state -
323 * in some configurations this may be a relatively speaking
324 * expensive operation, but we only have to do it once at startup */
325 PERL_HASH_SEED_STATE(PERL_HASH_SEED,PL_hash_state);
327 #ifdef PERL_USE_SINGLE_CHAR_HASH_CACHE
328 /* we can build a special cache for 0/1 byte keys, if people choose
329 * I suspect most of the time it is not worth it */
333 for (i=0;i<256;i++) {
335 PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[i],str,1);
337 PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[256],str,0);
340 /* at this point we have initialezed the hash function, and we can start
341 * constructing hashes */
342 PL_hash_seed_set= TRUE;
345 /* Allow PL_strtab to be pre-initialized before calling perl_construct.
346 * can use a custom optimized PL_strtab hash before calling perl_construct */
348 /* Note that strtab is a rather special HV. Assumptions are made
349 about not iterating on it, and not adding tie magic to it.
350 It is properly deallocated in perl_destruct() */
353 /* SHAREKEYS tells us that the hash has its keys shared with PL_strtab,
354 * which is not the case with PL_strtab itself */
355 HvSHAREKEYS_off(PL_strtab); /* mandatory */
356 hv_ksplit(PL_strtab, 1 << 11);
359 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
362 # ifdef USE_ENVIRON_ARRAY
364 PL_origenviron = environ;
368 /* Use sysconf(_SC_CLK_TCK) if available, if not
369 * available or if the sysconf() fails, use the HZ.
370 * The HZ if not originally defined has been by now
371 * been defined as CLK_TCK, if available. */
372 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
373 PL_clocktick = sysconf(_SC_CLK_TCK);
374 if (PL_clocktick <= 0)
378 PL_stashcache = newHV();
380 PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
383 if (!PL_mmap_page_size) {
384 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
386 SETERRNO(0, SS_NORMAL);
388 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
390 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
392 if ((long) PL_mmap_page_size < 0) {
393 Perl_croak(aTHX_ "panic: sysconf: %s",
394 errno ? Strerror(errno) : "pagesize unknown");
397 #elif defined(HAS_GETPAGESIZE)
398 PL_mmap_page_size = getpagesize();
399 #elif defined(I_SYS_PARAM) && defined(PAGESIZE)
400 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
402 if (PL_mmap_page_size <= 0)
403 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
404 (IV) PL_mmap_page_size);
406 #endif /* HAS_MMAP */
408 PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
410 PL_registered_mros = newHV();
411 /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
412 HvMAX(PL_registered_mros) = 0;
414 #ifdef USE_POSIX_2008_LOCALE
415 PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL);
423 =for apidoc nothreadhook
425 Stub that provides thread hook for perl_destruct when there are
432 Perl_nothreadhook(pTHX)
438 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
440 Perl_dump_sv_child(pTHX_ SV *sv)
443 const int sock = PL_dumper_fd;
444 const int debug_fd = PerlIO_fileno(Perl_debug_log);
445 union control_un control;
448 struct cmsghdr *cmptr;
450 unsigned char buffer[256];
452 PERL_ARGS_ASSERT_DUMP_SV_CHILD;
454 if(sock == -1 || debug_fd == -1)
457 PerlIO_flush(Perl_debug_log);
459 /* All these shenanigans are to pass a file descriptor over to our child for
460 it to dump out to. We can't let it hold open the file descriptor when it
461 forks, as the file descriptor it will dump to can turn out to be one end
462 of pipe that some other process will wait on for EOF. (So as it would
463 be open, the wait would be forever.) */
465 msg.msg_control = control.control;
466 msg.msg_controllen = sizeof(control.control);
467 /* We're a connected socket so we don't need a destination */
473 cmptr = CMSG_FIRSTHDR(&msg);
474 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
475 cmptr->cmsg_level = SOL_SOCKET;
476 cmptr->cmsg_type = SCM_RIGHTS;
477 *((int *)CMSG_DATA(cmptr)) = 1;
479 vec[0].iov_base = (void*)&sv;
480 vec[0].iov_len = sizeof(sv);
481 got = sendmsg(sock, &msg, 0);
484 perror("Debug leaking scalars parent sendmsg failed");
487 if(got < sizeof(sv)) {
488 perror("Debug leaking scalars parent short sendmsg");
492 /* Return protocol is
494 unsigned char: length of location string (0 for empty)
495 unsigned char*: string (not terminated)
497 vec[0].iov_base = (void*)&returned_errno;
498 vec[0].iov_len = sizeof(returned_errno);
499 vec[1].iov_base = buffer;
502 got = readv(sock, vec, 2);
505 perror("Debug leaking scalars parent read failed");
506 PerlIO_flush(PerlIO_stderr());
509 if(got < sizeof(returned_errno) + 1) {
510 perror("Debug leaking scalars parent short read");
511 PerlIO_flush(PerlIO_stderr());
516 got = read(sock, buffer + 1, *buffer);
518 perror("Debug leaking scalars parent read 2 failed");
519 PerlIO_flush(PerlIO_stderr());
524 perror("Debug leaking scalars parent short read 2");
525 PerlIO_flush(PerlIO_stderr());
530 if (returned_errno || *buffer) {
531 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
532 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
533 returned_errno, Strerror(returned_errno));
539 =for apidoc perl_destruct
541 Shuts down a Perl interpreter. See L<perlembed> for a tutorial.
543 C<my_perl> points to the Perl interpreter. It must have been previously
544 created through the use of L</perl_alloc> and L</perl_construct>. It may
545 have been initialised through L</perl_parse>, and may have been used
546 through L</perl_run> and other means. This function should be called for
547 any Perl interpreter that has been constructed with L</perl_construct>,
548 even if subsequent operations on it failed, for example if L</perl_parse>
549 returned a non-zero value.
551 If the interpreter's C<PL_exit_flags> word has the
552 C<PERL_EXIT_DESTRUCT_END> flag set, then this function will execute code
553 in C<END> blocks before performing the rest of destruction. If it is
554 desired to make any use of the interpreter between L</perl_parse> and
555 L</perl_destruct> other than just calling L</perl_run>, then this flag
556 should be set early on. This matters if L</perl_run> will not be called,
557 or if anything else will be done in addition to calling L</perl_run>.
559 Returns a value be a suitable value to pass to the C library function
560 C<exit> (or to return from C<main>), to serve as an exit code indicating
561 the nature of the way the interpreter terminated. This takes into account
562 any failure of L</perl_parse> and any early exit from L</perl_run>.
563 The exit code is of the type required by the host operating system,
564 so because of differing exit code conventions it is not portable to
565 interpret specific numeric values as having specific meanings.
573 volatile signed char destruct_level; /* see possible values in intrpvar.h */
575 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
580 PERL_ARGS_ASSERT_PERL_DESTRUCT;
582 PERL_UNUSED_ARG(my_perl);
585 assert(PL_scopestack_ix == 1);
587 /* wait for all pseudo-forked children to finish */
588 PERL_WAIT_FOR_CHILDREN;
590 destruct_level = PL_perl_destruct_level;
592 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
595 if (strEQ(s, "-1")) { /* Special case: modperl folklore. */
599 if (grok_atoUV(s, &uv, NULL) && uv <= INT_MAX)
604 if (destruct_level < i) destruct_level = i;
605 #ifdef PERL_TRACK_MEMPOOL
606 /* RT #114496, for perl_free */
607 PL_perl_destruct_level = i;
612 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
618 if (PL_endav && !PL_minus_c) {
619 PERL_SET_PHASE(PERL_PHASE_END);
620 call_list(PL_scopestack_ix, PL_endav);
626 assert(PL_scopestack_ix == 0);
628 /* normally when we get here, PL_parser should be null due to having
629 * its original (null) value restored by SAVEt_PARSER during leaving
630 * scope (usually before run-time starts in fact).
631 * But if a thread is created within a BEGIN block, the parser is
632 * duped, but the SAVEt_PARSER savestack entry isn't. So PL_parser
633 * never gets cleaned up.
634 * Clean it up here instead. This is a bit of a hack.
637 /* stop parser_free() stomping on PL_curcop */
638 PL_parser->saved_curcop = PL_curcop;
639 parser_free(PL_parser);
643 /* Need to flush since END blocks can produce output */
644 /* flush stdout separately, since we can identify it */
647 PerlIO *stdo = PerlIO_stdout();
648 if (*stdo && PerlIO_flush(stdo)) {
649 PerlIO_restore_errno(stdo);
651 PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s\n",
660 #ifdef PERL_TRACE_OPS
661 /* dump OP-counts if $ENV{PERL_TRACE_OPS} > 0 */
663 const char * const ptoenv = PerlEnv_getenv("PERL_TRACE_OPS");
666 if (!ptoenv || !Perl_grok_atoUV(ptoenv, &uv, NULL)
670 PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
671 for (i = 0; i <= OP_max; ++i) {
672 if (PL_op_exec_cnt[i])
673 PerlIO_printf(Perl_debug_log, " %s: %" UVuf "\n", PL_op_name[i], PL_op_exec_cnt[i]);
675 /* Utility slot for easily doing little tracing experiments in the runloop: */
676 if (PL_op_exec_cnt[OP_max+1] != 0)
677 PerlIO_printf(Perl_debug_log, " SPECIAL: %" UVuf "\n", PL_op_exec_cnt[OP_max+1]);
678 PerlIO_printf(Perl_debug_log, "\n");
683 if (PL_threadhook(aTHX)) {
684 /* Threads hook has vetoed further cleanup */
685 PL_veto_cleanup = TRUE;
689 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
690 if (destruct_level != 0) {
691 /* Fork here to create a child. Our child's job is to preserve the
692 state of scalars prior to destruction, so that we can instruct it
693 to dump any scalars that we later find have leaked.
694 There's no subtlety in this code - it assumes POSIX, and it doesn't
698 if(PerlSock_socketpair_cloexec(AF_UNIX, SOCK_STREAM, 0, fd)) {
699 perror("Debug leaking scalars socketpair failed");
705 perror("Debug leaking scalars fork failed");
709 /* We are the child */
710 const int sock = fd[1];
711 const int debug_fd = PerlIO_fileno(Perl_debug_log);
714 /* Our success message is an integer 0, and a char 0 */
715 static const char success[sizeof(int) + 1] = {0};
719 /* We need to close all other file descriptors otherwise we end up
720 with interesting hangs, where the parent closes its end of a
721 pipe, and sits waiting for (another) child to terminate. Only
722 that child never terminates, because it never gets EOF, because
723 we also have the far end of the pipe open. We even need to
724 close the debugging fd, because sometimes it happens to be one
725 end of a pipe, and a process is waiting on the other end for
726 EOF. Normally it would be closed at some point earlier in
727 destruction, but if we happen to cause the pipe to remain open,
728 EOF never occurs, and we get an infinite hang. Hence all the
729 games to pass in a file descriptor if it's actually needed. */
731 f = sysconf(_SC_OPEN_MAX);
733 where = "sysconf failed";
744 union control_un control;
747 struct cmsghdr *cmptr;
751 msg.msg_control = control.control;
752 msg.msg_controllen = sizeof(control.control);
753 /* We're a connected socket so we don't need a source */
757 msg.msg_iovlen = C_ARRAY_LENGTH(vec);
759 vec[0].iov_base = (void*)⌖
760 vec[0].iov_len = sizeof(target);
762 got = recvmsg(sock, &msg, 0);
767 where = "recv failed";
770 if(got < sizeof(target)) {
771 where = "short recv";
775 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
779 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
780 where = "wrong cmsg_len";
783 if(cmptr->cmsg_level != SOL_SOCKET) {
784 where = "wrong cmsg_level";
787 if(cmptr->cmsg_type != SCM_RIGHTS) {
788 where = "wrong cmsg_type";
792 got_fd = *(int*)CMSG_DATA(cmptr);
793 /* For our last little bit of trickery, put the file descriptor
794 back into Perl_debug_log, as if we never actually closed it
796 if(got_fd != debug_fd) {
797 if (PerlLIO_dup2_cloexec(got_fd, debug_fd) == -1) {
804 PerlIO_flush(Perl_debug_log);
806 got = write(sock, &success, sizeof(success));
809 where = "write failed";
812 if(got < sizeof(success)) {
813 where = "short write";
820 int send_errno = errno;
821 unsigned char length = (unsigned char) strlen(where);
822 struct iovec failure[3] = {
823 {(void*)&send_errno, sizeof(send_errno)},
825 {(void*)where, length}
827 int got = writev(sock, failure, 3);
828 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
829 in the parent if we try to read from the socketpair after the
830 child has exited, even if there was data to read.
831 So sleep a bit to give the parent a fighting chance of
834 _exit((got == -1) ? errno : 0);
838 PL_dumper_fd = fd[0];
843 /* We must account for everything. */
845 /* Destroy the main CV and syntax tree */
846 /* Set PL_curcop now, because destroying ops can cause new SVs
847 to be generated in Perl_pad_swipe, and when running with
848 -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
849 op from which the filename structure member is copied. */
850 PL_curcop = &PL_compiling;
852 /* ensure comppad/curpad to refer to main's pad */
853 if (CvPADLIST(PL_main_cv)) {
854 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
855 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
857 op_free(PL_main_root);
860 PL_main_start = NULL;
861 /* note that PL_main_cv isn't usually actually freed at this point,
862 * due to the CvOUTSIDE refs from subs compiled within it. It will
863 * get freed once all the subs are freed in sv_clean_all(), for
864 * destruct_level > 0 */
865 SvREFCNT_dec(PL_main_cv);
867 PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
869 /* Tell PerlIO we are about to tear things apart in case
870 we have layers which are using resources that should
874 PerlIO_destruct(aTHX);
877 * Try to destruct global references. We do this first so that the
878 * destructors and destructees still exist. Some sv's might remain.
879 * Non-referenced objects are on their own.
883 /* unhook hooks which will soon be, or use, destroyed data */
884 SvREFCNT_dec(PL_warnhook);
886 SvREFCNT_dec(PL_diehook);
889 /* call exit list functions */
890 while (PL_exitlistlen-- > 0)
891 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
893 Safefree(PL_exitlist);
898 SvREFCNT_dec(PL_registered_mros);
900 if (destruct_level == 0) {
902 DEBUG_P(debprofdump());
904 #if defined(PERLIO_LAYERS)
905 /* No more IO - including error messages ! */
906 PerlIO_cleanup(aTHX);
909 CopFILE_free(&PL_compiling);
911 /* The exit() function will do everything that needs doing. */
915 /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */
918 /* the syntax tree is shared between clones
919 * so op_free(PL_main_root) only ReREFCNT_dec's
920 * REGEXPs in the parent interpreter
921 * we need to manually ReREFCNT_dec for the clones
924 I32 i = AvFILLp(PL_regex_padav);
925 SV **ary = AvARRAY(PL_regex_padav);
928 SvREFCNT_dec(ary[i]);
929 ary[i] = &PL_sv_undef;
935 SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
936 PL_stashcache = NULL;
938 /* loosen bonds of global variables */
940 /* XXX can PL_parser still be non-null here? */
941 if(PL_parser && PL_parser->rsfp) {
942 (void)PerlIO_close(PL_parser->rsfp);
943 PL_parser->rsfp = NULL;
947 Safefree(PL_splitstr);
957 PL_doswitches = FALSE;
958 PL_dowarn = G_WARN_OFF;
959 #ifdef PERL_SAWAMPERSAND
960 PL_sawampersand = 0; /* must save all match strings */
964 Safefree(PL_inplace);
966 SvREFCNT_dec(PL_patchlevel);
969 SvREFCNT_dec(PL_e_script);
975 /* magical thingies */
977 SvREFCNT_dec(PL_ofsgv); /* *, */
980 SvREFCNT_dec(PL_ors_sv); /* $\ */
983 SvREFCNT_dec(PL_rs); /* $/ */
986 Safefree(PL_osname); /* $^O */
989 SvREFCNT_dec(PL_statname);
993 /* defgv, aka *_ should be taken care of elsewhere */
996 Safefree(PL_efloatbuf);
1000 /* startup and shutdown function lists */
1001 SvREFCNT_dec(PL_beginav);
1002 SvREFCNT_dec(PL_beginav_save);
1003 SvREFCNT_dec(PL_endav);
1004 SvREFCNT_dec(PL_checkav);
1005 SvREFCNT_dec(PL_checkav_save);
1006 SvREFCNT_dec(PL_unitcheckav);
1007 SvREFCNT_dec(PL_unitcheckav_save);
1008 SvREFCNT_dec(PL_initav);
1010 PL_beginav_save = NULL;
1013 PL_checkav_save = NULL;
1014 PL_unitcheckav = NULL;
1015 PL_unitcheckav_save = NULL;
1018 /* shortcuts just get cleared */
1021 PL_argvoutgv = NULL;
1024 PL_last_in_gv = NULL;
1035 SvREFCNT_dec(PL_envgv);
1036 SvREFCNT_dec(PL_incgv);
1037 SvREFCNT_dec(PL_argvgv);
1038 SvREFCNT_dec(PL_replgv);
1039 SvREFCNT_dec(PL_DBgv);
1040 SvREFCNT_dec(PL_DBline);
1041 SvREFCNT_dec(PL_DBsub);
1050 SvREFCNT_dec(PL_argvout_stack);
1051 PL_argvout_stack = NULL;
1053 SvREFCNT_dec(PL_modglobal);
1054 PL_modglobal = NULL;
1055 SvREFCNT_dec(PL_preambleav);
1056 PL_preambleav = NULL;
1057 SvREFCNT_dec(PL_subname);
1059 #ifdef PERL_USES_PL_PIDSTATUS
1060 SvREFCNT_dec(PL_pidstatus);
1061 PL_pidstatus = NULL;
1063 SvREFCNT_dec(PL_toptarget);
1064 PL_toptarget = NULL;
1065 SvREFCNT_dec(PL_bodytarget);
1066 PL_bodytarget = NULL;
1067 PL_formtarget = NULL;
1069 /* free locale stuff */
1070 #ifdef USE_LOCALE_COLLATE
1071 Safefree(PL_collation_name);
1072 PL_collation_name = NULL;
1074 #if defined(USE_POSIX_2008_LOCALE) \
1075 && defined(USE_THREAD_SAFE_LOCALE) \
1076 && ! defined(HAS_QUERYLOCALE)
1077 for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) {
1078 Safefree(PL_curlocales[i]);
1079 PL_curlocales[i] = NULL;
1082 #ifdef USE_POSIX_2008_LOCALE
1084 /* This also makes sure we aren't using a locale object that gets freed
1086 const locale_t old_locale = uselocale(LC_GLOBAL_LOCALE);
1087 if ( old_locale != LC_GLOBAL_LOCALE
1088 # ifdef USE_POSIX_2008_LOCALE
1089 && old_locale != PL_C_locale_obj
1092 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1093 "%s:%d: Freeing %p\n", __FILE__, __LINE__, old_locale));
1094 freelocale(old_locale);
1097 # ifdef USE_LOCALE_NUMERIC
1098 if (PL_underlying_numeric_obj) {
1099 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
1100 "%s:%d: Freeing %p\n", __FILE__, __LINE__,
1101 PL_underlying_numeric_obj));
1102 freelocale(PL_underlying_numeric_obj);
1103 PL_underlying_numeric_obj = (locale_t) NULL;
1107 #ifdef USE_LOCALE_NUMERIC
1108 Safefree(PL_numeric_name);
1109 PL_numeric_name = NULL;
1110 SvREFCNT_dec(PL_numeric_radix_sv);
1111 PL_numeric_radix_sv = NULL;
1114 if (PL_setlocale_buf) {
1115 Safefree(PL_setlocale_buf);
1116 PL_setlocale_buf = NULL;
1119 if (PL_langinfo_buf) {
1120 Safefree(PL_langinfo_buf);
1121 PL_langinfo_buf = NULL;
1124 #ifdef USE_LOCALE_CTYPE
1125 SvREFCNT_dec(PL_warn_locale);
1126 PL_warn_locale = NULL;
1129 SvREFCNT_dec(PL_AboveLatin1);
1130 PL_AboveLatin1 = NULL;
1131 SvREFCNT_dec(PL_Assigned_invlist);
1132 PL_Assigned_invlist = NULL;
1133 SvREFCNT_dec(PL_GCB_invlist);
1134 PL_GCB_invlist = NULL;
1135 SvREFCNT_dec(PL_HasMultiCharFold);
1136 PL_HasMultiCharFold = NULL;
1137 SvREFCNT_dec(PL_InMultiCharFold);
1138 PL_InMultiCharFold = NULL;
1139 SvREFCNT_dec(PL_Latin1);
1141 SvREFCNT_dec(PL_LB_invlist);
1142 PL_LB_invlist = NULL;
1143 SvREFCNT_dec(PL_SB_invlist);
1144 PL_SB_invlist = NULL;
1145 SvREFCNT_dec(PL_SCX_invlist);
1146 PL_SCX_invlist = NULL;
1147 SvREFCNT_dec(PL_UpperLatin1);
1148 PL_UpperLatin1 = NULL;
1149 SvREFCNT_dec(PL_in_some_fold);
1150 PL_in_some_fold = NULL;
1151 SvREFCNT_dec(PL_utf8_foldclosures);
1152 PL_utf8_foldclosures = NULL;
1153 SvREFCNT_dec(PL_utf8_idcont);
1154 PL_utf8_idcont = NULL;
1155 SvREFCNT_dec(PL_utf8_idstart);
1156 PL_utf8_idstart = NULL;
1157 SvREFCNT_dec(PL_utf8_perl_idcont);
1158 PL_utf8_perl_idcont = NULL;
1159 SvREFCNT_dec(PL_utf8_perl_idstart);
1160 PL_utf8_perl_idstart = NULL;
1161 SvREFCNT_dec(PL_utf8_xidcont);
1162 PL_utf8_xidcont = NULL;
1163 SvREFCNT_dec(PL_utf8_xidstart);
1164 PL_utf8_xidstart = NULL;
1165 SvREFCNT_dec(PL_WB_invlist);
1166 PL_WB_invlist = NULL;
1167 SvREFCNT_dec(PL_utf8_toupper);
1168 PL_utf8_toupper = NULL;
1169 SvREFCNT_dec(PL_utf8_totitle);
1170 PL_utf8_totitle = NULL;
1171 SvREFCNT_dec(PL_utf8_tolower);
1172 PL_utf8_tolower = NULL;
1173 SvREFCNT_dec(PL_utf8_tofold);
1174 PL_utf8_tofold = NULL;
1175 SvREFCNT_dec(PL_utf8_tosimplefold);
1176 PL_utf8_tosimplefold = NULL;
1177 SvREFCNT_dec(PL_utf8_charname_begin);
1178 PL_utf8_charname_begin = NULL;
1179 SvREFCNT_dec(PL_utf8_charname_continue);
1180 PL_utf8_charname_continue = NULL;
1181 SvREFCNT_dec(PL_utf8_mark);
1182 PL_utf8_mark = NULL;
1183 SvREFCNT_dec(PL_InBitmap);
1185 SvREFCNT_dec(PL_CCC_non0_non230);
1186 PL_CCC_non0_non230 = NULL;
1187 SvREFCNT_dec(PL_Private_Use);
1188 PL_Private_Use = NULL;
1190 for (i = 0; i < POSIX_CC_COUNT; i++) {
1191 SvREFCNT_dec(PL_XPosix_ptrs[i]);
1192 PL_XPosix_ptrs[i] = NULL;
1194 if (i != CC_CASED_) { /* A copy of Alpha */
1195 SvREFCNT_dec(PL_Posix_ptrs[i]);
1196 PL_Posix_ptrs[i] = NULL;
1200 free_and_set_cop_warnings(&PL_compiling, NULL);
1201 cophh_free(CopHINTHASH_get(&PL_compiling));
1202 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
1203 CopFILE_free(&PL_compiling);
1205 /* Prepare to destruct main symbol table. */
1208 /* break ref loop *:: <=> %:: */
1209 (void)hv_deletes(hv, "main::", G_DISCARD);
1212 SvREFCNT_dec(PL_curstname);
1213 PL_curstname = NULL;
1215 /* clear queued errors */
1216 SvREFCNT_dec(PL_errors);
1219 SvREFCNT_dec(PL_isarev);
1222 if (destruct_level >= 2) {
1223 if (PL_scopestack_ix != 0)
1224 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1225 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1226 (long)PL_scopestack_ix);
1227 if (PL_savestack_ix != 0)
1228 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1229 "Unbalanced saves: %ld more saves than restores\n",
1230 (long)PL_savestack_ix);
1231 if (PL_tmps_floor != -1)
1232 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1233 (long)PL_tmps_floor + 1);
1234 if (cxstack_ix != -1)
1235 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1236 (long)cxstack_ix + 1);
1240 SvREFCNT_dec(PL_regex_padav);
1241 PL_regex_padav = NULL;
1242 PL_regex_pad = NULL;
1246 /* the entries in this list are allocated via SV PVX's, so get freed
1247 * in sv_clean_all */
1248 Safefree(PL_my_cxt_list);
1251 /* Now absolutely destruct everything, somehow or other, loops or no. */
1253 /* the 2 is for PL_fdpid and PL_strtab */
1254 while (sv_clean_all() > 2)
1258 Safefree(PL_stashpad); /* must come after sv_clean_all */
1261 AvREAL_off(PL_fdpid); /* no surviving entries */
1262 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
1265 #ifdef HAVE_INTERP_INTERN
1269 /* constant strings */
1270 for (i = 0; i < SV_CONSTS_COUNT; i++) {
1271 SvREFCNT_dec(PL_sv_consts[i]);
1272 PL_sv_consts[i] = NULL;
1275 /* Destruct the global string table. */
1277 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1278 * so that sv_free() won't fail on them.
1279 * Now that the global string table is using a single hunk of memory
1280 * for both HE and HEK, we either need to explicitly unshare it the
1281 * correct way, or actually free things here.
1284 const I32 max = HvMAX(PL_strtab);
1285 HE * const * const array = HvARRAY(PL_strtab);
1286 HE *hent = array[0];
1289 if (hent && ckWARN_d(WARN_INTERNAL)) {
1290 HE * const next = HeNEXT(hent);
1291 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1292 "Unbalanced string table refcount: (%ld) for \"%s\"",
1293 (long)hent->he_valu.hent_refcount, HeKEY(hent));
1300 hent = array[riter];
1305 HvARRAY(PL_strtab) = 0;
1306 HvTOTALKEYS(PL_strtab) = 0;
1308 SvREFCNT_dec(PL_strtab);
1311 /* free the pointer tables used for cloning */
1312 ptr_table_free(PL_ptr_table);
1313 PL_ptr_table = (PTR_TBL_t*)NULL;
1316 /* free special SVs */
1318 SvREFCNT(&PL_sv_yes) = 0;
1319 sv_clear(&PL_sv_yes);
1320 SvANY(&PL_sv_yes) = NULL;
1321 SvFLAGS(&PL_sv_yes) = 0;
1323 SvREFCNT(&PL_sv_no) = 0;
1324 sv_clear(&PL_sv_no);
1325 SvANY(&PL_sv_no) = NULL;
1326 SvFLAGS(&PL_sv_no) = 0;
1328 SvREFCNT(&PL_sv_zero) = 0;
1329 sv_clear(&PL_sv_zero);
1330 SvANY(&PL_sv_zero) = NULL;
1331 SvFLAGS(&PL_sv_zero) = 0;
1335 for (i=0; i<=2; i++) {
1336 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1337 sv_clear(PERL_DEBUG_PAD(i));
1338 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1339 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1343 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1344 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1346 #ifdef DEBUG_LEAKING_SCALARS
1347 if (PL_sv_count != 0) {
1352 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1353 svend = &sva[SvREFCNT(sva)];
1354 for (sv = sva + 1; sv < svend; ++sv) {
1355 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
1356 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1358 " refcnt=%" UVuf pTHX__FORMAT "\n"
1359 "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");"
1360 "serial %" UVuf "\n",
1361 (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1363 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1365 sv->sv_debug_inpad ? "for" : "by",
1366 sv->sv_debug_optype ?
1367 PL_op_name[sv->sv_debug_optype]: "(none)",
1368 PTR2UV(sv->sv_debug_parent),
1371 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1372 Perl_dump_sv_child(aTHX_ sv);
1378 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1382 /* Wait for up to 4 seconds for child to terminate.
1383 This seems to be the least effort way of timing out on reaping
1385 struct timeval waitfor = {4, 0};
1386 int sock = PL_dumper_fd;
1390 FD_SET(sock, &rset);
1391 select(sock + 1, &rset, NULL, NULL, &waitfor);
1392 waitpid(child, &status, WNOHANG);
1397 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1403 #if defined(PERLIO_LAYERS)
1404 /* No more IO - including error messages ! */
1405 PerlIO_cleanup(aTHX);
1408 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1409 as currently layers use it rather than NULL as a marker
1410 for no arg - and will try and SvREFCNT_dec it.
1412 SvREFCNT(&PL_sv_undef) = 0;
1413 SvREADONLY_off(&PL_sv_undef);
1415 Safefree(PL_origfilename);
1416 PL_origfilename = NULL;
1417 Safefree(PL_reg_curpm);
1418 free_tied_hv_pool();
1419 Safefree(PL_op_mask);
1420 Safefree(PL_psig_name);
1421 PL_psig_name = (SV**)NULL;
1422 PL_psig_ptr = (SV**)NULL;
1424 /* We need to NULL PL_psig_pend first, so that
1425 signal handlers know not to use it */
1426 int *psig_save = PL_psig_pend;
1427 PL_psig_pend = (int*)NULL;
1428 Safefree(psig_save);
1431 TAINTING_set(FALSE);
1432 TAINT_WARN_set(FALSE);
1433 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
1435 DEBUG_P(debprofdump());
1439 #ifdef USE_REENTRANT_API
1440 Perl_reentrant_free(aTHX);
1443 /* These all point to HVs that are about to be blown away.
1444 Code in core and on CPAN assumes that if the interpreter is re-started
1445 that they will be cleanly NULL or pointing to a valid HV. */
1446 PL_custom_op_names = NULL;
1447 PL_custom_op_descs = NULL;
1448 PL_custom_ops = NULL;
1452 while (PL_regmatch_slab) {
1453 regmatch_slab *s = PL_regmatch_slab;
1454 PL_regmatch_slab = PL_regmatch_slab->next;
1458 /* As the absolutely last thing, free the non-arena SV for mess() */
1461 /* we know that type == SVt_PVMG */
1463 /* it could have accumulated taint magic */
1466 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1467 moremagic = mg->mg_moremagic;
1468 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1470 Safefree(mg->mg_ptr);
1474 /* we know that type >= SVt_PV */
1475 SvPV_free(PL_mess_sv);
1476 Safefree(SvANY(PL_mess_sv));
1477 Safefree(PL_mess_sv);
1484 =for apidoc perl_free
1486 Releases a Perl interpreter. See L<perlembed>.
1495 PERL_ARGS_ASSERT_PERL_FREE;
1497 if (PL_veto_cleanup)
1500 #ifdef PERL_TRACK_MEMPOOL
1503 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1504 * value as we're probably hunting memory leaks then
1506 if (PL_perl_destruct_level == 0) {
1507 const U32 old_debug = PL_debug;
1508 /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1509 thread at thread exit. */
1511 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1512 "free this thread's memory\n");
1513 PL_debug &= ~ DEBUG_m_FLAG;
1515 while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){
1516 char * next = (char *)(aTHXx->Imemory_debug_header.next);
1517 Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next;
1520 PL_debug = old_debug;
1526 # if defined(PERL_IMPLICIT_SYS)
1528 void *host = w32_internal_host;
1529 PerlMem_free(aTHXx);
1530 win32_delete_internal_host(host);
1533 PerlMem_free(aTHXx);
1536 PerlMem_free(aTHXx);
1540 #if defined(USE_ITHREADS)
1541 /* provide destructors to clean up the thread key when libperl is unloaded */
1542 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1544 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1545 #pragma fini "perl_fini"
1546 #elif defined(__sun) && !defined(__GNUC__)
1547 #pragma fini (perl_fini)
1551 #if defined(__GNUC__)
1552 __attribute__((destructor))
1557 PL_curinterp && !PL_veto_cleanup)
1562 #endif /* THREADS */
1565 =for apidoc call_atexit
1567 Add a function C<fn> to the list of functions to be called at global
1568 destruction. C<ptr> will be passed as an argument to C<fn>; it can point to a
1569 C<struct> so that you can pass anything you want.
1571 Note that under threads, C<fn> may run multiple times. This is because the
1572 list is executed each time the current or any descendent thread terminates.
1578 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1580 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1581 PL_exitlist[PL_exitlistlen].fn = fn;
1582 PL_exitlist[PL_exitlistlen].ptr = ptr;
1586 #ifdef USE_ENVIRON_ARRAY
1590 # ifdef USE_ITHREADS
1591 if (aTHX != PL_curinterp)
1597 size_t n_entries = 0, vars_size = 0;
1599 for (char **ep = environ; *ep; ++ep) {
1601 vars_size += strlen(*ep) + 1;
1604 /* To save memory, we store both the environ array and its values in a
1605 * single memory block. */
1606 char **new_environ = (char**)PerlMemShared_malloc(
1607 (sizeof(char*) * (n_entries + 1)) + vars_size
1609 char *vars = (char*)(new_environ + n_entries + 1);
1611 for (size_t i = 0, copied = 0; n_entries > i; ++i) {
1612 size_t len = strlen(environ[i]) + 1;
1613 new_environ[i] = (char *) CopyD(environ[i], vars + copied, len, char);
1616 new_environ[n_entries] = NULL;
1618 environ = new_environ;
1619 /* Store a pointer in a global variable to ensure it's always reachable so
1620 * LeakSanitizer/Valgrind won't complain about it. We can't ever free it.
1621 * Even if libc allocates a new environ, it's possible that some of its
1622 * values will still be pointing to the old environ.
1624 PL_my_environ = new_environ;
1629 =for apidoc perl_parse
1631 Tells a Perl interpreter to parse a Perl script. This performs most
1632 of the initialisation of a Perl interpreter. See L<perlembed> for
1635 C<my_perl> points to the Perl interpreter that is to parse the script.
1636 It must have been previously created through the use of L</perl_alloc>
1637 and L</perl_construct>. C<xsinit> points to a callback function that
1638 will be called to set up the ability for this Perl interpreter to load
1639 XS extensions, or may be null to perform no such setup.
1641 C<argc> and C<argv> supply a set of command-line arguments to the Perl
1642 interpreter, as would normally be passed to the C<main> function of
1643 a C program. C<argv[argc]> must be null. These arguments are where
1644 the script to parse is specified, either by naming a script file or by
1645 providing a script in a C<-e> option.
1646 If L<C<$0>|perlvar/$0> will be written to in the Perl interpreter, then
1647 the argument strings must be in writable memory, and so mustn't just be
1650 C<env> specifies a set of environment variables that will be used by
1651 this Perl interpreter. If non-null, it must point to a null-terminated
1652 array of environment strings. If null, the Perl interpreter will use
1653 the environment supplied by the C<environ> global variable.
1655 This function initialises the interpreter, and parses and compiles the
1656 script specified by the command-line arguments. This includes executing
1657 code in C<BEGIN>, C<UNITCHECK>, and C<CHECK> blocks. It does not execute
1658 C<INIT> blocks or the main program.
1660 Returns an integer of slightly tricky interpretation. The correct
1661 use of the return value is as a truth value indicating whether there
1662 was a failure in initialisation. If zero is returned, this indicates
1663 that initialisation was successful, and it is safe to proceed to call
1664 L</perl_run> and make other use of it. If a non-zero value is returned,
1665 this indicates some problem that means the interpreter wants to terminate.
1666 The interpreter should not be just abandoned upon such failure; the caller
1667 should proceed to shut the interpreter down cleanly with L</perl_destruct>
1668 and free it with L</perl_free>.
1670 For historical reasons, the non-zero return value also attempts to
1671 be a suitable value to pass to the C library function C<exit> (or to
1672 return from C<main>), to serve as an exit code indicating the nature
1673 of the way initialisation terminated. However, this isn't portable,
1674 due to differing exit code conventions. A historical bug is preserved
1675 for the time being: if the Perl built-in C<exit> is called during this
1676 function's execution, with a type of exit entailing a zero exit code
1677 under the host operating system's conventions, then this function
1678 returns zero rather than a non-zero value. This bug, [perl #2754],
1679 leads to C<perl_run> being called (and therefore C<INIT> blocks and the
1680 main program running) despite a call to C<exit>. It has been preserved
1681 because a popular module-installing module has come to rely on it and
1682 needs time to be fixed. This issue is [perl #132577], and the original
1683 bug is due to be fixed in Perl 5.30.
1688 #define SET_CURSTASH(newstash) \
1689 if (PL_curstash != newstash) { \
1690 SvREFCNT_dec(PL_curstash); \
1691 PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1695 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1701 PERL_ARGS_ASSERT_PERL_PARSE;
1702 #ifndef MULTIPLICITY
1703 PERL_UNUSED_ARG(my_perl);
1705 debug_hash_seed(false);
1708 struct NameTranslationInfo nti;
1709 __translate_amiga_to_unix_path_name(&argv[0],&nti);
1716 for(i = 0; i != argc; i++)
1718 assert(!argv[argc]);
1723 if (PL_origalen != 0) {
1724 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1727 /* Set PL_origalen be the sum of the contiguous argv[]
1728 * elements plus the size of the env in case that it is
1729 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1730 * as the maximum modifiable length of $0. In the worst case
1731 * the area we are able to modify is limited to the size of
1732 * the original argv[0]. (See below for 'contiguous', though.)
1734 const char *s = NULL;
1735 const UV mask = ~(UV)(PTRSIZE-1);
1736 /* Do the mask check only if the args seem like aligned. */
1738 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1740 /* See if all the arguments are contiguous in memory. Note
1741 * that 'contiguous' is a loose term because some platforms
1742 * align the argv[] and the envp[]. If the arguments look
1743 * like non-aligned, assume that they are 'strictly' or
1744 * 'traditionally' contiguous. If the arguments look like
1745 * aligned, we just check that they are within aligned
1746 * PTRSIZE bytes. As long as no system has something bizarre
1747 * like the argv[] interleaved with some other data, we are
1748 * fine. (Did I just evoke Murphy's Law?) --jhi */
1749 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1752 for (i = 1; i < PL_origargc; i++) {
1753 if ((PL_origargv[i] == s + 1
1755 || PL_origargv[i] == s + 2
1760 (PL_origargv[i] > s &&
1762 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1773 #ifdef USE_ENVIRON_ARRAY
1774 /* Can we grab env area too to be used as the area for $0? */
1775 if (s && PL_origenviron) {
1776 if ((PL_origenviron[0] == s + 1)
1779 (PL_origenviron[0] > s &&
1780 PL_origenviron[0] <=
1781 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1785 #ifndef OS2 /* ENVIRON is read by the kernel too. */
1786 s = PL_origenviron[0];
1790 /* Force copy of environment. */
1791 if (PL_origenviron == environ)
1794 for (i = 1; PL_origenviron[i]; i++) {
1795 if (PL_origenviron[i] == s + 1
1798 (PL_origenviron[i] > s &&
1799 PL_origenviron[i] <=
1800 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1803 s = PL_origenviron[i];
1811 #endif /* USE_ENVIRON_ARRAY */
1813 PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1818 /* Come here if running an undumped a.out. */
1820 PL_origfilename = savepv(argv[0]);
1821 PL_do_undump = FALSE;
1822 cxstack_ix = -1; /* start label stack again */
1824 assert (!TAINT_get);
1828 init_postdump_symbols(argc,argv,env);
1833 op_free(PL_main_root);
1834 PL_main_root = NULL;
1836 PL_main_start = NULL;
1837 SvREFCNT_dec(PL_main_cv);
1841 oldscope = PL_scopestack_ix;
1842 PL_dowarn = G_WARN_OFF;
1847 parse_body(env,xsinit);
1848 if (PL_unitcheckav) {
1849 call_list(oldscope, PL_unitcheckav);
1852 PERL_SET_PHASE(PERL_PHASE_CHECK);
1853 call_list(oldscope, PL_checkav);
1861 /* my_exit() was called */
1862 while (PL_scopestack_ix > oldscope)
1865 SET_CURSTASH(PL_defstash);
1866 if (PL_unitcheckav) {
1867 call_list(oldscope, PL_unitcheckav);
1870 PERL_SET_PHASE(PERL_PHASE_CHECK);
1871 call_list(oldscope, PL_checkav);
1876 * At this point we should do
1878 * to avoid [perl #2754], but that bugfix has been postponed
1879 * because of the Module::Install breakage it causes
1885 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1893 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1894 miniperl, and we need to see those flags reflected in the values here. */
1896 /* What this returns is subject to change. Use the public interface in Config.
1899 S_Internals_V(pTHX_ CV *cv)
1902 #ifdef LOCAL_PATCH_COUNT
1903 const int local_patch_count = LOCAL_PATCH_COUNT;
1905 const int local_patch_count = 0;
1907 const int entries = 3 + local_patch_count;
1909 static const char non_bincompat_options[] =
1916 # ifdef NO_HASH_SEED
1919 # ifdef NO_TAINT_SUPPORT
1922 # ifdef PERL_COPY_ON_WRITE
1923 " PERL_COPY_ON_WRITE"
1925 # ifdef PERL_DISABLE_PMC
1928 # ifdef PERL_DONT_CREATE_GVSV
1929 " PERL_DONT_CREATE_GVSV"
1931 # ifdef PERL_EXTERNAL_GLOB
1932 " PERL_EXTERNAL_GLOB"
1934 # ifdef PERL_HASH_FUNC_SIPHASH
1935 " PERL_HASH_FUNC_SIPHASH"
1937 # ifdef PERL_HASH_FUNC_SDBM
1938 " PERL_HASH_FUNC_SDBM"
1940 # ifdef PERL_HASH_FUNC_DJB2
1941 " PERL_HASH_FUNC_DJB2"
1943 # ifdef PERL_HASH_FUNC_SUPERFAST
1944 " PERL_HASH_FUNC_SUPERFAST"
1946 # ifdef PERL_HASH_FUNC_MURMUR3
1947 " PERL_HASH_FUNC_MURMUR3"
1949 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1950 " PERL_HASH_FUNC_ONE_AT_A_TIME"
1952 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1953 " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1955 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1956 " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1958 # ifdef PERL_IS_MINIPERL
1961 # ifdef PERL_MALLOC_WRAP
1964 # ifdef PERL_MEM_LOG
1967 # ifdef PERL_MEM_LOG_NOIMPL
1968 " PERL_MEM_LOG_NOIMPL"
1970 # ifdef PERL_OP_PARENT
1973 # ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1974 " PERL_PERTURB_KEYS_DETERMINISTIC"
1976 # ifdef PERL_PERTURB_KEYS_DISABLED
1977 " PERL_PERTURB_KEYS_DISABLED"
1979 # ifdef PERL_PERTURB_KEYS_RANDOM
1980 " PERL_PERTURB_KEYS_RANDOM"
1982 # ifdef PERL_PRESERVE_IVUV
1983 " PERL_PRESERVE_IVUV"
1985 # ifdef PERL_RELOCATABLE_INCPUSH
1986 " PERL_RELOCATABLE_INCPUSH"
1988 # ifdef PERL_USE_DEVEL
1991 # ifdef PERL_USE_SAFE_PUTENV
1992 " PERL_USE_SAFE_PUTENV"
1994 # ifdef PERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES
1995 " PERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES"
1997 # ifdef SILENT_NO_TAINT_SUPPORT
1998 " SILENT_NO_TAINT_SUPPORT"
2000 # ifdef UNLINK_ALL_VERSIONS
2001 " UNLINK_ALL_VERSIONS"
2003 # ifdef USE_ATTRIBUTES_FOR_PERLIO
2004 " USE_ATTRIBUTES_FOR_PERLIO"
2006 # ifdef USE_FAST_STDIO
2012 # ifdef USE_LOCALE_CTYPE
2015 # ifdef WIN32_NO_REGISTRY
2018 # ifdef USE_PERL_ATOF
2021 # ifdef USE_SITECUSTOMIZE
2022 " USE_SITECUSTOMIZE"
2024 # ifdef USE_THREAD_SAFE_LOCALE
2025 " USE_THREAD_SAFE_LOCALE"
2028 PERL_UNUSED_ARG(cv);
2029 PERL_UNUSED_VAR(items);
2031 EXTEND(SP, entries);
2033 PUSHs(newSVpvn_flags(PL_bincompat_options, strlen(PL_bincompat_options),
2035 PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
2036 sizeof(non_bincompat_options) - 1, SVs_TEMP));
2038 #ifndef PERL_BUILD_DATE
2041 # define PERL_BUILD_DATE __DATE__ " " __TIME__
2043 # define PERL_BUILD_DATE __DATE__
2048 #ifdef PERL_BUILD_DATE
2049 PUSHs(Perl_newSVpvn_flags(aTHX_
2050 STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
2053 PUSHs(&PL_sv_undef);
2056 for (i = 1; i <= local_patch_count; i++) {
2057 /* This will be an undef, if PL_localpatches[i] is NULL. */
2058 PUSHs(newSVpvn_flags(PL_localpatches[i],
2059 PL_localpatches[i] == NULL ? 0 : strlen(PL_localpatches[i]),
2066 #define INCPUSH_UNSHIFT 0x01
2067 #define INCPUSH_ADD_OLD_VERS 0x02
2068 #define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04
2069 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08
2070 #define INCPUSH_NOT_BASEDIR 0x10
2071 #define INCPUSH_CAN_RELOCATE 0x20
2072 #define INCPUSH_ADD_SUB_DIRS \
2073 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
2076 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
2079 int argc = PL_origargc;
2080 char **argv = PL_origargv;
2081 const char *scriptname = NULL;
2082 bool dosearch = FALSE;
2084 bool doextract = FALSE;
2085 const char *cddir = NULL;
2086 bool minus_e = FALSE; /* both -e and -E */
2087 #ifdef USE_SITECUSTOMIZE
2088 bool minus_f = FALSE;
2090 SV *linestr_sv = NULL;
2091 bool add_read_e_script = FALSE;
2092 U32 lex_start_flags = 0;
2094 PERL_SET_PHASE(PERL_PHASE_START);
2100 for (argc--,argv++; argc > 0; argc--,argv++) {
2101 if (argv[0][0] != '-' || !argv[0][1])
2107 #ifndef PERL_STRICT_CR
2133 if ((s = moreswitches(s)))
2138 #if defined(SILENT_NO_TAINT_SUPPORT)
2139 /* silently ignore */
2140 #elif defined(NO_TAINT_SUPPORT)
2141 Perl_croak_nocontext("This perl was compiled without taint support. "
2142 "Cowardly refusing to run with -t or -T flags");
2144 CHECK_MALLOC_TOO_LATE_FOR('t');
2145 if( !TAINTING_get ) {
2146 TAINT_WARN_set(TRUE);
2153 #if defined(SILENT_NO_TAINT_SUPPORT)
2154 /* silently ignore */
2155 #elif defined(NO_TAINT_SUPPORT)
2156 Perl_croak_nocontext("This perl was compiled without taint support. "
2157 "Cowardly refusing to run with -t or -T flags");
2159 CHECK_MALLOC_TOO_LATE_FOR('T');
2161 TAINT_WARN_set(FALSE);
2170 forbid_setid('e', FALSE);
2173 PL_e_script = newSVpvs("");
2174 add_read_e_script = TRUE;
2177 sv_catpv(PL_e_script, s);
2179 sv_catpv(PL_e_script, argv[1]);
2183 Perl_croak(aTHX_ "No code specified for -%c", c);
2184 sv_catpvs(PL_e_script, "\n");
2188 #ifdef USE_SITECUSTOMIZE
2194 case 'I': /* -I handled both here and in moreswitches() */
2195 forbid_setid('I', FALSE);
2196 if (!*++s && (s=argv[1]) != NULL) {
2200 STRLEN len = strlen(s);
2201 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
2204 Perl_croak(aTHX_ "No directory specified for -I");
2207 forbid_setid('S', FALSE);
2216 opts_prog = newSVpvs("use Config; Config::_V()");
2220 opts_prog = Perl_newSVpvf(aTHX_
2221 "use Config; Config::config_vars(qw%c%s%c)",
2225 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
2226 /* don't look for script or read stdin */
2227 scriptname = BIT_BUCKET;
2239 if (!*++s || isSPACE(*s)) {
2243 /* catch use of gnu style long options.
2244 Both of these exit immediately. */
2245 if (strEQ(s, "version"))
2247 if (strEQ(s, "help"))
2252 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
2263 #ifndef SECURE_INTERNAL_GETENV
2266 (s = PerlEnv_getenv("PERL5OPT")))
2270 if (*s == '-' && *(s+1) == 'T') {
2271 #if defined(SILENT_NO_TAINT_SUPPORT)
2272 /* silently ignore */
2273 #elif defined(NO_TAINT_SUPPORT)
2274 Perl_croak_nocontext("This perl was compiled without taint support. "
2275 "Cowardly refusing to run with -t or -T flags");
2277 CHECK_MALLOC_TOO_LATE_FOR('T');
2279 TAINT_WARN_set(FALSE);
2283 char *popt_copy = NULL;
2296 if (!memCHRs("CDIMUdmtwW", *s))
2297 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2301 popt_copy = SvPVX(newSVpvn_flags(d, strlen(d), SVs_TEMP));
2302 s = popt_copy + (s - d);
2310 #if defined(SILENT_NO_TAINT_SUPPORT)
2311 /* silently ignore */
2312 #elif defined(NO_TAINT_SUPPORT)
2313 Perl_croak_nocontext("This perl was compiled without taint support. "
2314 "Cowardly refusing to run with -t or -T flags");
2316 if( !TAINTING_get) {
2317 TAINT_WARN_set(TRUE);
2329 #ifndef NO_PERL_INTERNAL_RAND_SEED
2330 /* If we're not set[ug]id, we might have honored
2331 PERL_INTERNAL_RAND_SEED in perl_construct().
2332 At this point command-line options have been parsed, so if
2333 we're now tainting and not set[ug]id re-seed.
2334 This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid,
2335 but avoids duplicating the logic from perl_construct().
2338 PerlProc_getuid() == PerlProc_geteuid() &&
2339 PerlProc_getgid() == PerlProc_getegid()) {
2340 Perl_drand48_init_r(&PL_internal_random_state, seed());
2344 debug_hash_seed(true);
2346 /* Set $^X early so that it can be used for relocatable paths in @INC */
2347 /* and for SITELIB_EXP in USE_SITECUSTOMIZE */
2348 assert (!TAINT_get);
2353 #if defined(USE_SITECUSTOMIZE)
2355 /* The games with local $! are to avoid setting errno if there is no
2356 sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2357 ie a q() operator with a NUL byte as a the delimiter. This avoids
2358 problems with pathnames containing (say) ' */
2359 # ifdef PERL_IS_MINIPERL
2360 AV *const inc = GvAV(PL_incgv);
2361 SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2364 /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2365 it should be reported immediately as a build failure. */
2366 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2368 "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; "
2369 "do {local $!; -f $f }"
2370 " and do $f || die $@ || qq '$f: $!' }",
2371 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
2374 /* SITELIB_EXP is a function call on Win32. */
2375 const char *const raw_sitelib = SITELIB_EXP;
2377 /* process .../.. if PERL_RELOCATABLE_INC is defined */
2378 SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2379 INCPUSH_CAN_RELOCATE);
2380 const char *const sitelib = SvPVX(sitelib_sv);
2381 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2383 "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2386 assert (SvREFCNT(sitelib_sv) == 1);
2387 SvREFCNT_dec(sitelib_sv);
2394 scriptname = argv[0];
2397 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2399 else if (scriptname == NULL) {
2403 assert (!TAINT_get);
2407 bool suidscript = FALSE;
2409 rsfp = open_script(scriptname, dosearch, &suidscript);
2411 rsfp = PerlIO_stdin();
2412 lex_start_flags = LEX_DONT_CLOSE_RSFP;
2415 validate_suid(rsfp);
2418 # if defined(SIGCHLD) || defined(SIGCLD)
2421 # define SIGCHLD SIGCLD
2423 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2424 if (sigstate == (Sighandler_t) SIG_IGN) {
2425 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2426 "Can't ignore signal CHLD, forcing to default");
2427 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2435 /* This will croak if suidscript is true, as -x cannot be used with
2437 forbid_setid('x', suidscript);
2438 /* Hence you can't get here if suidscript is true */
2440 linestr_sv = newSV_type(SVt_PV);
2441 lex_start_flags |= LEX_START_COPIED;
2442 find_beginning(linestr_sv, rsfp);
2443 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2444 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2448 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2449 CvUNIQUE_on(PL_compcv);
2451 CvPADLIST_set(PL_compcv, pad_new(0));
2453 PL_isarev = newHV();
2456 boot_core_UNIVERSAL();
2457 boot_core_builtin();
2459 newXS("Internals::V", S_Internals_V, __FILE__);
2462 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
2464 #if defined(VMS) || defined(WIN32) || defined(__CYGWIN__)
2470 # ifdef HAS_SOCKS5_INIT
2471 socks5_init(argv[0]);
2477 init_predump_symbols();
2478 /* init_postdump_symbols not currently designed to be called */
2479 /* more than once (ENV isn't cleared first, for example) */
2480 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2482 init_postdump_symbols(argc,argv,env);
2484 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2485 * or explicitly in some platforms.
2486 * PL_utf8locale is conditionally turned on by
2487 * locale.c:Perl_init_i18nl10n() if the environment
2488 * look like the user wants to use UTF-8. */
2489 # ifndef PERL_IS_MINIPERL
2491 /* Requires init_predump_symbols(). */
2492 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2497 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2498 * and the default open disciplines. */
2499 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2500 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2502 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2503 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2504 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2506 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2507 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2508 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2510 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2511 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2512 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2514 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2515 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2518 sv_setpvs(sv, ":utf8\0:utf8");
2520 sv_setpvs(sv, ":utf8\0");
2523 sv_setpvs(sv, "\0:utf8");
2532 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2533 if (strEQ(s, "unsafe"))
2534 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2535 else if (strEQ(s, "safe"))
2536 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2538 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2543 lex_start(linestr_sv, rsfp, lex_start_flags);
2544 SvREFCNT_dec(linestr_sv);
2546 PL_subname = newSVpvs("main");
2548 if (add_read_e_script)
2549 filter_add(read_e_script, NULL);
2551 /* now parse the script */
2552 if (minus_e == FALSE)
2553 PL_hints |= HINTS_DEFAULT; /* after init_main_stash ; need to be after init_predump_symbols */
2555 SETERRNO(0,SS_NORMAL);
2556 if (yyparse(GRAMPROG) || PL_parser->error_count) {
2557 abort_execution("", PL_origfilename);
2559 CopLINE_set(PL_curcop, 0);
2560 SET_CURSTASH(PL_defstash);
2562 SvREFCNT_dec(PL_e_script);
2570 SAVECOPFILE(PL_curcop);
2571 SAVECOPLINE(PL_curcop);
2572 gv_check(PL_defstash);
2582 s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
2583 if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
2584 dump_mstats("after compilation:");
2589 PL_restartjmpenv = NULL;
2595 =for apidoc perl_run
2597 Tells a Perl interpreter to run its main program. See L<perlembed>
2600 C<my_perl> points to the Perl interpreter. It must have been previously
2601 created through the use of L</perl_alloc> and L</perl_construct>, and
2602 initialised through L</perl_parse>. This function should not be called
2603 if L</perl_parse> returned a non-zero value, indicating a failure in
2604 initialisation or compilation.
2606 This function executes code in C<INIT> blocks, and then executes the
2607 main program. The code to be executed is that established by the prior
2608 call to L</perl_parse>. If the interpreter's C<PL_exit_flags> word
2609 does not have the C<PERL_EXIT_DESTRUCT_END> flag set, then this function
2610 will also execute code in C<END> blocks. If it is desired to make any
2611 further use of the interpreter after calling this function, then C<END>
2612 blocks should be postponed to L</perl_destruct> time by setting that flag.
2614 Returns an integer of slightly tricky interpretation. The correct use
2615 of the return value is as a truth value indicating whether the program
2616 terminated non-locally. If zero is returned, this indicates that
2617 the program ran to completion, and it is safe to make other use of the
2618 interpreter (provided that the C<PERL_EXIT_DESTRUCT_END> flag was set as
2619 described above). If a non-zero value is returned, this indicates that
2620 the interpreter wants to terminate early. The interpreter should not be
2621 just abandoned because of this desire to terminate; the caller should
2622 proceed to shut the interpreter down cleanly with L</perl_destruct>
2623 and free it with L</perl_free>.
2625 For historical reasons, the non-zero return value also attempts to
2626 be a suitable value to pass to the C library function C<exit> (or to
2627 return from C<main>), to serve as an exit code indicating the nature of
2628 the way the program terminated. However, this isn't portable, due to
2629 differing exit code conventions. An attempt is made to return an exit
2630 code of the type required by the host operating system, but because
2631 it is constrained to be non-zero, it is not necessarily possible to
2632 indicate every type of exit. It is only reliable on Unix, where a zero
2633 exit code can be augmented with a set bit that will be ignored. In any
2634 case, this function is not the correct place to acquire an exit code:
2635 one should get that from L</perl_destruct>.
2647 PERL_ARGS_ASSERT_PERL_RUN;
2648 #ifndef MULTIPLICITY
2649 PERL_UNUSED_ARG(my_perl);
2652 oldscope = PL_scopestack_ix;
2660 cxstack_ix = -1; /* start context stack again */
2662 case 0: /* normal completion */
2666 case 2: /* my_exit() */
2667 while (PL_scopestack_ix > oldscope)
2670 SET_CURSTASH(PL_defstash);
2671 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2672 PL_endav && !PL_minus_c) {
2673 PERL_SET_PHASE(PERL_PHASE_END);
2674 call_list(oldscope, PL_endav);
2677 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2678 dump_mstats("after execution: ");
2684 POPSTACK_TO(PL_mainstack);
2687 PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2698 S_run_body(pTHX_ I32 oldscope)
2700 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2701 PL_sawampersand ? "Enabling" : "Omitting",
2702 (unsigned int)(PL_sawampersand)));
2704 if (!PL_restartop) {
2706 if (DEBUG_x_TEST || DEBUG_B_TEST)
2707 dump_all_perl(!DEBUG_B_TEST);
2709 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2713 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2716 if (PERLDB_SINGLE && PL_DBsingle)
2719 PERL_SET_PHASE(PERL_PHASE_INIT);
2720 call_list(oldscope, PL_initav);
2722 #ifdef PERL_DEBUG_READONLY_OPS
2723 if (PL_main_root && PL_main_root->op_slabbed)
2724 Slab_to_ro(OpSLAB(PL_main_root));
2730 PERL_SET_PHASE(PERL_PHASE_RUN);
2733 PL_restartjmpenv = NULL;
2734 PL_op = PL_restartop;
2738 else if (PL_main_start) {
2739 CvDEPTH(PL_main_cv) = 1;
2740 PL_op = PL_main_start;
2744 NOT_REACHED; /* NOTREACHED */
2748 =for apidoc_section $SV
2752 Returns the SV of the specified Perl scalar. C<flags> are passed to
2753 L</C<gv_fetchpv>>. If C<GV_ADD> is set and the
2754 Perl variable does not exist then it will be created. If C<flags> is zero
2755 and the variable does not exist then NULL is returned.
2761 Perl_get_sv(pTHX_ const char *name, I32 flags)
2765 PERL_ARGS_ASSERT_GET_SV;
2767 gv = gv_fetchpv(name, flags, SVt_PV);
2774 =for apidoc_section $AV
2778 Returns the AV of the specified Perl global or package array with the given
2779 name (so it won't work on lexical variables). C<flags> are passed
2780 to C<gv_fetchpv>. If C<GV_ADD> is set and the
2781 Perl variable does not exist then it will be created. If C<flags> is zero
2782 and the variable does not exist then NULL is returned.
2784 Perl equivalent: C<@{"$name"}>.
2790 Perl_get_av(pTHX_ const char *name, I32 flags)
2792 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2794 PERL_ARGS_ASSERT_GET_AV;
2804 =for apidoc_section $HV
2808 Returns the HV of the specified Perl hash. C<flags> are passed to
2809 C<gv_fetchpv>. If C<GV_ADD> is set and the
2810 Perl variable does not exist then it will be created. If C<flags> is zero
2811 and the variable does not exist then C<NULL> is returned.
2817 Perl_get_hv(pTHX_ const char *name, I32 flags)
2819 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2821 PERL_ARGS_ASSERT_GET_HV;
2831 =for apidoc_section $CV
2834 =for apidoc_item get_cvn_flags
2835 =for apidoc_item |CV *|get_cvs|"string"|I32 flags
2837 These return the CV of the specified Perl subroutine. C<flags> are passed to
2838 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2839 exist then it will be declared (which has the same effect as saying
2840 C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist,
2841 then NULL is returned.
2843 The forms differ only in how the subroutine is specified.. With C<get_cvs>,
2844 the name is a literal C string, enclosed in double quotes. With C<get_cv>, the
2845 name is given by the C<name> parameter, which must be a NUL-terminated C
2846 string. With C<get_cvn_flags>, the name is also given by the C<name>
2847 parameter, but it is a Perl string (possibly containing embedded NUL bytes),
2848 and its length in bytes is contained in the C<len> parameter.
2850 =for apidoc Amnh||GV_ADD
2856 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2858 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2860 PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2862 if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV)
2863 return (CV*)SvRV((SV *)gv);
2865 /* XXX this is probably not what they think they're getting.
2866 * It has the same effect as "sub name;", i.e. just a forward
2868 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2869 return newSTUB(gv,0);
2876 /* Nothing in core calls this now, but we can't replace it with a macro and
2877 move it to mathoms.c as a macro would evaluate name twice. */
2879 Perl_get_cv(pTHX_ const char *name, I32 flags)
2881 PERL_ARGS_ASSERT_GET_CV;
2883 return get_cvn_flags(name, strlen(name), flags);
2886 /* Be sure to refetch the stack pointer after calling these routines. */
2890 =for apidoc_section $callback
2892 =for apidoc call_argv
2894 Performs a callback to the specified named and package-scoped Perl subroutine
2895 with C<argv> (a C<NULL>-terminated array of strings) as arguments. See
2898 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2904 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2906 /* See G_* flags in cop.h */
2907 /* null terminated arg list */
2911 PERL_ARGS_ASSERT_CALL_ARGV;
2915 mXPUSHs(newSVpv(*argv,0));
2919 return call_pv(sub_name, flags);
2925 Performs a callback to the specified Perl sub. See L<perlcall>.
2931 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2932 /* name of the subroutine */
2933 /* See G_* flags in cop.h */
2935 PERL_ARGS_ASSERT_CALL_PV;
2937 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2941 =for apidoc call_method
2943 Performs a callback to the specified Perl method. The blessed object must
2944 be on the stack. See L<perlcall>.
2950 Perl_call_method(pTHX_ const char *methname, I32 flags)
2951 /* name of the subroutine */
2952 /* See G_* flags in cop.h */
2956 PERL_ARGS_ASSERT_CALL_METHOD;
2958 len = strlen(methname);
2959 sv = flags & G_METHOD_NAMED
2960 ? sv_2mortal(newSVpvn_share(methname, len,0))
2961 : newSVpvn_flags(methname, len, SVs_TEMP);
2963 return call_sv(sv, flags | G_METHOD);
2966 /* May be called with any of a CV, a GV, or an SV containing the name. */
2970 Performs a callback to the Perl sub specified by the SV.
2972 If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
2973 SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
2974 or C<SvPV(sv)> will be used as the name of the sub to call.
2976 If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
2977 C<SvPV(sv)> will be used as the name of the method to call.
2979 If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
2980 the name of the method to call.
2982 Some other values are treated specially for internal use and should
2987 =for apidoc Amnh||G_METHOD
2988 =for apidoc Amnh||G_METHOD_NAMED
2994 Perl_call_sv(pTHX_ SV *sv, volatile I32 flags)
2995 /* See G_* flags in cop.h */
2997 LOGOP myop; /* fake syntax tree node */
3000 volatile I32 retval = 0;
3001 bool oldcatch = CATCH_GET;
3003 OP* const oldop = PL_op;
3006 PERL_ARGS_ASSERT_CALL_SV;
3008 if (flags & G_DISCARD) {
3012 if (!(flags & G_WANT)) {
3013 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
3018 Zero(&myop, 1, LOGOP);
3019 if (!(flags & G_NOARGS))
3020 myop.op_flags |= OPf_STACKED;
3021 myop.op_flags |= OP_GIMME_REVERSE(flags);
3025 if (!(flags & G_METHOD_NAMED)) {
3033 if (PERLDB_SUB && PL_curstash != PL_debstash
3034 /* Handle first BEGIN of -d. */
3035 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
3036 /* Try harder, since this may have been a sighandler, thus
3037 * curstash may be meaningless. */
3038 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
3039 && !(flags & G_NODEBUG))
3040 myop.op_private |= OPpENTERSUB_DB;
3042 if (flags & (G_METHOD|G_METHOD_NAMED)) {
3043 Zero(&method_op, 1, METHOP);
3044 method_op.op_next = (OP*)&myop;
3045 PL_op = (OP*)&method_op;
3046 if ( flags & G_METHOD_NAMED ) {
3047 method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
3048 method_op.op_type = OP_METHOD_NAMED;
3049 method_op.op_u.op_meth_sv = sv;
3051 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
3052 method_op.op_type = OP_METHOD;
3054 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
3055 myop.op_type = OP_ENTERSUB;
3058 if (!(flags & G_EVAL)) {
3060 CALL_BODY_SUB((OP*)&myop);
3061 retval = PL_stack_sp - (PL_stack_base + oldmark);
3062 CATCH_SET(oldcatch);
3066 myop.op_other = (OP*)&myop;
3068 old_cxix = cxstack_ix;
3069 create_eval_scope(NULL, flags|G_FAKINGEVAL);
3077 CALL_BODY_SUB((OP*)&myop);
3078 retval = PL_stack_sp - (PL_stack_base + oldmark);
3079 if (!(flags & G_KEEPERR)) {
3087 /* my_exit() was called */
3088 SET_CURSTASH(PL_defstash);
3092 NOT_REACHED; /* NOTREACHED */
3095 PL_restartjmpenv = NULL;
3096 PL_op = PL_restartop;
3100 PL_stack_sp = PL_stack_base + oldmark;
3101 if ((flags & G_WANT) == G_LIST)
3105 *++PL_stack_sp = &PL_sv_undef;
3110 /* if we croaked, depending on how we croaked the eval scope
3111 * may or may not have already been popped */
3112 if (cxstack_ix > old_cxix) {
3113 assert(cxstack_ix == old_cxix + 1);
3114 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3115 delete_eval_scope();
3120 if (flags & G_DISCARD) {
3121 PL_stack_sp = PL_stack_base + oldmark;
3130 /* Eval a string. The G_EVAL flag is always assumed. */
3135 Tells Perl to C<eval> the string in the SV. It supports the same flags
3136 as C<call_sv>, with the obvious exception of C<G_EVAL>. See L<perlcall>.
3138 The C<G_RETHROW> flag can be used if you only need eval_sv() to
3139 execute code specified by a string, but not catch any errors.
3141 =for apidoc Amnh||G_RETHROW
3146 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
3148 /* See G_* flags in cop.h */
3150 UNOP myop; /* fake syntax tree node */
3151 volatile I32 oldmark;
3152 volatile I32 retval = 0;
3154 OP* const oldop = PL_op;
3157 PERL_ARGS_ASSERT_EVAL_SV;
3159 if (flags & G_DISCARD) {
3166 Zero(&myop, 1, UNOP);
3169 oldmark = SP - PL_stack_base;
3175 if (!(flags & G_NOARGS))
3176 myop.op_flags = OPf_STACKED;
3177 myop.op_type = OP_ENTEREVAL;
3178 myop.op_flags |= OP_GIMME_REVERSE(flags);
3179 if (flags & G_KEEPERR)
3180 myop.op_flags |= OPf_SPECIAL;
3182 if (flags & G_RE_REPARSING)
3183 myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
3185 /* fail now; otherwise we could fail after the JMPENV_PUSH but
3186 * before a cx_pusheval(), which corrupts the stack after a croak */
3187 TAINT_PROPER("eval_sv()");
3193 if (PL_op == (OP*)(&myop)) {
3194 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
3196 goto fail; /* failed in compilation */
3199 retval = PL_stack_sp - (PL_stack_base + oldmark);
3200 if (!(flags & G_KEEPERR)) {
3208 /* my_exit() was called */
3209 SET_CURSTASH(PL_defstash);
3213 NOT_REACHED; /* NOTREACHED */
3216 PL_restartjmpenv = NULL;
3217 PL_op = PL_restartop;
3222 if (flags & G_RETHROW) {
3227 PL_stack_sp = PL_stack_base + oldmark;
3228 if ((flags & G_WANT) == G_LIST)
3232 *++PL_stack_sp = &PL_sv_undef;
3238 if (flags & G_DISCARD) {
3239 PL_stack_sp = PL_stack_base + oldmark;
3251 Tells Perl to C<eval> the given string in scalar context and return an SV* result.
3257 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
3259 SV* sv = newSVpv(p, 0);
3261 PERL_ARGS_ASSERT_EVAL_PV;
3263 if (croak_on_error) {
3265 eval_sv(sv, G_SCALAR | G_RETHROW);
3268 eval_sv(sv, G_SCALAR);
3281 /* Require a module. */
3284 =for apidoc_section $embedding
3286 =for apidoc require_pv
3288 Tells Perl to C<require> the file named by the string argument. It is
3289 analogous to the Perl code C<eval "require '$file'">. It's even
3290 implemented that way; consider using load_module instead.
3295 Perl_require_pv(pTHX_ const char *pv)
3300 PERL_ARGS_ASSERT_REQUIRE_PV;
3302 PUSHSTACKi(PERLSI_REQUIRE);
3303 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3304 eval_sv(sv_2mortal(sv), G_DISCARD);
3309 S_usage(pTHX) /* XXX move this out into a module ? */
3311 /* This message really ought to be max 23 lines.
3312 * Removed -h because the user already knows that option. Others? */
3314 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3315 minimum of 509 character string literals. */
3316 static const char * const usage_msg[] = {
3317 " -0[octal/hexadecimal] specify record separator (\\0, if no argument)\n"
3318 " -a autosplit mode with -n or -p (splits $_ into @F)\n"
3319 " -C[number/list] enables the listed Unicode features\n"
3320 " -c check syntax only (runs BEGIN and CHECK blocks)\n"
3321 " -d[t][:MOD] run program under debugger or module Devel::MOD\n"
3322 " -D[number/letters] set debugging flags (argument is a bit mask or alphabets)\n",
3323 " -e commandline one line of program (several -e's allowed, omit programfile)\n"
3324 " -E commandline like -e, but enables all optional features\n"
3325 " -f don't do $sitelib/sitecustomize.pl at startup\n"
3326 " -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
3327 " -g read all input in one go (slurp), rather than line-by-line (alias for -0777)\n"
3328 " -i[extension] edit <> files in place (makes backup if extension supplied)\n"
3329 " -Idirectory specify @INC/#include directory (several -I's allowed)\n",
3330 " -l[octnum] enable line ending processing, specifies line terminator\n"
3331 " -[mM][-]module execute \"use/no module...\" before executing program\n"
3332 " -n assume \"while (<>) { ... }\" loop around program\n"
3333 " -p assume loop like -n but print line also, like sed\n"
3334 " -s enable rudimentary parsing for switches after programfile\n"
3335 " -S look for programfile using PATH environment variable\n",
3336 " -t enable tainting warnings\n"
3337 " -T enable tainting checks\n"
3338 " -u dump core after parsing program\n"
3339 " -U allow unsafe operations\n"
3340 " -v print version, patchlevel and license\n"
3341 " -V[:configvar] print configuration summary (or a single Config.pm variable)\n",
3342 " -w enable many useful warnings\n"
3343 " -W enable all warnings\n"
3344 " -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
3345 " -X disable all warnings\n"
3347 "Run 'perldoc perl' for more help with Perl.\n\n",
3350 const char * const *p = usage_msg;
3351 PerlIO *out = PerlIO_stdout();
3354 "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3357 PerlIO_puts(out, *p++);
3361 /* convert a string of -D options (or digits) into an int.
3362 * sets *s to point to the char after the options */
3366 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3368 static const char * const usage_msgd[] = {
3369 " Debugging flag values: (see also -d)\n"
3370 " p Tokenizing and parsing (with v, displays parse stack)\n"
3371 " s Stack snapshots (with v, displays all stacks)\n"
3372 " l Context (loop) stack processing\n"
3373 " t Trace execution\n"
3374 " o Method and overloading resolution\n",
3375 " c String/numeric conversions\n"
3376 " P Print profiling info, source file input state\n"
3377 " m Memory and SV allocation\n"
3378 " f Format processing\n"
3379 " r Regular expression parsing and execution\n"
3380 " x Syntax tree dump\n",
3381 " u Tainting checks\n"
3382 " X Scratchpad allocation\n"
3384 " S Op slab allocation\n"
3386 " R Include reference counts of dumped variables (eg when using -Ds)\n",
3387 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3388 " v Verbose: use in conjunction with other flags\n"
3389 " C Copy On Write\n"
3390 " A Consistency checks on internal structures\n"
3391 " q quiet - currently only suppresses the 'EXECUTING' message\n"
3392 " M trace smart match resolution\n"
3393 " B dump suBroutine definitions, including special Blocks like BEGIN\n",
3394 " L trace some locale setting information--for Perl core development\n",
3395 " i trace PerlIO layer processing\n",
3396 " y trace y///, tr/// compilation and execution\n",
3397 " h Show (h)ash randomization debug output"
3398 " (changes to PL_hash_rand_bits)\n",
3403 PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3407 * If adding new options add them to the END of debopts[].
3408 * If you remove an option replace it with a '?'.
3409 * If there is a free slot available marked with '?' feel
3410 * free to reuse it for something else.
3412 * Regardles remember to update DEBUG_MASK in perl.h, and
3413 * update the documentation above AND in pod/perlrun.pod.
3415 * Note that the ? indicates an unused slot. As the code below
3416 * indicates the position in this list is important. You cannot
3417 * change the order or delete a character from the list without
3418 * impacting the definitions of all the other flags in perl.h
3419 * However because the logic is guarded by isWORDCHAR we can
3420 * fill in holes with non-wordchar characters instead. */
3421 static const char debopts[] = "psltocPmfrxuUhXDSTRJvCAqMBLiy";
3423 for (; isWORDCHAR(**s); (*s)++) {
3424 const char * const d = strchr(debopts,**s);
3426 uv |= 1 << (d - debopts);
3427 else if (ckWARN_d(WARN_DEBUGGING))
3428 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3429 "invalid option -D%c, use -D'' to see choices\n", **s);
3432 else if (isDIGIT(**s)) {
3433 const char* e = *s + strlen(*s);
3434 if (grok_atoUV(*s, &uv, &e))
3436 for (; isWORDCHAR(**s); (*s)++) ;
3438 else if (givehelp) {
3439 const char *const *p = usage_msgd;
3440 while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3442 return (int)uv; /* ignore any UV->int conversion loss */
3446 /* This routine handles any switches that can be given during run */
3449 Perl_moreswitches(pTHX_ const char *s)
3452 const char option = *s; /* used to remember option in -m/-M code */
3454 PERL_ARGS_ASSERT_MORESWITCHES;
3462 SvREFCNT_dec(PL_rs);
3463 if (s[1] == 'x' && s[2]) {
3464 const char *e = s+=2;
3470 flags = PERL_SCAN_SILENT_ILLDIGIT;
3471 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3472 if (s + numlen < e) {
3473 /* Continue to treat -0xFOO as -0 -xFOO
3474 * (ie NUL as the input record separator, and -x with FOO
3475 * as the directory argument)
3477 * hex support for -0 was only added in 5.8.1, hence this
3478 * heuristic to distinguish between it and '-0' clustered with
3479 * '-x' with an argument. The text following '-0x' is only
3480 * processed as the IRS specified in hexadecimal if all
3481 * characters are valid hex digits. */
3486 PL_rs = newSVpvs("");
3487 tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
3488 uvchr_to_utf8(tmps, rschar);
3489 SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
3494 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3495 if (rschar & ~((U8)~0))
3496 PL_rs = &PL_sv_undef;
3497 else if (!rschar && numlen >= 2)
3498 PL_rs = newSVpvs("");
3500 char ch = (char)rschar;
3501 PL_rs = newSVpvn(&ch, 1);
3504 sv_setsv(get_sv("/", GV_ADD), PL_rs);
3509 PL_unicode = parse_unicode_opts( (const char **)&s );
3510 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3518 while (*s && !isSPACE(*s)) ++s;
3519 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3531 forbid_setid('d', FALSE);
3534 /* -dt indicates to the debugger that threads will be used */
3535 if (*s == 't' && !isWORDCHAR(s[1])) {
3537 my_setenv("PERL5DB_THREADED", "1");
3540 /* The following permits -d:Mod to accepts arguments following an =
3541 in the fashion that -MSome::Mod does. */
3542 if (*s == ':' || *s == '=') {
3549 sv = newSVpvs("no Devel::");
3551 sv = newSVpvs("use Devel::");
3555 end = s + strlen(s);
3557 /* We now allow -d:Module=Foo,Bar and -d:-Module */
3558 while(isWORDCHAR(*s) || *s==':') ++s;
3560 sv_catpvn(sv, start, end - start);
3562 sv_catpvn(sv, start, s-start);
3563 /* Don't use NUL as q// delimiter here, this string goes in the
3565 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3568 my_setenv("PERL5DB", SvPV_nolen_const(sv));
3572 PL_perldb = PERLDB_ALL;
3579 forbid_setid('D', FALSE);
3581 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3582 #else /* !DEBUGGING */
3583 if (ckWARN_d(WARN_DEBUGGING))
3584 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3585 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3586 for (s++; isWORDCHAR(*s); s++) ;
3589 NOT_REACHED; /* NOTREACHED */
3592 SvREFCNT_dec(PL_rs);
3593 PL_rs = &PL_sv_undef;
3594 sv_setsv(get_sv("/", GV_ADD), PL_rs);
3601 NOT_REACHED; /* NOTREACHED */
3604 Safefree(PL_inplace);
3606 const char * const start = ++s;
3607 while (*s && !isSPACE(*s))
3610 PL_inplace = savepvn(start, s - start);
3613 case 'I': /* -I handled both here and in parse_body() */
3614 forbid_setid('I', FALSE);
3616 while (*s && isSPACE(*s))
3621 /* ignore trailing spaces (possibly followed by other switches) */
3623 for (e = p; *e && !isSPACE(*e); e++) ;
3627 } while (*p && *p != '-');
3629 INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3635 Perl_croak(aTHX_ "No directory specified for -I");
3641 SvREFCNT_dec(PL_ors_sv);
3647 PL_ors_sv = newSVpvs("\n");
3648 numlen = 3 + (*s == '0');
3649 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3653 if (RsPARA(PL_rs)) {
3654 PL_ors_sv = newSVpvs("\n\n");
3657 PL_ors_sv = newSVsv(PL_rs);
3662 forbid_setid('M', FALSE); /* XXX ? */
3665 forbid_setid('m', FALSE); /* XXX ? */
3670 const char *use = "use ";
3672 /* -M-foo == 'no foo' */
3673 /* Leading space on " no " is deliberate, to make both
3674 possibilities the same length. */
3675 if (*s == '-') { use = " no "; ++s; }
3676 sv = newSVpvn(use,4);
3678 /* We allow -M'Module qw(Foo Bar)' */
3679 while(isWORDCHAR(*s) || *s==':') {
3688 Perl_croak(aTHX_ "Module name required with -%c option",
3691 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3692 "contains single ':'",
3693 (int)(s - start), start, option);
3694 end = s + strlen(s);
3696 sv_catpvn(sv, start, end - start);
3697 if (option == 'm') {
3699 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3700 sv_catpvs( sv, " ()");
3703 sv_catpvn(sv, start, s-start);
3704 /* Use NUL as q''-delimiter. */
3705 sv_catpvs(sv, " split(/,/,q\0");
3707 sv_catpvn(sv, s, end - s);
3708 sv_catpvs(sv, "\0)");
3711 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3714 Perl_croak(aTHX_ "Missing argument to -%c", option);
3725 forbid_setid('s', FALSE);
3726 PL_doswitches = TRUE;
3731 #if defined(SILENT_NO_TAINT_SUPPORT)
3732 /* silently ignore */
3733 #elif defined(NO_TAINT_SUPPORT)
3734 Perl_croak_nocontext("This perl was compiled without taint support. "
3735 "Cowardly refusing to run with -t or -T flags");
3743 PL_do_undump = TRUE;
3753 if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3754 PL_dowarn |= G_WARN_ON;
3759 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3760 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
3764 PL_dowarn = G_WARN_ALL_OFF;
3765 free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
3772 if (s[0] == '-') /* Additional switches on #! line. */
3777 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3783 #ifdef ALTERNATE_SHEBANG
3784 case 'S': /* OS/2 needs -S on "extproc" line. */
3787 case 'e': case 'f': case 'x': case 'E':
3788 #ifndef ALTERNATE_SHEBANG
3792 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3795 "Unrecognized switch: -%.1s (-h will show valid options)",s
3805 PerlIO * PIO_stdout;
3807 const char * const level_str = "v" PERL_VERSION_STRING;
3808 const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
3809 #ifdef PERL_PATCHNUM
3811 # ifdef PERL_GIT_UNCOMMITTED_CHANGES
3812 static const char num [] = PERL_PATCHNUM "*";
3814 static const char num [] = PERL_PATCHNUM;
3817 const STRLEN num_len = sizeof(num)-1;
3818 /* A very advanced compiler would fold away the strnEQ
3819 and this whole conditional, but most (all?) won't do it.
3820 SV level could also be replaced by with preprocessor
3823 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3824 /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3825 of the interp so it might contain format characters
3827 level = newSVpvn(num, num_len);
3829 level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
3833 SV* level = newSVpvn(level_str, level_len);
3834 #endif /* #ifdef PERL_PATCHNUM */
3835 PIO_stdout = PerlIO_stdout();
3836 PerlIO_printf(PIO_stdout,
3837 "\nThis is perl " STRINGIFY(PERL_REVISION)
3838 ", version " STRINGIFY(PERL_VERSION)
3839 ", subversion " STRINGIFY(PERL_SUBVERSION)
3840 " (%" SVf ") built for " ARCHNAME, SVfARG(level)
3842 SvREFCNT_dec_NN(level);
3844 #if defined(LOCAL_PATCH_COUNT)
3845 if (LOCAL_PATCH_COUNT > 0)
3846 PerlIO_printf(PIO_stdout,
3847 "\n(with %d registered patch%s, "
3848 "see perl -V for more detail)",
3850 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3853 PerlIO_printf(PIO_stdout,
3854 "\n\nCopyright 1987-2022, Larry Wall\n");
3856 PerlIO_printf(PIO_stdout,
3857 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3858 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3861 PerlIO_printf(PIO_stdout,
3862 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3865 PerlIO_printf(PIO_stdout,
3866 "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3869 PerlIO_printf(PIO_stdout,
3870 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3872 #ifdef BINARY_BUILD_NOTICE
3873 BINARY_BUILD_NOTICE;
3875 PerlIO_printf(PIO_stdout,
3877 Perl may be copied only under the terms of either the Artistic License or the\n\
3878 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3879 Complete documentation for Perl, including FAQ lists, should be found on\n\
3880 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3881 Internet, point your browser at https://www.perl.org/, the Perl Home Page.\n\n");
3885 /* compliments of Tom Christiansen */
3887 /* unexec() can be found in the Gnu emacs distribution */
3888 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3891 #include <lib$routines.h>
3895 Perl_my_unexec(pTHX)
3898 SV * prog = newSVpv(BIN_EXP, 0);
3899 SV * file = newSVpv(PL_origfilename, 0);
3903 sv_catpvs(prog, "/perl");
3904 sv_catpvs(file, ".perldump");
3906 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3907 /* unexec prints msg to stderr in case of failure */
3908 PerlProc_exit(status);
3910 PERL_UNUSED_CONTEXT;
3912 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3913 # elif defined(WIN32) || defined(__CYGWIN__)
3914 Perl_croak_nocontext("dump is not supported");
3916 ABORT(); /* for use with undump */
3921 /* initialize curinterp */
3926 # define PERLVAR(prefix,var,type)
3927 # define PERLVARA(prefix,var,n,type)
3928 # if defined(MULTIPLICITY)
3929 # define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init;
3930 # define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init;
3932 # define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init;
3933 # define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init;
3935 # include "intrpvar.h"
3941 # define PERLVAR(prefix,var,type)
3942 # define PERLVARA(prefix,var,n,type)
3943 # define PERLVARI(prefix,var,type,init) PL_##var = init;
3944 # define PERLVARIC(prefix,var,type,init) PL_##var = init;
3945 # include "intrpvar.h"
3955 S_init_main_stash(pTHX)
3960 PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(hv);
3961 /* We know that the string "main" will be in the global shared string
3962 table, so it's a small saving to use it rather than allocate another
3964 PL_curstname = newSVpvs_share("main");
3965 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3966 /* If we hadn't caused another reference to "main" to be in the shared
3967 string table above, then it would be worth reordering these two,
3968 because otherwise all we do is delete "main" from it as a consequence
3969 of the SvREFCNT_dec, only to add it again with hv_name_set */
3970 SvREFCNT_dec(GvHV(gv));
3971 hv_name_sets(PL_defstash, "main", 0);
3972 GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3974 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3976 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3977 GvMULTI_on(PL_incgv);
3978 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3979 SvREFCNT_inc_simple_void(PL_hintgv);
3980 GvMULTI_on(PL_hintgv);
3981 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3982 SvREFCNT_inc_simple_void(PL_defgv);
3983 PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
3984 SvREFCNT_inc_simple_void(PL_errgv);
3985 GvMULTI_on(PL_errgv);
3986 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3987 SvREFCNT_inc_simple_void(PL_replgv);
3988 GvMULTI_on(PL_replgv);
3989 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
3990 #ifdef PERL_DONT_CREATE_GVSV
3991 (void)gv_SVadd(PL_errgv);
3993 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3995 CopSTASH_set(&PL_compiling, PL_defstash);
3996 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3997 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3999 /* We must init $/ before switches are processed. */
4000 sv_setpvs(get_sv("/", GV_ADD), "\n");
4004 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
4007 PerlIO *rsfp = NULL;
4011 PERL_ARGS_ASSERT_OPEN_SCRIPT;
4014 PL_origfilename = savepvs("-e");
4019 /* if find_script() returns, it returns a malloc()-ed value */
4020 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
4021 s = scriptname + strlen(scriptname);
4023 if (strBEGINs(scriptname, "/dev/fd/")
4024 && isDIGIT(scriptname[8])
4025 && grok_atoUV(scriptname + 8, &uv, &s)
4026 && uv <= PERL_INT_MAX
4031 * Tell apart "normal" usage of fdscript, e.g.
4032 * with bash on FreeBSD:
4033 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
4034 * from usage in suidperl.
4035 * Does any "normal" usage leave garbage after the number???
4036 * Is it a mistake to use a similar /dev/fd/ construct for
4041 * Be supersafe and do some sanity-checks.
4042 * Still, can we be sure we got the right thing?
4045 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
4048 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
4050 scriptname = savepv(s + 1);
4051 Safefree(PL_origfilename);
4052 PL_origfilename = (char *)scriptname;
4057 CopFILE_free(PL_curcop);
4058 CopFILE_set(PL_curcop, PL_origfilename);
4059 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
4060 scriptname = (char *)"";
4061 if (fdscript >= 0) {
4062 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
4064 else if (!*scriptname) {
4065 forbid_setid(0, *suidscript);
4069 #ifdef FAKE_BIT_BUCKET
4070 /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
4071 * is called) and still have the "-e" work. (Believe it or not,
4072 * a /dev/null is required for the "-e" to work because source
4073 * filter magic is used to implement it. ) This is *not* a general
4074 * replacement for a /dev/null. What we do here is create a temp
4075 * file (an empty file), open up that as the script, and then
4076 * immediately close and unlink it. Close enough for jazz. */
4077 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
4078 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
4079 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
4080 char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
4081 FAKE_BIT_BUCKET_TEMPLATE
4083 const char * const err = "Failed to create a fake bit bucket";
4084 if (strEQ(scriptname, BIT_BUCKET)) {
4085 int tmpfd = Perl_my_mkstemp_cloexec(tmpname);
4087 scriptname = tmpname;
4090 Perl_croak(aTHX_ err);
4093 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
4094 #ifdef FAKE_BIT_BUCKET
4095 if ( strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX)
4096 && strlen(scriptname) == sizeof(tmpname) - 1)
4100 scriptname = BIT_BUCKET;
4104 /* PSz 16 Sep 03 Keep neat error message */
4106 Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno));
4108 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4109 CopFILE(PL_curcop), Strerror(errno));
4111 fd = PerlIO_fileno(rsfp);
4114 (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
4115 && S_ISDIR(tmpstatbuf.st_mode)))
4116 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
4123 /* In the days of suidperl, we refused to execute a setuid script stored on
4124 * a filesystem mounted nosuid and/or noexec. This meant that we probed for the
4125 * existence of the appropriate filesystem-statting function, and behaved
4126 * accordingly. But even though suidperl is long gone, we must still include
4127 * those probes for the benefit of modules like Filesys::Df, which expect the
4128 * results of those probes to be stored in %Config; see RT#126368. So mention
4129 * the relevant cpp symbols here, to ensure that metaconfig will include their
4130 * probes in the generated Configure:
4132 * I_SYSSTATVFS HAS_FSTATVFS
4134 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
4135 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
4139 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4140 /* Don't even need this function. */
4143 S_validate_suid(pTHX_ PerlIO *rsfp)
4145 const Uid_t my_uid = PerlProc_getuid();
4146 const Uid_t my_euid = PerlProc_geteuid();
4147 const Gid_t my_gid = PerlProc_getgid();
4148 const Gid_t my_egid = PerlProc_getegid();
4150 PERL_ARGS_ASSERT_VALIDATE_SUID;
4152 if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
4153 int fd = PerlIO_fileno(rsfp);
4155 if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
4156 Perl_croak_nocontext( "Illegal suidscript");
4158 if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
4160 (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
4163 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4164 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4165 /* not set-id, must be wrapped */
4168 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4171 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
4176 PERL_ARGS_ASSERT_FIND_BEGINNING;
4178 /* skip forward in input to the real script? */
4181 if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
4182 Perl_croak(aTHX_ "No Perl script found in input\n");
4184 } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
4185 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
4186 while (*s && !(isSPACE (*s) || *s == '#')) s++;
4188 while (*s == ' ' || *s == '\t') s++;
4190 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4191 || s2[-1] == '_') s2--;
4192 if (strBEGINs(s2-4,"perl"))
4193 while ((s = moreswitches(s)))
4202 /* no need to do anything here any more if we don't
4204 #ifndef NO_TAINT_SUPPORT
4205 const Uid_t my_uid = PerlProc_getuid();
4206 const Uid_t my_euid = PerlProc_geteuid();
4207 const Gid_t my_gid = PerlProc_getgid();
4208 const Gid_t my_egid = PerlProc_getegid();
4210 PERL_UNUSED_CONTEXT;
4212 /* Should not happen: */
4213 CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
4214 TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
4218 * Should go by suidscript, not uid!=euid: why disallow
4219 * system("ls") in scripts run from setuid things?
4220 * Or, is this run before we check arguments and set suidscript?
4221 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4222 * (We never have suidscript, can we be sure to have fdscript?)
4223 * Or must then go by UID checks? See comments in forbid_setid also.
4227 /* This is used very early in the lifetime of the program,
4228 * before even the options are parsed, so PL_tainting has
4229 * not been initialized properly. */
4231 Perl_doing_taint(int argc, char *argv[], char *envp[])
4233 #ifndef PERL_IMPLICIT_SYS
4234 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4235 * before we have an interpreter-- and the whole point of this
4236 * function is to be called at such an early stage. If you are on
4237 * a system with PERL_IMPLICIT_SYS but you do have a concept of
4238 * "tainted because running with altered effective ids', you'll
4239 * have to add your own checks somewhere in here. The most known
4240 * sample of 'implicitness' is Win32, which doesn't have much of
4241 * concept of 'uids'. */
4242 Uid_t uid = PerlProc_getuid();
4243 Uid_t euid = PerlProc_geteuid();
4244 Gid_t gid = PerlProc_getgid();
4245 Gid_t egid = PerlProc_getegid();
4252 if (uid && (euid != uid || egid != gid))
4254 #endif /* !PERL_IMPLICIT_SYS */
4255 /* This is a really primitive check; environment gets ignored only
4256 * if -T are the first chars together; otherwise one gets
4257 * "Too late" message. */
4258 if ( argc > 1 && argv[1][0] == '-'
4259 && isALPHA_FOLD_EQ(argv[1][1], 't'))
4264 /* Passing the flag as a single char rather than a string is a slight space
4265 optimisation. The only message that isn't /^-.$/ is
4266 "program input from stdin", which is substituted in place of '\0', which
4267 could never be a command line flag. */
4269 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4271 char string[3] = "-x";
4272 const char *message = "program input from stdin";
4274 PERL_UNUSED_CONTEXT;
4280 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4281 if (PerlProc_getuid() != PerlProc_geteuid())
4282 Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4283 if (PerlProc_getgid() != PerlProc_getegid())
4284 Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4285 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4287 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4291 Perl_init_dbargs(pTHX)
4293 AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4298 /* Someone has already created it.
4299 It might have entries, and if we just turn off AvREAL(), they will
4300 "leak" until global destruction. */
4302 if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4303 Perl_croak(aTHX_ "Cannot set tied @DB::args");
4305 AvREIFY_only(PL_dbargs);
4309 Perl_init_debugger(pTHX)
4311 HV * const ostash = PL_curstash;
4314 PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4316 Perl_init_dbargs(aTHX);
4317 PL_DBgv = MUTABLE_GV(
4318 SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4320 PL_DBline = MUTABLE_GV(
4321 SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4323 PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4324 gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4326 PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4327 if (!SvIOK(PL_DBsingle))
4328 sv_setiv(PL_DBsingle, 0);
4329 mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4330 mg->mg_private = DBVARMG_SINGLE;
4331 SvSETMAGIC(PL_DBsingle);
4333 PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4334 if (!SvIOK(PL_DBtrace))
4335 sv_setiv(PL_DBtrace, 0);
4336 mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4337 mg->mg_private = DBVARMG_TRACE;
4338 SvSETMAGIC(PL_DBtrace);
4340 PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4341 if (!SvIOK(PL_DBsignal))
4342 sv_setiv(PL_DBsignal, 0);
4343 mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4344 mg->mg_private = DBVARMG_SIGNAL;
4345 SvSETMAGIC(PL_DBsignal);
4347 SvREFCNT_dec(PL_curstash);
4348 PL_curstash = ostash;
4351 #ifndef STRESS_REALLOC
4352 #define REASONABLE(size) (size)
4353 #define REASONABLE_but_at_least(size,min) (size)
4355 #define REASONABLE(size) (1) /* unreasonable */
4356 #define REASONABLE_but_at_least(size,min) (min)
4360 Perl_init_stacks(pTHX)
4364 /* start with 128-item stack and 8K cxstack */
4365 PL_curstackinfo = new_stackinfo(REASONABLE(128),
4366 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4367 PL_curstackinfo->si_type = PERLSI_MAIN;
4368 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
4369 PL_curstackinfo->si_stack_hwm = 0;
4371 PL_curstack = PL_curstackinfo->si_stack;
4372 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
4374 PL_stack_base = AvARRAY(PL_curstack);
4375 PL_stack_sp = PL_stack_base;
4376 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4378 Newxz(PL_tmps_stack,REASONABLE(128),SV*);
4381 PL_tmps_max = REASONABLE(128);
4383 Newxz(PL_markstack,REASONABLE(32),I32);
4384 PL_markstack_ptr = PL_markstack;
4385 PL_markstack_max = PL_markstack + REASONABLE(32);
4389 Newxz(PL_scopestack,REASONABLE(32),I32);
4391 Newxz(PL_scopestack_name,REASONABLE(32),const char*);
4393 PL_scopestack_ix = 0;
4394 PL_scopestack_max = REASONABLE(32);
4396 size = REASONABLE_but_at_least(128,SS_MAXPUSH);
4397 Newxz(PL_savestack, size, ANY);
4398 PL_savestack_ix = 0;
4399 /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */
4400 PL_savestack_max = size - SS_MAXPUSH;
4408 while (PL_curstackinfo->si_next)
4409 PL_curstackinfo = PL_curstackinfo->si_next;
4410 while (PL_curstackinfo) {
4411 PERL_SI *p = PL_curstackinfo->si_prev;
4412 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4413 Safefree(PL_curstackinfo->si_cxstack);
4414 Safefree(PL_curstackinfo);
4415 PL_curstackinfo = p;
4417 Safefree(PL_tmps_stack);
4418 Safefree(PL_markstack);
4419 Safefree(PL_scopestack);
4421 Safefree(PL_scopestack_name);
4423 Safefree(PL_savestack);
4427 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4429 GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4430 AV *const isa = GvAVn(gv);
4433 PERL_ARGS_ASSERT_POPULATE_ISA;
4435 if(AvFILLp(isa) != -1)
4438 /* NOTE: No support for tied ISA */
4440 va_start(args, len);
4442 const char *const parent = va_arg(args, const char*);
4447 parent_len = va_arg(args, size_t);
4449 /* Arguments are supplied with a trailing :: */
4450 assert(parent_len > 2);
4451 assert(parent[parent_len - 1] == ':');
4452 assert(parent[parent_len - 2] == ':');
4453 av_push(isa, newSVpvn(parent, parent_len - 2));
4454 (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4461 S_init_predump_symbols(pTHX)
4466 sv_setpvs(get_sv("\"", GV_ADD), " ");
4467 PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4470 /* Historically, PVIOs were blessed into IO::Handle, unless
4471 FileHandle was loaded, in which case they were blessed into
4472 that. Action at a distance.
4473 However, if we simply bless into IO::Handle, we break code
4474 that assumes that PVIOs will have (among others) a seek
4475 method. IO::File inherits from IO::Handle and IO::Seekable,
4476 and provides the needed methods. But if we simply bless into
4477 it, then we break code that assumed that by loading
4478 IO::Handle, *it* would work.
4479 So a compromise is to set up the correct @IO::File::ISA,
4480 so that code that does C<use IO::Handle>; will still work.
4483 Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4484 STR_WITH_LEN("IO::Handle::"),
4485 STR_WITH_LEN("IO::Seekable::"),
4486 STR_WITH_LEN("Exporter::"),
4489 PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4490 GvMULTI_on(PL_stdingv);
4491 io = GvIOp(PL_stdingv);
4492 IoTYPE(io) = IoTYPE_RDONLY;
4493 IoIFP(io) = PerlIO_stdin();
4494 tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4496 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4498 tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4501 IoTYPE(io) = IoTYPE_WRONLY;
4502 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4504 tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4506 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4508 PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4509 GvMULTI_on(PL_stderrgv);
4510 io = GvIOp(PL_stderrgv);
4511 IoTYPE(io) = IoTYPE_WRONLY;
4512 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4513 tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4515 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4517 PL_statname = newSVpvs(""); /* last filename we did stat on */
4521 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4523 PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4525 argc--,argv++; /* skip name of script */
4526 if (PL_doswitches) {
4527 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4531 if (argv[0][1] == '-' && !argv[0][2]) {
4535 if ((s = strchr(argv[0], '='))) {
4536 const char *const start_name = argv[0] + 1;
4537 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4538 TRUE, SVt_PV)), s + 1);
4541 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4544 if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4545 SvREFCNT_inc_simple_void_NN(PL_argvgv);
4546 GvMULTI_on(PL_argvgv);
4547 av_clear(GvAVn(PL_argvgv));
4548 for (; argc > 0; argc--,argv++) {
4549 SV * const sv = newSVpv(argv[0],0);
4550 av_push(GvAV(PL_argvgv),sv);
4551 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4552 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4555 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4556 (void)sv_utf8_decode(sv);
4560 if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4561 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4562 "-i used with no filenames on the command line, "
4563 "reading from STDIN");
4567 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4571 PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4573 PL_toptarget = newSV_type(SVt_PVIV);
4574 SvPVCLEAR(PL_toptarget);
4575 PL_bodytarget = newSV_type(SVt_PVIV);
4576 SvPVCLEAR(PL_bodytarget);
4577 PL_formtarget = PL_bodytarget;
4581 init_argv_symbols(argc,argv);
4583 if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4584 sv_setpv(GvSV(tmpgv),PL_origfilename);
4586 if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4588 bool env_is_not_environ;
4589 SvREFCNT_inc_simple_void_NN(PL_envgv);
4590 GvMULTI_on(PL_envgv);
4591 hv = GvHVn(PL_envgv);
4592 hv_magic(hv, NULL, PERL_MAGIC_env);
4594 #if defined(USE_ENVIRON_ARRAY) || defined(WIN32)
4595 /* Note that if the supplied env parameter is actually a copy
4596 of the global environ then it may now point to free'd memory
4597 if the environment has been modified since. To avoid this
4598 problem we treat env==NULL as meaning 'use the default'
4602 env_is_not_environ = env != environ;
4603 if (env_is_not_environ
4604 # ifdef USE_ITHREADS
4605 && PL_curinterp == aTHX
4613 char **env_copy = env;
4620 count = env_copy - env;
4622 if (count > PERL_HASH_DEFAULT_HvMAX) {
4623 /* This might be an over-estimate (due to dups and other skips),
4624 * but if so, likely it won't hurt much.
4625 * A straw poll of login environments I have suggests that
4626 * between 23 and 52 environment variables are typical (and no
4627 * dups). As the default hash size is 8 buckets, expanding in
4628 * advance saves between 2 and 3 splits in the loop below. */
4629 hv_ksplit(hv, count);
4633 for (; *env; env++) {
4634 char *old_var = *env;
4635 char *s = strchr(old_var, '=');
4639 if (!s || s == old_var)
4644 /* It's tempting to think that this hv_exists/hv_store pair should
4645 * be replaced with a single hv_fetch with the LVALUE flag true.
4646 * However, hv has magic, and if you follow the code in hv_common
4647 * then for LVALUE fetch it recurses once, whereas exists and
4648 * store do not recurse. Hence internally there would be no
4649 * difference in the complexity of the code run. Moreover, all
4650 * calls pass through "is there magic?" special case code, which
4651 * in turn has its own #ifdef ENV_IS_CASELESS special case special
4652 * case. Hence this code shouldn't change, as doing so won't give
4653 * any meaningful speedup, and might well add bugs. */
4655 if (hv_exists(hv, old_var, nlen)) {
4657 const char *name = savepvn(old_var, nlen);
4659 /* make sure we use the same value as getenv(), otherwise code that
4660 uses getenv() (like setlocale()) might see a different value to %ENV
4662 sv = newSVpv(PerlEnv_getenv(name), 0);
4664 /* keep a count of the dups of this name so we can de-dup environ later */
4665 dup = hv_fetch(dups, name, nlen, TRUE);
4673 sv = newSVpv(s+1, 0);
4675 (void)hv_store(hv, old_var, nlen, sv, 0);
4676 if (env_is_not_environ)
4679 if (HvTOTALKEYS(dups)) {
4680 /* environ has some duplicate definitions, remove them */
4683 while ((entry = hv_iternext_flags(dups, 0))) {
4685 const char *name = HePV(entry, nlen);
4686 IV count = SvIV(HeVAL(entry));
4688 SV **valp = hv_fetch(hv, name, nlen, 0);
4692 /* try to remove any duplicate names, depending on the
4693 * implementation used in my_setenv() the iteration might
4694 * not be necessary, but let's be safe.
4696 for (i = 0; i < count; ++i)
4699 /* and set it back to the value we set $ENV{name} to */
4700 my_setenv(name, SvPV_nolen(*valp));
4703 SvREFCNT_dec_NN(dups);
4705 #endif /* USE_ENVIRON_ARRAY */
4706 #endif /* !PERL_MICRO */
4710 /* touch @F array to prevent spurious warnings 20020415 MJD */
4712 (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4717 S_init_perllib(pTHX)
4720 const char *perl5lib = NULL;
4723 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4727 if (!TAINTING_get) {
4729 perl5lib = PerlEnv_getenv("PERL5LIB");
4730 if (perl5lib && *perl5lib != '\0')
4731 incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4733 s = PerlEnv_getenv("PERLLIB");
4735 incpush_use_sep(s, 0, 0);
4738 /* Treat PERL5?LIB as a possible search list logical name -- the
4739 * "natural" VMS idiom for a Unix path string. We allow each
4740 * element to be a set of |-separated directories for compatibility.
4744 if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4746 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4747 } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4749 while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
4750 incpush_use_sep(buf, 0, 0);
4755 #ifndef PERL_IS_MINIPERL
4756 /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4757 (and not the architecture specific directories from $ENV{PERL5LIB}) */
4759 #include "perl_inc_macro.h"
4760 /* Use the ~-expanded versions of APPLLIB (undocumented),
4761 SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4764 INCPUSH_SITEARCH_EXP
4766 INCPUSH_PERL_VENDORARCH_EXP
4767 INCPUSH_PERL_VENDORLIB_EXP
4770 INCPUSH_PERL_OTHERLIBDIRS
4772 INCPUSH_APPLLIB_OLD_EXP
4773 INCPUSH_SITELIB_STEM
4774 INCPUSH_PERL_VENDORLIB_STEM
4775 INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY
4777 #endif /* !PERL_IS_MINIPERL */
4779 if (!TAINTING_get) {
4780 #if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT)
4781 const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC");
4782 if (unsafe && strEQ(unsafe, "1"))
4784 S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4789 # define PERLLIB_SEP ';'
4790 #elif defined(__VMS)
4791 # define PERLLIB_SEP PL_perllib_sep
4793 # define PERLLIB_SEP ':'
4795 #ifndef PERLLIB_MANGLE
4796 # define PERLLIB_MANGLE(s,n) (s)
4799 #ifndef PERL_IS_MINIPERL
4800 /* Push a directory onto @INC if it exists.
4801 Generate a new SV if we do this, to save needing to copy the SV we push
4804 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4808 PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4810 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4811 S_ISDIR(tmpstatbuf.st_mode)) {
4813 dir = newSVsv(stem);
4815 /* Truncate dir back to stem. */
4816 SvCUR_set(dir, SvCUR(stem));
4823 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4825 const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4828 PERL_ARGS_ASSERT_MAYBERELOCATE;
4831 /* I am not convinced that this is valid when PERLLIB_MANGLE is
4832 defined to so something (in os2/os2.c), but the code has been
4833 this way, ignoring any possible changed of length, since
4834 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4836 libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4842 if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4844 while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */
4845 sv_usepvn(libdir,unix,len);
4848 PerlIO_printf(Perl_error_log,
4849 "Failed to unixify @INC element \"%s\"\n",
4850 SvPV_nolen_const(libdir));
4854 /* Do the if() outside the #ifdef to avoid warnings about an unused
4857 #ifdef PERL_RELOCATABLE_INC
4859 * Relocatable include entries are marked with a leading .../
4862 * 0: Remove that leading ".../"
4863 * 1: Remove trailing executable name (anything after the last '/')
4864 * from the perl path to give a perl prefix
4866 * While the @INC element starts "../" and the prefix ends with a real
4867 * directory (ie not . or ..) chop that real directory off the prefix
4868 * and the leading "../" from the @INC element. ie a logical "../"
4870 * Finally concatenate the prefix and the remainder of the @INC element
4871 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4872 * generates /usr/local/lib/perl5
4874 const char *libpath = SvPVX(libdir);
4875 STRLEN libpath_len = SvCUR(libdir);
4876 if (memBEGINs(libpath, libpath_len, ".../")) {
4878 SV * const caret_X = get_sv("\030", 0);
4879 /* Going to use the SV just as a scratch buffer holding a C
4885 /* $^X is *the* source of taint if tainting is on, hence
4886 SvPOK() won't be true. */
4888 assert(SvPOKp(caret_X));
4889 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4891 /* Firstly take off the leading .../
4892 If all else fail we'll do the paths relative to the current
4894 sv_chop(libdir, libpath + 4);
4895 /* Don't use SvPV as we're intentionally bypassing taining,
4896 mortal copies that the mg_get of tainting creates, and
4897 corruption that seems to come via the save stack.
4898 I guess that the save stack isn't correctly set up yet. */
4899 libpath = SvPVX(libdir);
4900 libpath_len = SvCUR(libdir);
4902 prefix = SvPVX(prefix_sv);
4903 lastslash = (char *) my_memrchr(prefix, '/',
4904 SvEND(prefix_sv) - prefix);
4906 /* First time in with the *lastslash = '\0' we just wipe off
4907 the trailing /perl from (say) /usr/foo/bin/perl
4911 while ((*lastslash = '\0'), /* Do that, come what may. */
4912 ( memBEGINs(libpath, libpath_len, "../")
4914 (char *) my_memrchr(prefix, '/',
4915 SvEND(prefix_sv) - prefix))))
4917 if (lastslash[1] == '\0'
4918 || (lastslash[1] == '.'
4919 && (lastslash[2] == '/' /* ends "/." */
4920 || (lastslash[2] == '/'
4921 && lastslash[3] == '/' /* or "/.." */
4923 /* Prefix ends "/" or "/." or "/..", any of which
4924 are fishy, so don't do any more logical cleanup.
4928 /* Remove leading "../" from path */
4931 /* Next iteration round the loop removes the last
4932 directory name from prefix by writing a '\0' in
4933 the while clause. */
4935 /* prefix has been terminated with a '\0' to the correct
4936 length. libpath points somewhere into the libdir SV.
4937 We need to join the 2 with '/' and drop the result into
4939 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4940 SvREFCNT_dec(libdir);
4941 /* And this is the new libdir. */
4944 (PerlProc_getuid() != PerlProc_geteuid() ||
4945 PerlProc_getgid() != PerlProc_getegid())) {
4946 /* Need to taint relocated paths if running set ID */
4947 SvTAINTED_on(libdir);
4950 SvREFCNT_dec(prefix_sv);
4958 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4960 #ifndef PERL_IS_MINIPERL
4961 const U8 using_sub_dirs
4962 = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4963 |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4964 const U8 add_versioned_sub_dirs
4965 = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4966 const U8 add_archonly_sub_dirs
4967 = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4968 #ifdef PERL_INC_VERSION_LIST
4969 const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
4972 const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
4973 const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4974 AV *const inc = GvAVn(PL_incgv);
4976 PERL_ARGS_ASSERT_INCPUSH;
4979 /* Could remove this vestigial extra block, if we don't mind a lot of
4980 re-indenting diff noise. */
4982 SV *const libdir = mayberelocate(dir, len, flags);
4983 /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4984 arranged to unshift #! line -I onto the front of @INC. However,
4985 -I can add version and architecture specific libraries, and they
4986 need to go first. The old code assumed that it was always
4987 pushing. Hence to make it work, need to push the architecture
4988 (etc) libraries onto a temporary array, then "unshift" that onto
4989 the front of @INC. */
4990 #ifndef PERL_IS_MINIPERL
4991 AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4994 * BEFORE pushing libdir onto @INC we may first push version- and
4995 * archname-specific sub-directories.
4997 if (using_sub_dirs) {
4998 SV *subdir = newSVsv(libdir);
4999 #ifdef PERL_INC_VERSION_LIST
5000 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
5001 const char * const incverlist[] = { PERL_INC_VERSION_LIST };
5002 const char * const *incver;
5005 if (add_versioned_sub_dirs) {
5006 /* .../version/archname if -d .../version/archname */
5007 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
5008 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
5010 /* .../version if -d .../version */
5011 sv_catpvs(subdir, "/" PERL_FS_VERSION);
5012 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
5015 #ifdef PERL_INC_VERSION_LIST
5017 for (incver = incverlist; *incver; incver++) {
5018 /* .../xxx if -d .../xxx */
5019 Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
5020 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
5025 if (add_archonly_sub_dirs) {
5026 /* .../archname if -d .../archname */
5027 sv_catpvs(subdir, "/" ARCHNAME);
5028 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
5032 assert (SvREFCNT(subdir) == 1);
5033 SvREFCNT_dec(subdir);
5035 #endif /* !PERL_IS_MINIPERL */
5036 /* finally add this lib directory at the end of @INC */
5038 #ifdef PERL_IS_MINIPERL
5039 const Size_t extra = 0;
5041 Size_t extra = av_count(av);
5043 av_unshift(inc, extra + push_basedir);
5045 av_store(inc, extra, libdir);
5046 #ifndef PERL_IS_MINIPERL
5048 /* av owns a reference, av_store() expects to be donated a
5049 reference, and av expects to be sane when it's cleared.
5050 If I wanted to be naughty and wrong, I could peek inside the
5051 implementation of av_clear(), realise that it uses
5052 SvREFCNT_dec() too, so av's array could be a run of NULLs,
5053 and so directly steal from it (with a memcpy() to inc, and
5054 then memset() to NULL them out. But people copy code from the
5055 core expecting it to be best practise, so let's use the API.
5056 Although studious readers will note that I'm not checking any
5058 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
5063 else if (push_basedir) {
5064 av_push(inc, libdir);
5067 if (!push_basedir) {
5068 assert (SvREFCNT(libdir) == 1);
5069 SvREFCNT_dec(libdir);
5075 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
5079 /* This logic has been broken out from S_incpush(). It may be possible to
5082 PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
5084 /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
5085 * argument to incpush_use_sep. This allows creation of relocatable
5086 * Perl distributions that patch the binary at install time. Those
5087 * distributions will have to provide their own relocation tools; this
5088 * is not a feature otherwise supported by core Perl.
5090 #ifndef PERL_RELOCATABLE_INCPUSH
5097 /* Break at all separators */
5098 while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
5100 /* skip any consecutive separators */
5102 /* Uncomment the next line for PATH semantics */
5103 /* But you'll need to write tests */
5104 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
5106 incpush(p, (STRLEN)(s - p), flags);
5111 incpush(p, (STRLEN)(end - p), flags);
5116 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
5119 volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
5125 PERL_ARGS_ASSERT_CALL_LIST;
5127 while (av_count(paramList) > 0) {
5128 cv = MUTABLE_CV(av_shift(paramList));
5130 if (paramList == PL_beginav) {
5131 /* save PL_beginav for compiler */
5132 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
5134 else if (paramList == PL_checkav) {
5135 /* save PL_checkav for compiler */
5136 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
5138 else if (paramList == PL_unitcheckav) {
5139 /* save PL_unitcheckav for compiler */
5140 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
5150 (void)SvPV_const(atsv, len);
5152 PL_curcop = &PL_compiling;
5153 CopLINE_set(PL_curcop, oldline);
5154 if (paramList == PL_beginav)
5155 sv_catpvs(atsv, "BEGIN failed--compilation aborted");
5157 Perl_sv_catpvf(aTHX_ atsv,
5158 "%s failed--call queue aborted",
5159 paramList == PL_checkav ? "CHECK"
5160 : paramList == PL_initav ? "INIT"
5161 : paramList == PL_unitcheckav ? "UNITCHECK"
5163 while (PL_scopestack_ix > oldscope)
5166 Perl_croak(aTHX_ "%" SVf, SVfARG(atsv));
5173 /* my_exit() was called */
5174 while (PL_scopestack_ix > oldscope)
5177 SET_CURSTASH(PL_defstash);
5178 PL_curcop = &PL_compiling;
5179 CopLINE_set(PL_curcop, oldline);
5182 NOT_REACHED; /* NOTREACHED */
5185 PL_curcop = &PL_compiling;
5186 CopLINE_set(PL_curcop, oldline);
5189 PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
5200 A wrapper for the C library L<exit(3)>, honoring what L<perlapi/PL_exit_flags>
5207 Perl_my_exit(pTHX_ U32 status)
5209 if (PL_exit_flags & PERL_EXIT_ABORT) {
5212 if (PL_exit_flags & PERL_EXIT_WARN) {
5213 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
5214 Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status);
5215 PL_exit_flags &= ~PERL_EXIT_ABORT;
5225 STATUS_EXIT_SET(status);
5232 =for apidoc my_failure_exit
5234 Exit the running Perl process with an error.
5236 On non-VMS platforms, this is essentially equivalen to L</C<my_exit>>, using
5237 C<errno>, but forces an en error code of 255 if C<errno> is 0.
5239 On VMS, it takes care to set the expected exit error return variables.
5245 Perl_my_failure_exit(pTHX)
5248 /* We have been called to fall on our sword. The desired exit code
5249 * should be already set in STATUS_UNIX, but could be shifted over
5250 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
5253 * If an error code has not been set, then force the issue.
5255 if (MY_POSIX_EXIT) {
5257 /* According to the die_exit.t tests, if errno is non-zero */
5258 /* It should be used for the error status. */
5260 if (errno == EVMSERR) {
5261 STATUS_NATIVE = vaxc$errno;
5264 /* According to die_exit.t tests, if the child_exit code is */
5265 /* also zero, then we need to exit with a code of 255 */
5266 if ((errno != 0) && (errno < 256))
5267 STATUS_UNIX_EXIT_SET(errno);
5268 else if (STATUS_UNIX < 255) {
5269 STATUS_UNIX_EXIT_SET(255);
5274 /* The exit code could have been set by $? or vmsish which
5275 * means that it may not have fatal set. So convert
5276 * success/warning codes to fatal with out changing
5277 * the POSIX status code. The severity makes VMS native
5278 * status handling work, while UNIX mode programs use the
5281 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
5282 STATUS_NATIVE &= STS$M_COND_ID;
5283 STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
5287 /* Traditionally Perl on VMS always expects a Fatal Error. */
5288 if (vaxc$errno & 1) {
5290 /* So force success status to failure */
5291 if (STATUS_NATIVE & 1)
5296 STATUS_UNIX = EINTR; /* In case something cares */
5301 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5303 /* Encode the severity code */
5304 severity = STATUS_NATIVE & STS$M_SEVERITY;
5305 STATUS_UNIX = (severity ? severity : 1) << 8;
5307 /* Perl expects this to be a fatal error */
5308 if (severity != STS$K_SEVERE)
5318 STATUS_UNIX_SET(eno);
5320 exitstatus = STATUS_UNIX >> 8;
5321 if (exitstatus & 255)
5322 STATUS_UNIX_SET(exitstatus);
5324 STATUS_UNIX_SET(255);
5327 if (PL_exit_flags & PERL_EXIT_ABORT) {
5330 if (PL_exit_flags & PERL_EXIT_WARN) {
5331 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
5332 Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue);
5333 PL_exit_flags &= ~PERL_EXIT_ABORT;
5339 S_my_exit_jump(pTHX)
5342 SvREFCNT_dec(PL_e_script);
5346 POPSTACK_TO(PL_mainstack);
5347 if (cxstack_ix >= 0) {
5349 cx_popblock(cxstack);
5357 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5359 const char * const p = SvPVX_const(PL_e_script);
5360 const char * const e = SvEND(PL_e_script);
5361 const char *nl = (char *) memchr(p, '\n', e - p);
5363 PERL_UNUSED_ARG(idx);
5364 PERL_UNUSED_ARG(maxlen);
5366 nl = (nl) ? nl+1 : e;
5368 filter_del(read_e_script);
5371 sv_catpvn(buf_sv, p, nl-p);
5372 sv_chop(PL_e_script, nl);
5376 /* removes boilerplate code at the end of each boot_Module xsub */
5378 Perl_xs_boot_epilog(pTHX_ const I32 ax)
5381 call_list(PL_scopestack_ix, PL_unitcheckav);
5386 * ex: set ts=8 sts=4 sw=4 et: