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 by Larry Wall and others
8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
14 * A ship then new they built for him
15 * of mithril and of elven-glass
16 * --from Bilbo's song of EƤrendil
18 * [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
21 /* This file contains the top-level functions that are used to create, use
22 * and destroy a perl interpreter, plus the functions used by XS code to
23 * call back into perl. Note that it does not contain the actual main()
24 * function of the interpreter; that can be found in perlmain.c
26 * Note that at build time this file is also linked to as perlmini.c,
27 * and perlmini.o is then built with PERL_IS_MINIPERL defined, which is
28 * then used to create the miniperl executable, rather than perl.o.
31 #if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
32 # define USE_SITECUSTOMIZE
36 #define PERL_IN_PERL_C
38 #include "patchlevel.h" /* for local_patches */
45 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
52 char control[CMSG_SPACE(sizeof(int))];
65 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
66 char *getenv (char *); /* Usually in <stdlib.h> */
69 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
71 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
72 # define validate_suid(rsfp) NOOP
74 # define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
77 #define CALL_BODY_SUB(myop) \
78 if (PL_op == (myop)) \
79 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
83 #define CALL_LIST_BODY(cv) \
84 PUSHMARK(PL_stack_sp); \
85 call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
88 S_init_tls_and_interp(PerlInterpreter *my_perl)
92 PERL_SET_INTERP(my_perl);
93 #if defined(USE_ITHREADS)
96 PERL_SET_THX(my_perl);
101 MUTEX_INIT(&PL_dollarzero_mutex);
102 MUTEX_INIT(&PL_my_ctx_mutex);
105 #if defined(USE_ITHREADS)
108 /* This always happens for non-ithreads */
111 PERL_SET_THX(my_perl);
116 /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
119 Perl_sys_init(int* argc, char*** argv)
123 PERL_ARGS_ASSERT_SYS_INIT;
125 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
126 PERL_UNUSED_ARG(argv);
127 PERL_SYS_INIT_BODY(argc, argv);
131 Perl_sys_init3(int* argc, char*** argv, char*** env)
135 PERL_ARGS_ASSERT_SYS_INIT3;
137 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
138 PERL_UNUSED_ARG(argv);
139 PERL_UNUSED_ARG(env);
140 PERL_SYS_INIT3_BODY(argc, argv, env);
147 if (!PL_veto_cleanup) {
148 PERL_SYS_TERM_BODY();
153 #ifdef PERL_IMPLICIT_SYS
155 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
156 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
157 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
158 struct IPerlDir* ipD, struct IPerlSock* ipS,
159 struct IPerlProc* ipP)
161 PerlInterpreter *my_perl;
163 PERL_ARGS_ASSERT_PERL_ALLOC_USING;
165 /* Newx() needs interpreter, so call malloc() instead */
166 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
167 S_init_tls_and_interp(my_perl);
168 Zero(my_perl, 1, PerlInterpreter);
178 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
185 =head1 Embedding Functions
187 =for apidoc perl_alloc
189 Allocates a new Perl interpreter. See L<perlembed>.
197 PerlInterpreter *my_perl;
199 /* Newx() needs interpreter, so call malloc() instead */
200 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
202 S_init_tls_and_interp(my_perl);
203 #ifndef PERL_TRACK_MEMPOOL
204 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
206 Zero(my_perl, 1, PerlInterpreter);
207 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
211 #endif /* PERL_IMPLICIT_SYS */
214 =for apidoc perl_construct
216 Initializes a new Perl interpreter. See L<perlembed>.
222 S_fixup_platform_bugs(void)
224 #if defined(__GLIBC__) && IVSIZE == 8 \
225 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
229 /* Cannot do this check with inlined IV constants since
230 * that seems to work correctly even with the buggy glibc. */
233 /* Yikes, we have the bug.
234 * Patch in the workaround version. */
235 PL_ppaddr[OP_I_MODULO] = &Perl_pp_i_modulo_glibc_bugfix;
242 perl_construct(pTHXx)
246 PERL_ARGS_ASSERT_PERL_CONSTRUCT;
250 PL_perl_destruct_level = 1;
252 PERL_UNUSED_ARG(my_perl);
253 if (PL_perl_destruct_level > 0)
256 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
258 #ifdef PERL_TRACE_OPS
259 Zero(PL_op_exec_cnt, OP_max+2, UV);
264 SvREADONLY_on(&PL_sv_placeholder);
265 SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
267 PL_sighandlerp = (Sighandler_t) Perl_sighandler;
268 #ifdef PERL_USES_PL_PIDSTATUS
269 PL_pidstatus = newHV();
272 PL_rs = newSVpvs("\n");
276 /* The PERL_INTERNAL_RAND_SEED set-up must be after init_stacks because it calls
277 * things that may put SVs on the stack.
280 #ifdef NO_PERL_INTERNAL_RAND_SEED
281 Perl_drand48_init_r(&PL_internal_random_state, seed());
286 if (PerlProc_getuid() != PerlProc_geteuid() ||
287 PerlProc_getgid() != PerlProc_getegid() ||
288 !(env_pv = PerlEnv_getenv("PERL_INTERNAL_RAND_SEED")) ||
289 grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV) {
292 Perl_drand48_init_r(&PL_internal_random_state, (U32)seed);
298 S_fixup_platform_bugs();
305 #if defined(LOCAL_PATCH_COUNT)
306 PL_localpatches = local_patches; /* For possible -v */
309 #if defined(LIBM_LIB_VERSION)
311 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
312 * This switches them over to IEEE.
314 _LIB_VERSION = _IEEE_;
317 #ifdef HAVE_INTERP_INTERN
321 PerlIO_init(aTHX); /* Hook to IO system */
323 PL_fdpid = newAV(); /* for remembering popen pids by fd */
324 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
325 PL_errors = newSVpvs("");
326 SvPVCLEAR(PERL_DEBUG_PAD(0)); /* For regex debugging. */
327 SvPVCLEAR(PERL_DEBUG_PAD(1)); /* ext/re needs these */
328 SvPVCLEAR(PERL_DEBUG_PAD(2)); /* even without DEBUGGING. */
330 /* First entry is a list of empty elements. It needs to be initialised
331 else all hell breaks loose in S_find_uninit_var(). */
332 Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
333 PL_regex_pad = AvARRAY(PL_regex_padav);
334 Newxz(PL_stashpad, PL_stashpadmax, HV *);
336 #ifdef USE_REENTRANT_API
337 Perl_reentrant_init(aTHX);
339 if (PL_hash_seed_set == FALSE) {
340 /* Initialize the hash seed and state at startup. This must be
341 * done very early, before ANY hashes are constructed, and once
342 * setup is fixed for the lifetime of the process.
344 * If you decide to disable the seeding process you should choose
345 * a suitable seed yourself and define PERL_HASH_SEED to a well chosen
346 * string. See hv_func.h for details.
348 #if defined(USE_HASH_SEED)
349 /* get the hash seed from the environment or from an RNG */
350 Perl_get_hash_seed(aTHX_ PL_hash_seed);
352 /* they want a hard coded seed, check that it is long enough */
353 assert( strlen(PERL_HASH_SEED) >= PERL_HASH_SEED_BYTES );
356 /* now we use the chosen seed to initialize the state -
357 * in some configurations this may be a relatively speaking
358 * expensive operation, but we only have to do it once at startup */
359 PERL_HASH_SEED_STATE(PERL_HASH_SEED,PL_hash_state);
361 #ifdef PERL_USE_SINGLE_CHAR_HASH_CACHE
362 /* we can build a special cache for 0/1 byte keys, if people choose
363 * I suspect most of the time it is not worth it */
367 for (i=0;i<256;i++) {
369 PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[i],str,1);
371 PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[256],str,0);
374 /* at this point we have initialezed the hash function, and we can start
375 * constructing hashes */
376 PL_hash_seed_set= TRUE;
378 /* Note that strtab is a rather special HV. Assumptions are made
379 about not iterating on it, and not adding tie magic to it.
380 It is properly deallocated in perl_destruct() */
383 /* SHAREKEYS tells us that the hash has its keys shared with PL_strtab,
384 * which is not the case with PL_strtab itself */
385 HvSHAREKEYS_off(PL_strtab); /* mandatory */
386 hv_ksplit(PL_strtab, 1 << 11);
388 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
391 # ifdef USE_ENVIRON_ARRAY
392 PL_origenviron = environ;
396 /* Use sysconf(_SC_CLK_TCK) if available, if not
397 * available or if the sysconf() fails, use the HZ.
398 * The HZ if not originally defined has been by now
399 * been defined as CLK_TCK, if available. */
400 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
401 PL_clocktick = sysconf(_SC_CLK_TCK);
402 if (PL_clocktick <= 0)
406 PL_stashcache = newHV();
408 PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
411 if (!PL_mmap_page_size) {
412 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
414 SETERRNO(0, SS_NORMAL);
416 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
418 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
420 if ((long) PL_mmap_page_size < 0) {
422 SV * const error = ERRSV;
423 SvUPGRADE(error, SVt_PV);
424 Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
427 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
431 # ifdef HAS_GETPAGESIZE
432 PL_mmap_page_size = getpagesize();
434 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
435 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
439 if (PL_mmap_page_size <= 0)
440 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
441 (IV) PL_mmap_page_size);
443 #endif /* HAS_MMAP */
445 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
446 PL_timesbase.tms_utime = 0;
447 PL_timesbase.tms_stime = 0;
448 PL_timesbase.tms_cutime = 0;
449 PL_timesbase.tms_cstime = 0;
452 PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
454 PL_registered_mros = newHV();
455 /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
456 HvMAX(PL_registered_mros) = 0;
458 PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist);
459 PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(XPosixAlnum_invlist);
460 PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(XPosixAlpha_invlist);
461 PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist);
462 PL_XPosix_ptrs[_CC_CASED] = _new_invlist_C_array(Cased_invlist);
463 PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist);
464 PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(XPosixDigit_invlist);
465 PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(XPosixGraph_invlist);
466 PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(XPosixLower_invlist);
467 PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(XPosixPrint_invlist);
468 PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(XPosixPunct_invlist);
469 PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist);
470 PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(XPosixUpper_invlist);
471 PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist);
472 PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist);
473 PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist);
474 PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist);
475 PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist);
476 PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist);
477 PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist);
478 PL_Assigned_invlist = _new_invlist_C_array(Assigned_invlist);
479 #ifdef HAS_POSIX_2008_LOCALE
480 PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL);
487 =for apidoc nothreadhook
489 Stub that provides thread hook for perl_destruct when there are
496 Perl_nothreadhook(pTHX)
502 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
504 Perl_dump_sv_child(pTHX_ SV *sv)
507 const int sock = PL_dumper_fd;
508 const int debug_fd = PerlIO_fileno(Perl_debug_log);
509 union control_un control;
512 struct cmsghdr *cmptr;
514 unsigned char buffer[256];
516 PERL_ARGS_ASSERT_DUMP_SV_CHILD;
518 if(sock == -1 || debug_fd == -1)
521 PerlIO_flush(Perl_debug_log);
523 /* All these shenanigans are to pass a file descriptor over to our child for
524 it to dump out to. We can't let it hold open the file descriptor when it
525 forks, as the file descriptor it will dump to can turn out to be one end
526 of pipe that some other process will wait on for EOF. (So as it would
527 be open, the wait would be forever.) */
529 msg.msg_control = control.control;
530 msg.msg_controllen = sizeof(control.control);
531 /* We're a connected socket so we don't need a destination */
537 cmptr = CMSG_FIRSTHDR(&msg);
538 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
539 cmptr->cmsg_level = SOL_SOCKET;
540 cmptr->cmsg_type = SCM_RIGHTS;
541 *((int *)CMSG_DATA(cmptr)) = 1;
543 vec[0].iov_base = (void*)&sv;
544 vec[0].iov_len = sizeof(sv);
545 got = sendmsg(sock, &msg, 0);
548 perror("Debug leaking scalars parent sendmsg failed");
551 if(got < sizeof(sv)) {
552 perror("Debug leaking scalars parent short sendmsg");
556 /* Return protocol is
558 unsigned char: length of location string (0 for empty)
559 unsigned char*: string (not terminated)
561 vec[0].iov_base = (void*)&returned_errno;
562 vec[0].iov_len = sizeof(returned_errno);
563 vec[1].iov_base = buffer;
566 got = readv(sock, vec, 2);
569 perror("Debug leaking scalars parent read failed");
570 PerlIO_flush(PerlIO_stderr());
573 if(got < sizeof(returned_errno) + 1) {
574 perror("Debug leaking scalars parent short read");
575 PerlIO_flush(PerlIO_stderr());
580 got = read(sock, buffer + 1, *buffer);
582 perror("Debug leaking scalars parent read 2 failed");
583 PerlIO_flush(PerlIO_stderr());
588 perror("Debug leaking scalars parent short read 2");
589 PerlIO_flush(PerlIO_stderr());
594 if (returned_errno || *buffer) {
595 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
596 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
597 returned_errno, Strerror(returned_errno));
603 =for apidoc perl_destruct
605 Shuts down a Perl interpreter. See L<perlembed>.
614 VOL signed char destruct_level; /* see possible values in intrpvar.h */
616 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
621 PERL_ARGS_ASSERT_PERL_DESTRUCT;
623 PERL_UNUSED_ARG(my_perl);
626 assert(PL_scopestack_ix == 1);
628 /* wait for all pseudo-forked children to finish */
629 PERL_WAIT_FOR_CHILDREN;
631 destruct_level = PL_perl_destruct_level;
632 #if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL)
634 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
637 if (strEQ(s, "-1")) { /* Special case: modperl folklore. */
641 if (grok_atoUV(s, &uv, NULL) && uv <= INT_MAX)
647 if (destruct_level < i) destruct_level = i;
649 #ifdef PERL_TRACK_MEMPOOL
650 /* RT #114496, for perl_free */
651 PL_perl_destruct_level = i;
657 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
663 if (PL_endav && !PL_minus_c) {
664 PERL_SET_PHASE(PERL_PHASE_END);
665 call_list(PL_scopestack_ix, PL_endav);
671 assert(PL_scopestack_ix == 0);
673 /* Need to flush since END blocks can produce output */
674 /* flush stdout separately, since we can identify it */
677 PerlIO *stdo = PerlIO_stdout();
678 if (*stdo && PerlIO_flush(stdo)) {
679 PerlIO_restore_errno(stdo);
681 PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s",
690 #ifdef PERL_TRACE_OPS
691 /* dump OP-counts if $ENV{PERL_TRACE_OPS} > 0 */
693 const char * const ptoenv = PerlEnv_getenv("PERL_TRACE_OPS");
696 if (!ptoenv || !Perl_grok_atoUV(ptoenv, &uv, NULL)
700 PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
701 for (i = 0; i <= OP_max; ++i) {
702 if (PL_op_exec_cnt[i])
703 PerlIO_printf(Perl_debug_log, " %s: %" UVuf "\n", PL_op_name[i], PL_op_exec_cnt[i]);
705 /* Utility slot for easily doing little tracing experiments in the runloop: */
706 if (PL_op_exec_cnt[OP_max+1] != 0)
707 PerlIO_printf(Perl_debug_log, " SPECIAL: %" UVuf "\n", PL_op_exec_cnt[OP_max+1]);
708 PerlIO_printf(Perl_debug_log, "\n");
713 if (PL_threadhook(aTHX)) {
714 /* Threads hook has vetoed further cleanup */
715 PL_veto_cleanup = TRUE;
719 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
720 if (destruct_level != 0) {
721 /* Fork here to create a child. Our child's job is to preserve the
722 state of scalars prior to destruction, so that we can instruct it
723 to dump any scalars that we later find have leaked.
724 There's no subtlety in this code - it assumes POSIX, and it doesn't
728 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
729 perror("Debug leaking scalars socketpair failed");
735 perror("Debug leaking scalars fork failed");
739 /* We are the child */
740 const int sock = fd[1];
741 const int debug_fd = PerlIO_fileno(Perl_debug_log);
744 /* Our success message is an integer 0, and a char 0 */
745 static const char success[sizeof(int) + 1] = {0};
749 /* We need to close all other file descriptors otherwise we end up
750 with interesting hangs, where the parent closes its end of a
751 pipe, and sits waiting for (another) child to terminate. Only
752 that child never terminates, because it never gets EOF, because
753 we also have the far end of the pipe open. We even need to
754 close the debugging fd, because sometimes it happens to be one
755 end of a pipe, and a process is waiting on the other end for
756 EOF. Normally it would be closed at some point earlier in
757 destruction, but if we happen to cause the pipe to remain open,
758 EOF never occurs, and we get an infinite hang. Hence all the
759 games to pass in a file descriptor if it's actually needed. */
761 f = sysconf(_SC_OPEN_MAX);
763 where = "sysconf failed";
774 union control_un control;
777 struct cmsghdr *cmptr;
781 msg.msg_control = control.control;
782 msg.msg_controllen = sizeof(control.control);
783 /* We're a connected socket so we don't need a source */
787 msg.msg_iovlen = C_ARRAY_LENGTH(vec);
789 vec[0].iov_base = (void*)⌖
790 vec[0].iov_len = sizeof(target);
792 got = recvmsg(sock, &msg, 0);
797 where = "recv failed";
800 if(got < sizeof(target)) {
801 where = "short recv";
805 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
809 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
810 where = "wrong cmsg_len";
813 if(cmptr->cmsg_level != SOL_SOCKET) {
814 where = "wrong cmsg_level";
817 if(cmptr->cmsg_type != SCM_RIGHTS) {
818 where = "wrong cmsg_type";
822 got_fd = *(int*)CMSG_DATA(cmptr);
823 /* For our last little bit of trickery, put the file descriptor
824 back into Perl_debug_log, as if we never actually closed it
826 if(got_fd != debug_fd) {
827 if (dup2(got_fd, debug_fd) == -1) {
834 PerlIO_flush(Perl_debug_log);
836 got = write(sock, &success, sizeof(success));
839 where = "write failed";
842 if(got < sizeof(success)) {
843 where = "short write";
850 int send_errno = errno;
851 unsigned char length = (unsigned char) strlen(where);
852 struct iovec failure[3] = {
853 {(void*)&send_errno, sizeof(send_errno)},
855 {(void*)where, length}
857 int got = writev(sock, failure, 3);
858 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
859 in the parent if we try to read from the socketpair after the
860 child has exited, even if there was data to read.
861 So sleep a bit to give the parent a fighting chance of
864 _exit((got == -1) ? errno : 0);
868 PL_dumper_fd = fd[0];
873 /* We must account for everything. */
875 /* Destroy the main CV and syntax tree */
876 /* Set PL_curcop now, because destroying ops can cause new SVs
877 to be generated in Perl_pad_swipe, and when running with
878 -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
879 op from which the filename structure member is copied. */
880 PL_curcop = &PL_compiling;
882 /* ensure comppad/curpad to refer to main's pad */
883 if (CvPADLIST(PL_main_cv)) {
884 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
885 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
887 op_free(PL_main_root);
890 PL_main_start = NULL;
891 /* note that PL_main_cv isn't usually actually freed at this point,
892 * due to the CvOUTSIDE refs from subs compiled within it. It will
893 * get freed once all the subs are freed in sv_clean_all(), for
894 * destruct_level > 0 */
895 SvREFCNT_dec(PL_main_cv);
897 PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
899 /* Tell PerlIO we are about to tear things apart in case
900 we have layers which are using resources that should
904 PerlIO_destruct(aTHX);
907 * Try to destruct global references. We do this first so that the
908 * destructors and destructees still exist. Some sv's might remain.
909 * Non-referenced objects are on their own.
913 /* unhook hooks which will soon be, or use, destroyed data */
914 SvREFCNT_dec(PL_warnhook);
916 SvREFCNT_dec(PL_diehook);
919 /* call exit list functions */
920 while (PL_exitlistlen-- > 0)
921 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
923 Safefree(PL_exitlist);
928 SvREFCNT_dec(PL_registered_mros);
930 /* jettison our possibly duplicated environment */
931 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
932 * so we certainly shouldn't free it here
935 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
936 if (environ != PL_origenviron && !PL_use_safe_putenv
938 /* only main thread can free environ[0] contents */
939 && PL_curinterp == aTHX
945 for (i = 0; environ[i]; i++)
946 safesysfree(environ[i]);
948 /* Must use safesysfree() when working with environ. */
949 safesysfree(environ);
951 environ = PL_origenviron;
954 #endif /* !PERL_MICRO */
956 if (destruct_level == 0) {
958 DEBUG_P(debprofdump());
960 #if defined(PERLIO_LAYERS)
961 /* No more IO - including error messages ! */
962 PerlIO_cleanup(aTHX);
965 CopFILE_free(&PL_compiling);
967 /* The exit() function will do everything that needs doing. */
971 /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */
974 /* the syntax tree is shared between clones
975 * so op_free(PL_main_root) only ReREFCNT_dec's
976 * REGEXPs in the parent interpreter
977 * we need to manually ReREFCNT_dec for the clones
980 I32 i = AvFILLp(PL_regex_padav);
981 SV **ary = AvARRAY(PL_regex_padav);
984 SvREFCNT_dec(ary[i]);
985 ary[i] = &PL_sv_undef;
991 SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
992 PL_stashcache = NULL;
994 /* loosen bonds of global variables */
996 /* XXX can PL_parser still be non-null here? */
997 if(PL_parser && PL_parser->rsfp) {
998 (void)PerlIO_close(PL_parser->rsfp);
999 PL_parser->rsfp = NULL;
1003 Safefree(PL_splitstr);
1013 PL_doswitches = FALSE;
1014 PL_dowarn = G_WARN_OFF;
1015 #ifdef PERL_SAWAMPERSAND
1016 PL_sawampersand = 0; /* must save all match strings */
1020 Safefree(PL_inplace);
1022 SvREFCNT_dec(PL_patchlevel);
1025 SvREFCNT_dec(PL_e_script);
1031 /* magical thingies */
1033 SvREFCNT_dec(PL_ofsgv); /* *, */
1036 SvREFCNT_dec(PL_ors_sv); /* $\ */
1039 SvREFCNT_dec(PL_rs); /* $/ */
1042 Safefree(PL_osname); /* $^O */
1045 SvREFCNT_dec(PL_statname);
1049 /* defgv, aka *_ should be taken care of elsewhere */
1052 Safefree(PL_efloatbuf);
1053 PL_efloatbuf = NULL;
1056 /* startup and shutdown function lists */
1057 SvREFCNT_dec(PL_beginav);
1058 SvREFCNT_dec(PL_beginav_save);
1059 SvREFCNT_dec(PL_endav);
1060 SvREFCNT_dec(PL_checkav);
1061 SvREFCNT_dec(PL_checkav_save);
1062 SvREFCNT_dec(PL_unitcheckav);
1063 SvREFCNT_dec(PL_unitcheckav_save);
1064 SvREFCNT_dec(PL_initav);
1066 PL_beginav_save = NULL;
1069 PL_checkav_save = NULL;
1070 PL_unitcheckav = NULL;
1071 PL_unitcheckav_save = NULL;
1074 /* shortcuts just get cleared */
1077 PL_argvoutgv = NULL;
1080 PL_last_in_gv = NULL;
1091 SvREFCNT_dec(PL_envgv);
1092 SvREFCNT_dec(PL_incgv);
1093 SvREFCNT_dec(PL_argvgv);
1094 SvREFCNT_dec(PL_replgv);
1095 SvREFCNT_dec(PL_DBgv);
1096 SvREFCNT_dec(PL_DBline);
1097 SvREFCNT_dec(PL_DBsub);
1106 SvREFCNT_dec(PL_argvout_stack);
1107 PL_argvout_stack = NULL;
1109 SvREFCNT_dec(PL_modglobal);
1110 PL_modglobal = NULL;
1111 SvREFCNT_dec(PL_preambleav);
1112 PL_preambleav = NULL;
1113 SvREFCNT_dec(PL_subname);
1115 #ifdef PERL_USES_PL_PIDSTATUS
1116 SvREFCNT_dec(PL_pidstatus);
1117 PL_pidstatus = NULL;
1119 SvREFCNT_dec(PL_toptarget);
1120 PL_toptarget = NULL;
1121 SvREFCNT_dec(PL_bodytarget);
1122 PL_bodytarget = NULL;
1123 PL_formtarget = NULL;
1125 /* free locale stuff */
1126 #ifdef USE_LOCALE_COLLATE
1127 Safefree(PL_collation_name);
1128 PL_collation_name = NULL;
1131 #ifdef USE_LOCALE_NUMERIC
1132 Safefree(PL_numeric_name);
1133 PL_numeric_name = NULL;
1134 SvREFCNT_dec(PL_numeric_radix_sv);
1135 PL_numeric_radix_sv = NULL;
1138 if (PL_langinfo_buf) {
1139 Safefree(PL_langinfo_buf);
1140 PL_langinfo_buf = NULL;
1143 /* clear character classes */
1144 for (i = 0; i < POSIX_SWASH_COUNT; i++) {
1145 SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
1146 PL_utf8_swash_ptrs[i] = NULL;
1148 SvREFCNT_dec(PL_utf8_mark);
1149 SvREFCNT_dec(PL_utf8_toupper);
1150 SvREFCNT_dec(PL_utf8_totitle);
1151 SvREFCNT_dec(PL_utf8_tolower);
1152 SvREFCNT_dec(PL_utf8_tofold);
1153 SvREFCNT_dec(PL_utf8_idstart);
1154 SvREFCNT_dec(PL_utf8_idcont);
1155 SvREFCNT_dec(PL_utf8_foldable);
1156 SvREFCNT_dec(PL_utf8_foldclosures);
1157 SvREFCNT_dec(PL_AboveLatin1);
1158 SvREFCNT_dec(PL_InBitmap);
1159 SvREFCNT_dec(PL_UpperLatin1);
1160 SvREFCNT_dec(PL_Latin1);
1161 SvREFCNT_dec(PL_NonL1NonFinalFold);
1162 SvREFCNT_dec(PL_HasMultiCharFold);
1163 #ifdef USE_LOCALE_CTYPE
1164 SvREFCNT_dec(PL_warn_locale);
1166 PL_utf8_mark = NULL;
1167 PL_utf8_toupper = NULL;
1168 PL_utf8_totitle = NULL;
1169 PL_utf8_tolower = NULL;
1170 PL_utf8_tofold = NULL;
1171 PL_utf8_idstart = NULL;
1172 PL_utf8_idcont = NULL;
1173 PL_utf8_foldclosures = NULL;
1174 PL_AboveLatin1 = NULL;
1176 PL_HasMultiCharFold = NULL;
1177 #ifdef USE_LOCALE_CTYPE
1178 PL_warn_locale = NULL;
1181 PL_NonL1NonFinalFold = NULL;
1182 PL_UpperLatin1 = NULL;
1183 for (i = 0; i < POSIX_CC_COUNT; i++) {
1184 SvREFCNT_dec(PL_XPosix_ptrs[i]);
1185 PL_XPosix_ptrs[i] = NULL;
1187 PL_GCB_invlist = NULL;
1188 PL_LB_invlist = NULL;
1189 PL_SB_invlist = NULL;
1190 PL_WB_invlist = NULL;
1191 PL_Assigned_invlist = NULL;
1193 if (!specialWARN(PL_compiling.cop_warnings))
1194 PerlMemShared_free(PL_compiling.cop_warnings);
1195 PL_compiling.cop_warnings = NULL;
1196 cophh_free(CopHINTHASH_get(&PL_compiling));
1197 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
1198 CopFILE_free(&PL_compiling);
1200 /* Prepare to destruct main symbol table. */
1203 /* break ref loop *:: <=> %:: */
1204 (void)hv_deletes(hv, "main::", G_DISCARD);
1207 SvREFCNT_dec(PL_curstname);
1208 PL_curstname = NULL;
1210 /* clear queued errors */
1211 SvREFCNT_dec(PL_errors);
1214 SvREFCNT_dec(PL_isarev);
1217 if (destruct_level >= 2) {
1218 if (PL_scopestack_ix != 0)
1219 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1220 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1221 (long)PL_scopestack_ix);
1222 if (PL_savestack_ix != 0)
1223 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1224 "Unbalanced saves: %ld more saves than restores\n",
1225 (long)PL_savestack_ix);
1226 if (PL_tmps_floor != -1)
1227 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1228 (long)PL_tmps_floor + 1);
1229 if (cxstack_ix != -1)
1230 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1231 (long)cxstack_ix + 1);
1235 SvREFCNT_dec(PL_regex_padav);
1236 PL_regex_padav = NULL;
1237 PL_regex_pad = NULL;
1240 #ifdef PERL_IMPLICIT_CONTEXT
1241 /* the entries in this list are allocated via SV PVX's, so get freed
1242 * in sv_clean_all */
1243 Safefree(PL_my_cxt_list);
1246 /* Now absolutely destruct everything, somehow or other, loops or no. */
1248 /* the 2 is for PL_fdpid and PL_strtab */
1249 while (sv_clean_all() > 2)
1253 Safefree(PL_stashpad); /* must come after sv_clean_all */
1256 AvREAL_off(PL_fdpid); /* no surviving entries */
1257 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
1260 #ifdef HAVE_INTERP_INTERN
1264 /* constant strings */
1265 for (i = 0; i < SV_CONSTS_COUNT; i++) {
1266 SvREFCNT_dec(PL_sv_consts[i]);
1267 PL_sv_consts[i] = NULL;
1270 /* Destruct the global string table. */
1272 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1273 * so that sv_free() won't fail on them.
1274 * Now that the global string table is using a single hunk of memory
1275 * for both HE and HEK, we either need to explicitly unshare it the
1276 * correct way, or actually free things here.
1279 const I32 max = HvMAX(PL_strtab);
1280 HE * const * const array = HvARRAY(PL_strtab);
1281 HE *hent = array[0];
1284 if (hent && ckWARN_d(WARN_INTERNAL)) {
1285 HE * const next = HeNEXT(hent);
1286 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1287 "Unbalanced string table refcount: (%ld) for \"%s\"",
1288 (long)hent->he_valu.hent_refcount, HeKEY(hent));
1295 hent = array[riter];
1300 HvARRAY(PL_strtab) = 0;
1301 HvTOTALKEYS(PL_strtab) = 0;
1303 SvREFCNT_dec(PL_strtab);
1306 /* free the pointer tables used for cloning */
1307 ptr_table_free(PL_ptr_table);
1308 PL_ptr_table = (PTR_TBL_t*)NULL;
1311 /* free special SVs */
1313 SvREFCNT(&PL_sv_yes) = 0;
1314 sv_clear(&PL_sv_yes);
1315 SvANY(&PL_sv_yes) = NULL;
1316 SvFLAGS(&PL_sv_yes) = 0;
1318 SvREFCNT(&PL_sv_no) = 0;
1319 sv_clear(&PL_sv_no);
1320 SvANY(&PL_sv_no) = NULL;
1321 SvFLAGS(&PL_sv_no) = 0;
1323 SvREFCNT(&PL_sv_zero) = 0;
1324 sv_clear(&PL_sv_zero);
1325 SvANY(&PL_sv_zero) = NULL;
1326 SvFLAGS(&PL_sv_zero) = 0;
1330 for (i=0; i<=2; i++) {
1331 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1332 sv_clear(PERL_DEBUG_PAD(i));
1333 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1334 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1338 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1339 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1341 #ifdef DEBUG_LEAKING_SCALARS
1342 if (PL_sv_count != 0) {
1347 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1348 svend = &sva[SvREFCNT(sva)];
1349 for (sv = sva + 1; sv < svend; ++sv) {
1350 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
1351 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1353 " refcnt=%"UVuf pTHX__FORMAT "\n"
1354 "\tallocated at %s:%d %s %s (parent 0x%" UVxf ");"
1355 "serial %" UVuf "\n",
1356 (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1358 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1360 sv->sv_debug_inpad ? "for" : "by",
1361 sv->sv_debug_optype ?
1362 PL_op_name[sv->sv_debug_optype]: "(none)",
1363 PTR2UV(sv->sv_debug_parent),
1366 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1367 Perl_dump_sv_child(aTHX_ sv);
1373 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1377 /* Wait for up to 4 seconds for child to terminate.
1378 This seems to be the least effort way of timing out on reaping
1380 struct timeval waitfor = {4, 0};
1381 int sock = PL_dumper_fd;
1385 FD_SET(sock, &rset);
1386 select(sock + 1, &rset, NULL, NULL, &waitfor);
1387 waitpid(child, &status, WNOHANG);
1392 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1398 #if defined(PERLIO_LAYERS)
1399 /* No more IO - including error messages ! */
1400 PerlIO_cleanup(aTHX);
1403 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1404 as currently layers use it rather than NULL as a marker
1405 for no arg - and will try and SvREFCNT_dec it.
1407 SvREFCNT(&PL_sv_undef) = 0;
1408 SvREADONLY_off(&PL_sv_undef);
1410 Safefree(PL_origfilename);
1411 PL_origfilename = NULL;
1412 Safefree(PL_reg_curpm);
1413 free_tied_hv_pool();
1414 Safefree(PL_op_mask);
1415 Safefree(PL_psig_name);
1416 PL_psig_name = (SV**)NULL;
1417 PL_psig_ptr = (SV**)NULL;
1419 /* We need to NULL PL_psig_pend first, so that
1420 signal handlers know not to use it */
1421 int *psig_save = PL_psig_pend;
1422 PL_psig_pend = (int*)NULL;
1423 Safefree(psig_save);
1426 TAINTING_set(FALSE);
1427 TAINT_WARN_set(FALSE);
1428 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
1430 DEBUG_P(debprofdump());
1434 #ifdef USE_REENTRANT_API
1435 Perl_reentrant_free(aTHX);
1438 /* These all point to HVs that are about to be blown away.
1439 Code in core and on CPAN assumes that if the interpreter is re-started
1440 that they will be cleanly NULL or pointing to a valid HV. */
1441 PL_custom_op_names = NULL;
1442 PL_custom_op_descs = NULL;
1443 PL_custom_ops = NULL;
1447 while (PL_regmatch_slab) {
1448 regmatch_slab *s = PL_regmatch_slab;
1449 PL_regmatch_slab = PL_regmatch_slab->next;
1453 /* As the absolutely last thing, free the non-arena SV for mess() */
1456 /* we know that type == SVt_PVMG */
1458 /* it could have accumulated taint magic */
1461 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1462 moremagic = mg->mg_moremagic;
1463 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1465 Safefree(mg->mg_ptr);
1469 /* we know that type >= SVt_PV */
1470 SvPV_free(PL_mess_sv);
1471 Safefree(SvANY(PL_mess_sv));
1472 Safefree(PL_mess_sv);
1479 =for apidoc perl_free
1481 Releases a Perl interpreter. See L<perlembed>.
1491 PERL_ARGS_ASSERT_PERL_FREE;
1493 if (PL_veto_cleanup)
1496 #ifdef PERL_TRACK_MEMPOOL
1499 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1500 * value as we're probably hunting memory leaks then
1502 if (PL_perl_destruct_level == 0) {
1503 const U32 old_debug = PL_debug;
1504 /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1505 thread at thread exit. */
1507 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1508 "free this thread's memory\n");
1509 PL_debug &= ~ DEBUG_m_FLAG;
1511 while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){
1512 char * next = (char *)(aTHXx->Imemory_debug_header.next);
1513 Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next;
1516 PL_debug = old_debug;
1521 #if defined(WIN32) || defined(NETWARE)
1522 # if defined(PERL_IMPLICIT_SYS)
1525 void *host = nw_internal_host;
1526 PerlMem_free(aTHXx);
1527 nw_delete_internal_host(host);
1529 void *host = w32_internal_host;
1530 PerlMem_free(aTHXx);
1531 win32_delete_internal_host(host);
1535 PerlMem_free(aTHXx);
1538 PerlMem_free(aTHXx);
1542 #if defined(USE_ITHREADS)
1543 /* provide destructors to clean up the thread key when libperl is unloaded */
1544 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1546 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1547 #pragma fini "perl_fini"
1548 #elif defined(__sun) && !defined(__GNUC__)
1549 #pragma fini (perl_fini)
1553 #if defined(__GNUC__)
1554 __attribute__((destructor))
1560 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1563 PL_curinterp && !PL_veto_cleanup)
1568 #endif /* THREADS */
1571 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1573 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1574 PL_exitlist[PL_exitlistlen].fn = fn;
1575 PL_exitlist[PL_exitlistlen].ptr = ptr;
1580 =for apidoc perl_parse
1582 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1587 #define SET_CURSTASH(newstash) \
1588 if (PL_curstash != newstash) { \
1589 SvREFCNT_dec(PL_curstash); \
1590 PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1594 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1601 PERL_ARGS_ASSERT_PERL_PARSE;
1602 #ifndef MULTIPLICITY
1603 PERL_UNUSED_ARG(my_perl);
1605 #if (defined(USE_HASH_SEED) || defined(USE_HASH_SEED_DEBUG)) && !defined(NO_PERL_HASH_SEED_DEBUG)
1607 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1609 if (s && strEQ(s, "1")) {
1610 const unsigned char *seed= PERL_HASH_SEED;
1611 const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
1612 PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
1613 while (seed < seed_end) {
1614 PerlIO_printf(Perl_debug_log, "%02x", *seed++);
1616 #ifdef PERL_HASH_RANDOMIZE_KEYS
1617 PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
1618 PL_HASH_RAND_BITS_ENABLED,
1619 PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
1621 PerlIO_printf(Perl_debug_log, "\n");
1624 #endif /* #if (defined(USE_HASH_SEED) ... */
1628 struct NameTranslationInfo nti;
1629 __translate_amiga_to_unix_path_name(&argv[0],&nti);
1636 if (PL_origalen != 0) {
1637 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1640 /* Set PL_origalen be the sum of the contiguous argv[]
1641 * elements plus the size of the env in case that it is
1642 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1643 * as the maximum modifiable length of $0. In the worst case
1644 * the area we are able to modify is limited to the size of
1645 * the original argv[0]. (See below for 'contiguous', though.)
1647 const char *s = NULL;
1648 const UV mask = ~(UV)(PTRSIZE-1);
1649 /* Do the mask check only if the args seem like aligned. */
1651 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1653 /* See if all the arguments are contiguous in memory. Note
1654 * that 'contiguous' is a loose term because some platforms
1655 * align the argv[] and the envp[]. If the arguments look
1656 * like non-aligned, assume that they are 'strictly' or
1657 * 'traditionally' contiguous. If the arguments look like
1658 * aligned, we just check that they are within aligned
1659 * PTRSIZE bytes. As long as no system has something bizarre
1660 * like the argv[] interleaved with some other data, we are
1661 * fine. (Did I just evoke Murphy's Law?) --jhi */
1662 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1665 for (i = 1; i < PL_origargc; i++) {
1666 if ((PL_origargv[i] == s + 1
1668 || PL_origargv[i] == s + 2
1673 (PL_origargv[i] > s &&
1675 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1686 #ifndef PERL_USE_SAFE_PUTENV
1687 /* Can we grab env area too to be used as the area for $0? */
1688 if (s && PL_origenviron && !PL_use_safe_putenv) {
1689 if ((PL_origenviron[0] == s + 1)
1692 (PL_origenviron[0] > s &&
1693 PL_origenviron[0] <=
1694 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1698 #ifndef OS2 /* ENVIRON is read by the kernel too. */
1699 s = PL_origenviron[0];
1702 my_setenv("NoNe SuCh", NULL);
1703 /* Force copy of environment. */
1704 for (i = 1; PL_origenviron[i]; i++) {
1705 if (PL_origenviron[i] == s + 1
1708 (PL_origenviron[i] > s &&
1709 PL_origenviron[i] <=
1710 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1713 s = PL_origenviron[i];
1721 #endif /* !defined(PERL_USE_SAFE_PUTENV) */
1723 PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1728 /* Come here if running an undumped a.out. */
1730 PL_origfilename = savepv(argv[0]);
1731 PL_do_undump = FALSE;
1732 cxstack_ix = -1; /* start label stack again */
1734 assert (!TAINT_get);
1738 init_postdump_symbols(argc,argv,env);
1743 op_free(PL_main_root);
1744 PL_main_root = NULL;
1746 PL_main_start = NULL;
1747 SvREFCNT_dec(PL_main_cv);
1751 oldscope = PL_scopestack_ix;
1752 PL_dowarn = G_WARN_OFF;
1757 parse_body(env,xsinit);
1758 if (PL_unitcheckav) {
1759 call_list(oldscope, PL_unitcheckav);
1762 PERL_SET_PHASE(PERL_PHASE_CHECK);
1763 call_list(oldscope, PL_checkav);
1771 /* my_exit() was called */
1772 while (PL_scopestack_ix > oldscope)
1775 SET_CURSTASH(PL_defstash);
1776 if (PL_unitcheckav) {
1777 call_list(oldscope, PL_unitcheckav);
1780 PERL_SET_PHASE(PERL_PHASE_CHECK);
1781 call_list(oldscope, PL_checkav);
1786 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1794 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1795 miniperl, and we need to see those flags reflected in the values here. */
1797 /* What this returns is subject to change. Use the public interface in Config.
1800 S_Internals_V(pTHX_ CV *cv)
1803 #ifdef LOCAL_PATCH_COUNT
1804 const int local_patch_count = LOCAL_PATCH_COUNT;
1806 const int local_patch_count = 0;
1808 const int entries = 3 + local_patch_count;
1810 static const char non_bincompat_options[] =
1817 # ifdef NO_HASH_SEED
1820 # ifdef NO_TAINT_SUPPORT
1823 # ifdef PERL_BOOL_AS_CHAR
1824 " PERL_BOOL_AS_CHAR"
1826 # ifdef PERL_COPY_ON_WRITE
1827 " PERL_COPY_ON_WRITE"
1829 # ifdef PERL_DISABLE_PMC
1832 # ifdef PERL_DONT_CREATE_GVSV
1833 " PERL_DONT_CREATE_GVSV"
1835 # ifdef PERL_EXTERNAL_GLOB
1836 " PERL_EXTERNAL_GLOB"
1838 # ifdef PERL_HASH_FUNC_SIPHASH
1839 " PERL_HASH_FUNC_SIPHASH"
1841 # ifdef PERL_HASH_FUNC_SDBM
1842 " PERL_HASH_FUNC_SDBM"
1844 # ifdef PERL_HASH_FUNC_DJB2
1845 " PERL_HASH_FUNC_DJB2"
1847 # ifdef PERL_HASH_FUNC_SUPERFAST
1848 " PERL_HASH_FUNC_SUPERFAST"
1850 # ifdef PERL_HASH_FUNC_MURMUR3
1851 " PERL_HASH_FUNC_MURMUR3"
1853 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1854 " PERL_HASH_FUNC_ONE_AT_A_TIME"
1856 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1857 " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1859 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1860 " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1862 # ifdef PERL_IS_MINIPERL
1865 # ifdef PERL_MALLOC_WRAP
1868 # ifdef PERL_MEM_LOG
1871 # ifdef PERL_MEM_LOG_NOIMPL
1872 " PERL_MEM_LOG_NOIMPL"
1874 # ifdef PERL_OP_PARENT
1877 # ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1878 " PERL_PERTURB_KEYS_DETERMINISTIC"
1880 # ifdef PERL_PERTURB_KEYS_DISABLED
1881 " PERL_PERTURB_KEYS_DISABLED"
1883 # ifdef PERL_PERTURB_KEYS_RANDOM
1884 " PERL_PERTURB_KEYS_RANDOM"
1886 # ifdef PERL_PRESERVE_IVUV
1887 " PERL_PRESERVE_IVUV"
1889 # ifdef PERL_RELOCATABLE_INCPUSH
1890 " PERL_RELOCATABLE_INCPUSH"
1892 # ifdef PERL_USE_DEVEL
1895 # ifdef PERL_USE_SAFE_PUTENV
1896 " PERL_USE_SAFE_PUTENV"
1898 # ifdef SILENT_NO_TAINT_SUPPORT
1899 " SILENT_NO_TAINT_SUPPORT"
1901 # ifdef UNLINK_ALL_VERSIONS
1902 " UNLINK_ALL_VERSIONS"
1904 # ifdef USE_ATTRIBUTES_FOR_PERLIO
1905 " USE_ATTRIBUTES_FOR_PERLIO"
1907 # ifdef USE_FAST_STDIO
1913 # ifdef USE_LOCALE_CTYPE
1916 # ifdef WIN32_NO_REGISTRY
1919 # ifdef USE_PERL_ATOF
1922 # ifdef USE_SITECUSTOMIZE
1923 " USE_SITECUSTOMIZE"
1926 PERL_UNUSED_ARG(cv);
1927 PERL_UNUSED_VAR(items);
1929 EXTEND(SP, entries);
1931 PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
1932 PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
1933 sizeof(non_bincompat_options) - 1, SVs_TEMP));
1935 #ifndef PERL_BUILD_DATE
1938 # define PERL_BUILD_DATE __DATE__ " " __TIME__
1940 # define PERL_BUILD_DATE __DATE__
1945 #ifdef PERL_BUILD_DATE
1946 PUSHs(Perl_newSVpvn_flags(aTHX_
1947 STR_WITH_LEN("Compiled at " PERL_BUILD_DATE),
1950 PUSHs(&PL_sv_undef);
1953 for (i = 1; i <= local_patch_count; i++) {
1954 /* This will be an undef, if PL_localpatches[i] is NULL. */
1955 PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
1961 #define INCPUSH_UNSHIFT 0x01
1962 #define INCPUSH_ADD_OLD_VERS 0x02
1963 #define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04
1964 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08
1965 #define INCPUSH_NOT_BASEDIR 0x10
1966 #define INCPUSH_CAN_RELOCATE 0x20
1967 #define INCPUSH_ADD_SUB_DIRS \
1968 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
1971 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1975 int argc = PL_origargc;
1976 char **argv = PL_origargv;
1977 const char *scriptname = NULL;
1978 bool dosearch = FALSE;
1980 bool doextract = FALSE;
1981 const char *cddir = NULL;
1982 #ifdef USE_SITECUSTOMIZE
1983 bool minus_f = FALSE;
1985 SV *linestr_sv = NULL;
1986 bool add_read_e_script = FALSE;
1987 U32 lex_start_flags = 0;
1989 PERL_SET_PHASE(PERL_PHASE_START);
1995 for (argc--,argv++; argc > 0; argc--,argv++) {
1996 if (argv[0][0] != '-' || !argv[0][1])
2002 #ifndef PERL_STRICT_CR
2026 if ((s = moreswitches(s)))
2031 #if defined(SILENT_NO_TAINT_SUPPORT)
2032 /* silently ignore */
2033 #elif defined(NO_TAINT_SUPPORT)
2034 Perl_croak_nocontext("This perl was compiled without taint support. "
2035 "Cowardly refusing to run with -t or -T flags");
2037 CHECK_MALLOC_TOO_LATE_FOR('t');
2038 if( !TAINTING_get ) {
2039 TAINT_WARN_set(TRUE);
2046 #if defined(SILENT_NO_TAINT_SUPPORT)
2047 /* silently ignore */
2048 #elif defined(NO_TAINT_SUPPORT)
2049 Perl_croak_nocontext("This perl was compiled without taint support. "
2050 "Cowardly refusing to run with -t or -T flags");
2052 CHECK_MALLOC_TOO_LATE_FOR('T');
2054 TAINT_WARN_set(FALSE);
2063 forbid_setid('e', FALSE);
2065 PL_e_script = newSVpvs("");
2066 add_read_e_script = TRUE;
2069 sv_catpv(PL_e_script, s);
2071 sv_catpv(PL_e_script, argv[1]);
2075 Perl_croak(aTHX_ "No code specified for -%c", c);
2076 sv_catpvs(PL_e_script, "\n");
2080 #ifdef USE_SITECUSTOMIZE
2086 case 'I': /* -I handled both here and in moreswitches() */
2087 forbid_setid('I', FALSE);
2088 if (!*++s && (s=argv[1]) != NULL) {
2092 STRLEN len = strlen(s);
2093 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
2096 Perl_croak(aTHX_ "No directory specified for -I");
2099 forbid_setid('S', FALSE);
2108 opts_prog = newSVpvs("use Config; Config::_V()");
2112 opts_prog = Perl_newSVpvf(aTHX_
2113 "use Config; Config::config_vars(qw%c%s%c)",
2117 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
2118 /* don't look for script or read stdin */
2119 scriptname = BIT_BUCKET;
2131 if (!*++s || isSPACE(*s)) {
2135 /* catch use of gnu style long options.
2136 Both of these exit immediately. */
2137 if (strEQ(s, "version"))
2139 if (strEQ(s, "help"))
2144 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
2155 #ifndef SECURE_INTERNAL_GETENV
2158 (s = PerlEnv_getenv("PERL5OPT")))
2160 /* s points to static memory in getenv(), which may be overwritten at
2161 * any time; use a mortal copy instead */
2162 s = SvPVX(sv_2mortal(newSVpv(s, 0)));
2166 if (*s == '-' && *(s+1) == 'T') {
2167 #if defined(SILENT_NO_TAINT_SUPPORT)
2168 /* silently ignore */
2169 #elif defined(NO_TAINT_SUPPORT)
2170 Perl_croak_nocontext("This perl was compiled without taint support. "
2171 "Cowardly refusing to run with -t or -T flags");
2173 CHECK_MALLOC_TOO_LATE_FOR('T');
2175 TAINT_WARN_set(FALSE);
2179 char *popt_copy = NULL;
2192 if (!strchr("CDIMUdmtwW", *s))
2193 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2197 popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2198 s = popt_copy + (s - d);
2206 #if defined(SILENT_NO_TAINT_SUPPORT)
2207 /* silently ignore */
2208 #elif defined(NO_TAINT_SUPPORT)
2209 Perl_croak_nocontext("This perl was compiled without taint support. "
2210 "Cowardly refusing to run with -t or -T flags");
2212 if( !TAINTING_get) {
2213 TAINT_WARN_set(TRUE);
2225 #ifndef NO_PERL_INTERNAL_RAND_SEED
2226 /* If we're not set[ug]id, we might have honored
2227 PERL_INTERNAL_RAND_SEED in perl_construct().
2228 At this point command-line options have been parsed, so if
2229 we're now tainting and not set[ug]id re-seed.
2230 This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid,
2231 but avoids duplicating the logic from perl_construct().
2234 PerlProc_getuid() == PerlProc_geteuid() &&
2235 PerlProc_getgid() == PerlProc_getegid()) {
2236 Perl_drand48_init_r(&PL_internal_random_state, seed());
2240 /* Set $^X early so that it can be used for relocatable paths in @INC */
2241 /* and for SITELIB_EXP in USE_SITECUSTOMIZE */
2242 assert (!TAINT_get);
2247 #if defined(USE_SITECUSTOMIZE)
2249 /* The games with local $! are to avoid setting errno if there is no
2250 sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2251 ie a q() operator with a NUL byte as a the delimiter. This avoids
2252 problems with pathnames containing (say) ' */
2253 # ifdef PERL_IS_MINIPERL
2254 AV *const inc = GvAV(PL_incgv);
2255 SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2258 /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2259 it should be reported immediately as a build failure. */
2260 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2262 "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; "
2263 "do {local $!; -f $f }"
2264 " and do $f || die $@ || qq '$f: $!' }",
2265 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
2268 /* SITELIB_EXP is a function call on Win32. */
2269 const char *const raw_sitelib = SITELIB_EXP;
2271 /* process .../.. if PERL_RELOCATABLE_INC is defined */
2272 SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2273 INCPUSH_CAN_RELOCATE);
2274 const char *const sitelib = SvPVX(sitelib_sv);
2275 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2277 "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2278 0, SVfARG(sitelib), 0,
2279 0, SVfARG(sitelib), 0));
2280 assert (SvREFCNT(sitelib_sv) == 1);
2281 SvREFCNT_dec(sitelib_sv);
2288 scriptname = argv[0];
2291 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2293 else if (scriptname == NULL) {
2295 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2301 assert (!TAINT_get);
2305 bool suidscript = FALSE;
2307 rsfp = open_script(scriptname, dosearch, &suidscript);
2309 rsfp = PerlIO_stdin();
2310 lex_start_flags = LEX_DONT_CLOSE_RSFP;
2313 validate_suid(rsfp);
2316 # if defined(SIGCHLD) || defined(SIGCLD)
2319 # define SIGCHLD SIGCLD
2321 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2322 if (sigstate == (Sighandler_t) SIG_IGN) {
2323 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2324 "Can't ignore signal CHLD, forcing to default");
2325 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2333 /* This will croak if suidscript is true, as -x cannot be used with
2335 forbid_setid('x', suidscript);
2336 /* Hence you can't get here if suidscript is true */
2338 linestr_sv = newSV_type(SVt_PV);
2339 lex_start_flags |= LEX_START_COPIED;
2340 find_beginning(linestr_sv, rsfp);
2341 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2342 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2346 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2347 CvUNIQUE_on(PL_compcv);
2349 CvPADLIST_set(PL_compcv, pad_new(0));
2351 PL_isarev = newHV();
2354 boot_core_UNIVERSAL();
2356 newXS("Internals::V", S_Internals_V, __FILE__);
2359 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
2361 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
2367 # ifdef HAS_SOCKS5_INIT
2368 socks5_init(argv[0]);
2374 init_predump_symbols();
2375 /* init_postdump_symbols not currently designed to be called */
2376 /* more than once (ENV isn't cleared first, for example) */
2377 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2379 init_postdump_symbols(argc,argv,env);
2381 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2382 * or explicitly in some platforms.
2383 * PL_utf8locale is conditionally turned on by
2384 * locale.c:Perl_init_i18nl10n() if the environment
2385 * look like the user wants to use UTF-8. */
2386 #if defined(__SYMBIAN32__)
2387 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2389 # ifndef PERL_IS_MINIPERL
2391 /* Requires init_predump_symbols(). */
2392 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2397 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2398 * and the default open disciplines. */
2399 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2400 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2402 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2403 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2404 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2406 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2407 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2408 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2410 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2411 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2412 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2414 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2415 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2418 sv_setpvs(sv, ":utf8\0:utf8");
2420 sv_setpvs(sv, ":utf8\0");
2423 sv_setpvs(sv, "\0:utf8");
2432 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2433 if (strEQ(s, "unsafe"))
2434 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2435 else if (strEQ(s, "safe"))
2436 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2438 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2443 lex_start(linestr_sv, rsfp, lex_start_flags);
2444 SvREFCNT_dec(linestr_sv);
2446 PL_subname = newSVpvs("main");
2448 if (add_read_e_script)
2449 filter_add(read_e_script, NULL);
2451 /* now parse the script */
2453 SETERRNO(0,SS_NORMAL);
2454 if (yyparse(GRAMPROG) || PL_parser->error_count) {
2455 abort_execution("", PL_origfilename);
2457 CopLINE_set(PL_curcop, 0);
2458 SET_CURSTASH(PL_defstash);
2460 SvREFCNT_dec(PL_e_script);
2468 SAVECOPFILE(PL_curcop);
2469 SAVECOPLINE(PL_curcop);
2470 gv_check(PL_defstash);
2480 s = PerlEnv_getenv("PERL_DEBUG_MSTATS");
2481 if (s && grok_atoUV(s, &uv, NULL) && uv >= 2)
2482 dump_mstats("after compilation:");
2487 PL_restartjmpenv = NULL;
2493 =for apidoc perl_run
2495 Tells a Perl interpreter to run. See L<perlembed>.
2507 PERL_ARGS_ASSERT_PERL_RUN;
2508 #ifndef MULTIPLICITY
2509 PERL_UNUSED_ARG(my_perl);
2512 oldscope = PL_scopestack_ix;
2520 cxstack_ix = -1; /* start context stack again */
2522 case 0: /* normal completion */
2526 case 2: /* my_exit() */
2527 while (PL_scopestack_ix > oldscope)
2530 SET_CURSTASH(PL_defstash);
2531 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2532 PL_endav && !PL_minus_c) {
2533 PERL_SET_PHASE(PERL_PHASE_END);
2534 call_list(oldscope, PL_endav);
2537 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2538 dump_mstats("after execution: ");
2544 POPSTACK_TO(PL_mainstack);
2547 PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2558 S_run_body(pTHX_ I32 oldscope)
2560 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2561 PL_sawampersand ? "Enabling" : "Omitting",
2562 (unsigned int)(PL_sawampersand)));
2564 if (!PL_restartop) {
2566 if (DEBUG_x_TEST || DEBUG_B_TEST)
2567 dump_all_perl(!DEBUG_B_TEST);
2569 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2573 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2576 if (PERLDB_SINGLE && PL_DBsingle)
2579 PERL_SET_PHASE(PERL_PHASE_INIT);
2580 call_list(oldscope, PL_initav);
2582 #ifdef PERL_DEBUG_READONLY_OPS
2583 if (PL_main_root && PL_main_root->op_slabbed)
2584 Slab_to_ro(OpSLAB(PL_main_root));
2590 PERL_SET_PHASE(PERL_PHASE_RUN);
2593 PL_restartjmpenv = NULL;
2594 PL_op = PL_restartop;
2598 else if (PL_main_start) {
2599 CvDEPTH(PL_main_cv) = 1;
2600 PL_op = PL_main_start;
2604 NOT_REACHED; /* NOTREACHED */
2608 =head1 SV Manipulation Functions
2610 =for apidoc p||get_sv
2612 Returns the SV of the specified Perl scalar. C<flags> are passed to
2613 C<gv_fetchpv>. If C<GV_ADD> is set and the
2614 Perl variable does not exist then it will be created. If C<flags> is zero
2615 and the variable does not exist then NULL is returned.
2621 Perl_get_sv(pTHX_ const char *name, I32 flags)
2625 PERL_ARGS_ASSERT_GET_SV;
2627 gv = gv_fetchpv(name, flags, SVt_PV);
2634 =head1 Array Manipulation Functions
2636 =for apidoc p||get_av
2638 Returns the AV of the specified Perl global or package array with the given
2639 name (so it won't work on lexical variables). C<flags> are passed
2640 to C<gv_fetchpv>. If C<GV_ADD> is set and the
2641 Perl variable does not exist then it will be created. If C<flags> is zero
2642 and the variable does not exist then NULL is returned.
2644 Perl equivalent: C<@{"$name"}>.
2650 Perl_get_av(pTHX_ const char *name, I32 flags)
2652 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2654 PERL_ARGS_ASSERT_GET_AV;
2664 =head1 Hash Manipulation Functions
2666 =for apidoc p||get_hv
2668 Returns the HV of the specified Perl hash. C<flags> are passed to
2669 C<gv_fetchpv>. If C<GV_ADD> is set and the
2670 Perl variable does not exist then it will be created. If C<flags> is zero
2671 and the variable does not exist then C<NULL> is returned.
2677 Perl_get_hv(pTHX_ const char *name, I32 flags)
2679 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2681 PERL_ARGS_ASSERT_GET_HV;
2691 =head1 CV Manipulation Functions
2693 =for apidoc p||get_cvn_flags
2695 Returns the CV of the specified Perl subroutine. C<flags> are passed to
2696 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2697 exist then it will be declared (which has the same effect as saying
2698 C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
2699 then NULL is returned.
2701 =for apidoc p||get_cv
2703 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2709 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2711 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2713 PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2715 /* XXX this is probably not what they think they're getting.
2716 * It has the same effect as "sub name;", i.e. just a forward
2718 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2719 return newSTUB(gv,0);
2726 /* Nothing in core calls this now, but we can't replace it with a macro and
2727 move it to mathoms.c as a macro would evaluate name twice. */
2729 Perl_get_cv(pTHX_ const char *name, I32 flags)
2731 PERL_ARGS_ASSERT_GET_CV;
2733 return get_cvn_flags(name, strlen(name), flags);
2736 /* Be sure to refetch the stack pointer after calling these routines. */
2740 =head1 Callback Functions
2742 =for apidoc p||call_argv
2744 Performs a callback to the specified named and package-scoped Perl subroutine
2745 with C<argv> (a C<NULL>-terminated array of strings) as arguments. See
2748 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2754 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2756 /* See G_* flags in cop.h */
2757 /* null terminated arg list */
2761 PERL_ARGS_ASSERT_CALL_ARGV;
2765 mXPUSHs(newSVpv(*argv,0));
2769 return call_pv(sub_name, flags);
2773 =for apidoc p||call_pv
2775 Performs a callback to the specified Perl sub. See L<perlcall>.
2781 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2782 /* name of the subroutine */
2783 /* See G_* flags in cop.h */
2785 PERL_ARGS_ASSERT_CALL_PV;
2787 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2791 =for apidoc p||call_method
2793 Performs a callback to the specified Perl method. The blessed object must
2794 be on the stack. See L<perlcall>.
2800 Perl_call_method(pTHX_ const char *methname, I32 flags)
2801 /* name of the subroutine */
2802 /* See G_* flags in cop.h */
2806 PERL_ARGS_ASSERT_CALL_METHOD;
2808 len = strlen(methname);
2809 sv = flags & G_METHOD_NAMED
2810 ? sv_2mortal(newSVpvn_share(methname, len,0))
2811 : newSVpvn_flags(methname, len, SVs_TEMP);
2813 return call_sv(sv, flags | G_METHOD);
2816 /* May be called with any of a CV, a GV, or an SV containing the name. */
2818 =for apidoc p||call_sv
2820 Performs a callback to the Perl sub specified by the SV.
2822 If neither the C<G_METHOD> nor C<G_METHOD_NAMED> flag is supplied, the
2823 SV may be any of a CV, a GV, a reference to a CV, a reference to a GV
2824 or C<SvPV(sv)> will be used as the name of the sub to call.
2826 If the C<G_METHOD> flag is supplied, the SV may be a reference to a CV or
2827 C<SvPV(sv)> will be used as the name of the method to call.
2829 If the C<G_METHOD_NAMED> flag is supplied, C<SvPV(sv)> will be used as
2830 the name of the method to call.
2832 Some other values are treated specially for internal use and should
2841 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2842 /* See G_* flags in cop.h */
2845 LOGOP myop; /* fake syntax tree node */
2849 bool oldcatch = CATCH_GET;
2851 OP* const oldop = PL_op;
2854 PERL_ARGS_ASSERT_CALL_SV;
2856 if (flags & G_DISCARD) {
2860 if (!(flags & G_WANT)) {
2861 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2866 Zero(&myop, 1, LOGOP);
2867 if (!(flags & G_NOARGS))
2868 myop.op_flags |= OPf_STACKED;
2869 myop.op_flags |= OP_GIMME_REVERSE(flags);
2873 if (!(flags & G_METHOD_NAMED)) {
2881 if (PERLDB_SUB && PL_curstash != PL_debstash
2882 /* Handle first BEGIN of -d. */
2883 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2884 /* Try harder, since this may have been a sighandler, thus
2885 * curstash may be meaningless. */
2886 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2887 && !(flags & G_NODEBUG))
2888 myop.op_private |= OPpENTERSUB_DB;
2890 if (flags & (G_METHOD|G_METHOD_NAMED)) {
2891 Zero(&method_op, 1, METHOP);
2892 method_op.op_next = (OP*)&myop;
2893 PL_op = (OP*)&method_op;
2894 if ( flags & G_METHOD_NAMED ) {
2895 method_op.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
2896 method_op.op_type = OP_METHOD_NAMED;
2897 method_op.op_u.op_meth_sv = sv;
2899 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2900 method_op.op_type = OP_METHOD;
2902 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2903 myop.op_type = OP_ENTERSUB;
2906 if (!(flags & G_EVAL)) {
2908 CALL_BODY_SUB((OP*)&myop);
2909 retval = PL_stack_sp - (PL_stack_base + oldmark);
2910 CATCH_SET(oldcatch);
2914 myop.op_other = (OP*)&myop;
2916 old_cxix = cxstack_ix;
2917 create_eval_scope(NULL, flags|G_FAKINGEVAL);
2925 CALL_BODY_SUB((OP*)&myop);
2926 retval = PL_stack_sp - (PL_stack_base + oldmark);
2927 if (!(flags & G_KEEPERR)) {
2935 /* my_exit() was called */
2936 SET_CURSTASH(PL_defstash);
2940 NOT_REACHED; /* NOTREACHED */
2943 PL_restartjmpenv = NULL;
2944 PL_op = PL_restartop;
2948 PL_stack_sp = PL_stack_base + oldmark;
2949 if ((flags & G_WANT) == G_ARRAY)
2953 *++PL_stack_sp = &PL_sv_undef;
2958 /* if we croaked, depending on how we croaked the eval scope
2959 * may or may not have already been popped */
2960 if (cxstack_ix > old_cxix) {
2961 assert(cxstack_ix == old_cxix + 1);
2962 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
2963 delete_eval_scope();
2968 if (flags & G_DISCARD) {
2969 PL_stack_sp = PL_stack_base + oldmark;
2978 /* Eval a string. The G_EVAL flag is always assumed. */
2981 =for apidoc p||eval_sv
2983 Tells Perl to C<eval> the string in the SV. It supports the same flags
2984 as C<call_sv>, with the obvious exception of C<G_EVAL>. See L<perlcall>.
2990 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2992 /* See G_* flags in cop.h */
2995 UNOP myop; /* fake syntax tree node */
2999 OP* const oldop = PL_op;
3002 PERL_ARGS_ASSERT_EVAL_SV;
3004 if (flags & G_DISCARD) {
3011 Zero(&myop, 1, UNOP);
3014 oldmark = SP - PL_stack_base;
3020 if (!(flags & G_NOARGS))
3021 myop.op_flags = OPf_STACKED;
3022 myop.op_type = OP_ENTEREVAL;
3023 myop.op_flags |= OP_GIMME_REVERSE(flags);
3024 if (flags & G_KEEPERR)
3025 myop.op_flags |= OPf_SPECIAL;
3027 if (flags & G_RE_REPARSING)
3028 myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
3030 /* fail now; otherwise we could fail after the JMPENV_PUSH but
3031 * before a cx_pusheval(), which corrupts the stack after a croak */
3032 TAINT_PROPER("eval_sv()");
3038 if (PL_op == (OP*)(&myop)) {
3039 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
3041 goto fail; /* failed in compilation */
3044 retval = PL_stack_sp - (PL_stack_base + oldmark);
3045 if (!(flags & G_KEEPERR)) {
3053 /* my_exit() was called */
3054 SET_CURSTASH(PL_defstash);
3058 NOT_REACHED; /* NOTREACHED */
3061 PL_restartjmpenv = NULL;
3062 PL_op = PL_restartop;
3067 PL_stack_sp = PL_stack_base + oldmark;
3068 if ((flags & G_WANT) == G_ARRAY)
3072 *++PL_stack_sp = &PL_sv_undef;
3078 if (flags & G_DISCARD) {
3079 PL_stack_sp = PL_stack_base + oldmark;
3089 =for apidoc p||eval_pv
3091 Tells Perl to C<eval> the given string in scalar context and return an SV* result.
3097 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
3099 SV* sv = newSVpv(p, 0);
3101 PERL_ARGS_ASSERT_EVAL_PV;
3103 eval_sv(sv, G_SCALAR);
3112 /* just check empty string or undef? */
3113 if (croak_on_error) {
3114 SV * const errsv = ERRSV;
3115 if(SvTRUE_NN(errsv))
3116 /* replace with croak_sv? */
3117 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
3123 /* Require a module. */
3126 =head1 Embedding Functions
3128 =for apidoc p||require_pv
3130 Tells Perl to C<require> the file named by the string argument. It is
3131 analogous to the Perl code C<eval "require '$file'">. It's even
3132 implemented that way; consider using load_module instead.
3137 Perl_require_pv(pTHX_ const char *pv)
3142 PERL_ARGS_ASSERT_REQUIRE_PV;
3144 PUSHSTACKi(PERLSI_REQUIRE);
3145 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3146 eval_sv(sv_2mortal(sv), G_DISCARD);
3151 S_usage(pTHX) /* XXX move this out into a module ? */
3153 /* This message really ought to be max 23 lines.
3154 * Removed -h because the user already knows that option. Others? */
3156 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3157 minimum of 509 character string literals. */
3158 static const char * const usage_msg[] = {
3159 " -0[octal] specify record separator (\\0, if no argument)\n"
3160 " -a autosplit mode with -n or -p (splits $_ into @F)\n"
3161 " -C[number/list] enables the listed Unicode features\n"
3162 " -c check syntax only (runs BEGIN and CHECK blocks)\n"
3163 " -d[:debugger] run program under debugger\n"
3164 " -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n",
3165 " -e program one line of program (several -e's allowed, omit programfile)\n"
3166 " -E program like -e, but enables all optional features\n"
3167 " -f don't do $sitelib/sitecustomize.pl at startup\n"
3168 " -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
3169 " -i[extension] edit <> files in place (makes backup if extension supplied)\n"
3170 " -Idirectory specify @INC/#include directory (several -I's allowed)\n",
3171 " -l[octal] enable line ending processing, specifies line terminator\n"
3172 " -[mM][-]module execute \"use/no module...\" before executing program\n"
3173 " -n assume \"while (<>) { ... }\" loop around program\n"
3174 " -p assume loop like -n but print line also, like sed\n"
3175 " -s enable rudimentary parsing for switches after programfile\n"
3176 " -S look for programfile using PATH environment variable\n",
3177 " -t enable tainting warnings\n"
3178 " -T enable tainting checks\n"
3179 " -u dump core after parsing program\n"
3180 " -U allow unsafe operations\n"
3181 " -v print version, patchlevel and license\n"
3182 " -V[:variable] print configuration summary (or a single Config.pm variable)\n",
3183 " -w enable many useful warnings\n"
3184 " -W enable all warnings\n"
3185 " -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
3186 " -X disable all warnings\n"
3188 "Run 'perldoc perl' for more help with Perl.\n\n",
3191 const char * const *p = usage_msg;
3192 PerlIO *out = PerlIO_stdout();
3195 "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3198 PerlIO_puts(out, *p++);
3202 /* convert a string of -D options (or digits) into an int.
3203 * sets *s to point to the char after the options */
3207 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3209 static const char * const usage_msgd[] = {
3210 " Debugging flag values: (see also -d)\n"
3211 " p Tokenizing and parsing (with v, displays parse stack)\n"
3212 " s Stack snapshots (with v, displays all stacks)\n"
3213 " l Context (loop) stack processing\n"
3214 " t Trace execution\n"
3215 " o Method and overloading resolution\n",
3216 " c String/numeric conversions\n"
3217 " P Print profiling info, source file input state\n"
3218 " m Memory and SV allocation\n"
3219 " f Format processing\n"
3220 " r Regular expression parsing and execution\n"
3221 " x Syntax tree dump\n",
3222 " u Tainting checks\n"
3223 " H Hash dump -- usurps values()\n"
3224 " X Scratchpad allocation\n"
3226 " S Op slab allocation\n"
3228 " R Include reference counts of dumped variables (eg when using -Ds)\n",
3229 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3230 " v Verbose: use in conjunction with other flags\n"
3231 " C Copy On Write\n"
3232 " A Consistency checks on internal structures\n"
3233 " q quiet - currently only suppresses the 'EXECUTING' message\n"
3234 " M trace smart match resolution\n"
3235 " B dump suBroutine definitions, including special Blocks like BEGIN\n",
3236 " L trace some locale setting information--for Perl core development\n",
3237 " i trace PerlIO layer processing\n",
3242 PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3245 /* if adding extra options, remember to update DEBUG_MASK */
3246 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi";
3248 for (; isWORDCHAR(**s); (*s)++) {
3249 const char * const d = strchr(debopts,**s);
3251 uv |= 1 << (d - debopts);
3252 else if (ckWARN_d(WARN_DEBUGGING))
3253 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3254 "invalid option -D%c, use -D'' to see choices\n", **s);
3257 else if (isDIGIT(**s)) {
3259 if (grok_atoUV(*s, &uv, &e))
3261 for (; isWORDCHAR(**s); (*s)++) ;
3263 else if (givehelp) {
3264 const char *const *p = usage_msgd;
3265 while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3267 return (int)uv; /* ignore any UV->int conversion loss */
3271 /* This routine handles any switches that can be given during run */
3274 Perl_moreswitches(pTHX_ const char *s)
3278 const char option = *s; /* used to remember option in -m/-M code */
3280 PERL_ARGS_ASSERT_MORESWITCHES;
3288 SvREFCNT_dec(PL_rs);
3289 if (s[1] == 'x' && s[2]) {
3290 const char *e = s+=2;
3296 flags = PERL_SCAN_SILENT_ILLDIGIT;
3297 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3298 if (s + numlen < e) {
3299 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3303 PL_rs = newSVpvs("");
3304 tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1));
3305 uvchr_to_utf8(tmps, rschar);
3306 SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
3311 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3312 if (rschar & ~((U8)~0))
3313 PL_rs = &PL_sv_undef;
3314 else if (!rschar && numlen >= 2)
3315 PL_rs = newSVpvs("");
3317 char ch = (char)rschar;
3318 PL_rs = newSVpvn(&ch, 1);
3321 sv_setsv(get_sv("/", GV_ADD), PL_rs);
3326 PL_unicode = parse_unicode_opts( (const char **)&s );
3327 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3335 while (*s && !isSPACE(*s)) ++s;
3336 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3348 forbid_setid('d', FALSE);
3351 /* -dt indicates to the debugger that threads will be used */
3352 if (*s == 't' && !isWORDCHAR(s[1])) {
3354 my_setenv("PERL5DB_THREADED", "1");
3357 /* The following permits -d:Mod to accepts arguments following an =
3358 in the fashion that -MSome::Mod does. */
3359 if (*s == ':' || *s == '=') {
3366 sv = newSVpvs("no Devel::");
3368 sv = newSVpvs("use Devel::");
3372 end = s + strlen(s);
3374 /* We now allow -d:Module=Foo,Bar and -d:-Module */
3375 while(isWORDCHAR(*s) || *s==':') ++s;
3377 sv_catpvn(sv, start, end - start);
3379 sv_catpvn(sv, start, s-start);
3380 /* Don't use NUL as q// delimiter here, this string goes in the
3382 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3385 my_setenv("PERL5DB", SvPV_nolen_const(sv));
3389 PL_perldb = PERLDB_ALL;
3396 forbid_setid('D', FALSE);
3398 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3399 #else /* !DEBUGGING */
3400 if (ckWARN_d(WARN_DEBUGGING))
3401 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3402 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3403 for (s++; isWORDCHAR(*s); s++) ;
3406 NOT_REACHED; /* NOTREACHED */
3410 NOT_REACHED; /* NOTREACHED */
3413 Safefree(PL_inplace);
3415 const char * const start = ++s;
3416 while (*s && !isSPACE(*s))
3419 PL_inplace = savepvn(start, s - start);
3422 case 'I': /* -I handled both here and in parse_body() */
3423 forbid_setid('I', FALSE);
3425 while (*s && isSPACE(*s))
3430 /* ignore trailing spaces (possibly followed by other switches) */
3432 for (e = p; *e && !isSPACE(*e); e++) ;
3436 } while (*p && *p != '-');
3438 INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3444 Perl_croak(aTHX_ "No directory specified for -I");
3450 SvREFCNT_dec(PL_ors_sv);
3456 PL_ors_sv = newSVpvs("\n");
3457 numlen = 3 + (*s == '0');
3458 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3462 if (RsPARA(PL_rs)) {
3463 PL_ors_sv = newSVpvs("\n\n");
3466 PL_ors_sv = newSVsv(PL_rs);
3471 forbid_setid('M', FALSE); /* XXX ? */
3474 forbid_setid('m', FALSE); /* XXX ? */
3479 const char *use = "use ";
3481 /* -M-foo == 'no foo' */
3482 /* Leading space on " no " is deliberate, to make both
3483 possibilities the same length. */
3484 if (*s == '-') { use = " no "; ++s; }
3485 sv = newSVpvn(use,4);
3487 /* We allow -M'Module qw(Foo Bar)' */
3488 while(isWORDCHAR(*s) || *s==':') {
3497 Perl_croak(aTHX_ "Module name required with -%c option",
3500 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3501 "contains single ':'",
3502 (int)(s - start), start, option);
3503 end = s + strlen(s);
3505 sv_catpvn(sv, start, end - start);
3506 if (option == 'm') {
3508 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3509 sv_catpvs( sv, " ()");
3512 sv_catpvn(sv, start, s-start);
3513 /* Use NUL as q''-delimiter. */
3514 sv_catpvs(sv, " split(/,/,q\0");
3516 sv_catpvn(sv, s, end - s);
3517 sv_catpvs(sv, "\0)");
3520 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3523 Perl_croak(aTHX_ "Missing argument to -%c", option);
3534 forbid_setid('s', FALSE);
3535 PL_doswitches = TRUE;
3540 #if defined(SILENT_NO_TAINT_SUPPORT)
3541 /* silently ignore */
3542 #elif defined(NO_TAINT_SUPPORT)
3543 Perl_croak_nocontext("This perl was compiled without taint support. "
3544 "Cowardly refusing to run with -t or -T flags");
3552 PL_do_undump = TRUE;
3562 if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3563 PL_dowarn |= G_WARN_ON;
3568 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3569 if (!specialWARN(PL_compiling.cop_warnings))
3570 PerlMemShared_free(PL_compiling.cop_warnings);
3571 PL_compiling.cop_warnings = pWARN_ALL ;
3575 PL_dowarn = G_WARN_ALL_OFF;
3576 if (!specialWARN(PL_compiling.cop_warnings))
3577 PerlMemShared_free(PL_compiling.cop_warnings);
3578 PL_compiling.cop_warnings = pWARN_NONE ;
3585 if (s[0] == '-') /* Additional switches on #! line. */
3590 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3596 #ifdef ALTERNATE_SHEBANG
3597 case 'S': /* OS/2 needs -S on "extproc" line. */
3600 case 'e': case 'f': case 'x': case 'E':
3601 #ifndef ALTERNATE_SHEBANG
3605 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3608 "Unrecognized switch: -%.1s (-h will show valid options)",s
3618 PerlIO * PIO_stdout;
3620 const char * const level_str = "v" PERL_VERSION_STRING;
3621 const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1;
3622 #ifdef PERL_PATCHNUM
3624 # ifdef PERL_GIT_UNCOMMITTED_CHANGES
3625 static const char num [] = PERL_PATCHNUM "*";
3627 static const char num [] = PERL_PATCHNUM;
3630 const STRLEN num_len = sizeof(num)-1;
3631 /* A very advanced compiler would fold away the strnEQ
3632 and this whole conditional, but most (all?) won't do it.
3633 SV level could also be replaced by with preprocessor
3636 if (num_len >= level_len && strnEQ(num,level_str,level_len)) {
3637 /* per 46807d8e80, PERL_PATCHNUM is outside of the control
3638 of the interp so it might contain format characters
3640 level = newSVpvn(num, num_len);
3642 level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num);
3646 SV* level = newSVpvn(level_str, level_len);
3647 #endif /* #ifdef PERL_PATCHNUM */
3648 PIO_stdout = PerlIO_stdout();
3649 PerlIO_printf(PIO_stdout,
3650 "\nThis is perl " STRINGIFY(PERL_REVISION)
3651 ", version " STRINGIFY(PERL_VERSION)
3652 ", subversion " STRINGIFY(PERL_SUBVERSION)
3653 " (%" SVf ") built for " ARCHNAME, SVfARG(level)
3655 SvREFCNT_dec_NN(level);
3657 #if defined(LOCAL_PATCH_COUNT)
3658 if (LOCAL_PATCH_COUNT > 0)
3659 PerlIO_printf(PIO_stdout,
3660 "\n(with %d registered patch%s, "
3661 "see perl -V for more detail)",
3663 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3666 PerlIO_printf(PIO_stdout,
3667 "\n\nCopyright 1987-2017, Larry Wall\n");
3669 PerlIO_printf(PIO_stdout,
3670 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3673 PerlIO_printf(PIO_stdout,
3674 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3675 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3678 PerlIO_printf(PIO_stdout,
3679 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3680 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3683 PerlIO_printf(PIO_stdout,
3684 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3687 PerlIO_printf(PIO_stdout,
3688 "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3691 PerlIO_printf(PIO_stdout,
3692 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3695 PerlIO_printf(PIO_stdout,
3696 "WINCE port by Rainer Keuchel, 2001-2002\n"
3697 "Built on " __DATE__ " " __TIME__ "\n\n");
3700 #ifdef __SYMBIAN32__
3701 PerlIO_printf(PIO_stdout,
3702 "Symbian port by Nokia, 2004-2005\n");
3704 #ifdef BINARY_BUILD_NOTICE
3705 BINARY_BUILD_NOTICE;
3707 PerlIO_printf(PIO_stdout,
3709 Perl may be copied only under the terms of either the Artistic License or the\n\
3710 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3711 Complete documentation for Perl, including FAQ lists, should be found on\n\
3712 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3713 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3717 /* compliments of Tom Christiansen */
3719 /* unexec() can be found in the Gnu emacs distribution */
3720 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3723 #include <lib$routines.h>
3727 Perl_my_unexec(pTHX)
3730 SV * prog = newSVpv(BIN_EXP, 0);
3731 SV * file = newSVpv(PL_origfilename, 0);
3735 sv_catpvs(prog, "/perl");
3736 sv_catpvs(file, ".perldump");
3738 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3739 /* unexec prints msg to stderr in case of failure */
3740 PerlProc_exit(status);
3742 PERL_UNUSED_CONTEXT;
3744 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3745 # elif defined(WIN32) || defined(__CYGWIN__)
3746 Perl_croak_nocontext("dump is not supported");
3748 ABORT(); /* for use with undump */
3753 /* initialize curinterp */
3758 # define PERLVAR(prefix,var,type)
3759 # define PERLVARA(prefix,var,n,type)
3760 # if defined(PERL_IMPLICIT_CONTEXT)
3761 # define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init;
3762 # define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init;
3764 # define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init;
3765 # define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init;
3767 # include "intrpvar.h"
3773 # define PERLVAR(prefix,var,type)
3774 # define PERLVARA(prefix,var,n,type)
3775 # define PERLVARI(prefix,var,type,init) PL_##var = init;
3776 # define PERLVARIC(prefix,var,type,init) PL_##var = init;
3777 # include "intrpvar.h"
3787 S_init_main_stash(pTHX)
3791 PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
3792 /* We know that the string "main" will be in the global shared string
3793 table, so it's a small saving to use it rather than allocate another
3795 PL_curstname = newSVpvs_share("main");
3796 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3797 /* If we hadn't caused another reference to "main" to be in the shared
3798 string table above, then it would be worth reordering these two,
3799 because otherwise all we do is delete "main" from it as a consequence
3800 of the SvREFCNT_dec, only to add it again with hv_name_set */
3801 SvREFCNT_dec(GvHV(gv));
3802 hv_name_sets(PL_defstash, "main", 0);
3803 GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3805 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3807 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3808 GvMULTI_on(PL_incgv);
3809 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3810 SvREFCNT_inc_simple_void(PL_hintgv);
3811 GvMULTI_on(PL_hintgv);
3812 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3813 SvREFCNT_inc_simple_void(PL_defgv);
3814 PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
3815 SvREFCNT_inc_simple_void(PL_errgv);
3816 GvMULTI_on(PL_errgv);
3817 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3818 SvREFCNT_inc_simple_void(PL_replgv);
3819 GvMULTI_on(PL_replgv);
3820 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
3821 #ifdef PERL_DONT_CREATE_GVSV
3822 (void)gv_SVadd(PL_errgv);
3824 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3826 CopSTASH_set(&PL_compiling, PL_defstash);
3827 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3828 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3830 /* We must init $/ before switches are processed. */
3831 sv_setpvs(get_sv("/", GV_ADD), "\n");
3835 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
3838 PerlIO *rsfp = NULL;
3842 PERL_ARGS_ASSERT_OPEN_SCRIPT;
3845 PL_origfilename = savepvs("-e");
3850 /* if find_script() returns, it returns a malloc()-ed value */
3851 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3853 if (strEQs(scriptname, "/dev/fd/")
3854 && isDIGIT(scriptname[8])
3855 && grok_atoUV(scriptname + 8, &uv, &s)
3856 && uv <= PERL_INT_MAX
3861 * Tell apart "normal" usage of fdscript, e.g.
3862 * with bash on FreeBSD:
3863 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3864 * from usage in suidperl.
3865 * Does any "normal" usage leave garbage after the number???
3866 * Is it a mistake to use a similar /dev/fd/ construct for
3871 * Be supersafe and do some sanity-checks.
3872 * Still, can we be sure we got the right thing?
3875 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3878 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3880 scriptname = savepv(s + 1);
3881 Safefree(PL_origfilename);
3882 PL_origfilename = (char *)scriptname;
3887 CopFILE_free(PL_curcop);
3888 CopFILE_set(PL_curcop, PL_origfilename);
3889 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3890 scriptname = (char *)"";
3891 if (fdscript >= 0) {
3892 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3894 else if (!*scriptname) {
3895 forbid_setid(0, *suidscript);
3899 #ifdef FAKE_BIT_BUCKET
3900 /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3901 * is called) and still have the "-e" work. (Believe it or not,
3902 * a /dev/null is required for the "-e" to work because source
3903 * filter magic is used to implement it. ) This is *not* a general
3904 * replacement for a /dev/null. What we do here is create a temp
3905 * file (an empty file), open up that as the script, and then
3906 * immediately close and unlink it. Close enough for jazz. */
3907 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3908 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3909 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3910 char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3911 FAKE_BIT_BUCKET_TEMPLATE
3913 const char * const err = "Failed to create a fake bit bucket";
3914 if (strEQ(scriptname, BIT_BUCKET)) {
3915 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3916 int old_umask = umask(0177);
3917 int tmpfd = mkstemp(tmpname);
3920 scriptname = tmpname;
3923 Perl_croak(aTHX_ err);
3926 scriptname = mktemp(tmpname);
3928 Perl_croak(aTHX_ err);
3933 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3934 #ifdef FAKE_BIT_BUCKET
3935 if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3936 sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3937 && strlen(scriptname) == sizeof(tmpname) - 1) {
3940 scriptname = BIT_BUCKET;
3944 /* PSz 16 Sep 03 Keep neat error message */
3946 Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno));
3948 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3949 CopFILE(PL_curcop), Strerror(errno));
3951 fd = PerlIO_fileno(rsfp);
3952 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
3954 /* ensure close-on-exec */
3955 if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) {
3956 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3957 CopFILE(PL_curcop), Strerror(errno));
3963 (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
3964 && S_ISDIR(tmpstatbuf.st_mode)))
3965 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3973 * I_SYSSTATVFS HAS_FSTATVFS
3975 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3976 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3977 * here so that metaconfig picks them up. */
3980 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3981 /* Don't even need this function. */
3984 S_validate_suid(pTHX_ PerlIO *rsfp)
3986 const Uid_t my_uid = PerlProc_getuid();
3987 const Uid_t my_euid = PerlProc_geteuid();
3988 const Gid_t my_gid = PerlProc_getgid();
3989 const Gid_t my_egid = PerlProc_getegid();
3991 PERL_ARGS_ASSERT_VALIDATE_SUID;
3993 if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
3995 int fd = PerlIO_fileno(rsfp);
3997 if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */
3998 Perl_croak_nocontext( "Illegal suidscript");
4000 if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
4002 (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
4005 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4006 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4007 /* not set-id, must be wrapped */
4010 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4013 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
4018 PERL_ARGS_ASSERT_FIND_BEGINNING;
4020 /* skip forward in input to the real script? */
4023 if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
4024 Perl_croak(aTHX_ "No Perl script found in input\n");
4026 } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
4027 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
4028 while (*s && !(isSPACE (*s) || *s == '#')) s++;
4030 while (*s == ' ' || *s == '\t') s++;
4032 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4033 || s2[-1] == '_') s2--;
4034 if (strEQs(s2-4,"perl"))
4035 while ((s = moreswitches(s)))
4044 /* no need to do anything here any more if we don't
4046 #ifndef NO_TAINT_SUPPORT
4047 const Uid_t my_uid = PerlProc_getuid();
4048 const Uid_t my_euid = PerlProc_geteuid();
4049 const Gid_t my_gid = PerlProc_getgid();
4050 const Gid_t my_egid = PerlProc_getegid();
4052 PERL_UNUSED_CONTEXT;
4054 /* Should not happen: */
4055 CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
4056 TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
4060 * Should go by suidscript, not uid!=euid: why disallow
4061 * system("ls") in scripts run from setuid things?
4062 * Or, is this run before we check arguments and set suidscript?
4063 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4064 * (We never have suidscript, can we be sure to have fdscript?)
4065 * Or must then go by UID checks? See comments in forbid_setid also.
4069 /* This is used very early in the lifetime of the program,
4070 * before even the options are parsed, so PL_tainting has
4071 * not been initialized properly. */
4073 Perl_doing_taint(int argc, char *argv[], char *envp[])
4075 #ifndef PERL_IMPLICIT_SYS
4076 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4077 * before we have an interpreter-- and the whole point of this
4078 * function is to be called at such an early stage. If you are on
4079 * a system with PERL_IMPLICIT_SYS but you do have a concept of
4080 * "tainted because running with altered effective ids', you'll
4081 * have to add your own checks somewhere in here. The two most
4082 * known samples of 'implicitness' are Win32 and NetWare, neither
4083 * of which has much of concept of 'uids'. */
4084 Uid_t uid = PerlProc_getuid();
4085 Uid_t euid = PerlProc_geteuid();
4086 Gid_t gid = PerlProc_getgid();
4087 Gid_t egid = PerlProc_getegid();
4094 if (uid && (euid != uid || egid != gid))
4096 #endif /* !PERL_IMPLICIT_SYS */
4097 /* This is a really primitive check; environment gets ignored only
4098 * if -T are the first chars together; otherwise one gets
4099 * "Too late" message. */
4100 if ( argc > 1 && argv[1][0] == '-'
4101 && isALPHA_FOLD_EQ(argv[1][1], 't'))
4106 /* Passing the flag as a single char rather than a string is a slight space
4107 optimisation. The only message that isn't /^-.$/ is
4108 "program input from stdin", which is substituted in place of '\0', which
4109 could never be a command line flag. */
4111 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4113 char string[3] = "-x";
4114 const char *message = "program input from stdin";
4116 PERL_UNUSED_CONTEXT;
4122 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4123 if (PerlProc_getuid() != PerlProc_geteuid())
4124 Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4125 if (PerlProc_getgid() != PerlProc_getegid())
4126 Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4127 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4129 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4133 Perl_init_dbargs(pTHX)
4135 AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4140 /* Someone has already created it.
4141 It might have entries, and if we just turn off AvREAL(), they will
4142 "leak" until global destruction. */
4144 if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4145 Perl_croak(aTHX_ "Cannot set tied @DB::args");
4147 AvREIFY_only(PL_dbargs);
4151 Perl_init_debugger(pTHX)
4153 HV * const ostash = PL_curstash;
4156 PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4158 Perl_init_dbargs(aTHX);
4159 PL_DBgv = MUTABLE_GV(
4160 SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4162 PL_DBline = MUTABLE_GV(
4163 SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4165 PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4166 gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4168 PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4169 if (!SvIOK(PL_DBsingle))
4170 sv_setiv(PL_DBsingle, 0);
4171 mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4172 mg->mg_private = DBVARMG_SINGLE;
4173 SvSETMAGIC(PL_DBsingle);
4175 PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4176 if (!SvIOK(PL_DBtrace))
4177 sv_setiv(PL_DBtrace, 0);
4178 mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4179 mg->mg_private = DBVARMG_TRACE;
4180 SvSETMAGIC(PL_DBtrace);
4182 PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4183 if (!SvIOK(PL_DBsignal))
4184 sv_setiv(PL_DBsignal, 0);
4185 mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0);
4186 mg->mg_private = DBVARMG_SIGNAL;
4187 SvSETMAGIC(PL_DBsignal);
4189 SvREFCNT_dec(PL_curstash);
4190 PL_curstash = ostash;
4193 #ifndef STRESS_REALLOC
4194 #define REASONABLE(size) (size)
4195 #define REASONABLE_but_at_least(size,min) (size)
4197 #define REASONABLE(size) (1) /* unreasonable */
4198 #define REASONABLE_but_at_least(size,min) (min)
4202 Perl_init_stacks(pTHX)
4206 /* start with 128-item stack and 8K cxstack */
4207 PL_curstackinfo = new_stackinfo(REASONABLE(128),
4208 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4209 PL_curstackinfo->si_type = PERLSI_MAIN;
4210 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
4211 PL_curstackinfo->si_stack_hwm = 0;
4213 PL_curstack = PL_curstackinfo->si_stack;
4214 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
4216 PL_stack_base = AvARRAY(PL_curstack);
4217 PL_stack_sp = PL_stack_base;
4218 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4220 Newx(PL_tmps_stack,REASONABLE(128),SV*);
4223 PL_tmps_max = REASONABLE(128);
4225 Newx(PL_markstack,REASONABLE(32),I32);
4226 PL_markstack_ptr = PL_markstack;
4227 PL_markstack_max = PL_markstack + REASONABLE(32);
4231 Newx(PL_scopestack,REASONABLE(32),I32);
4233 Newx(PL_scopestack_name,REASONABLE(32),const char*);
4235 PL_scopestack_ix = 0;
4236 PL_scopestack_max = REASONABLE(32);
4238 size = REASONABLE_but_at_least(128,SS_MAXPUSH);
4239 Newx(PL_savestack, size, ANY);
4240 PL_savestack_ix = 0;
4241 /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */
4242 PL_savestack_max = size - SS_MAXPUSH;
4250 while (PL_curstackinfo->si_next)
4251 PL_curstackinfo = PL_curstackinfo->si_next;
4252 while (PL_curstackinfo) {
4253 PERL_SI *p = PL_curstackinfo->si_prev;
4254 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4255 Safefree(PL_curstackinfo->si_cxstack);
4256 Safefree(PL_curstackinfo);
4257 PL_curstackinfo = p;
4259 Safefree(PL_tmps_stack);
4260 Safefree(PL_markstack);
4261 Safefree(PL_scopestack);
4263 Safefree(PL_scopestack_name);
4265 Safefree(PL_savestack);
4269 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4271 GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4272 AV *const isa = GvAVn(gv);
4275 PERL_ARGS_ASSERT_POPULATE_ISA;
4277 if(AvFILLp(isa) != -1)
4280 /* NOTE: No support for tied ISA */
4282 va_start(args, len);
4284 const char *const parent = va_arg(args, const char*);
4289 parent_len = va_arg(args, size_t);
4291 /* Arguments are supplied with a trailing :: */
4292 assert(parent_len > 2);
4293 assert(parent[parent_len - 1] == ':');
4294 assert(parent[parent_len - 2] == ':');
4295 av_push(isa, newSVpvn(parent, parent_len - 2));
4296 (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4303 S_init_predump_symbols(pTHX)
4308 sv_setpvs(get_sv("\"", GV_ADD), " ");
4309 PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4312 /* Historically, PVIOs were blessed into IO::Handle, unless
4313 FileHandle was loaded, in which case they were blessed into
4314 that. Action at a distance.
4315 However, if we simply bless into IO::Handle, we break code
4316 that assumes that PVIOs will have (among others) a seek
4317 method. IO::File inherits from IO::Handle and IO::Seekable,
4318 and provides the needed methods. But if we simply bless into
4319 it, then we break code that assumed that by loading
4320 IO::Handle, *it* would work.
4321 So a compromise is to set up the correct @IO::File::ISA,
4322 so that code that does C<use IO::Handle>; will still work.
4325 Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4326 STR_WITH_LEN("IO::Handle::"),
4327 STR_WITH_LEN("IO::Seekable::"),
4328 STR_WITH_LEN("Exporter::"),
4331 PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4332 GvMULTI_on(PL_stdingv);
4333 io = GvIOp(PL_stdingv);
4334 IoTYPE(io) = IoTYPE_RDONLY;
4335 IoIFP(io) = PerlIO_stdin();
4336 tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4338 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4340 tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4343 IoTYPE(io) = IoTYPE_WRONLY;
4344 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4346 tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4348 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4350 PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4351 GvMULTI_on(PL_stderrgv);
4352 io = GvIOp(PL_stderrgv);
4353 IoTYPE(io) = IoTYPE_WRONLY;
4354 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4355 tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4357 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4359 PL_statname = newSVpvs(""); /* last filename we did stat on */
4363 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4365 PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4367 argc--,argv++; /* skip name of script */
4368 if (PL_doswitches) {
4369 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4373 if (argv[0][1] == '-' && !argv[0][2]) {
4377 if ((s = strchr(argv[0], '='))) {
4378 const char *const start_name = argv[0] + 1;
4379 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4380 TRUE, SVt_PV)), s + 1);
4383 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4386 if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4387 SvREFCNT_inc_simple_void_NN(PL_argvgv);
4388 GvMULTI_on(PL_argvgv);
4389 av_clear(GvAVn(PL_argvgv));
4390 for (; argc > 0; argc--,argv++) {
4391 SV * const sv = newSVpv(argv[0],0);
4392 av_push(GvAV(PL_argvgv),sv);
4393 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4394 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4397 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4398 (void)sv_utf8_decode(sv);
4402 if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4403 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4404 "-i used with no filenames on the command line, "
4405 "reading from STDIN");
4409 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4416 PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4418 PL_toptarget = newSV_type(SVt_PVIV);
4419 SvPVCLEAR(PL_toptarget);
4420 PL_bodytarget = newSV_type(SVt_PVIV);
4421 SvPVCLEAR(PL_bodytarget);
4422 PL_formtarget = PL_bodytarget;
4426 init_argv_symbols(argc,argv);
4428 if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4429 sv_setpv(GvSV(tmpgv),PL_origfilename);
4431 if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4433 bool env_is_not_environ;
4434 SvREFCNT_inc_simple_void_NN(PL_envgv);
4435 GvMULTI_on(PL_envgv);
4436 hv = GvHVn(PL_envgv);
4437 hv_magic(hv, NULL, PERL_MAGIC_env);
4439 #ifdef USE_ENVIRON_ARRAY
4440 /* Note that if the supplied env parameter is actually a copy
4441 of the global environ then it may now point to free'd memory
4442 if the environment has been modified since. To avoid this
4443 problem we treat env==NULL as meaning 'use the default'
4447 env_is_not_environ = env != environ;
4448 if (env_is_not_environ
4449 # ifdef USE_ITHREADS
4450 && PL_curinterp == aTHX
4462 for (; *env; env++) {
4465 if (!(s = strchr(old_var,'=')) || s == old_var)
4469 #if defined(MSDOS) && !defined(DJGPP)
4471 (void)strupr(old_var);
4474 if (hv_exists(hv, old_var, nlen)) {
4475 const char *name = savepvn(old_var, nlen);
4477 /* make sure we use the same value as getenv(), otherwise code that
4478 uses getenv() (like setlocale()) might see a different value to %ENV
4480 sv = newSVpv(PerlEnv_getenv(name), 0);
4482 /* keep a count of the dups of this name so we can de-dup environ later */
4483 if (hv_exists(dups, name, nlen))
4484 ++SvIVX(*hv_fetch(dups, name, nlen, 0));
4486 (void)hv_store(dups, name, nlen, newSViv(1), 0);
4491 sv = newSVpv(s+1, 0);
4493 (void)hv_store(hv, old_var, nlen, sv, 0);
4494 if (env_is_not_environ)
4498 /* environ has some duplicate definitions, remove them */
4501 while ((entry = hv_iternext_flags(dups, 0))) {
4503 const char *name = HePV(entry, nlen);
4504 IV count = SvIV(HeVAL(entry));
4506 SV **valp = hv_fetch(hv, name, nlen, 0);
4510 /* try to remove any duplicate names, depending on the
4511 * implementation used in my_setenv() the iteration might
4512 * not be necessary, but let's be safe.
4514 for (i = 0; i < count; ++i)
4517 /* and set it back to the value we set $ENV{name} to */
4518 my_setenv(name, SvPV_nolen(*valp));
4521 SvREFCNT_dec_NN(dups);
4523 #endif /* USE_ENVIRON_ARRAY */
4524 #endif /* !PERL_MICRO */
4528 /* touch @F array to prevent spurious warnings 20020415 MJD */
4530 (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4535 S_init_perllib(pTHX)
4538 const char *perl5lib = NULL;
4541 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4545 if (!TAINTING_get) {
4547 perl5lib = PerlEnv_getenv("PERL5LIB");
4549 * It isn't possible to delete an environment variable with
4550 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4551 * case we treat PERL5LIB as undefined if it has a zero-length value.
4553 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4554 if (perl5lib && *perl5lib != '\0')
4558 incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4560 s = PerlEnv_getenv("PERLLIB");
4562 incpush_use_sep(s, 0, 0);
4565 /* Treat PERL5?LIB as a possible search list logical name -- the
4566 * "natural" VMS idiom for a Unix path string. We allow each
4567 * element to be a set of |-separated directories for compatibility.
4571 if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4573 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4574 } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4576 while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
4577 incpush_use_sep(buf, 0, 0);
4582 #ifndef PERL_IS_MINIPERL
4583 /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4584 (and not the architecture specific directories from $ENV{PERL5LIB}) */
4586 /* Use the ~-expanded versions of APPLLIB (undocumented),
4587 SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4590 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4591 INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4595 /* sitearch is always relative to sitelib on Windows for
4596 * DLL-based path intuition to work correctly */
4597 # if !defined(WIN32)
4598 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4599 INCPUSH_CAN_RELOCATE);
4605 /* this picks up sitearch as well */
4606 s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len);
4608 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4610 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4614 #ifdef PERL_VENDORARCH_EXP
4615 /* vendorarch is always relative to vendorlib on Windows for
4616 * DLL-based path intuition to work correctly */
4617 # if !defined(WIN32)
4618 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4619 INCPUSH_CAN_RELOCATE);
4623 #ifdef PERL_VENDORLIB_EXP
4625 /* this picks up vendorarch as well */
4626 s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len);
4628 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4630 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4631 INCPUSH_CAN_RELOCATE);
4636 S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4640 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4644 s = PerlEnv_lib_path(PERL_FS_VERSION, &len);
4646 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4649 S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4651 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4655 #ifdef PERL_OTHERLIBDIRS
4656 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4657 INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4658 |INCPUSH_CAN_RELOCATE);
4661 if (!TAINTING_get) {
4664 * It isn't possible to delete an environment variable with
4665 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4666 * case we treat PERL5LIB as undefined if it has a zero-length value.
4668 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4669 if (perl5lib && *perl5lib != '\0')
4673 incpush_use_sep(perl5lib, 0,
4674 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4676 /* Treat PERL5?LIB as a possible search list logical name -- the
4677 * "natural" VMS idiom for a Unix path string. We allow each
4678 * element to be a set of |-separated directories for compatibility.
4682 if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
4684 incpush_use_sep(buf, 0,
4685 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4686 } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
4690 /* Use the ~-expanded versions of APPLLIB (undocumented),
4691 SITELIB and VENDORLIB for older versions
4694 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4695 |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4698 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4699 /* Search for version-specific dirs below here */
4700 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4701 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4705 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4706 /* Search for version-specific dirs below here */
4707 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4708 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4711 #ifdef PERL_OTHERLIBDIRS
4712 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4713 INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4714 |INCPUSH_CAN_RELOCATE);
4716 #endif /* !PERL_IS_MINIPERL */
4718 if (!TAINTING_get) {
4719 #if !defined(PERL_IS_MINIPERL) && defined(DEFAULT_INC_EXCLUDES_DOT)
4720 const char * const unsafe = PerlEnv_getenv("PERL_USE_UNSAFE_INC");
4721 if (unsafe && strEQ(unsafe, "1"))
4723 S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4727 #if defined(DOSISH) || defined(__SYMBIAN32__)
4728 # define PERLLIB_SEP ';'
4731 # define PERLLIB_SEP PL_perllib_sep
4733 # define PERLLIB_SEP ':'
4736 #ifndef PERLLIB_MANGLE
4737 # define PERLLIB_MANGLE(s,n) (s)
4740 #ifndef PERL_IS_MINIPERL
4741 /* Push a directory onto @INC if it exists.
4742 Generate a new SV if we do this, to save needing to copy the SV we push
4745 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4749 PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4751 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4752 S_ISDIR(tmpstatbuf.st_mode)) {
4754 dir = newSVsv(stem);
4756 /* Truncate dir back to stem. */
4757 SvCUR_set(dir, SvCUR(stem));
4764 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4766 const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4769 PERL_ARGS_ASSERT_MAYBERELOCATE;
4772 /* I am not convinced that this is valid when PERLLIB_MANGLE is
4773 defined to so something (in os2/os2.c), but the code has been
4774 this way, ignoring any possible changed of length, since
4775 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4777 libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4783 if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4785 while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */
4786 sv_usepvn(libdir,unix,len);
4789 PerlIO_printf(Perl_error_log,
4790 "Failed to unixify @INC element \"%s\"\n",
4791 SvPV_nolen_const(libdir));
4795 /* Do the if() outside the #ifdef to avoid warnings about an unused
4798 #ifdef PERL_RELOCATABLE_INC
4800 * Relocatable include entries are marked with a leading .../
4803 * 0: Remove that leading ".../"
4804 * 1: Remove trailing executable name (anything after the last '/')
4805 * from the perl path to give a perl prefix
4807 * While the @INC element starts "../" and the prefix ends with a real
4808 * directory (ie not . or ..) chop that real directory off the prefix
4809 * and the leading "../" from the @INC element. ie a logical "../"
4811 * Finally concatenate the prefix and the remainder of the @INC element
4812 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4813 * generates /usr/local/lib/perl5
4815 const char *libpath = SvPVX(libdir);
4816 STRLEN libpath_len = SvCUR(libdir);
4817 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4819 SV * const caret_X = get_sv("\030", 0);
4820 /* Going to use the SV just as a scratch buffer holding a C
4826 /* $^X is *the* source of taint if tainting is on, hence
4827 SvPOK() won't be true. */
4829 assert(SvPOKp(caret_X));
4830 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4832 /* Firstly take off the leading .../
4833 If all else fail we'll do the paths relative to the current
4835 sv_chop(libdir, libpath + 4);
4836 /* Don't use SvPV as we're intentionally bypassing taining,
4837 mortal copies that the mg_get of tainting creates, and
4838 corruption that seems to come via the save stack.
4839 I guess that the save stack isn't correctly set up yet. */
4840 libpath = SvPVX(libdir);
4841 libpath_len = SvCUR(libdir);
4843 /* This would work more efficiently with memrchr, but as it's
4844 only a GNU extension we'd need to probe for it and
4845 implement our own. Not hard, but maybe not worth it? */
4847 prefix = SvPVX(prefix_sv);
4848 lastslash = strrchr(prefix, '/');
4850 /* First time in with the *lastslash = '\0' we just wipe off
4851 the trailing /perl from (say) /usr/foo/bin/perl
4855 while ((*lastslash = '\0'), /* Do that, come what may. */
4856 (libpath_len >= 3 && _memEQs(libpath, "../")
4857 && (lastslash = strrchr(prefix, '/')))) {
4858 if (lastslash[1] == '\0'
4859 || (lastslash[1] == '.'
4860 && (lastslash[2] == '/' /* ends "/." */
4861 || (lastslash[2] == '/'
4862 && lastslash[3] == '/' /* or "/.." */
4864 /* Prefix ends "/" or "/." or "/..", any of which
4865 are fishy, so don't do any more logical cleanup.
4869 /* Remove leading "../" from path */
4872 /* Next iteration round the loop removes the last
4873 directory name from prefix by writing a '\0' in
4874 the while clause. */
4876 /* prefix has been terminated with a '\0' to the correct
4877 length. libpath points somewhere into the libdir SV.
4878 We need to join the 2 with '/' and drop the result into
4880 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4881 SvREFCNT_dec(libdir);
4882 /* And this is the new libdir. */
4885 (PerlProc_getuid() != PerlProc_geteuid() ||
4886 PerlProc_getgid() != PerlProc_getegid())) {
4887 /* Need to taint relocated paths if running set ID */
4888 SvTAINTED_on(libdir);
4891 SvREFCNT_dec(prefix_sv);
4899 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4901 #ifndef PERL_IS_MINIPERL
4902 const U8 using_sub_dirs
4903 = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4904 |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4905 const U8 add_versioned_sub_dirs
4906 = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4907 const U8 add_archonly_sub_dirs
4908 = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4909 #ifdef PERL_INC_VERSION_LIST
4910 const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
4913 const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
4914 const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4915 AV *const inc = GvAVn(PL_incgv);
4917 PERL_ARGS_ASSERT_INCPUSH;
4920 /* Could remove this vestigial extra block, if we don't mind a lot of
4921 re-indenting diff noise. */
4923 SV *const libdir = mayberelocate(dir, len, flags);
4924 /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4925 arranged to unshift #! line -I onto the front of @INC. However,
4926 -I can add version and architecture specific libraries, and they
4927 need to go first. The old code assumed that it was always
4928 pushing. Hence to make it work, need to push the architecture
4929 (etc) libraries onto a temporary array, then "unshift" that onto
4930 the front of @INC. */
4931 #ifndef PERL_IS_MINIPERL
4932 AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4935 * BEFORE pushing libdir onto @INC we may first push version- and
4936 * archname-specific sub-directories.
4938 if (using_sub_dirs) {
4939 SV *subdir = newSVsv(libdir);
4940 #ifdef PERL_INC_VERSION_LIST
4941 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4942 const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4943 const char * const *incver;
4946 if (add_versioned_sub_dirs) {
4947 /* .../version/archname if -d .../version/archname */
4948 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4949 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4951 /* .../version if -d .../version */
4952 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4953 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4956 #ifdef PERL_INC_VERSION_LIST
4958 for (incver = incverlist; *incver; incver++) {
4959 /* .../xxx if -d .../xxx */
4960 Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4961 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4966 if (add_archonly_sub_dirs) {
4967 /* .../archname if -d .../archname */
4968 sv_catpvs(subdir, "/" ARCHNAME);
4969 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4973 assert (SvREFCNT(subdir) == 1);
4974 SvREFCNT_dec(subdir);
4976 #endif /* !PERL_IS_MINIPERL */
4977 /* finally add this lib directory at the end of @INC */
4979 #ifdef PERL_IS_MINIPERL
4980 const Size_t extra = 0;
4982 Size_t extra = av_tindex(av) + 1;
4984 av_unshift(inc, extra + push_basedir);
4986 av_store(inc, extra, libdir);
4987 #ifndef PERL_IS_MINIPERL
4989 /* av owns a reference, av_store() expects to be donated a
4990 reference, and av expects to be sane when it's cleared.
4991 If I wanted to be naughty and wrong, I could peek inside the
4992 implementation of av_clear(), realise that it uses
4993 SvREFCNT_dec() too, so av's array could be a run of NULLs,
4994 and so directly steal from it (with a memcpy() to inc, and
4995 then memset() to NULL them out. But people copy code from the
4996 core expecting it to be best practise, so let's use the API.
4997 Although studious readers will note that I'm not checking any
4999 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
5004 else if (push_basedir) {
5005 av_push(inc, libdir);
5008 if (!push_basedir) {
5009 assert (SvREFCNT(libdir) == 1);
5010 SvREFCNT_dec(libdir);
5016 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
5020 /* This logic has been broken out from S_incpush(). It may be possible to
5023 PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
5025 /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
5026 * argument to incpush_use_sep. This allows creation of relocatable
5027 * Perl distributions that patch the binary at install time. Those
5028 * distributions will have to provide their own relocation tools; this
5029 * is not a feature otherwise supported by core Perl.
5031 #ifndef PERL_RELOCATABLE_INCPUSH
5038 /* Break at all separators */
5039 while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
5041 /* skip any consecutive separators */
5043 /* Uncomment the next line for PATH semantics */
5044 /* But you'll need to write tests */
5045 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
5047 incpush(p, (STRLEN)(s - p), flags);
5052 incpush(p, (STRLEN)(end - p), flags);
5057 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
5060 VOL const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
5066 PERL_ARGS_ASSERT_CALL_LIST;
5068 while (av_tindex(paramList) >= 0) {
5069 cv = MUTABLE_CV(av_shift(paramList));
5071 if (paramList == PL_beginav) {
5072 /* save PL_beginav for compiler */
5073 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
5075 else if (paramList == PL_checkav) {
5076 /* save PL_checkav for compiler */
5077 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
5079 else if (paramList == PL_unitcheckav) {
5080 /* save PL_unitcheckav for compiler */
5081 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
5091 (void)SvPV_const(atsv, len);
5093 PL_curcop = &PL_compiling;
5094 CopLINE_set(PL_curcop, oldline);
5095 if (paramList == PL_beginav)
5096 sv_catpvs(atsv, "BEGIN failed--compilation aborted");
5098 Perl_sv_catpvf(aTHX_ atsv,
5099 "%s failed--call queue aborted",
5100 paramList == PL_checkav ? "CHECK"
5101 : paramList == PL_initav ? "INIT"
5102 : paramList == PL_unitcheckav ? "UNITCHECK"
5104 while (PL_scopestack_ix > oldscope)
5107 Perl_croak(aTHX_ "%" SVf, SVfARG(atsv));
5114 /* my_exit() was called */
5115 while (PL_scopestack_ix > oldscope)
5118 SET_CURSTASH(PL_defstash);
5119 PL_curcop = &PL_compiling;
5120 CopLINE_set(PL_curcop, oldline);
5123 NOT_REACHED; /* NOTREACHED */
5126 PL_curcop = &PL_compiling;
5127 CopLINE_set(PL_curcop, oldline);
5130 PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
5139 Perl_my_exit(pTHX_ U32 status)
5141 if (PL_exit_flags & PERL_EXIT_ABORT) {
5144 if (PL_exit_flags & PERL_EXIT_WARN) {
5145 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
5146 Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status);
5147 PL_exit_flags &= ~PERL_EXIT_ABORT;
5157 STATUS_EXIT_SET(status);
5164 Perl_my_failure_exit(pTHX)
5167 /* We have been called to fall on our sword. The desired exit code
5168 * should be already set in STATUS_UNIX, but could be shifted over
5169 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
5172 * If an error code has not been set, then force the issue.
5174 if (MY_POSIX_EXIT) {
5176 /* According to the die_exit.t tests, if errno is non-zero */
5177 /* It should be used for the error status. */
5179 if (errno == EVMSERR) {
5180 STATUS_NATIVE = vaxc$errno;
5183 /* According to die_exit.t tests, if the child_exit code is */
5184 /* also zero, then we need to exit with a code of 255 */
5185 if ((errno != 0) && (errno < 256))
5186 STATUS_UNIX_EXIT_SET(errno);
5187 else if (STATUS_UNIX < 255) {
5188 STATUS_UNIX_EXIT_SET(255);
5193 /* The exit code could have been set by $? or vmsish which
5194 * means that it may not have fatal set. So convert
5195 * success/warning codes to fatal with out changing
5196 * the POSIX status code. The severity makes VMS native
5197 * status handling work, while UNIX mode programs use the
5198 * the POSIX exit codes.
5200 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
5201 STATUS_NATIVE &= STS$M_COND_ID;
5202 STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
5206 /* Traditionally Perl on VMS always expects a Fatal Error. */
5207 if (vaxc$errno & 1) {
5209 /* So force success status to failure */
5210 if (STATUS_NATIVE & 1)
5215 STATUS_UNIX = EINTR; /* In case something cares */
5220 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5222 /* Encode the severity code */
5223 severity = STATUS_NATIVE & STS$M_SEVERITY;
5224 STATUS_UNIX = (severity ? severity : 1) << 8;
5226 /* Perl expects this to be a fatal error */
5227 if (severity != STS$K_SEVERE)
5236 STATUS_UNIX_SET(errno);
5238 exitstatus = STATUS_UNIX >> 8;
5239 if (exitstatus & 255)
5240 STATUS_UNIX_SET(exitstatus);
5242 STATUS_UNIX_SET(255);
5245 if (PL_exit_flags & PERL_EXIT_ABORT) {
5248 if (PL_exit_flags & PERL_EXIT_WARN) {
5249 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
5250 Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue);
5251 PL_exit_flags &= ~PERL_EXIT_ABORT;
5257 S_my_exit_jump(pTHX)
5260 SvREFCNT_dec(PL_e_script);
5264 POPSTACK_TO(PL_mainstack);
5265 if (cxstack_ix >= 0) {
5267 cx_popblock(cxstack);
5275 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5277 const char * const p = SvPVX_const(PL_e_script);
5278 const char *nl = strchr(p, '\n');
5280 PERL_UNUSED_ARG(idx);
5281 PERL_UNUSED_ARG(maxlen);
5283 nl = (nl) ? nl+1 : SvEND(PL_e_script);
5285 filter_del(read_e_script);
5288 sv_catpvn(buf_sv, p, nl-p);
5289 sv_chop(PL_e_script, nl);
5293 /* removes boilerplate code at the end of each boot_Module xsub */
5295 Perl_xs_boot_epilog(pTHX_ const I32 ax)
5298 call_list(PL_scopestack_ix, PL_unitcheckav);
5303 * ex: set ts=8 sts=4 sw=4 et: