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 * 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
27 #if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
28 # define USE_SITECUSTOMIZE
32 #define PERL_IN_PERL_C
34 #include "patchlevel.h" /* for local_patches */
41 #ifdef USE_KERN_PROC_PATHNAME
42 # include <sys/sysctl.h>
45 #ifdef USE_NSGETEXECUTABLEPATH
46 # include <mach-o/dyld.h>
49 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
56 char control[CMSG_SPACE(sizeof(int))];
69 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
70 char *getenv (char *); /* Usually in <stdlib.h> */
73 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
75 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
76 # define validate_suid(rsfp) NOOP
78 # define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
81 #define CALL_BODY_SUB(myop) \
82 if (PL_op == (myop)) \
83 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
87 #define CALL_LIST_BODY(cv) \
88 PUSHMARK(PL_stack_sp); \
89 call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
92 S_init_tls_and_interp(PerlInterpreter *my_perl)
96 PERL_SET_INTERP(my_perl);
97 #if defined(USE_ITHREADS)
100 PERL_SET_THX(my_perl);
104 MUTEX_INIT(&PL_dollarzero_mutex);
105 MUTEX_INIT(&PL_my_ctx_mutex);
108 #if defined(USE_ITHREADS)
111 /* This always happens for non-ithreads */
114 PERL_SET_THX(my_perl);
119 /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
122 Perl_sys_init(int* argc, char*** argv)
126 PERL_ARGS_ASSERT_SYS_INIT;
128 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
129 PERL_UNUSED_ARG(argv);
130 PERL_SYS_INIT_BODY(argc, argv);
134 Perl_sys_init3(int* argc, char*** argv, char*** env)
138 PERL_ARGS_ASSERT_SYS_INIT3;
140 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
141 PERL_UNUSED_ARG(argv);
142 PERL_UNUSED_ARG(env);
143 PERL_SYS_INIT3_BODY(argc, argv, env);
150 if (!PL_veto_cleanup) {
151 PERL_SYS_TERM_BODY();
156 #ifdef PERL_IMPLICIT_SYS
158 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
159 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
160 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
161 struct IPerlDir* ipD, struct IPerlSock* ipS,
162 struct IPerlProc* ipP)
164 PerlInterpreter *my_perl;
166 PERL_ARGS_ASSERT_PERL_ALLOC_USING;
168 /* Newx() needs interpreter, so call malloc() instead */
169 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
170 S_init_tls_and_interp(my_perl);
171 Zero(my_perl, 1, PerlInterpreter);
181 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
188 =head1 Embedding Functions
190 =for apidoc perl_alloc
192 Allocates a new Perl interpreter. See L<perlembed>.
200 PerlInterpreter *my_perl;
202 /* Newx() needs interpreter, so call malloc() instead */
203 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
205 S_init_tls_and_interp(my_perl);
206 #ifndef PERL_TRACK_MEMPOOL
207 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
209 Zero(my_perl, 1, PerlInterpreter);
210 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
214 #endif /* PERL_IMPLICIT_SYS */
217 =for apidoc perl_construct
219 Initializes a new Perl interpreter. See L<perlembed>.
225 perl_construct(pTHXx)
229 PERL_ARGS_ASSERT_PERL_CONSTRUCT;
233 PL_perl_destruct_level = 1;
235 PERL_UNUSED_ARG(my_perl);
236 if (PL_perl_destruct_level > 0)
239 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
241 #ifdef PERL_TRACE_OPS
242 Zero(PL_op_exec_cnt, OP_max+2, UV);
247 SvREADONLY_on(&PL_sv_placeholder);
248 SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
250 PL_sighandlerp = (Sighandler_t) Perl_sighandler;
251 #ifdef PERL_USES_PL_PIDSTATUS
252 PL_pidstatus = newHV();
255 PL_rs = newSVpvs("\n");
265 SET_NUMERIC_STANDARD();
267 #if defined(LOCAL_PATCH_COUNT)
268 PL_localpatches = local_patches; /* For possible -v */
271 #ifdef HAVE_INTERP_INTERN
275 PerlIO_init(aTHX); /* Hook to IO system */
277 PL_fdpid = newAV(); /* for remembering popen pids by fd */
278 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
279 PL_errors = newSVpvs("");
280 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
281 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
282 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
284 /* First entry is a list of empty elements. It needs to be initialised
285 else all hell breaks loose in S_find_uninit_var(). */
286 Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
287 PL_regex_pad = AvARRAY(PL_regex_padav);
288 Newxz(PL_stashpad, PL_stashpadmax, HV *);
290 #ifdef USE_REENTRANT_API
291 Perl_reentrant_init(aTHX);
293 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
294 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
295 * This MUST be done before any hash stores or fetches take place.
296 * If you set PL_hash_seed (and presumably also PL_hash_seed_set)
297 * yourself, it is your responsibility to provide a good random seed!
298 * You can also define PERL_HASH_SEED in compile time, see hv.h.
300 * XXX: fix this comment */
301 if (PL_hash_seed_set == FALSE) {
302 Perl_get_hash_seed(aTHX_ PL_hash_seed);
303 PL_hash_seed_set= TRUE;
305 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
307 /* Note that strtab is a rather special HV. Assumptions are made
308 about not iterating on it, and not adding tie magic to it.
309 It is properly deallocated in perl_destruct() */
312 HvSHAREKEYS_off(PL_strtab); /* mandatory */
313 hv_ksplit(PL_strtab, 512);
315 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
317 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
318 _dyld_lookup_and_bind
319 ("__environ", (unsigned long *) &environ_pointer, NULL);
323 # ifdef USE_ENVIRON_ARRAY
324 PL_origenviron = environ;
328 /* Use sysconf(_SC_CLK_TCK) if available, if not
329 * available or if the sysconf() fails, use the HZ.
330 * The HZ if not originally defined has been by now
331 * been defined as CLK_TCK, if available. */
332 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
333 PL_clocktick = sysconf(_SC_CLK_TCK);
334 if (PL_clocktick <= 0)
338 PL_stashcache = newHV();
340 PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
341 PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING);
344 if (!PL_mmap_page_size) {
345 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
347 SETERRNO(0, SS_NORMAL);
349 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
351 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
353 if ((long) PL_mmap_page_size < 0) {
355 SV * const error = ERRSV;
356 SvUPGRADE(error, SVt_PV);
357 Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
360 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
364 # ifdef HAS_GETPAGESIZE
365 PL_mmap_page_size = getpagesize();
367 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
368 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
372 if (PL_mmap_page_size <= 0)
373 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
374 (IV) PL_mmap_page_size);
376 #endif /* HAS_MMAP */
378 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
379 PL_timesbase.tms_utime = 0;
380 PL_timesbase.tms_stime = 0;
381 PL_timesbase.tms_cutime = 0;
382 PL_timesbase.tms_cstime = 0;
385 PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
387 PL_registered_mros = newHV();
388 /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
389 HvMAX(PL_registered_mros) = 0;
395 =for apidoc nothreadhook
397 Stub that provides thread hook for perl_destruct when there are
404 Perl_nothreadhook(pTHX)
410 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
412 Perl_dump_sv_child(pTHX_ SV *sv)
415 const int sock = PL_dumper_fd;
416 const int debug_fd = PerlIO_fileno(Perl_debug_log);
417 union control_un control;
420 struct cmsghdr *cmptr;
422 unsigned char buffer[256];
424 PERL_ARGS_ASSERT_DUMP_SV_CHILD;
426 if(sock == -1 || debug_fd == -1)
429 PerlIO_flush(Perl_debug_log);
431 /* All these shenanigans are to pass a file descriptor over to our child for
432 it to dump out to. We can't let it hold open the file descriptor when it
433 forks, as the file descriptor it will dump to can turn out to be one end
434 of pipe that some other process will wait on for EOF. (So as it would
435 be open, the wait would be forever.) */
437 msg.msg_control = control.control;
438 msg.msg_controllen = sizeof(control.control);
439 /* We're a connected socket so we don't need a destination */
445 cmptr = CMSG_FIRSTHDR(&msg);
446 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
447 cmptr->cmsg_level = SOL_SOCKET;
448 cmptr->cmsg_type = SCM_RIGHTS;
449 *((int *)CMSG_DATA(cmptr)) = 1;
451 vec[0].iov_base = (void*)&sv;
452 vec[0].iov_len = sizeof(sv);
453 got = sendmsg(sock, &msg, 0);
456 perror("Debug leaking scalars parent sendmsg failed");
459 if(got < sizeof(sv)) {
460 perror("Debug leaking scalars parent short sendmsg");
464 /* Return protocol is
466 unsigned char: length of location string (0 for empty)
467 unsigned char*: string (not terminated)
469 vec[0].iov_base = (void*)&returned_errno;
470 vec[0].iov_len = sizeof(returned_errno);
471 vec[1].iov_base = buffer;
474 got = readv(sock, vec, 2);
477 perror("Debug leaking scalars parent read failed");
478 PerlIO_flush(PerlIO_stderr());
481 if(got < sizeof(returned_errno) + 1) {
482 perror("Debug leaking scalars parent short read");
483 PerlIO_flush(PerlIO_stderr());
488 got = read(sock, buffer + 1, *buffer);
490 perror("Debug leaking scalars parent read 2 failed");
491 PerlIO_flush(PerlIO_stderr());
496 perror("Debug leaking scalars parent short read 2");
497 PerlIO_flush(PerlIO_stderr());
502 if (returned_errno || *buffer) {
503 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
504 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
505 returned_errno, strerror(returned_errno));
511 =for apidoc perl_destruct
513 Shuts down a Perl interpreter. See L<perlembed>.
522 VOL signed char destruct_level; /* see possible values in intrpvar.h */
524 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
529 PERL_ARGS_ASSERT_PERL_DESTRUCT;
531 PERL_UNUSED_ARG(my_perl);
534 assert(PL_scopestack_ix == 1);
536 /* wait for all pseudo-forked children to finish */
537 PERL_WAIT_FOR_CHILDREN;
539 destruct_level = PL_perl_destruct_level;
540 #if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL)
542 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
544 const int i = atoi(s);
546 if (destruct_level < i) destruct_level = i;
548 #ifdef PERL_TRACK_MEMPOOL
549 /* RT #114496, for perl_free */
550 PL_perl_destruct_level = i;
556 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
562 if (PL_endav && !PL_minus_c) {
563 PERL_SET_PHASE(PERL_PHASE_END);
564 call_list(PL_scopestack_ix, PL_endav);
570 assert(PL_scopestack_ix == 0);
572 /* Need to flush since END blocks can produce output */
575 #ifdef PERL_TRACE_OPS
576 /* If we traced all Perl OP usage, report and clean up */
577 PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
578 for (i = 0; i <= OP_max; ++i) {
579 PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
580 PL_op_exec_cnt[i] = 0;
582 /* Utility slot for easily doing little tracing experiments in the runloop: */
583 if (PL_op_exec_cnt[OP_max+1] != 0)
584 PerlIO_printf(Perl_debug_log, " SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]);
585 PerlIO_printf(Perl_debug_log, "\n");
589 if (PL_threadhook(aTHX)) {
590 /* Threads hook has vetoed further cleanup */
591 PL_veto_cleanup = TRUE;
595 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
596 if (destruct_level != 0) {
597 /* Fork here to create a child. Our child's job is to preserve the
598 state of scalars prior to destruction, so that we can instruct it
599 to dump any scalars that we later find have leaked.
600 There's no subtlety in this code - it assumes POSIX, and it doesn't
604 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
605 perror("Debug leaking scalars socketpair failed");
611 perror("Debug leaking scalars fork failed");
615 /* We are the child */
616 const int sock = fd[1];
617 const int debug_fd = PerlIO_fileno(Perl_debug_log);
620 /* Our success message is an integer 0, and a char 0 */
621 static const char success[sizeof(int) + 1] = {0};
625 /* We need to close all other file descriptors otherwise we end up
626 with interesting hangs, where the parent closes its end of a
627 pipe, and sits waiting for (another) child to terminate. Only
628 that child never terminates, because it never gets EOF, because
629 we also have the far end of the pipe open. We even need to
630 close the debugging fd, because sometimes it happens to be one
631 end of a pipe, and a process is waiting on the other end for
632 EOF. Normally it would be closed at some point earlier in
633 destruction, but if we happen to cause the pipe to remain open,
634 EOF never occurs, and we get an infinite hang. Hence all the
635 games to pass in a file descriptor if it's actually needed. */
637 f = sysconf(_SC_OPEN_MAX);
639 where = "sysconf failed";
650 union control_un control;
653 struct cmsghdr *cmptr;
657 msg.msg_control = control.control;
658 msg.msg_controllen = sizeof(control.control);
659 /* We're a connected socket so we don't need a source */
663 msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
665 vec[0].iov_base = (void*)⌖
666 vec[0].iov_len = sizeof(target);
668 got = recvmsg(sock, &msg, 0);
673 where = "recv failed";
676 if(got < sizeof(target)) {
677 where = "short recv";
681 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
685 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
686 where = "wrong cmsg_len";
689 if(cmptr->cmsg_level != SOL_SOCKET) {
690 where = "wrong cmsg_level";
693 if(cmptr->cmsg_type != SCM_RIGHTS) {
694 where = "wrong cmsg_type";
698 got_fd = *(int*)CMSG_DATA(cmptr);
699 /* For our last little bit of trickery, put the file descriptor
700 back into Perl_debug_log, as if we never actually closed it
702 if(got_fd != debug_fd) {
703 if (dup2(got_fd, debug_fd) == -1) {
710 PerlIO_flush(Perl_debug_log);
712 got = write(sock, &success, sizeof(success));
715 where = "write failed";
718 if(got < sizeof(success)) {
719 where = "short write";
726 int send_errno = errno;
727 unsigned char length = (unsigned char) strlen(where);
728 struct iovec failure[3] = {
729 {(void*)&send_errno, sizeof(send_errno)},
731 {(void*)where, length}
733 int got = writev(sock, failure, 3);
734 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
735 in the parent if we try to read from the socketpair after the
736 child has exited, even if there was data to read.
737 So sleep a bit to give the parent a fighting chance of
740 _exit((got == -1) ? errno : 0);
744 PL_dumper_fd = fd[0];
749 /* We must account for everything. */
751 /* Destroy the main CV and syntax tree */
752 /* Set PL_curcop now, because destroying ops can cause new SVs
753 to be generated in Perl_pad_swipe, and when running with
754 -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
755 op from which the filename structure member is copied. */
756 PL_curcop = &PL_compiling;
758 /* ensure comppad/curpad to refer to main's pad */
759 if (CvPADLIST(PL_main_cv)) {
760 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
762 op_free(PL_main_root);
765 PL_main_start = NULL;
766 /* note that PL_main_cv isn't usually actually freed at this point,
767 * due to the CvOUTSIDE refs from subs compiled within it. It will
768 * get freed once all the subs are freed in sv_clean_all(), for
769 * destruct_level > 0 */
770 SvREFCNT_dec(PL_main_cv);
772 PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
774 /* Tell PerlIO we are about to tear things apart in case
775 we have layers which are using resources that should
779 PerlIO_destruct(aTHX);
782 * Try to destruct global references. We do this first so that the
783 * destructors and destructees still exist. Some sv's might remain.
784 * Non-referenced objects are on their own.
788 /* unhook hooks which will soon be, or use, destroyed data */
789 SvREFCNT_dec(PL_warnhook);
791 SvREFCNT_dec(PL_diehook);
794 /* call exit list functions */
795 while (PL_exitlistlen-- > 0)
796 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
798 Safefree(PL_exitlist);
803 SvREFCNT_dec(PL_registered_mros);
805 /* jettison our possibly duplicated environment */
806 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
807 * so we certainly shouldn't free it here
810 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
811 if (environ != PL_origenviron && !PL_use_safe_putenv
813 /* only main thread can free environ[0] contents */
814 && PL_curinterp == aTHX
820 for (i = 0; environ[i]; i++)
821 safesysfree(environ[i]);
823 /* Must use safesysfree() when working with environ. */
824 safesysfree(environ);
826 environ = PL_origenviron;
829 #endif /* !PERL_MICRO */
831 if (destruct_level == 0) {
833 DEBUG_P(debprofdump());
835 #if defined(PERLIO_LAYERS)
836 /* No more IO - including error messages ! */
837 PerlIO_cleanup(aTHX);
840 CopFILE_free(&PL_compiling);
842 /* The exit() function will do everything that needs doing. */
847 /* the syntax tree is shared between clones
848 * so op_free(PL_main_root) only ReREFCNT_dec's
849 * REGEXPs in the parent interpreter
850 * we need to manually ReREFCNT_dec for the clones
853 I32 i = AvFILLp(PL_regex_padav);
854 SV **ary = AvARRAY(PL_regex_padav);
857 SvREFCNT_dec(ary[i]);
858 ary[i] = &PL_sv_undef;
864 SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
865 PL_stashcache = NULL;
867 /* loosen bonds of global variables */
869 /* XXX can PL_parser still be non-null here? */
870 if(PL_parser && PL_parser->rsfp) {
871 (void)PerlIO_close(PL_parser->rsfp);
872 PL_parser->rsfp = NULL;
876 Safefree(PL_splitstr);
886 PL_doswitches = FALSE;
887 PL_dowarn = G_WARN_OFF;
888 #ifdef PERL_SAWAMPERSAND
889 PL_sawampersand = 0; /* must save all match strings */
893 Safefree(PL_inplace);
895 SvREFCNT_dec(PL_patchlevel);
896 SvREFCNT_dec(PL_apiversion);
899 SvREFCNT_dec(PL_e_script);
905 /* magical thingies */
907 SvREFCNT_dec(PL_ofsgv); /* *, */
910 SvREFCNT_dec(PL_ors_sv); /* $\ */
913 SvREFCNT_dec(PL_rs); /* $/ */
916 Safefree(PL_osname); /* $^O */
919 SvREFCNT_dec(PL_statname);
923 /* defgv, aka *_ should be taken care of elsewhere */
926 Safefree(PL_efloatbuf);
930 /* startup and shutdown function lists */
931 SvREFCNT_dec(PL_beginav);
932 SvREFCNT_dec(PL_beginav_save);
933 SvREFCNT_dec(PL_endav);
934 SvREFCNT_dec(PL_checkav);
935 SvREFCNT_dec(PL_checkav_save);
936 SvREFCNT_dec(PL_unitcheckav);
937 SvREFCNT_dec(PL_unitcheckav_save);
938 SvREFCNT_dec(PL_initav);
940 PL_beginav_save = NULL;
943 PL_checkav_save = NULL;
944 PL_unitcheckav = NULL;
945 PL_unitcheckav_save = NULL;
948 /* shortcuts just get cleared */
957 PL_last_in_gv = NULL;
969 SvREFCNT_dec(PL_argvout_stack);
970 PL_argvout_stack = NULL;
972 SvREFCNT_dec(PL_modglobal);
974 SvREFCNT_dec(PL_preambleav);
975 PL_preambleav = NULL;
976 SvREFCNT_dec(PL_subname);
978 #ifdef PERL_USES_PL_PIDSTATUS
979 SvREFCNT_dec(PL_pidstatus);
982 SvREFCNT_dec(PL_toptarget);
984 SvREFCNT_dec(PL_bodytarget);
985 PL_bodytarget = NULL;
986 PL_formtarget = NULL;
988 /* free locale stuff */
989 #ifdef USE_LOCALE_COLLATE
990 Safefree(PL_collation_name);
991 PL_collation_name = NULL;
994 #ifdef USE_LOCALE_NUMERIC
995 Safefree(PL_numeric_name);
996 PL_numeric_name = NULL;
997 SvREFCNT_dec(PL_numeric_radix_sv);
998 PL_numeric_radix_sv = NULL;
1001 /* clear character classes */
1002 for (i = 0; i < POSIX_SWASH_COUNT; i++) {
1003 SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
1004 PL_utf8_swash_ptrs[i] = NULL;
1006 SvREFCNT_dec(PL_utf8_mark);
1007 SvREFCNT_dec(PL_utf8_toupper);
1008 SvREFCNT_dec(PL_utf8_totitle);
1009 SvREFCNT_dec(PL_utf8_tolower);
1010 SvREFCNT_dec(PL_utf8_tofold);
1011 SvREFCNT_dec(PL_utf8_idstart);
1012 SvREFCNT_dec(PL_utf8_idcont);
1013 SvREFCNT_dec(PL_utf8_foldclosures);
1014 PL_utf8_mark = NULL;
1015 PL_utf8_toupper = NULL;
1016 PL_utf8_totitle = NULL;
1017 PL_utf8_tolower = NULL;
1018 PL_utf8_tofold = NULL;
1019 PL_utf8_idstart = NULL;
1020 PL_utf8_idcont = NULL;
1021 PL_utf8_foldclosures = NULL;
1022 for (i = 0; i < POSIX_CC_COUNT; i++) {
1023 SvREFCNT_dec(PL_Posix_ptrs[i]);
1024 PL_Posix_ptrs[i] = NULL;
1026 SvREFCNT_dec(PL_L1Posix_ptrs[i]);
1027 PL_L1Posix_ptrs[i] = NULL;
1029 SvREFCNT_dec(PL_XPosix_ptrs[i]);
1030 PL_XPosix_ptrs[i] = NULL;
1033 if (!specialWARN(PL_compiling.cop_warnings))
1034 PerlMemShared_free(PL_compiling.cop_warnings);
1035 PL_compiling.cop_warnings = NULL;
1036 cophh_free(CopHINTHASH_get(&PL_compiling));
1037 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
1038 CopFILE_free(&PL_compiling);
1040 /* Prepare to destruct main symbol table. */
1043 /* break ref loop *:: <=> %:: */
1044 (void)hv_delete(hv, "main::", 6, G_DISCARD);
1047 SvREFCNT_dec(PL_curstname);
1048 PL_curstname = NULL;
1050 /* clear queued errors */
1051 SvREFCNT_dec(PL_errors);
1054 SvREFCNT_dec(PL_isarev);
1057 if (destruct_level >= 2) {
1058 if (PL_scopestack_ix != 0)
1059 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1060 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1061 (long)PL_scopestack_ix);
1062 if (PL_savestack_ix != 0)
1063 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1064 "Unbalanced saves: %ld more saves than restores\n",
1065 (long)PL_savestack_ix);
1066 if (PL_tmps_floor != -1)
1067 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1068 (long)PL_tmps_floor + 1);
1069 if (cxstack_ix != -1)
1070 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1071 (long)cxstack_ix + 1);
1075 SvREFCNT_dec(PL_regex_padav);
1076 PL_regex_padav = NULL;
1077 PL_regex_pad = NULL;
1080 #ifdef PERL_IMPLICIT_CONTEXT
1081 /* the entries in this list are allocated via SV PVX's, so get freed
1082 * in sv_clean_all */
1083 Safefree(PL_my_cxt_list);
1086 /* Now absolutely destruct everything, somehow or other, loops or no. */
1088 /* the 2 is for PL_fdpid and PL_strtab */
1089 while (sv_clean_all() > 2)
1093 Safefree(PL_stashpad); /* must come after sv_clean_all */
1096 AvREAL_off(PL_fdpid); /* no surviving entries */
1097 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
1100 #ifdef HAVE_INTERP_INTERN
1104 /* constant strings */
1105 for (i = 0; i < SV_CONSTS_COUNT; i++) {
1106 SvREFCNT_dec(PL_sv_consts[i]);
1107 PL_sv_consts[i] = NULL;
1110 /* Destruct the global string table. */
1112 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1113 * so that sv_free() won't fail on them.
1114 * Now that the global string table is using a single hunk of memory
1115 * for both HE and HEK, we either need to explicitly unshare it the
1116 * correct way, or actually free things here.
1119 const I32 max = HvMAX(PL_strtab);
1120 HE * const * const array = HvARRAY(PL_strtab);
1121 HE *hent = array[0];
1124 if (hent && ckWARN_d(WARN_INTERNAL)) {
1125 HE * const next = HeNEXT(hent);
1126 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1127 "Unbalanced string table refcount: (%ld) for \"%s\"",
1128 (long)hent->he_valu.hent_refcount, HeKEY(hent));
1135 hent = array[riter];
1140 HvARRAY(PL_strtab) = 0;
1141 HvTOTALKEYS(PL_strtab) = 0;
1143 SvREFCNT_dec(PL_strtab);
1146 /* free the pointer tables used for cloning */
1147 ptr_table_free(PL_ptr_table);
1148 PL_ptr_table = (PTR_TBL_t*)NULL;
1151 /* free special SVs */
1153 SvREFCNT(&PL_sv_yes) = 0;
1154 sv_clear(&PL_sv_yes);
1155 SvANY(&PL_sv_yes) = NULL;
1156 SvFLAGS(&PL_sv_yes) = 0;
1158 SvREFCNT(&PL_sv_no) = 0;
1159 sv_clear(&PL_sv_no);
1160 SvANY(&PL_sv_no) = NULL;
1161 SvFLAGS(&PL_sv_no) = 0;
1165 for (i=0; i<=2; i++) {
1166 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1167 sv_clear(PERL_DEBUG_PAD(i));
1168 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1169 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1173 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1174 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1176 #ifdef DEBUG_LEAKING_SCALARS
1177 if (PL_sv_count != 0) {
1182 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1183 svend = &sva[SvREFCNT(sva)];
1184 for (sv = sva + 1; sv < svend; ++sv) {
1185 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
1186 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1188 " refcnt=%"UVuf pTHX__FORMAT "\n"
1189 "\tallocated at %s:%d %s %s (parent 0x%"UVxf");"
1191 (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1193 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1195 sv->sv_debug_inpad ? "for" : "by",
1196 sv->sv_debug_optype ?
1197 PL_op_name[sv->sv_debug_optype]: "(none)",
1198 PTR2UV(sv->sv_debug_parent),
1201 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1202 Perl_dump_sv_child(aTHX_ sv);
1208 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1212 /* Wait for up to 4 seconds for child to terminate.
1213 This seems to be the least effort way of timing out on reaping
1215 struct timeval waitfor = {4, 0};
1216 int sock = PL_dumper_fd;
1220 FD_SET(sock, &rset);
1221 select(sock + 1, &rset, NULL, NULL, &waitfor);
1222 waitpid(child, &status, WNOHANG);
1227 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1233 #if defined(PERLIO_LAYERS)
1234 /* No more IO - including error messages ! */
1235 PerlIO_cleanup(aTHX);
1238 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1239 as currently layers use it rather than NULL as a marker
1240 for no arg - and will try and SvREFCNT_dec it.
1242 SvREFCNT(&PL_sv_undef) = 0;
1243 SvREADONLY_off(&PL_sv_undef);
1245 Safefree(PL_origfilename);
1246 PL_origfilename = NULL;
1247 Safefree(PL_reg_curpm);
1248 free_tied_hv_pool();
1249 Safefree(PL_op_mask);
1250 Safefree(PL_psig_name);
1251 PL_psig_name = (SV**)NULL;
1252 PL_psig_ptr = (SV**)NULL;
1254 /* We need to NULL PL_psig_pend first, so that
1255 signal handlers know not to use it */
1256 int *psig_save = PL_psig_pend;
1257 PL_psig_pend = (int*)NULL;
1258 Safefree(psig_save);
1261 TAINTING_set(FALSE);
1262 TAINT_WARN_set(FALSE);
1263 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
1266 DEBUG_P(debprofdump());
1268 #ifdef USE_REENTRANT_API
1269 Perl_reentrant_free(aTHX);
1274 while (PL_regmatch_slab) {
1275 regmatch_slab *s = PL_regmatch_slab;
1276 PL_regmatch_slab = PL_regmatch_slab->next;
1280 /* As the absolutely last thing, free the non-arena SV for mess() */
1283 /* we know that type == SVt_PVMG */
1285 /* it could have accumulated taint magic */
1288 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1289 moremagic = mg->mg_moremagic;
1290 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1292 Safefree(mg->mg_ptr);
1296 /* we know that type >= SVt_PV */
1297 SvPV_free(PL_mess_sv);
1298 Safefree(SvANY(PL_mess_sv));
1299 Safefree(PL_mess_sv);
1306 =for apidoc perl_free
1308 Releases a Perl interpreter. See L<perlembed>.
1318 PERL_ARGS_ASSERT_PERL_FREE;
1320 if (PL_veto_cleanup)
1323 #ifdef PERL_TRACK_MEMPOOL
1326 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1327 * value as we're probably hunting memory leaks then
1329 if (PL_perl_destruct_level == 0) {
1330 const U32 old_debug = PL_debug;
1331 /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1332 thread at thread exit. */
1334 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1335 "free this thread's memory\n");
1336 PL_debug &= ~ DEBUG_m_FLAG;
1338 while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
1339 safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
1340 PL_debug = old_debug;
1345 #if defined(WIN32) || defined(NETWARE)
1346 # if defined(PERL_IMPLICIT_SYS)
1349 void *host = nw_internal_host;
1350 PerlMem_free(aTHXx);
1351 nw_delete_internal_host(host);
1353 void *host = w32_internal_host;
1354 PerlMem_free(aTHXx);
1355 win32_delete_internal_host(host);
1359 PerlMem_free(aTHXx);
1362 PerlMem_free(aTHXx);
1366 #if defined(USE_ITHREADS)
1367 /* provide destructors to clean up the thread key when libperl is unloaded */
1368 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1370 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1371 #pragma fini "perl_fini"
1372 #elif defined(__sun) && !defined(__GNUC__)
1373 #pragma fini (perl_fini)
1377 #if defined(__GNUC__)
1378 __attribute__((destructor))
1383 if (PL_curinterp && !PL_veto_cleanup)
1388 #endif /* THREADS */
1391 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1394 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1395 PL_exitlist[PL_exitlistlen].fn = fn;
1396 PL_exitlist[PL_exitlistlen].ptr = ptr;
1401 S_set_caret_X(pTHX) {
1403 GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
1405 SV *const caret_x = GvSV(tmpgv);
1407 sv_setpv(caret_x, os2_execname(aTHX));
1409 # ifdef USE_KERN_PROC_PATHNAME
1414 mib[2] = KERN_PROC_PATHNAME;
1417 if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
1418 && size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
1419 sv_grow(caret_x, size);
1421 if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
1423 SvPOK_only(caret_x);
1424 SvCUR_set(caret_x, size - 1);
1429 # elif defined(USE_NSGETEXECUTABLEPATH)
1431 uint32_t size = sizeof(buf);
1433 _NSGetExecutablePath(buf, &size);
1434 if (size < MAXPATHLEN * MAXPATHLEN) {
1435 sv_grow(caret_x, size);
1436 if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
1437 char *const tidied = realpath(SvPVX(caret_x), NULL);
1439 sv_setpv(caret_x, tidied);
1442 SvPOK_only(caret_x);
1443 SvCUR_set(caret_x, size);
1448 # elif defined(HAS_PROCSELFEXE)
1449 char buf[MAXPATHLEN];
1450 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1452 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1453 includes a spurious NUL which will cause $^X to fail in system
1454 or backticks (this will prevent extensions from being built and
1455 many tests from working). readlink is not meant to add a NUL.
1456 Normal readlink works fine.
1458 if (len > 0 && buf[len-1] == '\0') {
1462 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1463 returning the text "unknown" from the readlink rather than the path
1464 to the executable (or returning an error from the readlink). Any
1465 valid path has a '/' in it somewhere, so use that to validate the
1466 result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1468 if (len > 0 && memchr(buf, '/', len)) {
1469 sv_setpvn(caret_x, buf, len);
1473 /* Fallback to this: */
1474 sv_setpv(caret_x, PL_origargv[0]);
1480 =for apidoc perl_parse
1482 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1487 #define SET_CURSTASH(newstash) \
1488 if (PL_curstash != newstash) { \
1489 SvREFCNT_dec(PL_curstash); \
1490 PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1494 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1501 PERL_ARGS_ASSERT_PERL_PARSE;
1502 #ifndef MULTIPLICITY
1503 PERL_UNUSED_ARG(my_perl);
1505 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG)
1507 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1509 if (s && (atoi(s) == 1)) {
1510 unsigned char *seed= PERL_HASH_SEED;
1511 unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
1512 PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
1513 while (seed < seed_end) {
1514 PerlIO_printf(Perl_debug_log, "%02x", *seed++);
1516 #ifdef PERL_HASH_RANDOMIZE_KEYS
1517 PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
1518 PL_HASH_RAND_BITS_ENABLED,
1519 PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
1521 PerlIO_printf(Perl_debug_log, "\n");
1524 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1528 if (PL_origalen != 0) {
1529 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1532 /* Set PL_origalen be the sum of the contiguous argv[]
1533 * elements plus the size of the env in case that it is
1534 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1535 * as the maximum modifiable length of $0. In the worst case
1536 * the area we are able to modify is limited to the size of
1537 * the original argv[0]. (See below for 'contiguous', though.)
1539 const char *s = NULL;
1542 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1543 /* Do the mask check only if the args seem like aligned. */
1545 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1547 /* See if all the arguments are contiguous in memory. Note
1548 * that 'contiguous' is a loose term because some platforms
1549 * align the argv[] and the envp[]. If the arguments look
1550 * like non-aligned, assume that they are 'strictly' or
1551 * 'traditionally' contiguous. If the arguments look like
1552 * aligned, we just check that they are within aligned
1553 * PTRSIZE bytes. As long as no system has something bizarre
1554 * like the argv[] interleaved with some other data, we are
1555 * fine. (Did I just evoke Murphy's Law?) --jhi */
1556 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1558 for (i = 1; i < PL_origargc; i++) {
1559 if ((PL_origargv[i] == s + 1
1561 || PL_origargv[i] == s + 2
1566 (PL_origargv[i] > s &&
1568 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1579 #ifndef PERL_USE_SAFE_PUTENV
1580 /* Can we grab env area too to be used as the area for $0? */
1581 if (s && PL_origenviron && !PL_use_safe_putenv) {
1582 if ((PL_origenviron[0] == s + 1)
1585 (PL_origenviron[0] > s &&
1586 PL_origenviron[0] <=
1587 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1590 #ifndef OS2 /* ENVIRON is read by the kernel too. */
1591 s = PL_origenviron[0];
1594 my_setenv("NoNe SuCh", NULL);
1595 /* Force copy of environment. */
1596 for (i = 1; PL_origenviron[i]; i++) {
1597 if (PL_origenviron[i] == s + 1
1600 (PL_origenviron[i] > s &&
1601 PL_origenviron[i] <=
1602 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1605 s = PL_origenviron[i];
1613 #endif /* !defined(PERL_USE_SAFE_PUTENV) */
1615 PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1620 /* Come here if running an undumped a.out. */
1622 PL_origfilename = savepv(argv[0]);
1623 PL_do_undump = FALSE;
1624 cxstack_ix = -1; /* start label stack again */
1626 assert (!TAINT_get);
1628 S_set_caret_X(aTHX);
1630 init_postdump_symbols(argc,argv,env);
1635 op_free(PL_main_root);
1636 PL_main_root = NULL;
1638 PL_main_start = NULL;
1639 SvREFCNT_dec(PL_main_cv);
1643 oldscope = PL_scopestack_ix;
1644 PL_dowarn = G_WARN_OFF;
1649 parse_body(env,xsinit);
1650 if (PL_unitcheckav) {
1651 call_list(oldscope, PL_unitcheckav);
1654 PERL_SET_PHASE(PERL_PHASE_CHECK);
1655 call_list(oldscope, PL_checkav);
1663 /* my_exit() was called */
1664 while (PL_scopestack_ix > oldscope)
1667 SET_CURSTASH(PL_defstash);
1668 if (PL_unitcheckav) {
1669 call_list(oldscope, PL_unitcheckav);
1672 PERL_SET_PHASE(PERL_PHASE_CHECK);
1673 call_list(oldscope, PL_checkav);
1678 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1686 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1687 miniperl, and we need to see those flags reflected in the values here. */
1689 /* What this returns is subject to change. Use the public interface in Config.
1692 S_Internals_V(pTHX_ CV *cv)
1695 #ifdef LOCAL_PATCH_COUNT
1696 const int local_patch_count = LOCAL_PATCH_COUNT;
1698 const int local_patch_count = 0;
1700 const int entries = 3 + local_patch_count;
1702 static const char non_bincompat_options[] =
1709 # ifdef NO_HASH_SEED
1712 # ifdef NO_TAINT_SUPPORT
1715 # ifdef PERL_DISABLE_PMC
1718 # ifdef PERL_DONT_CREATE_GVSV
1719 " PERL_DONT_CREATE_GVSV"
1721 # ifdef PERL_EXTERNAL_GLOB
1722 " PERL_EXTERNAL_GLOB"
1724 # ifdef PERL_HASH_FUNC_SIPHASH
1725 " PERL_HASH_FUNC_SIPHASH"
1727 # ifdef PERL_HASH_FUNC_SDBM
1728 " PERL_HASH_FUNC_SDBM"
1730 # ifdef PERL_HASH_FUNC_DJB2
1731 " PERL_HASH_FUNC_DJB2"
1733 # ifdef PERL_HASH_FUNC_SUPERFAST
1734 " PERL_HASH_FUNC_SUPERFAST"
1736 # ifdef PERL_HASH_FUNC_MURMUR3
1737 " PERL_HASH_FUNC_MURMUR3"
1739 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1740 " PERL_HASH_FUNC_ONE_AT_A_TIME"
1742 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1743 " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1745 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1746 " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1748 # ifdef PERL_IS_MINIPERL
1751 # ifdef PERL_MALLOC_WRAP
1754 # ifdef PERL_MEM_LOG
1757 # ifdef PERL_MEM_LOG_NOIMPL
1758 " PERL_MEM_LOG_NOIMPL"
1760 # ifdef PERL_NEW_COPY_ON_WRITE
1761 " PERL_NEW_COPY_ON_WRITE"
1763 # ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1764 " PERL_PERTURB_KEYS_DETERMINISTIC"
1766 # ifdef PERL_PERTURB_KEYS_DISABLED
1767 " PERL_PERTURB_KEYS_DISABLED"
1769 # ifdef PERL_PERTURB_KEYS_RANDOM
1770 " PERL_PERTURB_KEYS_RANDOM"
1772 # ifdef PERL_PRESERVE_IVUV
1773 " PERL_PRESERVE_IVUV"
1775 # ifdef PERL_RELOCATABLE_INCPUSH
1776 " PERL_RELOCATABLE_INCPUSH"
1778 # ifdef PERL_USE_DEVEL
1781 # ifdef PERL_USE_SAFE_PUTENV
1782 " PERL_USE_SAFE_PUTENV"
1784 # ifdef UNLINK_ALL_VERSIONS
1785 " UNLINK_ALL_VERSIONS"
1787 # ifdef USE_ATTRIBUTES_FOR_PERLIO
1788 " USE_ATTRIBUTES_FOR_PERLIO"
1790 # ifdef USE_FAST_STDIO
1793 # ifdef USE_HASH_SEED_EXPLICIT
1794 " USE_HASH_SEED_EXPLICIT"
1799 # ifdef USE_LOCALE_CTYPE
1802 # ifdef USE_PERL_ATOF
1805 # ifdef USE_SITECUSTOMIZE
1806 " USE_SITECUSTOMIZE"
1809 PERL_UNUSED_ARG(cv);
1810 PERL_UNUSED_ARG(items);
1812 EXTEND(SP, entries);
1814 PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
1815 PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
1816 sizeof(non_bincompat_options) - 1, SVs_TEMP));
1820 PUSHs(Perl_newSVpvn_flags(aTHX_
1821 STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__),
1824 PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
1828 PUSHs(&PL_sv_undef);
1831 for (i = 1; i <= local_patch_count; i++) {
1832 /* This will be an undef, if PL_localpatches[i] is NULL. */
1833 PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
1839 #define INCPUSH_UNSHIFT 0x01
1840 #define INCPUSH_ADD_OLD_VERS 0x02
1841 #define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04
1842 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08
1843 #define INCPUSH_NOT_BASEDIR 0x10
1844 #define INCPUSH_CAN_RELOCATE 0x20
1845 #define INCPUSH_ADD_SUB_DIRS \
1846 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
1849 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1853 int argc = PL_origargc;
1854 char **argv = PL_origargv;
1855 const char *scriptname = NULL;
1856 VOL bool dosearch = FALSE;
1858 bool doextract = FALSE;
1859 const char *cddir = NULL;
1860 #ifdef USE_SITECUSTOMIZE
1861 bool minus_f = FALSE;
1863 SV *linestr_sv = NULL;
1864 bool add_read_e_script = FALSE;
1865 U32 lex_start_flags = 0;
1867 PERL_SET_PHASE(PERL_PHASE_START);
1873 for (argc--,argv++; argc > 0; argc--,argv++) {
1874 if (argv[0][0] != '-' || !argv[0][1])
1880 #ifndef PERL_STRICT_CR
1904 if ((s = moreswitches(s)))
1909 #if SILENT_NO_TAINT_SUPPORT
1910 /* silently ignore */
1911 #elif NO_TAINT_SUPPORT
1912 Perl_croak_nocontext("This perl was compiled without taint support. "
1913 "Cowardly refusing to run with -t or -T flags");
1915 CHECK_MALLOC_TOO_LATE_FOR('t');
1916 if( !TAINTING_get ) {
1917 TAINT_WARN_set(TRUE);
1924 #if SILENT_NO_TAINT_SUPPORT
1925 /* silently ignore */
1926 #elif NO_TAINT_SUPPORT
1927 Perl_croak_nocontext("This perl was compiled without taint support. "
1928 "Cowardly refusing to run with -t or -T flags");
1930 CHECK_MALLOC_TOO_LATE_FOR('T');
1932 TAINT_WARN_set(FALSE);
1941 forbid_setid('e', FALSE);
1943 PL_e_script = newSVpvs("");
1944 add_read_e_script = TRUE;
1947 sv_catpv(PL_e_script, s);
1949 sv_catpv(PL_e_script, argv[1]);
1953 Perl_croak(aTHX_ "No code specified for -%c", c);
1954 sv_catpvs(PL_e_script, "\n");
1958 #ifdef USE_SITECUSTOMIZE
1964 case 'I': /* -I handled both here and in moreswitches() */
1965 forbid_setid('I', FALSE);
1966 if (!*++s && (s=argv[1]) != NULL) {
1970 STRLEN len = strlen(s);
1971 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
1974 Perl_croak(aTHX_ "No directory specified for -I");
1977 forbid_setid('S', FALSE);
1986 opts_prog = newSVpvs("use Config; Config::_V()");
1990 opts_prog = Perl_newSVpvf(aTHX_
1991 "use Config; Config::config_vars(qw%c%s%c)",
1995 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
1996 /* don't look for script or read stdin */
1997 scriptname = BIT_BUCKET;
2009 if (!*++s || isSPACE(*s)) {
2013 /* catch use of gnu style long options.
2014 Both of these exit immediately. */
2015 if (strEQ(s, "version"))
2017 if (strEQ(s, "help"))
2022 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
2033 #ifndef SECURE_INTERNAL_GETENV
2036 (s = PerlEnv_getenv("PERL5OPT")))
2040 if (*s == '-' && *(s+1) == 'T') {
2041 #if SILENT_NO_TAINT_SUPPORT
2042 /* silently ignore */
2043 #elif NO_TAINT_SUPPORT
2044 Perl_croak_nocontext("This perl was compiled without taint support. "
2045 "Cowardly refusing to run with -t or -T flags");
2047 CHECK_MALLOC_TOO_LATE_FOR('T');
2049 TAINT_WARN_set(FALSE);
2053 char *popt_copy = NULL;
2066 if (!strchr("CDIMUdmtwW", *s))
2067 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2071 popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2072 s = popt_copy + (s - d);
2080 #if SILENT_NO_TAINT_SUPPORT
2081 /* silently ignore */
2082 #elif NO_TAINT_SUPPORT
2083 Perl_croak_nocontext("This perl was compiled without taint support. "
2084 "Cowardly refusing to run with -t or -T flags");
2086 if( !TAINTING_get) {
2087 TAINT_WARN_set(TRUE);
2099 /* Set $^X early so that it can be used for relocatable paths in @INC */
2100 /* and for SITELIB_EXP in USE_SITECUSTOMIZE */
2101 assert (!TAINT_get);
2103 S_set_caret_X(aTHX);
2106 #if defined(USE_SITECUSTOMIZE)
2108 /* The games with local $! are to avoid setting errno if there is no
2109 sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2110 ie a q() operator with a NUL byte as a the delimiter. This avoids
2111 problems with pathnames containing (say) ' */
2112 # ifdef PERL_IS_MINIPERL
2113 AV *const inc = GvAV(PL_incgv);
2114 SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2117 /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2118 it should be reported immediately as a build failure. */
2119 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2121 "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }",
2126 /* SITELIB_EXP is a function call on Win32. */
2127 const char *const raw_sitelib = SITELIB_EXP;
2129 /* process .../.. if PERL_RELOCATABLE_INC is defined */
2130 SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2131 INCPUSH_CAN_RELOCATE);
2132 const char *const sitelib = SvPVX(sitelib_sv);
2133 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2135 "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2138 assert (SvREFCNT(sitelib_sv) == 1);
2139 SvREFCNT_dec(sitelib_sv);
2146 scriptname = argv[0];
2149 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2151 else if (scriptname == NULL) {
2153 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2159 assert (!TAINT_get);
2163 bool suidscript = FALSE;
2165 rsfp = open_script(scriptname, dosearch, &suidscript);
2167 rsfp = PerlIO_stdin();
2168 lex_start_flags = LEX_DONT_CLOSE_RSFP;
2171 validate_suid(rsfp);
2174 # if defined(SIGCHLD) || defined(SIGCLD)
2177 # define SIGCHLD SIGCLD
2179 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2180 if (sigstate == (Sighandler_t) SIG_IGN) {
2181 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2182 "Can't ignore signal CHLD, forcing to default");
2183 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2191 /* This will croak if suidscript is true, as -x cannot be used with
2193 forbid_setid('x', suidscript);
2194 /* Hence you can't get here if suidscript is true */
2196 linestr_sv = newSV_type(SVt_PV);
2197 lex_start_flags |= LEX_START_COPIED;
2198 find_beginning(linestr_sv, rsfp);
2199 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2200 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2204 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2205 CvUNIQUE_on(PL_compcv);
2207 CvPADLIST(PL_compcv) = pad_new(0);
2209 PL_isarev = newHV();
2212 boot_core_UNIVERSAL();
2214 newXS("Internals::V", S_Internals_V, __FILE__);
2217 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
2219 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
2225 # ifdef HAS_SOCKS5_INIT
2226 socks5_init(argv[0]);
2232 init_predump_symbols();
2233 /* init_postdump_symbols not currently designed to be called */
2234 /* more than once (ENV isn't cleared first, for example) */
2235 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2237 init_postdump_symbols(argc,argv,env);
2239 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2240 * or explicitly in some platforms.
2241 * locale.c:Perl_init_i18nl10n() if the environment
2242 * look like the user wants to use UTF-8. */
2243 #if defined(__SYMBIAN32__)
2244 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2246 # ifndef PERL_IS_MINIPERL
2248 /* Requires init_predump_symbols(). */
2249 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2254 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2255 * and the default open disciplines. */
2256 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2257 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2259 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2260 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2261 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2263 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2264 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2265 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2267 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2268 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2269 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2271 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2272 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2275 sv_setpvs(sv, ":utf8\0:utf8");
2277 sv_setpvs(sv, ":utf8\0");
2280 sv_setpvs(sv, "\0:utf8");
2289 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2290 if (strEQ(s, "unsafe"))
2291 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2292 else if (strEQ(s, "safe"))
2293 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2295 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2302 if (!TAINTING_get &&
2303 (s = PerlEnv_getenv("PERL_XMLDUMP"))) {
2307 PL_xmlfp = PerlIO_stdout();
2309 PL_xmlfp = PerlIO_open(s, "w");
2311 Perl_croak(aTHX_ "Can't open %s", s);
2313 my_setenv("PERL_XMLDUMP", NULL); /* hide from subprocs */
2319 if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2320 PL_madskills = atoi(s);
2321 my_setenv("PERL_MADSKILLS", NULL); /* hide from subprocs */
2326 lex_start(linestr_sv, rsfp, lex_start_flags);
2327 SvREFCNT_dec(linestr_sv);
2329 PL_subname = newSVpvs("main");
2331 if (add_read_e_script)
2332 filter_add(read_e_script, NULL);
2334 /* now parse the script */
2336 SETERRNO(0,SS_NORMAL);
2337 if (yyparse(GRAMPROG) || PL_parser->error_count) {
2339 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2341 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2345 CopLINE_set(PL_curcop, 0);
2346 SET_CURSTASH(PL_defstash);
2348 SvREFCNT_dec(PL_e_script);
2356 SAVECOPFILE(PL_curcop);
2357 SAVECOPLINE(PL_curcop);
2358 gv_check(PL_defstash);
2367 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2368 dump_mstats("after compilation:");
2373 PL_restartjmpenv = NULL;
2379 =for apidoc perl_run
2381 Tells a Perl interpreter to run. See L<perlembed>.
2394 PERL_ARGS_ASSERT_PERL_RUN;
2395 #ifndef MULTIPLICITY
2396 PERL_UNUSED_ARG(my_perl);
2399 oldscope = PL_scopestack_ix;
2407 cxstack_ix = -1; /* start context stack again */
2409 case 0: /* normal completion */
2413 case 2: /* my_exit() */
2414 while (PL_scopestack_ix > oldscope)
2417 SET_CURSTASH(PL_defstash);
2418 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2419 PL_endav && !PL_minus_c) {
2420 PERL_SET_PHASE(PERL_PHASE_END);
2421 call_list(oldscope, PL_endav);
2424 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2425 dump_mstats("after execution: ");
2431 POPSTACK_TO(PL_mainstack);
2434 PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2445 S_run_body(pTHX_ I32 oldscope)
2448 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2449 PL_sawampersand ? "Enabling" : "Omitting",
2450 (unsigned int)(PL_sawampersand)));
2452 if (!PL_restartop) {
2456 exit(0); /* less likely to core dump than my_exit(0) */
2460 if (DEBUG_x_TEST || DEBUG_B_TEST)
2461 dump_all_perl(!DEBUG_B_TEST);
2463 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2467 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2470 if (PERLDB_SINGLE && PL_DBsingle)
2471 sv_setiv(PL_DBsingle, 1);
2473 PERL_SET_PHASE(PERL_PHASE_INIT);
2474 call_list(oldscope, PL_initav);
2476 #ifdef PERL_DEBUG_READONLY_OPS
2477 if (PL_main_root && PL_main_root->op_slabbed)
2478 Slab_to_ro(OpSLAB(PL_main_root));
2484 PERL_SET_PHASE(PERL_PHASE_RUN);
2487 PL_restartjmpenv = NULL;
2488 PL_op = PL_restartop;
2492 else if (PL_main_start) {
2493 CvDEPTH(PL_main_cv) = 1;
2494 PL_op = PL_main_start;
2498 assert(0); /* NOTREACHED */
2502 =head1 SV Manipulation Functions
2504 =for apidoc p||get_sv
2506 Returns the SV of the specified Perl scalar. C<flags> are passed to
2507 C<gv_fetchpv>. If C<GV_ADD> is set and the
2508 Perl variable does not exist then it will be created. If C<flags> is zero
2509 and the variable does not exist then NULL is returned.
2515 Perl_get_sv(pTHX_ const char *name, I32 flags)
2519 PERL_ARGS_ASSERT_GET_SV;
2521 gv = gv_fetchpv(name, flags, SVt_PV);
2528 =head1 Array Manipulation Functions
2530 =for apidoc p||get_av
2532 Returns the AV of the specified Perl global or package array with the given
2533 name (so it won't work on lexical variables). C<flags> are passed
2534 to C<gv_fetchpv>. If C<GV_ADD> is set and the
2535 Perl variable does not exist then it will be created. If C<flags> is zero
2536 and the variable does not exist then NULL is returned.
2538 Perl equivalent: C<@{"$name"}>.
2544 Perl_get_av(pTHX_ const char *name, I32 flags)
2546 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2548 PERL_ARGS_ASSERT_GET_AV;
2558 =head1 Hash Manipulation Functions
2560 =for apidoc p||get_hv
2562 Returns the HV of the specified Perl hash. C<flags> are passed to
2563 C<gv_fetchpv>. If C<GV_ADD> is set and the
2564 Perl variable does not exist then it will be created. If C<flags> is zero
2565 and the variable does not exist then NULL is returned.
2571 Perl_get_hv(pTHX_ const char *name, I32 flags)
2573 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2575 PERL_ARGS_ASSERT_GET_HV;
2585 =head1 CV Manipulation Functions
2587 =for apidoc p||get_cvn_flags
2589 Returns the CV of the specified Perl subroutine. C<flags> are passed to
2590 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2591 exist then it will be declared (which has the same effect as saying
2592 C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
2593 then NULL is returned.
2595 =for apidoc p||get_cv
2597 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2603 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2605 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2607 PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2609 /* XXX this is probably not what they think they're getting.
2610 * It has the same effect as "sub name;", i.e. just a forward
2612 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2613 return newSTUB(gv,0);
2620 /* Nothing in core calls this now, but we can't replace it with a macro and
2621 move it to mathoms.c as a macro would evaluate name twice. */
2623 Perl_get_cv(pTHX_ const char *name, I32 flags)
2625 PERL_ARGS_ASSERT_GET_CV;
2627 return get_cvn_flags(name, strlen(name), flags);
2630 /* Be sure to refetch the stack pointer after calling these routines. */
2634 =head1 Callback Functions
2636 =for apidoc p||call_argv
2638 Performs a callback to the specified named and package-scoped Perl subroutine
2639 with C<argv> (a NULL-terminated array of strings) as arguments. See L<perlcall>.
2641 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2647 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2649 /* See G_* flags in cop.h */
2650 /* null terminated arg list */
2655 PERL_ARGS_ASSERT_CALL_ARGV;
2660 mXPUSHs(newSVpv(*argv,0));
2665 return call_pv(sub_name, flags);
2669 =for apidoc p||call_pv
2671 Performs a callback to the specified Perl sub. See L<perlcall>.
2677 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2678 /* name of the subroutine */
2679 /* See G_* flags in cop.h */
2681 PERL_ARGS_ASSERT_CALL_PV;
2683 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2687 =for apidoc p||call_method
2689 Performs a callback to the specified Perl method. The blessed object must
2690 be on the stack. See L<perlcall>.
2696 Perl_call_method(pTHX_ const char *methname, I32 flags)
2697 /* name of the subroutine */
2698 /* See G_* flags in cop.h */
2702 PERL_ARGS_ASSERT_CALL_METHOD;
2704 len = strlen(methname);
2705 sv = flags & G_METHOD_NAMED
2706 ? sv_2mortal(newSVpvn_share(methname, len,0))
2707 : newSVpvn_flags(methname, len, SVs_TEMP);
2709 return call_sv(sv, flags | G_METHOD);
2712 /* May be called with any of a CV, a GV, or an SV containing the name. */
2714 =for apidoc p||call_sv
2716 Performs a callback to the Perl sub whose name is in the SV. See
2723 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2724 /* See G_* flags in cop.h */
2727 LOGOP myop; /* fake syntax tree node */
2733 bool oldcatch = CATCH_GET;
2735 OP* const oldop = PL_op;
2738 PERL_ARGS_ASSERT_CALL_SV;
2740 if (flags & G_DISCARD) {
2744 if (!(flags & G_WANT)) {
2745 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2750 Zero(&myop, 1, LOGOP);
2751 if (!(flags & G_NOARGS))
2752 myop.op_flags |= OPf_STACKED;
2753 myop.op_flags |= OP_GIMME_REVERSE(flags);
2757 EXTEND(PL_stack_sp, 1);
2758 if (!(flags & G_METHOD_NAMED))
2759 *++PL_stack_sp = sv;
2761 oldscope = PL_scopestack_ix;
2763 if (PERLDB_SUB && PL_curstash != PL_debstash
2764 /* Handle first BEGIN of -d. */
2765 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2766 /* Try harder, since this may have been a sighandler, thus
2767 * curstash may be meaningless. */
2768 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2769 && !(flags & G_NODEBUG))
2770 myop.op_private |= OPpENTERSUB_DB;
2772 if (flags & (G_METHOD|G_METHOD_NAMED)) {
2773 if ( flags & G_METHOD_NAMED ) {
2774 Zero(&method_svop, 1, SVOP);
2775 method_svop.op_next = (OP*)&myop;
2776 method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
2777 method_svop.op_type = OP_METHOD_NAMED;
2778 method_svop.op_sv = sv;
2779 PL_op = (OP*)&method_svop;
2781 Zero(&method_unop, 1, UNOP);
2782 method_unop.op_next = (OP*)&myop;
2783 method_unop.op_ppaddr = PL_ppaddr[OP_METHOD];
2784 method_unop.op_type = OP_METHOD;
2785 PL_op = (OP*)&method_unop;
2787 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2788 myop.op_type = OP_ENTERSUB;
2792 if (!(flags & G_EVAL)) {
2794 CALL_BODY_SUB((OP*)&myop);
2795 retval = PL_stack_sp - (PL_stack_base + oldmark);
2796 CATCH_SET(oldcatch);
2799 myop.op_other = (OP*)&myop;
2801 create_eval_scope(flags|G_FAKINGEVAL);
2809 CALL_BODY_SUB((OP*)&myop);
2810 retval = PL_stack_sp - (PL_stack_base + oldmark);
2811 if (!(flags & G_KEEPERR)) {
2819 /* my_exit() was called */
2820 SET_CURSTASH(PL_defstash);
2824 assert(0); /* NOTREACHED */
2827 PL_restartjmpenv = NULL;
2828 PL_op = PL_restartop;
2832 PL_stack_sp = PL_stack_base + oldmark;
2833 if ((flags & G_WANT) == G_ARRAY)
2837 *++PL_stack_sp = &PL_sv_undef;
2842 if (PL_scopestack_ix > oldscope)
2843 delete_eval_scope();
2847 if (flags & G_DISCARD) {
2848 PL_stack_sp = PL_stack_base + oldmark;
2857 /* Eval a string. The G_EVAL flag is always assumed. */
2860 =for apidoc p||eval_sv
2862 Tells Perl to C<eval> the string in the SV. It supports the same flags
2863 as C<call_sv>, with the obvious exception of G_EVAL. See L<perlcall>.
2869 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2871 /* See G_* flags in cop.h */
2875 UNOP myop; /* fake syntax tree node */
2876 VOL I32 oldmark = SP - PL_stack_base;
2879 OP* const oldop = PL_op;
2882 PERL_ARGS_ASSERT_EVAL_SV;
2884 if (flags & G_DISCARD) {
2891 Zero(&myop, 1, UNOP);
2892 EXTEND(PL_stack_sp, 1);
2893 *++PL_stack_sp = sv;
2895 if (!(flags & G_NOARGS))
2896 myop.op_flags = OPf_STACKED;
2897 myop.op_type = OP_ENTEREVAL;
2898 myop.op_flags |= OP_GIMME_REVERSE(flags);
2899 if (flags & G_KEEPERR)
2900 myop.op_flags |= OPf_SPECIAL;
2902 if (flags & G_RE_REPARSING)
2903 myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
2905 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2906 * before a PUSHEVAL, which corrupts the stack after a croak */
2907 TAINT_PROPER("eval_sv()");
2913 if (PL_op == (OP*)(&myop)) {
2914 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
2916 goto fail; /* failed in compilation */
2919 retval = PL_stack_sp - (PL_stack_base + oldmark);
2920 if (!(flags & G_KEEPERR)) {
2928 /* my_exit() was called */
2929 SET_CURSTASH(PL_defstash);
2933 assert(0); /* NOTREACHED */
2936 PL_restartjmpenv = NULL;
2937 PL_op = PL_restartop;
2942 PL_stack_sp = PL_stack_base + oldmark;
2943 if ((flags & G_WANT) == G_ARRAY)
2947 *++PL_stack_sp = &PL_sv_undef;
2953 if (flags & G_DISCARD) {
2954 PL_stack_sp = PL_stack_base + oldmark;
2964 =for apidoc p||eval_pv
2966 Tells Perl to C<eval> the given string and return an SV* result.
2972 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2975 SV* sv = newSVpv(p, 0);
2977 PERL_ARGS_ASSERT_EVAL_PV;
2979 eval_sv(sv, G_SCALAR);
2988 /* just check empty string or undef? */
2989 if (croak_on_error) {
2990 SV * const errsv = ERRSV;
2991 if(SvTRUE_NN(errsv))
2992 /* replace with croak_sv? */
2993 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
2999 /* Require a module. */
3002 =head1 Embedding Functions
3004 =for apidoc p||require_pv
3006 Tells Perl to C<require> the file named by the string argument. It is
3007 analogous to the Perl code C<eval "require '$file'">. It's even
3008 implemented that way; consider using load_module instead.
3013 Perl_require_pv(pTHX_ const char *pv)
3019 PERL_ARGS_ASSERT_REQUIRE_PV;
3021 PUSHSTACKi(PERLSI_REQUIRE);
3023 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3024 eval_sv(sv_2mortal(sv), G_DISCARD);
3030 S_usage(pTHX) /* XXX move this out into a module ? */
3032 /* This message really ought to be max 23 lines.
3033 * Removed -h because the user already knows that option. Others? */
3035 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3036 minimum of 509 character string literals. */
3037 static const char * const usage_msg[] = {
3038 " -0[octal] specify record separator (\\0, if no argument)\n"
3039 " -a autosplit mode with -n or -p (splits $_ into @F)\n"
3040 " -C[number/list] enables the listed Unicode features\n"
3041 " -c check syntax only (runs BEGIN and CHECK blocks)\n"
3042 " -d[:debugger] run program under debugger\n"
3043 " -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n",
3044 " -e program one line of program (several -e's allowed, omit programfile)\n"
3045 " -E program like -e, but enables all optional features\n"
3046 " -f don't do $sitelib/sitecustomize.pl at startup\n"
3047 " -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
3048 " -i[extension] edit <> files in place (makes backup if extension supplied)\n"
3049 " -Idirectory specify @INC/#include directory (several -I's allowed)\n",
3050 " -l[octal] enable line ending processing, specifies line terminator\n"
3051 " -[mM][-]module execute \"use/no module...\" before executing program\n"
3052 " -n assume \"while (<>) { ... }\" loop around program\n"
3053 " -p assume loop like -n but print line also, like sed\n"
3054 " -s enable rudimentary parsing for switches after programfile\n"
3055 " -S look for programfile using PATH environment variable\n",
3056 " -t enable tainting warnings\n"
3057 " -T enable tainting checks\n"
3058 " -u dump core after parsing program\n"
3059 " -U allow unsafe operations\n"
3060 " -v print version, patchlevel and license\n"
3061 " -V[:variable] print configuration summary (or a single Config.pm variable)\n",
3062 " -w enable many useful warnings\n"
3063 " -W enable all warnings\n"
3064 " -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
3065 " -X disable all warnings\n"
3067 "Run 'perldoc perl' for more help with Perl.\n\n",
3070 const char * const *p = usage_msg;
3071 PerlIO *out = PerlIO_stdout();
3074 "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3077 PerlIO_puts(out, *p++);
3081 /* convert a string of -D options (or digits) into an int.
3082 * sets *s to point to the char after the options */
3086 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3088 static const char * const usage_msgd[] = {
3089 " Debugging flag values: (see also -d)\n"
3090 " p Tokenizing and parsing (with v, displays parse stack)\n"
3091 " s Stack snapshots (with v, displays all stacks)\n"
3092 " l Context (loop) stack processing\n"
3093 " t Trace execution\n"
3094 " o Method and overloading resolution\n",
3095 " c String/numeric conversions\n"
3096 " P Print profiling info, source file input state\n"
3097 " m Memory and SV allocation\n"
3098 " f Format processing\n"
3099 " r Regular expression parsing and execution\n"
3100 " x Syntax tree dump\n",
3101 " u Tainting checks\n"
3102 " H Hash dump -- usurps values()\n"
3103 " X Scratchpad allocation\n"
3105 " S Op slab allocation\n"
3107 " R Include reference counts of dumped variables (eg when using -Ds)\n",
3108 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3109 " v Verbose: use in conjunction with other flags\n"
3110 " C Copy On Write\n"
3111 " A Consistency checks on internal structures\n"
3112 " q quiet - currently only suppresses the 'EXECUTING' message\n"
3113 " M trace smart match resolution\n"
3114 " B dump suBroutine definitions, including special Blocks like BEGIN\n",
3119 PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3122 /* if adding extra options, remember to update DEBUG_MASK */
3123 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
3125 for (; isWORDCHAR(**s); (*s)++) {
3126 const char * const d = strchr(debopts,**s);
3128 i |= 1 << (d - debopts);
3129 else if (ckWARN_d(WARN_DEBUGGING))
3130 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3131 "invalid option -D%c, use -D'' to see choices\n", **s);
3134 else if (isDIGIT(**s)) {
3136 for (; isWORDCHAR(**s); (*s)++) ;
3138 else if (givehelp) {
3139 const char *const *p = usage_msgd;
3140 while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3143 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3144 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3145 "-Dp not implemented on this platform\n");
3151 /* This routine handles any switches that can be given during run */
3154 Perl_moreswitches(pTHX_ const char *s)
3158 const char option = *s; /* used to remember option in -m/-M code */
3160 PERL_ARGS_ASSERT_MORESWITCHES;
3168 SvREFCNT_dec(PL_rs);
3169 if (s[1] == 'x' && s[2]) {
3170 const char *e = s+=2;
3176 flags = PERL_SCAN_SILENT_ILLDIGIT;
3177 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3178 if (s + numlen < e) {
3179 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3183 PL_rs = newSVpvs("");
3184 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
3185 tmps = (U8*)SvPVX(PL_rs);
3186 uvchr_to_utf8(tmps, rschar);
3187 SvCUR_set(PL_rs, UNISKIP(rschar));
3192 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3193 if (rschar & ~((U8)~0))
3194 PL_rs = &PL_sv_undef;
3195 else if (!rschar && numlen >= 2)
3196 PL_rs = newSVpvs("");
3198 char ch = (char)rschar;
3199 PL_rs = newSVpvn(&ch, 1);
3202 sv_setsv(get_sv("/", GV_ADD), PL_rs);
3207 PL_unicode = parse_unicode_opts( (const char **)&s );
3208 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3214 while (*s && !isSPACE(*s)) ++s;
3215 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3226 forbid_setid('d', FALSE);
3229 /* -dt indicates to the debugger that threads will be used */
3230 if (*s == 't' && !isWORDCHAR(s[1])) {
3232 my_setenv("PERL5DB_THREADED", "1");
3235 /* The following permits -d:Mod to accepts arguments following an =
3236 in the fashion that -MSome::Mod does. */
3237 if (*s == ':' || *s == '=') {
3244 sv = newSVpvs("no Devel::");
3246 sv = newSVpvs("use Devel::");
3250 end = s + strlen(s);
3252 /* We now allow -d:Module=Foo,Bar and -d:-Module */
3253 while(isWORDCHAR(*s) || *s==':') ++s;
3255 sv_catpvn(sv, start, end - start);
3257 sv_catpvn(sv, start, s-start);
3258 /* Don't use NUL as q// delimiter here, this string goes in the
3260 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3263 my_setenv("PERL5DB", SvPV_nolen_const(sv));
3267 PL_perldb = PERLDB_ALL;
3274 forbid_setid('D', FALSE);
3276 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3277 #else /* !DEBUGGING */
3278 if (ckWARN_d(WARN_DEBUGGING))
3279 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3280 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3281 for (s++; isWORDCHAR(*s); s++) ;
3288 Safefree(PL_inplace);
3289 #if defined(__CYGWIN__) /* do backup extension automagically */
3290 if (*(s+1) == '\0') {
3291 PL_inplace = savepvs(".bak");
3294 #endif /* __CYGWIN__ */
3296 const char * const start = ++s;
3297 while (*s && !isSPACE(*s))
3300 PL_inplace = savepvn(start, s - start);
3304 if (*s == '-') /* Additional switches on #! line. */
3308 case 'I': /* -I handled both here and in parse_body() */
3309 forbid_setid('I', FALSE);
3311 while (*s && isSPACE(*s))
3316 /* ignore trailing spaces (possibly followed by other switches) */
3318 for (e = p; *e && !isSPACE(*e); e++) ;
3322 } while (*p && *p != '-');
3324 INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3330 Perl_croak(aTHX_ "No directory specified for -I");
3336 SvREFCNT_dec(PL_ors_sv);
3342 PL_ors_sv = newSVpvs("\n");
3343 numlen = 3 + (*s == '0');
3344 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3348 if (RsPARA(PL_rs)) {
3349 PL_ors_sv = newSVpvs("\n\n");
3352 PL_ors_sv = newSVsv(PL_rs);
3357 forbid_setid('M', FALSE); /* XXX ? */
3360 forbid_setid('m', FALSE); /* XXX ? */
3365 const char *use = "use ";
3367 /* -M-foo == 'no foo' */
3368 /* Leading space on " no " is deliberate, to make both
3369 possibilities the same length. */
3370 if (*s == '-') { use = " no "; ++s; }
3371 sv = newSVpvn(use,4);
3373 /* We allow -M'Module qw(Foo Bar)' */
3374 while(isWORDCHAR(*s) || *s==':') {
3383 Perl_croak(aTHX_ "Module name required with -%c option",
3386 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3387 "contains single ':'",
3388 (int)(s - start), start, option);
3389 end = s + strlen(s);
3391 sv_catpvn(sv, start, end - start);
3392 if (option == 'm') {
3394 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3395 sv_catpvs( sv, " ()");
3398 sv_catpvn(sv, start, s-start);
3399 /* Use NUL as q''-delimiter. */
3400 sv_catpvs(sv, " split(/,/,q\0");
3402 sv_catpvn(sv, s, end - s);
3403 sv_catpvs(sv, "\0)");
3406 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3409 Perl_croak(aTHX_ "Missing argument to -%c", option);
3420 forbid_setid('s', FALSE);
3421 PL_doswitches = TRUE;
3426 #if SILENT_NO_TAINT_SUPPORT
3427 /* silently ignore */
3428 #elif NO_TAINT_SUPPORT
3429 Perl_croak_nocontext("This perl was compiled without taint support. "
3430 "Cowardly refusing to run with -t or -T flags");
3438 PL_do_undump = TRUE;
3448 if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3449 PL_dowarn |= G_WARN_ON;
3454 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3455 if (!specialWARN(PL_compiling.cop_warnings))
3456 PerlMemShared_free(PL_compiling.cop_warnings);
3457 PL_compiling.cop_warnings = pWARN_ALL ;
3461 PL_dowarn = G_WARN_ALL_OFF;
3462 if (!specialWARN(PL_compiling.cop_warnings))
3463 PerlMemShared_free(PL_compiling.cop_warnings);
3464 PL_compiling.cop_warnings = pWARN_NONE ;
3471 if (s[0] == '-') /* Additional switches on #! line. */
3476 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3482 #ifdef ALTERNATE_SHEBANG
3483 case 'S': /* OS/2 needs -S on "extproc" line. */
3486 case 'e': case 'f': case 'x': case 'E':
3487 #ifndef ALTERNATE_SHEBANG
3491 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3494 "Unrecognized switch: -%.1s (-h will show valid options)",s
3504 PerlIO * PIO_stdout;
3505 if (!sv_derived_from(PL_patchlevel, "version"))
3506 upg_version(PL_patchlevel, TRUE);
3508 SV* level= vstringify(PL_patchlevel);
3509 #ifdef PERL_PATCHNUM
3510 # ifdef PERL_GIT_UNCOMMITTED_CHANGES
3511 SV *num = newSVpvs(PERL_PATCHNUM "*");
3513 SV *num = newSVpvs(PERL_PATCHNUM);
3516 STRLEN level_len, num_len;
3517 char * level_str, * num_str;
3518 num_str = SvPV(num, num_len);
3519 level_str = SvPV(level, level_len);
3520 if (num_len>=level_len && strnEQ(num_str,level_str,level_len)) {
3521 SvREFCNT_dec(level);
3524 Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
3529 PIO_stdout = PerlIO_stdout();
3530 PerlIO_printf(PIO_stdout,
3531 "\nThis is perl " STRINGIFY(PERL_REVISION)
3532 ", version " STRINGIFY(PERL_VERSION)
3533 ", subversion " STRINGIFY(PERL_SUBVERSION)
3534 " (%"SVf") built for " ARCHNAME, level
3536 SvREFCNT_dec(level);
3538 #if defined(LOCAL_PATCH_COUNT)
3539 if (LOCAL_PATCH_COUNT > 0)
3540 PerlIO_printf(PIO_stdout,
3541 "\n(with %d registered patch%s, "
3542 "see perl -V for more detail)",
3544 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3547 PerlIO_printf(PIO_stdout,
3548 "\n\nCopyright 1987-2013, Larry Wall\n");
3550 PerlIO_printf(PIO_stdout,
3551 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3554 PerlIO_printf(PIO_stdout,
3555 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3556 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3559 PerlIO_printf(PIO_stdout,
3560 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3561 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3564 PerlIO_printf(PIO_stdout,
3565 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3568 PerlIO_printf(PIO_stdout,
3569 "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3572 PerlIO_printf(PIO_stdout,
3573 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3576 PerlIO_printf(PIO_stdout,
3577 "WINCE port by Rainer Keuchel, 2001-2002\n"
3578 "Built on " __DATE__ " " __TIME__ "\n\n");
3581 #ifdef __SYMBIAN32__
3582 PerlIO_printf(PIO_stdout,
3583 "Symbian port by Nokia, 2004-2005\n");
3585 #ifdef BINARY_BUILD_NOTICE
3586 BINARY_BUILD_NOTICE;
3588 PerlIO_printf(PIO_stdout,
3590 Perl may be copied only under the terms of either the Artistic License or the\n\
3591 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3592 Complete documentation for Perl, including FAQ lists, should be found on\n\
3593 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3594 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3598 /* compliments of Tom Christiansen */
3600 /* unexec() can be found in the Gnu emacs distribution */
3601 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3604 #include <lib$routines.h>
3608 Perl_my_unexec(pTHX)
3610 PERL_UNUSED_CONTEXT;
3612 SV * prog = newSVpv(BIN_EXP, 0);
3613 SV * file = newSVpv(PL_origfilename, 0);
3617 sv_catpvs(prog, "/perl");
3618 sv_catpvs(file, ".perldump");
3620 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3621 /* unexec prints msg to stderr in case of failure */
3622 PerlProc_exit(status);
3625 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3626 # elif defined(WIN32) || defined(__CYGWIN__)
3627 Perl_croak(aTHX_ "dump is not supported");
3629 ABORT(); /* for use with undump */
3634 /* initialize curinterp */
3640 # define PERLVAR(prefix,var,type)
3641 # define PERLVARA(prefix,var,n,type)
3642 # if defined(PERL_IMPLICIT_CONTEXT)
3643 # define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init;
3644 # define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init;
3646 # define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init;
3647 # define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init;
3649 # include "intrpvar.h"
3655 # define PERLVAR(prefix,var,type)
3656 # define PERLVARA(prefix,var,n,type)
3657 # define PERLVARI(prefix,var,type,init) PL_##var = init;
3658 # define PERLVARIC(prefix,var,type,init) PL_##var = init;
3659 # include "intrpvar.h"
3669 S_init_main_stash(pTHX)
3674 PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
3675 /* We know that the string "main" will be in the global shared string
3676 table, so it's a small saving to use it rather than allocate another
3678 PL_curstname = newSVpvs_share("main");
3679 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3680 /* If we hadn't caused another reference to "main" to be in the shared
3681 string table above, then it would be worth reordering these two,
3682 because otherwise all we do is delete "main" from it as a consequence
3683 of the SvREFCNT_dec, only to add it again with hv_name_set */
3684 SvREFCNT_dec(GvHV(gv));
3685 hv_name_set(PL_defstash, "main", 4, 0);
3686 GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3688 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3690 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3691 GvMULTI_on(PL_incgv);
3692 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3693 GvMULTI_on(PL_hintgv);
3694 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3695 SvREFCNT_inc_simple_void(PL_defgv);
3696 PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
3697 SvREFCNT_inc_simple_void(PL_errgv);
3698 GvMULTI_on(PL_errgv);
3699 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3700 GvMULTI_on(PL_replgv);
3701 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
3702 #ifdef PERL_DONT_CREATE_GVSV
3705 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3707 SET_CURSTASH(PL_defstash);
3708 CopSTASH_set(&PL_compiling, PL_defstash);
3709 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3710 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3712 /* We must init $/ before switches are processed. */
3713 sv_setpvs(get_sv("/", GV_ADD), "\n");
3717 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
3720 PerlIO *rsfp = NULL;
3724 PERL_ARGS_ASSERT_OPEN_SCRIPT;
3727 PL_origfilename = savepvs("-e");
3730 /* if find_script() returns, it returns a malloc()-ed value */
3731 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3733 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3734 const char *s = scriptname + 8;
3740 * Tell apart "normal" usage of fdscript, e.g.
3741 * with bash on FreeBSD:
3742 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3743 * from usage in suidperl.
3744 * Does any "normal" usage leave garbage after the number???
3745 * Is it a mistake to use a similar /dev/fd/ construct for
3750 * Be supersafe and do some sanity-checks.
3751 * Still, can we be sure we got the right thing?
3754 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3757 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3759 scriptname = savepv(s + 1);
3760 Safefree(PL_origfilename);
3761 PL_origfilename = (char *)scriptname;
3766 CopFILE_free(PL_curcop);
3767 CopFILE_set(PL_curcop, PL_origfilename);
3768 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3769 scriptname = (char *)"";
3770 if (fdscript >= 0) {
3771 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3773 else if (!*scriptname) {
3774 forbid_setid(0, *suidscript);
3778 #ifdef FAKE_BIT_BUCKET
3779 /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3780 * is called) and still have the "-e" work. (Believe it or not,
3781 * a /dev/null is required for the "-e" to work because source
3782 * filter magic is used to implement it. ) This is *not* a general
3783 * replacement for a /dev/null. What we do here is create a temp
3784 * file (an empty file), open up that as the script, and then
3785 * immediately close and unlink it. Close enough for jazz. */
3786 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3787 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3788 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3789 char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3790 FAKE_BIT_BUCKET_TEMPLATE
3792 const char * const err = "Failed to create a fake bit bucket";
3793 if (strEQ(scriptname, BIT_BUCKET)) {
3794 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3795 int tmpfd = mkstemp(tmpname);
3797 scriptname = tmpname;
3800 Perl_croak(aTHX_ err);
3803 scriptname = mktemp(tmpname);
3805 Perl_croak(aTHX_ err);
3810 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3811 #ifdef FAKE_BIT_BUCKET
3812 if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3813 sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3814 && strlen(scriptname) == sizeof(tmpname) - 1) {
3817 scriptname = BIT_BUCKET;
3821 /* PSz 16 Sep 03 Keep neat error message */
3823 Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3825 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3826 CopFILE(PL_curcop), Strerror(errno));
3828 #if defined(HAS_FCNTL) && defined(F_SETFD)
3829 /* ensure close-on-exec */
3830 fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
3833 if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
3834 && S_ISDIR(tmpstatbuf.st_mode))
3835 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3843 * I_SYSSTATVFS HAS_FSTATVFS
3845 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3846 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3847 * here so that metaconfig picks them up. */
3850 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3851 /* Don't even need this function. */
3854 S_validate_suid(pTHX_ PerlIO *rsfp)
3856 const Uid_t my_uid = PerlProc_getuid();
3857 const Uid_t my_euid = PerlProc_geteuid();
3858 const Gid_t my_gid = PerlProc_getgid();
3859 const Gid_t my_egid = PerlProc_getegid();
3861 PERL_ARGS_ASSERT_VALIDATE_SUID;
3863 if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
3866 PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3867 if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3869 (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3872 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3873 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3874 /* not set-id, must be wrapped */
3877 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3880 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3886 PERL_ARGS_ASSERT_FIND_BEGINNING;
3888 /* skip forward in input to the real script? */
3891 if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3892 Perl_croak(aTHX_ "No Perl script found in input\n");
3894 } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3895 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
3896 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3898 while (*s == ' ' || *s == '\t') s++;
3900 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3901 || s2[-1] == '_') s2--;
3902 if (strnEQ(s2-4,"perl",4))
3903 while ((s = moreswitches(s)))
3912 /* no need to do anything here any more if we don't
3914 #if !NO_TAINT_SUPPORT
3916 const Uid_t my_uid = PerlProc_getuid();
3917 const Uid_t my_euid = PerlProc_geteuid();
3918 const Gid_t my_gid = PerlProc_getgid();
3919 const Gid_t my_egid = PerlProc_getegid();
3921 /* Should not happen: */
3922 CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
3923 TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
3927 * Should go by suidscript, not uid!=euid: why disallow
3928 * system("ls") in scripts run from setuid things?
3929 * Or, is this run before we check arguments and set suidscript?
3930 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3931 * (We never have suidscript, can we be sure to have fdscript?)
3932 * Or must then go by UID checks? See comments in forbid_setid also.
3936 /* This is used very early in the lifetime of the program,
3937 * before even the options are parsed, so PL_tainting has
3938 * not been initialized properly. */
3940 Perl_doing_taint(int argc, char *argv[], char *envp[])
3942 #ifndef PERL_IMPLICIT_SYS
3943 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3944 * before we have an interpreter-- and the whole point of this
3945 * function is to be called at such an early stage. If you are on
3946 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3947 * "tainted because running with altered effective ids', you'll
3948 * have to add your own checks somewhere in here. The two most
3949 * known samples of 'implicitness' are Win32 and NetWare, neither
3950 * of which has much of concept of 'uids'. */
3951 Uid_t uid = PerlProc_getuid();
3952 Uid_t euid = PerlProc_geteuid();
3953 Gid_t gid = PerlProc_getgid();
3954 Gid_t egid = PerlProc_getegid();
3961 if (uid && (euid != uid || egid != gid))
3963 #endif /* !PERL_IMPLICIT_SYS */
3964 /* This is a really primitive check; environment gets ignored only
3965 * if -T are the first chars together; otherwise one gets
3966 * "Too late" message. */
3967 if ( argc > 1 && argv[1][0] == '-'
3968 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3973 /* Passing the flag as a single char rather than a string is a slight space
3974 optimisation. The only message that isn't /^-.$/ is
3975 "program input from stdin", which is substituted in place of '\0', which
3976 could never be a command line flag. */
3978 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
3981 char string[3] = "-x";
3982 const char *message = "program input from stdin";
3989 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3990 if (PerlProc_getuid() != PerlProc_geteuid())
3991 Perl_croak(aTHX_ "No %s allowed while running setuid", message);
3992 if (PerlProc_getgid() != PerlProc_getegid())
3993 Perl_croak(aTHX_ "No %s allowed while running setgid", message);
3994 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3996 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4000 Perl_init_dbargs(pTHX)
4002 AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4007 /* Someone has already created it.
4008 It might have entries, and if we just turn off AvREAL(), they will
4009 "leak" until global destruction. */
4011 if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4012 Perl_croak(aTHX_ "Cannot set tied @DB::args");
4014 AvREIFY_only(PL_dbargs);
4018 Perl_init_debugger(pTHX)
4021 HV * const ostash = PL_curstash;
4023 PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4025 Perl_init_dbargs(aTHX);
4026 PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
4027 PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4028 PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
4029 PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4030 if (!SvIOK(PL_DBsingle))
4031 sv_setiv(PL_DBsingle, 0);
4032 PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4033 if (!SvIOK(PL_DBtrace))
4034 sv_setiv(PL_DBtrace, 0);
4035 PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4036 if (!SvIOK(PL_DBsignal))
4037 sv_setiv(PL_DBsignal, 0);
4038 SvREFCNT_dec(PL_curstash);
4039 PL_curstash = ostash;
4042 #ifndef STRESS_REALLOC
4043 #define REASONABLE(size) (size)
4045 #define REASONABLE(size) (1) /* unreasonable */
4049 Perl_init_stacks(pTHX)
4052 /* start with 128-item stack and 8K cxstack */
4053 PL_curstackinfo = new_stackinfo(REASONABLE(128),
4054 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4055 PL_curstackinfo->si_type = PERLSI_MAIN;
4056 PL_curstack = PL_curstackinfo->si_stack;
4057 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
4059 PL_stack_base = AvARRAY(PL_curstack);
4060 PL_stack_sp = PL_stack_base;
4061 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4063 Newx(PL_tmps_stack,REASONABLE(128),SV*);
4066 PL_tmps_max = REASONABLE(128);
4068 Newx(PL_markstack,REASONABLE(32),I32);
4069 PL_markstack_ptr = PL_markstack;
4070 PL_markstack_max = PL_markstack + REASONABLE(32);
4074 Newx(PL_scopestack,REASONABLE(32),I32);
4076 Newx(PL_scopestack_name,REASONABLE(32),const char*);
4078 PL_scopestack_ix = 0;
4079 PL_scopestack_max = REASONABLE(32);
4081 Newx(PL_savestack,REASONABLE(128),ANY);
4082 PL_savestack_ix = 0;
4083 PL_savestack_max = REASONABLE(128);
4092 while (PL_curstackinfo->si_next)
4093 PL_curstackinfo = PL_curstackinfo->si_next;
4094 while (PL_curstackinfo) {
4095 PERL_SI *p = PL_curstackinfo->si_prev;
4096 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4097 Safefree(PL_curstackinfo->si_cxstack);
4098 Safefree(PL_curstackinfo);
4099 PL_curstackinfo = p;
4101 Safefree(PL_tmps_stack);
4102 Safefree(PL_markstack);
4103 Safefree(PL_scopestack);
4105 Safefree(PL_scopestack_name);
4107 Safefree(PL_savestack);
4111 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4113 GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4114 AV *const isa = GvAVn(gv);
4117 PERL_ARGS_ASSERT_POPULATE_ISA;
4119 if(AvFILLp(isa) != -1)
4122 /* NOTE: No support for tied ISA */
4124 va_start(args, len);
4126 const char *const parent = va_arg(args, const char*);
4131 parent_len = va_arg(args, size_t);
4133 /* Arguments are supplied with a trailing :: */
4134 assert(parent_len > 2);
4135 assert(parent[parent_len - 1] == ':');
4136 assert(parent[parent_len - 2] == ':');
4137 av_push(isa, newSVpvn(parent, parent_len - 2));
4138 (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4145 S_init_predump_symbols(pTHX)
4151 sv_setpvs(get_sv("\"", GV_ADD), " ");
4152 PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4155 /* Historically, PVIOs were blessed into IO::Handle, unless
4156 FileHandle was loaded, in which case they were blessed into
4157 that. Action at a distance.
4158 However, if we simply bless into IO::Handle, we break code
4159 that assumes that PVIOs will have (among others) a seek
4160 method. IO::File inherits from IO::Handle and IO::Seekable,
4161 and provides the needed methods. But if we simply bless into
4162 it, then we break code that assumed that by loading
4163 IO::Handle, *it* would work.
4164 So a compromise is to set up the correct @IO::File::ISA,
4165 so that code that does C<use IO::Handle>; will still work.
4168 Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4169 STR_WITH_LEN("IO::Handle::"),
4170 STR_WITH_LEN("IO::Seekable::"),
4171 STR_WITH_LEN("Exporter::"),
4174 PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4175 GvMULTI_on(PL_stdingv);
4176 io = GvIOp(PL_stdingv);
4177 IoTYPE(io) = IoTYPE_RDONLY;
4178 IoIFP(io) = PerlIO_stdin();
4179 tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4181 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4183 tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4186 IoTYPE(io) = IoTYPE_WRONLY;
4187 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4189 tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4191 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4193 PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4194 GvMULTI_on(PL_stderrgv);
4195 io = GvIOp(PL_stderrgv);
4196 IoTYPE(io) = IoTYPE_WRONLY;
4197 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4198 tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4200 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4202 PL_statname = newSVpvs(""); /* last filename we did stat on */
4206 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4210 PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4212 argc--,argv++; /* skip name of script */
4213 if (PL_doswitches) {
4214 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4218 if (argv[0][1] == '-' && !argv[0][2]) {
4222 if ((s = strchr(argv[0], '='))) {
4223 const char *const start_name = argv[0] + 1;
4224 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4225 TRUE, SVt_PV)), s + 1);
4228 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4231 if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4232 GvMULTI_on(PL_argvgv);
4233 (void)gv_AVadd(PL_argvgv);
4234 av_clear(GvAVn(PL_argvgv));
4235 for (; argc > 0; argc--,argv++) {
4236 SV * const sv = newSVpv(argv[0],0);
4237 av_push(GvAVn(PL_argvgv),sv);
4238 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4239 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4242 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4243 (void)sv_utf8_decode(sv);
4247 if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4248 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4249 "-i used with no filenames on the command line, "
4250 "reading from STDIN");
4254 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4259 PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4261 PL_toptarget = newSV_type(SVt_PVIV);
4262 sv_setpvs(PL_toptarget, "");
4263 PL_bodytarget = newSV_type(SVt_PVIV);
4264 sv_setpvs(PL_bodytarget, "");
4265 PL_formtarget = PL_bodytarget;
4269 init_argv_symbols(argc,argv);
4271 if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4272 sv_setpv(GvSV(tmpgv),PL_origfilename);
4274 if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4276 bool env_is_not_environ;
4277 GvMULTI_on(PL_envgv);
4278 hv = GvHVn(PL_envgv);
4279 hv_magic(hv, NULL, PERL_MAGIC_env);
4281 #ifdef USE_ENVIRON_ARRAY
4282 /* Note that if the supplied env parameter is actually a copy
4283 of the global environ then it may now point to free'd memory
4284 if the environment has been modified since. To avoid this
4285 problem we treat env==NULL as meaning 'use the default'
4289 env_is_not_environ = env != environ;
4290 if (env_is_not_environ
4291 # ifdef USE_ITHREADS
4292 && PL_curinterp == aTHX
4301 for (; *env; env++) {
4304 if (!(s = strchr(old_var,'=')) || s == old_var)
4307 #if defined(MSDOS) && !defined(DJGPP)
4309 (void)strupr(old_var);
4312 sv = newSVpv(s+1, 0);
4313 (void)hv_store(hv, old_var, s - old_var, sv, 0);
4314 if (env_is_not_environ)
4318 #endif /* USE_ENVIRON_ARRAY */
4319 #endif /* !PERL_MICRO */
4323 /* touch @F array to prevent spurious warnings 20020415 MJD */
4325 (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4330 S_init_perllib(pTHX)
4334 const char *perl5lib = NULL;
4337 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4341 if (!TAINTING_get) {
4343 perl5lib = PerlEnv_getenv("PERL5LIB");
4345 * It isn't possible to delete an environment variable with
4346 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4347 * case we treat PERL5LIB as undefined if it has a zero-length value.
4349 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4350 if (perl5lib && *perl5lib != '\0')
4354 incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4356 s = PerlEnv_getenv("PERLLIB");
4358 incpush_use_sep(s, 0, 0);
4361 /* Treat PERL5?LIB as a possible search list logical name -- the
4362 * "natural" VMS idiom for a Unix path string. We allow each
4363 * element to be a set of |-separated directories for compatibility.
4367 if (my_trnlnm("PERL5LIB",buf,0))
4369 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4370 } while (my_trnlnm("PERL5LIB",buf,++idx));
4372 while (my_trnlnm("PERLLIB",buf,idx++))
4373 incpush_use_sep(buf, 0, 0);
4378 #ifndef PERL_IS_MINIPERL
4379 /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4380 (and not the architecture specific directories from $ENV{PERL5LIB}) */
4382 /* Use the ~-expanded versions of APPLLIB (undocumented),
4383 SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4386 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4387 INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4391 /* sitearch is always relative to sitelib on Windows for
4392 * DLL-based path intuition to work correctly */
4393 # if !defined(WIN32)
4394 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4395 INCPUSH_CAN_RELOCATE);
4401 /* this picks up sitearch as well */
4402 s = win32_get_sitelib(PERL_FS_VERSION, &len);
4404 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4406 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4410 #ifdef PERL_VENDORARCH_EXP
4411 /* vendorarch is always relative to vendorlib on Windows for
4412 * DLL-based path intuition to work correctly */
4413 # if !defined(WIN32)
4414 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4415 INCPUSH_CAN_RELOCATE);
4419 #ifdef PERL_VENDORLIB_EXP
4421 /* this picks up vendorarch as well */
4422 s = win32_get_vendorlib(PERL_FS_VERSION, &len);
4424 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4426 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4427 INCPUSH_CAN_RELOCATE);
4432 S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4436 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4440 s = win32_get_privlib(PERL_FS_VERSION, &len);
4442 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4445 S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4447 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4451 #ifdef PERL_OTHERLIBDIRS
4452 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4453 INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4454 |INCPUSH_CAN_RELOCATE);
4457 if (!TAINTING_get) {
4460 * It isn't possible to delete an environment variable with
4461 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4462 * case we treat PERL5LIB as undefined if it has a zero-length value.
4464 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4465 if (perl5lib && *perl5lib != '\0')
4469 incpush_use_sep(perl5lib, 0,
4470 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4472 /* Treat PERL5?LIB as a possible search list logical name -- the
4473 * "natural" VMS idiom for a Unix path string. We allow each
4474 * element to be a set of |-separated directories for compatibility.
4478 if (my_trnlnm("PERL5LIB",buf,0))
4480 incpush_use_sep(buf, 0,
4481 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4482 } while (my_trnlnm("PERL5LIB",buf,++idx));
4486 /* Use the ~-expanded versions of APPLLIB (undocumented),
4487 SITELIB and VENDORLIB for older versions
4490 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4491 |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4494 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4495 /* Search for version-specific dirs below here */
4496 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4497 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4501 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4502 /* Search for version-specific dirs below here */
4503 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4504 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4507 #ifdef PERL_OTHERLIBDIRS
4508 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4509 INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4510 |INCPUSH_CAN_RELOCATE);
4512 #endif /* !PERL_IS_MINIPERL */
4515 S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4518 #if defined(DOSISH) || defined(__SYMBIAN32__)
4519 # define PERLLIB_SEP ';'
4522 # define PERLLIB_SEP '|'
4524 # define PERLLIB_SEP ':'
4527 #ifndef PERLLIB_MANGLE
4528 # define PERLLIB_MANGLE(s,n) (s)
4531 #ifndef PERL_IS_MINIPERL
4532 /* Push a directory onto @INC if it exists.
4533 Generate a new SV if we do this, to save needing to copy the SV we push
4536 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4541 PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4543 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4544 S_ISDIR(tmpstatbuf.st_mode)) {
4546 dir = newSVsv(stem);
4548 /* Truncate dir back to stem. */
4549 SvCUR_set(dir, SvCUR(stem));
4556 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4558 const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4561 PERL_ARGS_ASSERT_MAYBERELOCATE;
4564 /* I am not convinced that this is valid when PERLLIB_MANGLE is
4565 defined to so something (in os2/os2.c), but the code has been
4566 this way, ignoring any possible changed of length, since
4567 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4569 libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4575 if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4577 while (unix[len-1] == '/') len--; /* Cosmetic */
4578 sv_usepvn(libdir,unix,len);
4581 PerlIO_printf(Perl_error_log,
4582 "Failed to unixify @INC element \"%s\"\n",
4583 SvPV_nolen_const(libdir));
4587 /* Do the if() outside the #ifdef to avoid warnings about an unused
4590 #ifdef PERL_RELOCATABLE_INC
4592 * Relocatable include entries are marked with a leading .../
4595 * 0: Remove that leading ".../"
4596 * 1: Remove trailing executable name (anything after the last '/')
4597 * from the perl path to give a perl prefix
4599 * While the @INC element starts "../" and the prefix ends with a real
4600 * directory (ie not . or ..) chop that real directory off the prefix
4601 * and the leading "../" from the @INC element. ie a logical "../"
4603 * Finally concatenate the prefix and the remainder of the @INC element
4604 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4605 * generates /usr/local/lib/perl5
4607 const char *libpath = SvPVX(libdir);
4608 STRLEN libpath_len = SvCUR(libdir);
4609 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4611 SV * const caret_X = get_sv("\030", 0);
4612 /* Going to use the SV just as a scratch buffer holding a C
4618 /* $^X is *the* source of taint if tainting is on, hence
4619 SvPOK() won't be true. */
4621 assert(SvPOKp(caret_X));
4622 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4624 /* Firstly take off the leading .../
4625 If all else fail we'll do the paths relative to the current
4627 sv_chop(libdir, libpath + 4);
4628 /* Don't use SvPV as we're intentionally bypassing taining,
4629 mortal copies that the mg_get of tainting creates, and
4630 corruption that seems to come via the save stack.
4631 I guess that the save stack isn't correctly set up yet. */
4632 libpath = SvPVX(libdir);
4633 libpath_len = SvCUR(libdir);
4635 /* This would work more efficiently with memrchr, but as it's
4636 only a GNU extension we'd need to probe for it and
4637 implement our own. Not hard, but maybe not worth it? */
4639 prefix = SvPVX(prefix_sv);
4640 lastslash = strrchr(prefix, '/');
4642 /* First time in with the *lastslash = '\0' we just wipe off
4643 the trailing /perl from (say) /usr/foo/bin/perl
4647 while ((*lastslash = '\0'), /* Do that, come what may. */
4648 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4649 && (lastslash = strrchr(prefix, '/')))) {
4650 if (lastslash[1] == '\0'
4651 || (lastslash[1] == '.'
4652 && (lastslash[2] == '/' /* ends "/." */
4653 || (lastslash[2] == '/'
4654 && lastslash[3] == '/' /* or "/.." */
4656 /* Prefix ends "/" or "/." or "/..", any of which
4657 are fishy, so don't do any more logical cleanup.
4661 /* Remove leading "../" from path */
4664 /* Next iteration round the loop removes the last
4665 directory name from prefix by writing a '\0' in
4666 the while clause. */
4668 /* prefix has been terminated with a '\0' to the correct
4669 length. libpath points somewhere into the libdir SV.
4670 We need to join the 2 with '/' and drop the result into
4672 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4673 SvREFCNT_dec(libdir);
4674 /* And this is the new libdir. */
4677 (PerlProc_getuid() != PerlProc_geteuid() ||
4678 PerlProc_getgid() != PerlProc_getegid())) {
4679 /* Need to taint relocated paths if running set ID */
4680 SvTAINTED_on(libdir);
4683 SvREFCNT_dec(prefix_sv);
4691 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4694 #ifndef PERL_IS_MINIPERL
4695 const U8 using_sub_dirs
4696 = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4697 |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4698 const U8 add_versioned_sub_dirs
4699 = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4700 const U8 add_archonly_sub_dirs
4701 = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4702 #ifdef PERL_INC_VERSION_LIST
4703 const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
4706 const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
4707 const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4708 AV *const inc = GvAVn(PL_incgv);
4710 PERL_ARGS_ASSERT_INCPUSH;
4713 /* Could remove this vestigial extra block, if we don't mind a lot of
4714 re-indenting diff noise. */
4716 SV *const libdir = mayberelocate(dir, len, flags);
4717 /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4718 arranged to unshift #! line -I onto the front of @INC. However,
4719 -I can add version and architecture specific libraries, and they
4720 need to go first. The old code assumed that it was always
4721 pushing. Hence to make it work, need to push the architecture
4722 (etc) libraries onto a temporary array, then "unshift" that onto
4723 the front of @INC. */
4724 #ifndef PERL_IS_MINIPERL
4725 AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4728 * BEFORE pushing libdir onto @INC we may first push version- and
4729 * archname-specific sub-directories.
4731 if (using_sub_dirs) {
4732 SV *subdir = newSVsv(libdir);
4733 #ifdef PERL_INC_VERSION_LIST
4734 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4735 const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4736 const char * const *incver;
4739 if (add_versioned_sub_dirs) {
4740 /* .../version/archname if -d .../version/archname */
4741 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4742 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4744 /* .../version if -d .../version */
4745 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4746 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4749 #ifdef PERL_INC_VERSION_LIST
4751 for (incver = incverlist; *incver; incver++) {
4752 /* .../xxx if -d .../xxx */
4753 Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4754 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4759 if (add_archonly_sub_dirs) {
4760 /* .../archname if -d .../archname */
4761 sv_catpvs(subdir, "/" ARCHNAME);
4762 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4766 assert (SvREFCNT(subdir) == 1);
4767 SvREFCNT_dec(subdir);
4769 #endif /* !PERL_IS_MINIPERL */
4770 /* finally add this lib directory at the end of @INC */
4772 #ifdef PERL_IS_MINIPERL
4773 const U32 extra = 0;
4775 U32 extra = av_len(av) + 1;
4777 av_unshift(inc, extra + push_basedir);
4779 av_store(inc, extra, libdir);
4780 #ifndef PERL_IS_MINIPERL
4782 /* av owns a reference, av_store() expects to be donated a
4783 reference, and av expects to be sane when it's cleared.
4784 If I wanted to be naughty and wrong, I could peek inside the
4785 implementation of av_clear(), realise that it uses
4786 SvREFCNT_dec() too, so av's array could be a run of NULLs,
4787 and so directly steal from it (with a memcpy() to inc, and
4788 then memset() to NULL them out. But people copy code from the
4789 core expecting it to be best practise, so let's use the API.
4790 Although studious readers will note that I'm not checking any
4792 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4797 else if (push_basedir) {
4798 av_push(inc, libdir);
4801 if (!push_basedir) {
4802 assert (SvREFCNT(libdir) == 1);
4803 SvREFCNT_dec(libdir);
4809 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
4813 /* This logic has been broken out from S_incpush(). It may be possible to
4816 PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4818 /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
4819 * argument to incpush_use_sep. This allows creation of relocatable
4820 * Perl distributions that patch the binary at install time. Those
4821 * distributions will have to provide their own relocation tools; this
4822 * is not a feature otherwise supported by core Perl.
4824 #ifndef PERL_RELOCATABLE_INCPUSH
4831 /* Break at all separators */
4832 while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
4834 /* skip any consecutive separators */
4836 /* Uncomment the next line for PATH semantics */
4837 /* But you'll need to write tests */
4838 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4840 incpush(p, (STRLEN)(s - p), flags);
4845 incpush(p, (STRLEN)(end - p), flags);
4850 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4854 volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
4860 PERL_ARGS_ASSERT_CALL_LIST;
4862 while (av_len(paramList) >= 0) {
4863 cv = MUTABLE_CV(av_shift(paramList));
4865 if (paramList == PL_beginav) {
4866 /* save PL_beginav for compiler */
4867 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
4869 else if (paramList == PL_checkav) {
4870 /* save PL_checkav for compiler */
4871 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
4873 else if (paramList == PL_unitcheckav) {
4874 /* save PL_unitcheckav for compiler */
4875 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
4886 PL_madskills |= 16384;
4891 PL_madskills &= ~16384;
4894 (void)SvPV_const(atsv, len);
4896 PL_curcop = &PL_compiling;
4897 CopLINE_set(PL_curcop, oldline);
4898 if (paramList == PL_beginav)
4899 sv_catpvs(atsv, "BEGIN failed--compilation aborted");
4901 Perl_sv_catpvf(aTHX_ atsv,
4902 "%s failed--call queue aborted",
4903 paramList == PL_checkav ? "CHECK"
4904 : paramList == PL_initav ? "INIT"
4905 : paramList == PL_unitcheckav ? "UNITCHECK"
4907 while (PL_scopestack_ix > oldscope)
4910 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
4917 /* my_exit() was called */
4918 while (PL_scopestack_ix > oldscope)
4921 SET_CURSTASH(PL_defstash);
4922 PL_curcop = &PL_compiling;
4923 CopLINE_set(PL_curcop, oldline);
4926 assert(0); /* NOTREACHED */
4929 PL_curcop = &PL_compiling;
4930 CopLINE_set(PL_curcop, oldline);
4933 PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
4942 Perl_my_exit(pTHX_ U32 status)
4953 STATUS_EXIT_SET(status);
4960 Perl_my_failure_exit(pTHX)
4964 /* We have been called to fall on our sword. The desired exit code
4965 * should be already set in STATUS_UNIX, but could be shifted over
4966 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
4969 * If an error code has not been set, then force the issue.
4971 if (MY_POSIX_EXIT) {
4973 /* According to the die_exit.t tests, if errno is non-zero */
4974 /* It should be used for the error status. */
4976 if (errno == EVMSERR) {
4977 STATUS_NATIVE = vaxc$errno;
4980 /* According to die_exit.t tests, if the child_exit code is */
4981 /* also zero, then we need to exit with a code of 255 */
4982 if ((errno != 0) && (errno < 256))
4983 STATUS_UNIX_EXIT_SET(errno);
4984 else if (STATUS_UNIX < 255) {
4985 STATUS_UNIX_EXIT_SET(255);
4990 /* The exit code could have been set by $? or vmsish which
4991 * means that it may not have fatal set. So convert
4992 * success/warning codes to fatal with out changing
4993 * the POSIX status code. The severity makes VMS native
4994 * status handling work, while UNIX mode programs use the
4995 * the POSIX exit codes.
4997 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
4998 STATUS_NATIVE &= STS$M_COND_ID;
4999 STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
5003 /* Traditionally Perl on VMS always expects a Fatal Error. */
5004 if (vaxc$errno & 1) {
5006 /* So force success status to failure */
5007 if (STATUS_NATIVE & 1)
5012 STATUS_UNIX = EINTR; /* In case something cares */
5017 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5019 /* Encode the severity code */
5020 severity = STATUS_NATIVE & STS$M_SEVERITY;
5021 STATUS_UNIX = (severity ? severity : 1) << 8;
5023 /* Perl expects this to be a fatal error */
5024 if (severity != STS$K_SEVERE)
5033 STATUS_UNIX_SET(errno);
5035 exitstatus = STATUS_UNIX >> 8;
5036 if (exitstatus & 255)
5037 STATUS_UNIX_SET(exitstatus);
5039 STATUS_UNIX_SET(255);
5046 S_my_exit_jump(pTHX)
5051 SvREFCNT_dec(PL_e_script);
5055 POPSTACK_TO(PL_mainstack);
5063 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5066 const char * const p = SvPVX_const(PL_e_script);
5067 const char *nl = strchr(p, '\n');
5069 PERL_UNUSED_ARG(idx);
5070 PERL_UNUSED_ARG(maxlen);
5072 nl = (nl) ? nl+1 : SvEND(PL_e_script);
5074 filter_del(read_e_script);
5077 sv_catpvn(buf_sv, p, nl-p);
5078 sv_chop(PL_e_script, nl);
5084 * c-indentation-style: bsd
5086 * indent-tabs-mode: nil
5089 * ex: set ts=8 sts=4 sw=4 et: