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 DEBUG_LEAKING_SCALARS_FORK_DUMP
52 char control[CMSG_SPACE(sizeof(int))];
65 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
66 char *getenv (char *); /* Usually in <stdlib.h> */
69 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
71 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
72 # define validate_suid(rsfp) NOOP
74 # define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
77 #define CALL_BODY_SUB(myop) \
78 if (PL_op == (myop)) \
79 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
83 #define CALL_LIST_BODY(cv) \
84 PUSHMARK(PL_stack_sp); \
85 call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
88 S_init_tls_and_interp(PerlInterpreter *my_perl)
92 PERL_SET_INTERP(my_perl);
93 #if defined(USE_ITHREADS)
96 PERL_SET_THX(my_perl);
100 MUTEX_INIT(&PL_dollarzero_mutex);
101 MUTEX_INIT(&PL_my_ctx_mutex);
104 #if defined(USE_ITHREADS)
107 /* This always happens for non-ithreads */
110 PERL_SET_THX(my_perl);
115 /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
118 Perl_sys_init(int* argc, char*** argv)
122 PERL_ARGS_ASSERT_SYS_INIT;
124 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
125 PERL_UNUSED_ARG(argv);
126 PERL_SYS_INIT_BODY(argc, argv);
130 Perl_sys_init3(int* argc, char*** argv, char*** env)
134 PERL_ARGS_ASSERT_SYS_INIT3;
136 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
137 PERL_UNUSED_ARG(argv);
138 PERL_UNUSED_ARG(env);
139 PERL_SYS_INIT3_BODY(argc, argv, env);
146 if (!PL_veto_cleanup) {
147 PERL_SYS_TERM_BODY();
152 #ifdef PERL_IMPLICIT_SYS
154 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
155 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
156 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
157 struct IPerlDir* ipD, struct IPerlSock* ipS,
158 struct IPerlProc* ipP)
160 PerlInterpreter *my_perl;
162 PERL_ARGS_ASSERT_PERL_ALLOC_USING;
164 /* Newx() needs interpreter, so call malloc() instead */
165 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
166 S_init_tls_and_interp(my_perl);
167 Zero(my_perl, 1, PerlInterpreter);
177 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
184 =head1 Embedding Functions
186 =for apidoc perl_alloc
188 Allocates a new Perl interpreter. See L<perlembed>.
196 PerlInterpreter *my_perl;
198 /* Newx() needs interpreter, so call malloc() instead */
199 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
201 S_init_tls_and_interp(my_perl);
202 #ifndef PERL_TRACK_MEMPOOL
203 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
205 Zero(my_perl, 1, PerlInterpreter);
206 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
210 #endif /* PERL_IMPLICIT_SYS */
213 =for apidoc perl_construct
215 Initializes a new Perl interpreter. See L<perlembed>.
221 perl_construct(pTHXx)
225 PERL_ARGS_ASSERT_PERL_CONSTRUCT;
229 PL_perl_destruct_level = 1;
231 PERL_UNUSED_ARG(my_perl);
232 if (PL_perl_destruct_level > 0)
235 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
237 #ifdef PERL_TRACE_OPS
238 Zero(PL_op_exec_cnt, OP_max+2, UV);
243 SvREADONLY_on(&PL_sv_placeholder);
244 SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
246 PL_sighandlerp = (Sighandler_t) Perl_sighandler;
247 #ifdef PERL_USES_PL_PIDSTATUS
248 PL_pidstatus = newHV();
251 PL_rs = newSVpvs("\n");
261 SET_NUMERIC_STANDARD();
263 #if defined(LOCAL_PATCH_COUNT)
264 PL_localpatches = local_patches; /* For possible -v */
267 #ifdef HAVE_INTERP_INTERN
271 PerlIO_init(aTHX); /* Hook to IO system */
273 PL_fdpid = newAV(); /* for remembering popen pids by fd */
274 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
275 PL_errors = newSVpvs("");
276 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
277 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
278 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
280 /* First entry is a list of empty elements. It needs to be initialised
281 else all hell breaks loose in S_find_uninit_var(). */
282 Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
283 PL_regex_pad = AvARRAY(PL_regex_padav);
284 Newxz(PL_stashpad, PL_stashpadmax, HV *);
286 #ifdef USE_REENTRANT_API
287 Perl_reentrant_init(aTHX);
289 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
290 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
291 * This MUST be done before any hash stores or fetches take place.
292 * If you set PL_hash_seed (and presumably also PL_hash_seed_set)
293 * yourself, it is your responsibility to provide a good random seed!
294 * You can also define PERL_HASH_SEED in compile time, see hv.h.
296 * XXX: fix this comment */
297 if (PL_hash_seed_set == FALSE) {
298 Perl_get_hash_seed(aTHX_ PL_hash_seed);
299 PL_hash_seed_set= TRUE;
301 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
303 /* Note that strtab is a rather special HV. Assumptions are made
304 about not iterating on it, and not adding tie magic to it.
305 It is properly deallocated in perl_destruct() */
308 HvSHAREKEYS_off(PL_strtab); /* mandatory */
309 hv_ksplit(PL_strtab, 512);
311 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
313 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
314 _dyld_lookup_and_bind
315 ("__environ", (unsigned long *) &environ_pointer, NULL);
319 # ifdef USE_ENVIRON_ARRAY
320 PL_origenviron = environ;
324 /* Use sysconf(_SC_CLK_TCK) if available, if not
325 * available or if the sysconf() fails, use the HZ.
326 * The HZ if not originally defined has been by now
327 * been defined as CLK_TCK, if available. */
328 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
329 PL_clocktick = sysconf(_SC_CLK_TCK);
330 if (PL_clocktick <= 0)
334 PL_stashcache = newHV();
336 PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
337 PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING);
340 if (!PL_mmap_page_size) {
341 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
343 SETERRNO(0, SS_NORMAL);
345 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
347 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
349 if ((long) PL_mmap_page_size < 0) {
351 SV * const error = ERRSV;
352 SvUPGRADE(error, SVt_PV);
353 Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
356 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
360 # ifdef HAS_GETPAGESIZE
361 PL_mmap_page_size = getpagesize();
363 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
364 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
368 if (PL_mmap_page_size <= 0)
369 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
370 (IV) PL_mmap_page_size);
372 #endif /* HAS_MMAP */
374 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
375 PL_timesbase.tms_utime = 0;
376 PL_timesbase.tms_stime = 0;
377 PL_timesbase.tms_cutime = 0;
378 PL_timesbase.tms_cstime = 0;
381 PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
383 PL_registered_mros = newHV();
384 /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
385 HvMAX(PL_registered_mros) = 0;
391 =for apidoc nothreadhook
393 Stub that provides thread hook for perl_destruct when there are
400 Perl_nothreadhook(pTHX)
406 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
408 Perl_dump_sv_child(pTHX_ SV *sv)
411 const int sock = PL_dumper_fd;
412 const int debug_fd = PerlIO_fileno(Perl_debug_log);
413 union control_un control;
416 struct cmsghdr *cmptr;
418 unsigned char buffer[256];
420 PERL_ARGS_ASSERT_DUMP_SV_CHILD;
422 if(sock == -1 || debug_fd == -1)
425 PerlIO_flush(Perl_debug_log);
427 /* All these shenanigans are to pass a file descriptor over to our child for
428 it to dump out to. We can't let it hold open the file descriptor when it
429 forks, as the file descriptor it will dump to can turn out to be one end
430 of pipe that some other process will wait on for EOF. (So as it would
431 be open, the wait would be forever.) */
433 msg.msg_control = control.control;
434 msg.msg_controllen = sizeof(control.control);
435 /* We're a connected socket so we don't need a destination */
441 cmptr = CMSG_FIRSTHDR(&msg);
442 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
443 cmptr->cmsg_level = SOL_SOCKET;
444 cmptr->cmsg_type = SCM_RIGHTS;
445 *((int *)CMSG_DATA(cmptr)) = 1;
447 vec[0].iov_base = (void*)&sv;
448 vec[0].iov_len = sizeof(sv);
449 got = sendmsg(sock, &msg, 0);
452 perror("Debug leaking scalars parent sendmsg failed");
455 if(got < sizeof(sv)) {
456 perror("Debug leaking scalars parent short sendmsg");
460 /* Return protocol is
462 unsigned char: length of location string (0 for empty)
463 unsigned char*: string (not terminated)
465 vec[0].iov_base = (void*)&returned_errno;
466 vec[0].iov_len = sizeof(returned_errno);
467 vec[1].iov_base = buffer;
470 got = readv(sock, vec, 2);
473 perror("Debug leaking scalars parent read failed");
474 PerlIO_flush(PerlIO_stderr());
477 if(got < sizeof(returned_errno) + 1) {
478 perror("Debug leaking scalars parent short read");
479 PerlIO_flush(PerlIO_stderr());
484 got = read(sock, buffer + 1, *buffer);
486 perror("Debug leaking scalars parent read 2 failed");
487 PerlIO_flush(PerlIO_stderr());
492 perror("Debug leaking scalars parent short read 2");
493 PerlIO_flush(PerlIO_stderr());
498 if (returned_errno || *buffer) {
499 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
500 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
501 returned_errno, Strerror(returned_errno));
507 =for apidoc perl_destruct
509 Shuts down a Perl interpreter. See L<perlembed>.
518 VOL signed char destruct_level; /* see possible values in intrpvar.h */
520 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
525 PERL_ARGS_ASSERT_PERL_DESTRUCT;
527 PERL_UNUSED_ARG(my_perl);
530 assert(PL_scopestack_ix == 1);
532 /* wait for all pseudo-forked children to finish */
533 PERL_WAIT_FOR_CHILDREN;
535 destruct_level = PL_perl_destruct_level;
536 #if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL)
538 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
540 const int i = atoi(s);
542 if (destruct_level < i) destruct_level = i;
544 #ifdef PERL_TRACK_MEMPOOL
545 /* RT #114496, for perl_free */
546 PL_perl_destruct_level = i;
552 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
558 if (PL_endav && !PL_minus_c) {
559 PERL_SET_PHASE(PERL_PHASE_END);
560 call_list(PL_scopestack_ix, PL_endav);
566 assert(PL_scopestack_ix == 0);
568 /* Need to flush since END blocks can produce output */
571 #ifdef PERL_TRACE_OPS
572 /* If we traced all Perl OP usage, report and clean up */
573 PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
574 for (i = 0; i <= OP_max; ++i) {
575 PerlIO_printf(Perl_debug_log, " %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
576 PL_op_exec_cnt[i] = 0;
578 /* Utility slot for easily doing little tracing experiments in the runloop: */
579 if (PL_op_exec_cnt[OP_max+1] != 0)
580 PerlIO_printf(Perl_debug_log, " SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]);
581 PerlIO_printf(Perl_debug_log, "\n");
585 if (PL_threadhook(aTHX)) {
586 /* Threads hook has vetoed further cleanup */
587 PL_veto_cleanup = TRUE;
591 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
592 if (destruct_level != 0) {
593 /* Fork here to create a child. Our child's job is to preserve the
594 state of scalars prior to destruction, so that we can instruct it
595 to dump any scalars that we later find have leaked.
596 There's no subtlety in this code - it assumes POSIX, and it doesn't
600 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
601 perror("Debug leaking scalars socketpair failed");
607 perror("Debug leaking scalars fork failed");
611 /* We are the child */
612 const int sock = fd[1];
613 const int debug_fd = PerlIO_fileno(Perl_debug_log);
616 /* Our success message is an integer 0, and a char 0 */
617 static const char success[sizeof(int) + 1] = {0};
621 /* We need to close all other file descriptors otherwise we end up
622 with interesting hangs, where the parent closes its end of a
623 pipe, and sits waiting for (another) child to terminate. Only
624 that child never terminates, because it never gets EOF, because
625 we also have the far end of the pipe open. We even need to
626 close the debugging fd, because sometimes it happens to be one
627 end of a pipe, and a process is waiting on the other end for
628 EOF. Normally it would be closed at some point earlier in
629 destruction, but if we happen to cause the pipe to remain open,
630 EOF never occurs, and we get an infinite hang. Hence all the
631 games to pass in a file descriptor if it's actually needed. */
633 f = sysconf(_SC_OPEN_MAX);
635 where = "sysconf failed";
646 union control_un control;
649 struct cmsghdr *cmptr;
653 msg.msg_control = control.control;
654 msg.msg_controllen = sizeof(control.control);
655 /* We're a connected socket so we don't need a source */
659 msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
661 vec[0].iov_base = (void*)⌖
662 vec[0].iov_len = sizeof(target);
664 got = recvmsg(sock, &msg, 0);
669 where = "recv failed";
672 if(got < sizeof(target)) {
673 where = "short recv";
677 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
681 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
682 where = "wrong cmsg_len";
685 if(cmptr->cmsg_level != SOL_SOCKET) {
686 where = "wrong cmsg_level";
689 if(cmptr->cmsg_type != SCM_RIGHTS) {
690 where = "wrong cmsg_type";
694 got_fd = *(int*)CMSG_DATA(cmptr);
695 /* For our last little bit of trickery, put the file descriptor
696 back into Perl_debug_log, as if we never actually closed it
698 if(got_fd != debug_fd) {
699 if (dup2(got_fd, debug_fd) == -1) {
706 PerlIO_flush(Perl_debug_log);
708 got = write(sock, &success, sizeof(success));
711 where = "write failed";
714 if(got < sizeof(success)) {
715 where = "short write";
722 int send_errno = errno;
723 unsigned char length = (unsigned char) strlen(where);
724 struct iovec failure[3] = {
725 {(void*)&send_errno, sizeof(send_errno)},
727 {(void*)where, length}
729 int got = writev(sock, failure, 3);
730 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
731 in the parent if we try to read from the socketpair after the
732 child has exited, even if there was data to read.
733 So sleep a bit to give the parent a fighting chance of
736 _exit((got == -1) ? errno : 0);
740 PL_dumper_fd = fd[0];
745 /* We must account for everything. */
747 /* Destroy the main CV and syntax tree */
748 /* Set PL_curcop now, because destroying ops can cause new SVs
749 to be generated in Perl_pad_swipe, and when running with
750 -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
751 op from which the filename structure member is copied. */
752 PL_curcop = &PL_compiling;
754 /* ensure comppad/curpad to refer to main's pad */
755 if (CvPADLIST(PL_main_cv)) {
756 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
757 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
759 op_free(PL_main_root);
762 PL_main_start = NULL;
763 /* note that PL_main_cv isn't usually actually freed at this point,
764 * due to the CvOUTSIDE refs from subs compiled within it. It will
765 * get freed once all the subs are freed in sv_clean_all(), for
766 * destruct_level > 0 */
767 SvREFCNT_dec(PL_main_cv);
769 PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
771 /* Tell PerlIO we are about to tear things apart in case
772 we have layers which are using resources that should
776 PerlIO_destruct(aTHX);
779 * Try to destruct global references. We do this first so that the
780 * destructors and destructees still exist. Some sv's might remain.
781 * Non-referenced objects are on their own.
785 /* unhook hooks which will soon be, or use, destroyed data */
786 SvREFCNT_dec(PL_warnhook);
788 SvREFCNT_dec(PL_diehook);
791 /* call exit list functions */
792 while (PL_exitlistlen-- > 0)
793 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
795 Safefree(PL_exitlist);
800 SvREFCNT_dec(PL_registered_mros);
802 /* jettison our possibly duplicated environment */
803 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
804 * so we certainly shouldn't free it here
807 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
808 if (environ != PL_origenviron && !PL_use_safe_putenv
810 /* only main thread can free environ[0] contents */
811 && PL_curinterp == aTHX
817 for (i = 0; environ[i]; i++)
818 safesysfree(environ[i]);
820 /* Must use safesysfree() when working with environ. */
821 safesysfree(environ);
823 environ = PL_origenviron;
826 #endif /* !PERL_MICRO */
828 if (destruct_level == 0) {
830 DEBUG_P(debprofdump());
832 #if defined(PERLIO_LAYERS)
833 /* No more IO - including error messages ! */
834 PerlIO_cleanup(aTHX);
837 CopFILE_free(&PL_compiling);
839 /* The exit() function will do everything that needs doing. */
843 /* Below, do clean up for when PERL_DESTRUCT_LEVEL is not 0 */
846 /* the syntax tree is shared between clones
847 * so op_free(PL_main_root) only ReREFCNT_dec's
848 * REGEXPs in the parent interpreter
849 * we need to manually ReREFCNT_dec for the clones
852 I32 i = AvFILLp(PL_regex_padav);
853 SV **ary = AvARRAY(PL_regex_padav);
856 SvREFCNT_dec(ary[i]);
857 ary[i] = &PL_sv_undef;
863 SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
864 PL_stashcache = NULL;
866 /* loosen bonds of global variables */
868 /* XXX can PL_parser still be non-null here? */
869 if(PL_parser && PL_parser->rsfp) {
870 (void)PerlIO_close(PL_parser->rsfp);
871 PL_parser->rsfp = NULL;
875 Safefree(PL_splitstr);
885 PL_doswitches = FALSE;
886 PL_dowarn = G_WARN_OFF;
887 #ifdef PERL_SAWAMPERSAND
888 PL_sawampersand = 0; /* must save all match strings */
892 Safefree(PL_inplace);
894 SvREFCNT_dec(PL_patchlevel);
895 SvREFCNT_dec(PL_apiversion);
898 SvREFCNT_dec(PL_e_script);
904 /* magical thingies */
906 SvREFCNT_dec(PL_ofsgv); /* *, */
909 SvREFCNT_dec(PL_ors_sv); /* $\ */
912 SvREFCNT_dec(PL_rs); /* $/ */
915 Safefree(PL_osname); /* $^O */
918 SvREFCNT_dec(PL_statname);
922 /* defgv, aka *_ should be taken care of elsewhere */
925 Safefree(PL_efloatbuf);
929 /* startup and shutdown function lists */
930 SvREFCNT_dec(PL_beginav);
931 SvREFCNT_dec(PL_beginav_save);
932 SvREFCNT_dec(PL_endav);
933 SvREFCNT_dec(PL_checkav);
934 SvREFCNT_dec(PL_checkav_save);
935 SvREFCNT_dec(PL_unitcheckav);
936 SvREFCNT_dec(PL_unitcheckav_save);
937 SvREFCNT_dec(PL_initav);
939 PL_beginav_save = NULL;
942 PL_checkav_save = NULL;
943 PL_unitcheckav = NULL;
944 PL_unitcheckav_save = NULL;
947 /* shortcuts just get cleared */
953 PL_last_in_gv = NULL;
961 SvREFCNT_dec(PL_envgv);
962 SvREFCNT_dec(PL_incgv);
963 SvREFCNT_dec(PL_argvgv);
964 SvREFCNT_dec(PL_replgv);
965 SvREFCNT_dec(PL_DBgv);
966 SvREFCNT_dec(PL_DBline);
967 SvREFCNT_dec(PL_DBsub);
976 SvREFCNT_dec(PL_argvout_stack);
977 PL_argvout_stack = NULL;
979 SvREFCNT_dec(PL_modglobal);
981 SvREFCNT_dec(PL_preambleav);
982 PL_preambleav = NULL;
983 SvREFCNT_dec(PL_subname);
985 #ifdef PERL_USES_PL_PIDSTATUS
986 SvREFCNT_dec(PL_pidstatus);
989 SvREFCNT_dec(PL_toptarget);
991 SvREFCNT_dec(PL_bodytarget);
992 PL_bodytarget = NULL;
993 PL_formtarget = NULL;
995 /* free locale stuff */
996 #ifdef USE_LOCALE_COLLATE
997 Safefree(PL_collation_name);
998 PL_collation_name = NULL;
1001 #ifdef USE_LOCALE_NUMERIC
1002 Safefree(PL_numeric_name);
1003 PL_numeric_name = NULL;
1004 SvREFCNT_dec(PL_numeric_radix_sv);
1005 PL_numeric_radix_sv = NULL;
1008 /* clear character classes */
1009 for (i = 0; i < POSIX_SWASH_COUNT; i++) {
1010 SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
1011 PL_utf8_swash_ptrs[i] = NULL;
1013 SvREFCNT_dec(PL_utf8_mark);
1014 SvREFCNT_dec(PL_utf8_toupper);
1015 SvREFCNT_dec(PL_utf8_totitle);
1016 SvREFCNT_dec(PL_utf8_tolower);
1017 SvREFCNT_dec(PL_utf8_tofold);
1018 SvREFCNT_dec(PL_utf8_idstart);
1019 SvREFCNT_dec(PL_utf8_idcont);
1020 SvREFCNT_dec(PL_utf8_foldclosures);
1021 SvREFCNT_dec(PL_AboveLatin1);
1022 SvREFCNT_dec(PL_UpperLatin1);
1023 SvREFCNT_dec(PL_Latin1);
1024 SvREFCNT_dec(PL_NonL1NonFinalFold);
1025 SvREFCNT_dec(PL_HasMultiCharFold);
1026 PL_utf8_mark = NULL;
1027 PL_utf8_toupper = NULL;
1028 PL_utf8_totitle = NULL;
1029 PL_utf8_tolower = NULL;
1030 PL_utf8_tofold = NULL;
1031 PL_utf8_idstart = NULL;
1032 PL_utf8_idcont = NULL;
1033 PL_utf8_foldclosures = NULL;
1034 PL_AboveLatin1 = NULL;
1035 PL_HasMultiCharFold = NULL;
1037 PL_NonL1NonFinalFold = NULL;
1038 PL_UpperLatin1 = NULL;
1039 for (i = 0; i < POSIX_CC_COUNT; i++) {
1040 SvREFCNT_dec(PL_Posix_ptrs[i]);
1041 PL_Posix_ptrs[i] = NULL;
1043 SvREFCNT_dec(PL_L1Posix_ptrs[i]);
1044 PL_L1Posix_ptrs[i] = NULL;
1046 SvREFCNT_dec(PL_XPosix_ptrs[i]);
1047 PL_XPosix_ptrs[i] = NULL;
1050 if (!specialWARN(PL_compiling.cop_warnings))
1051 PerlMemShared_free(PL_compiling.cop_warnings);
1052 PL_compiling.cop_warnings = NULL;
1053 cophh_free(CopHINTHASH_get(&PL_compiling));
1054 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
1055 CopFILE_free(&PL_compiling);
1057 /* Prepare to destruct main symbol table. */
1060 /* break ref loop *:: <=> %:: */
1061 (void)hv_delete(hv, "main::", 6, G_DISCARD);
1064 SvREFCNT_dec(PL_curstname);
1065 PL_curstname = NULL;
1067 /* clear queued errors */
1068 SvREFCNT_dec(PL_errors);
1071 SvREFCNT_dec(PL_isarev);
1074 if (destruct_level >= 2) {
1075 if (PL_scopestack_ix != 0)
1076 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1077 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1078 (long)PL_scopestack_ix);
1079 if (PL_savestack_ix != 0)
1080 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1081 "Unbalanced saves: %ld more saves than restores\n",
1082 (long)PL_savestack_ix);
1083 if (PL_tmps_floor != -1)
1084 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1085 (long)PL_tmps_floor + 1);
1086 if (cxstack_ix != -1)
1087 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1088 (long)cxstack_ix + 1);
1092 SvREFCNT_dec(PL_regex_padav);
1093 PL_regex_padav = NULL;
1094 PL_regex_pad = NULL;
1097 #ifdef PERL_IMPLICIT_CONTEXT
1098 /* the entries in this list are allocated via SV PVX's, so get freed
1099 * in sv_clean_all */
1100 Safefree(PL_my_cxt_list);
1103 /* Now absolutely destruct everything, somehow or other, loops or no. */
1105 /* the 2 is for PL_fdpid and PL_strtab */
1106 while (sv_clean_all() > 2)
1110 Safefree(PL_stashpad); /* must come after sv_clean_all */
1113 AvREAL_off(PL_fdpid); /* no surviving entries */
1114 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
1117 #ifdef HAVE_INTERP_INTERN
1121 /* constant strings */
1122 for (i = 0; i < SV_CONSTS_COUNT; i++) {
1123 SvREFCNT_dec(PL_sv_consts[i]);
1124 PL_sv_consts[i] = NULL;
1127 /* Destruct the global string table. */
1129 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1130 * so that sv_free() won't fail on them.
1131 * Now that the global string table is using a single hunk of memory
1132 * for both HE and HEK, we either need to explicitly unshare it the
1133 * correct way, or actually free things here.
1136 const I32 max = HvMAX(PL_strtab);
1137 HE * const * const array = HvARRAY(PL_strtab);
1138 HE *hent = array[0];
1141 if (hent && ckWARN_d(WARN_INTERNAL)) {
1142 HE * const next = HeNEXT(hent);
1143 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1144 "Unbalanced string table refcount: (%ld) for \"%s\"",
1145 (long)hent->he_valu.hent_refcount, HeKEY(hent));
1152 hent = array[riter];
1157 HvARRAY(PL_strtab) = 0;
1158 HvTOTALKEYS(PL_strtab) = 0;
1160 SvREFCNT_dec(PL_strtab);
1163 /* free the pointer tables used for cloning */
1164 ptr_table_free(PL_ptr_table);
1165 PL_ptr_table = (PTR_TBL_t*)NULL;
1168 /* free special SVs */
1170 SvREFCNT(&PL_sv_yes) = 0;
1171 sv_clear(&PL_sv_yes);
1172 SvANY(&PL_sv_yes) = NULL;
1173 SvFLAGS(&PL_sv_yes) = 0;
1175 SvREFCNT(&PL_sv_no) = 0;
1176 sv_clear(&PL_sv_no);
1177 SvANY(&PL_sv_no) = NULL;
1178 SvFLAGS(&PL_sv_no) = 0;
1182 for (i=0; i<=2; i++) {
1183 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1184 sv_clear(PERL_DEBUG_PAD(i));
1185 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1186 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1190 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1191 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1193 #ifdef DEBUG_LEAKING_SCALARS
1194 if (PL_sv_count != 0) {
1199 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1200 svend = &sva[SvREFCNT(sva)];
1201 for (sv = sva + 1; sv < svend; ++sv) {
1202 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
1203 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1205 " refcnt=%"UVuf pTHX__FORMAT "\n"
1206 "\tallocated at %s:%d %s %s (parent 0x%"UVxf");"
1208 (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1210 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1212 sv->sv_debug_inpad ? "for" : "by",
1213 sv->sv_debug_optype ?
1214 PL_op_name[sv->sv_debug_optype]: "(none)",
1215 PTR2UV(sv->sv_debug_parent),
1218 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1219 Perl_dump_sv_child(aTHX_ sv);
1225 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1229 /* Wait for up to 4 seconds for child to terminate.
1230 This seems to be the least effort way of timing out on reaping
1232 struct timeval waitfor = {4, 0};
1233 int sock = PL_dumper_fd;
1237 FD_SET(sock, &rset);
1238 select(sock + 1, &rset, NULL, NULL, &waitfor);
1239 waitpid(child, &status, WNOHANG);
1244 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1250 #if defined(PERLIO_LAYERS)
1251 /* No more IO - including error messages ! */
1252 PerlIO_cleanup(aTHX);
1255 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1256 as currently layers use it rather than NULL as a marker
1257 for no arg - and will try and SvREFCNT_dec it.
1259 SvREFCNT(&PL_sv_undef) = 0;
1260 SvREADONLY_off(&PL_sv_undef);
1262 Safefree(PL_origfilename);
1263 PL_origfilename = NULL;
1264 Safefree(PL_reg_curpm);
1265 free_tied_hv_pool();
1266 Safefree(PL_op_mask);
1267 Safefree(PL_psig_name);
1268 PL_psig_name = (SV**)NULL;
1269 PL_psig_ptr = (SV**)NULL;
1271 /* We need to NULL PL_psig_pend first, so that
1272 signal handlers know not to use it */
1273 int *psig_save = PL_psig_pend;
1274 PL_psig_pend = (int*)NULL;
1275 Safefree(psig_save);
1278 TAINTING_set(FALSE);
1279 TAINT_WARN_set(FALSE);
1280 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
1283 DEBUG_P(debprofdump());
1285 #ifdef USE_REENTRANT_API
1286 Perl_reentrant_free(aTHX);
1291 while (PL_regmatch_slab) {
1292 regmatch_slab *s = PL_regmatch_slab;
1293 PL_regmatch_slab = PL_regmatch_slab->next;
1297 /* As the absolutely last thing, free the non-arena SV for mess() */
1300 /* we know that type == SVt_PVMG */
1302 /* it could have accumulated taint magic */
1305 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1306 moremagic = mg->mg_moremagic;
1307 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1309 Safefree(mg->mg_ptr);
1313 /* we know that type >= SVt_PV */
1314 SvPV_free(PL_mess_sv);
1315 Safefree(SvANY(PL_mess_sv));
1316 Safefree(PL_mess_sv);
1323 =for apidoc perl_free
1325 Releases a Perl interpreter. See L<perlembed>.
1335 PERL_ARGS_ASSERT_PERL_FREE;
1337 if (PL_veto_cleanup)
1340 #ifdef PERL_TRACK_MEMPOOL
1343 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1344 * value as we're probably hunting memory leaks then
1346 if (PL_perl_destruct_level == 0) {
1347 const U32 old_debug = PL_debug;
1348 /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1349 thread at thread exit. */
1351 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1352 "free this thread's memory\n");
1353 PL_debug &= ~ DEBUG_m_FLAG;
1355 while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
1356 safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
1357 PL_debug = old_debug;
1362 #if defined(WIN32) || defined(NETWARE)
1363 # if defined(PERL_IMPLICIT_SYS)
1366 void *host = nw_internal_host;
1367 PerlMem_free(aTHXx);
1368 nw_delete_internal_host(host);
1370 void *host = w32_internal_host;
1371 PerlMem_free(aTHXx);
1372 win32_delete_internal_host(host);
1376 PerlMem_free(aTHXx);
1379 PerlMem_free(aTHXx);
1383 #if defined(USE_ITHREADS)
1384 /* provide destructors to clean up the thread key when libperl is unloaded */
1385 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1387 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1388 #pragma fini "perl_fini"
1389 #elif defined(__sun) && !defined(__GNUC__)
1390 #pragma fini (perl_fini)
1394 #if defined(__GNUC__)
1395 __attribute__((destructor))
1401 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
1404 PL_curinterp && !PL_veto_cleanup)
1409 #endif /* THREADS */
1412 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1415 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1416 PL_exitlist[PL_exitlistlen].fn = fn;
1417 PL_exitlist[PL_exitlistlen].ptr = ptr;
1422 S_set_caret_X(pTHX) {
1424 GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
1426 SV *const caret_x = GvSV(tmpgv);
1428 sv_setpv(caret_x, os2_execname(aTHX));
1430 # ifdef USE_KERN_PROC_PATHNAME
1435 mib[2] = KERN_PROC_PATHNAME;
1438 if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
1439 && size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
1440 sv_grow(caret_x, size);
1442 if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
1444 SvPOK_only(caret_x);
1445 SvCUR_set(caret_x, size - 1);
1450 # elif defined(USE_NSGETEXECUTABLEPATH)
1452 uint32_t size = sizeof(buf);
1454 _NSGetExecutablePath(buf, &size);
1455 if (size < MAXPATHLEN * MAXPATHLEN) {
1456 sv_grow(caret_x, size);
1457 if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
1458 char *const tidied = realpath(SvPVX(caret_x), NULL);
1460 sv_setpv(caret_x, tidied);
1463 SvPOK_only(caret_x);
1464 SvCUR_set(caret_x, size);
1469 # elif defined(HAS_PROCSELFEXE)
1470 char buf[MAXPATHLEN];
1471 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1473 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1474 includes a spurious NUL which will cause $^X to fail in system
1475 or backticks (this will prevent extensions from being built and
1476 many tests from working). readlink is not meant to add a NUL.
1477 Normal readlink works fine.
1479 if (len > 0 && buf[len-1] == '\0') {
1483 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1484 returning the text "unknown" from the readlink rather than the path
1485 to the executable (or returning an error from the readlink). Any
1486 valid path has a '/' in it somewhere, so use that to validate the
1487 result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1489 if (len > 0 && memchr(buf, '/', len)) {
1490 sv_setpvn(caret_x, buf, len);
1494 /* Fallback to this: */
1495 sv_setpv(caret_x, PL_origargv[0]);
1501 =for apidoc perl_parse
1503 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1508 #define SET_CURSTASH(newstash) \
1509 if (PL_curstash != newstash) { \
1510 SvREFCNT_dec(PL_curstash); \
1511 PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1515 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1522 PERL_ARGS_ASSERT_PERL_PARSE;
1523 #ifndef MULTIPLICITY
1524 PERL_UNUSED_ARG(my_perl);
1526 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG)
1528 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1530 if (s && (atoi(s) == 1)) {
1531 unsigned char *seed= PERL_HASH_SEED;
1532 unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
1533 PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
1534 while (seed < seed_end) {
1535 PerlIO_printf(Perl_debug_log, "%02x", *seed++);
1537 #ifdef PERL_HASH_RANDOMIZE_KEYS
1538 PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
1539 PL_HASH_RAND_BITS_ENABLED,
1540 PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
1542 PerlIO_printf(Perl_debug_log, "\n");
1545 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1549 if (PL_origalen != 0) {
1550 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1553 /* Set PL_origalen be the sum of the contiguous argv[]
1554 * elements plus the size of the env in case that it is
1555 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1556 * as the maximum modifiable length of $0. In the worst case
1557 * the area we are able to modify is limited to the size of
1558 * the original argv[0]. (See below for 'contiguous', though.)
1560 const char *s = NULL;
1563 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1564 /* Do the mask check only if the args seem like aligned. */
1566 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1568 /* See if all the arguments are contiguous in memory. Note
1569 * that 'contiguous' is a loose term because some platforms
1570 * align the argv[] and the envp[]. If the arguments look
1571 * like non-aligned, assume that they are 'strictly' or
1572 * 'traditionally' contiguous. If the arguments look like
1573 * aligned, we just check that they are within aligned
1574 * PTRSIZE bytes. As long as no system has something bizarre
1575 * like the argv[] interleaved with some other data, we are
1576 * fine. (Did I just evoke Murphy's Law?) --jhi */
1577 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1579 for (i = 1; i < PL_origargc; i++) {
1580 if ((PL_origargv[i] == s + 1
1582 || PL_origargv[i] == s + 2
1587 (PL_origargv[i] > s &&
1589 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1600 #ifndef PERL_USE_SAFE_PUTENV
1601 /* Can we grab env area too to be used as the area for $0? */
1602 if (s && PL_origenviron && !PL_use_safe_putenv) {
1603 if ((PL_origenviron[0] == s + 1)
1606 (PL_origenviron[0] > s &&
1607 PL_origenviron[0] <=
1608 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1611 #ifndef OS2 /* ENVIRON is read by the kernel too. */
1612 s = PL_origenviron[0];
1615 my_setenv("NoNe SuCh", NULL);
1616 /* Force copy of environment. */
1617 for (i = 1; PL_origenviron[i]; i++) {
1618 if (PL_origenviron[i] == s + 1
1621 (PL_origenviron[i] > s &&
1622 PL_origenviron[i] <=
1623 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1626 s = PL_origenviron[i];
1634 #endif /* !defined(PERL_USE_SAFE_PUTENV) */
1636 PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1641 /* Come here if running an undumped a.out. */
1643 PL_origfilename = savepv(argv[0]);
1644 PL_do_undump = FALSE;
1645 cxstack_ix = -1; /* start label stack again */
1647 assert (!TAINT_get);
1649 S_set_caret_X(aTHX);
1651 init_postdump_symbols(argc,argv,env);
1656 op_free(PL_main_root);
1657 PL_main_root = NULL;
1659 PL_main_start = NULL;
1660 SvREFCNT_dec(PL_main_cv);
1664 oldscope = PL_scopestack_ix;
1665 PL_dowarn = G_WARN_OFF;
1670 parse_body(env,xsinit);
1671 if (PL_unitcheckav) {
1672 call_list(oldscope, PL_unitcheckav);
1675 PERL_SET_PHASE(PERL_PHASE_CHECK);
1676 call_list(oldscope, PL_checkav);
1684 /* my_exit() was called */
1685 while (PL_scopestack_ix > oldscope)
1688 SET_CURSTASH(PL_defstash);
1689 if (PL_unitcheckav) {
1690 call_list(oldscope, PL_unitcheckav);
1693 PERL_SET_PHASE(PERL_PHASE_CHECK);
1694 call_list(oldscope, PL_checkav);
1699 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1707 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1708 miniperl, and we need to see those flags reflected in the values here. */
1710 /* What this returns is subject to change. Use the public interface in Config.
1713 S_Internals_V(pTHX_ CV *cv)
1716 #ifdef LOCAL_PATCH_COUNT
1717 const int local_patch_count = LOCAL_PATCH_COUNT;
1719 const int local_patch_count = 0;
1721 const int entries = 3 + local_patch_count;
1723 static const char non_bincompat_options[] =
1730 # ifdef NO_HASH_SEED
1733 # ifdef NO_TAINT_SUPPORT
1736 # ifdef PERL_DISABLE_PMC
1739 # ifdef PERL_DONT_CREATE_GVSV
1740 " PERL_DONT_CREATE_GVSV"
1742 # ifdef PERL_EXTERNAL_GLOB
1743 " PERL_EXTERNAL_GLOB"
1745 # ifdef PERL_HASH_FUNC_SIPHASH
1746 " PERL_HASH_FUNC_SIPHASH"
1748 # ifdef PERL_HASH_FUNC_SDBM
1749 " PERL_HASH_FUNC_SDBM"
1751 # ifdef PERL_HASH_FUNC_DJB2
1752 " PERL_HASH_FUNC_DJB2"
1754 # ifdef PERL_HASH_FUNC_SUPERFAST
1755 " PERL_HASH_FUNC_SUPERFAST"
1757 # ifdef PERL_HASH_FUNC_MURMUR3
1758 " PERL_HASH_FUNC_MURMUR3"
1760 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1761 " PERL_HASH_FUNC_ONE_AT_A_TIME"
1763 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1764 " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1766 # ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1767 " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1769 # ifdef PERL_IS_MINIPERL
1772 # ifdef PERL_MALLOC_WRAP
1775 # ifdef PERL_MEM_LOG
1778 # ifdef PERL_MEM_LOG_NOIMPL
1779 " PERL_MEM_LOG_NOIMPL"
1781 # ifdef PERL_NEW_COPY_ON_WRITE
1782 " PERL_NEW_COPY_ON_WRITE"
1784 # ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1785 " PERL_PERTURB_KEYS_DETERMINISTIC"
1787 # ifdef PERL_PERTURB_KEYS_DISABLED
1788 " PERL_PERTURB_KEYS_DISABLED"
1790 # ifdef PERL_PERTURB_KEYS_RANDOM
1791 " PERL_PERTURB_KEYS_RANDOM"
1793 # ifdef PERL_PRESERVE_IVUV
1794 " PERL_PRESERVE_IVUV"
1796 # ifdef PERL_RELOCATABLE_INCPUSH
1797 " PERL_RELOCATABLE_INCPUSH"
1799 # ifdef PERL_USE_DEVEL
1802 # ifdef PERL_USE_SAFE_PUTENV
1803 " PERL_USE_SAFE_PUTENV"
1805 # ifdef UNLINK_ALL_VERSIONS
1806 " UNLINK_ALL_VERSIONS"
1808 # ifdef USE_ATTRIBUTES_FOR_PERLIO
1809 " USE_ATTRIBUTES_FOR_PERLIO"
1811 # ifdef USE_FAST_STDIO
1814 # ifdef USE_HASH_SEED_EXPLICIT
1815 " USE_HASH_SEED_EXPLICIT"
1820 # ifdef USE_LOCALE_CTYPE
1823 # ifdef USE_PERL_ATOF
1826 # ifdef USE_SITECUSTOMIZE
1827 " USE_SITECUSTOMIZE"
1830 PERL_UNUSED_ARG(cv);
1831 PERL_UNUSED_ARG(items);
1833 EXTEND(SP, entries);
1835 PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
1836 PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
1837 sizeof(non_bincompat_options) - 1, SVs_TEMP));
1841 PUSHs(Perl_newSVpvn_flags(aTHX_
1842 STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__),
1845 PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
1849 PUSHs(&PL_sv_undef);
1852 for (i = 1; i <= local_patch_count; i++) {
1853 /* This will be an undef, if PL_localpatches[i] is NULL. */
1854 PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
1860 #define INCPUSH_UNSHIFT 0x01
1861 #define INCPUSH_ADD_OLD_VERS 0x02
1862 #define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04
1863 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08
1864 #define INCPUSH_NOT_BASEDIR 0x10
1865 #define INCPUSH_CAN_RELOCATE 0x20
1866 #define INCPUSH_ADD_SUB_DIRS \
1867 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
1870 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1874 int argc = PL_origargc;
1875 char **argv = PL_origargv;
1876 const char *scriptname = NULL;
1877 VOL bool dosearch = FALSE;
1879 bool doextract = FALSE;
1880 const char *cddir = NULL;
1881 #ifdef USE_SITECUSTOMIZE
1882 bool minus_f = FALSE;
1884 SV *linestr_sv = NULL;
1885 bool add_read_e_script = FALSE;
1886 U32 lex_start_flags = 0;
1888 PERL_SET_PHASE(PERL_PHASE_START);
1894 for (argc--,argv++; argc > 0; argc--,argv++) {
1895 if (argv[0][0] != '-' || !argv[0][1])
1901 #ifndef PERL_STRICT_CR
1925 if ((s = moreswitches(s)))
1930 #if SILENT_NO_TAINT_SUPPORT
1931 /* silently ignore */
1932 #elif NO_TAINT_SUPPORT
1933 Perl_croak_nocontext("This perl was compiled without taint support. "
1934 "Cowardly refusing to run with -t or -T flags");
1936 CHECK_MALLOC_TOO_LATE_FOR('t');
1937 if( !TAINTING_get ) {
1938 TAINT_WARN_set(TRUE);
1945 #if SILENT_NO_TAINT_SUPPORT
1946 /* silently ignore */
1947 #elif NO_TAINT_SUPPORT
1948 Perl_croak_nocontext("This perl was compiled without taint support. "
1949 "Cowardly refusing to run with -t or -T flags");
1951 CHECK_MALLOC_TOO_LATE_FOR('T');
1953 TAINT_WARN_set(FALSE);
1962 forbid_setid('e', FALSE);
1964 PL_e_script = newSVpvs("");
1965 add_read_e_script = TRUE;
1968 sv_catpv(PL_e_script, s);
1970 sv_catpv(PL_e_script, argv[1]);
1974 Perl_croak(aTHX_ "No code specified for -%c", c);
1975 sv_catpvs(PL_e_script, "\n");
1979 #ifdef USE_SITECUSTOMIZE
1985 case 'I': /* -I handled both here and in moreswitches() */
1986 forbid_setid('I', FALSE);
1987 if (!*++s && (s=argv[1]) != NULL) {
1991 STRLEN len = strlen(s);
1992 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
1995 Perl_croak(aTHX_ "No directory specified for -I");
1998 forbid_setid('S', FALSE);
2007 opts_prog = newSVpvs("use Config; Config::_V()");
2011 opts_prog = Perl_newSVpvf(aTHX_
2012 "use Config; Config::config_vars(qw%c%s%c)",
2016 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
2017 /* don't look for script or read stdin */
2018 scriptname = BIT_BUCKET;
2030 if (!*++s || isSPACE(*s)) {
2034 /* catch use of gnu style long options.
2035 Both of these exit immediately. */
2036 if (strEQ(s, "version"))
2038 if (strEQ(s, "help"))
2043 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
2054 #ifndef SECURE_INTERNAL_GETENV
2057 (s = PerlEnv_getenv("PERL5OPT")))
2061 if (*s == '-' && *(s+1) == 'T') {
2062 #if SILENT_NO_TAINT_SUPPORT
2063 /* silently ignore */
2064 #elif NO_TAINT_SUPPORT
2065 Perl_croak_nocontext("This perl was compiled without taint support. "
2066 "Cowardly refusing to run with -t or -T flags");
2068 CHECK_MALLOC_TOO_LATE_FOR('T');
2070 TAINT_WARN_set(FALSE);
2074 char *popt_copy = NULL;
2087 if (!strchr("CDIMUdmtwW", *s))
2088 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2092 popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2093 s = popt_copy + (s - d);
2101 #if SILENT_NO_TAINT_SUPPORT
2102 /* silently ignore */
2103 #elif NO_TAINT_SUPPORT
2104 Perl_croak_nocontext("This perl was compiled without taint support. "
2105 "Cowardly refusing to run with -t or -T flags");
2107 if( !TAINTING_get) {
2108 TAINT_WARN_set(TRUE);
2120 /* Set $^X early so that it can be used for relocatable paths in @INC */
2121 /* and for SITELIB_EXP in USE_SITECUSTOMIZE */
2122 assert (!TAINT_get);
2124 S_set_caret_X(aTHX);
2127 #if defined(USE_SITECUSTOMIZE)
2129 /* The games with local $! are to avoid setting errno if there is no
2130 sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2131 ie a q() operator with a NUL byte as a the delimiter. This avoids
2132 problems with pathnames containing (say) ' */
2133 # ifdef PERL_IS_MINIPERL
2134 AV *const inc = GvAV(PL_incgv);
2135 SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2138 /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2139 it should be reported immediately as a build failure. */
2140 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2142 "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }",
2147 /* SITELIB_EXP is a function call on Win32. */
2148 const char *const raw_sitelib = SITELIB_EXP;
2150 /* process .../.. if PERL_RELOCATABLE_INC is defined */
2151 SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2152 INCPUSH_CAN_RELOCATE);
2153 const char *const sitelib = SvPVX(sitelib_sv);
2154 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2156 "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2159 assert (SvREFCNT(sitelib_sv) == 1);
2160 SvREFCNT_dec(sitelib_sv);
2167 scriptname = argv[0];
2170 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2172 else if (scriptname == NULL) {
2174 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2180 assert (!TAINT_get);
2184 bool suidscript = FALSE;
2186 rsfp = open_script(scriptname, dosearch, &suidscript);
2188 rsfp = PerlIO_stdin();
2189 lex_start_flags = LEX_DONT_CLOSE_RSFP;
2192 validate_suid(rsfp);
2195 # if defined(SIGCHLD) || defined(SIGCLD)
2198 # define SIGCHLD SIGCLD
2200 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2201 if (sigstate == (Sighandler_t) SIG_IGN) {
2202 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2203 "Can't ignore signal CHLD, forcing to default");
2204 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2212 /* This will croak if suidscript is true, as -x cannot be used with
2214 forbid_setid('x', suidscript);
2215 /* Hence you can't get here if suidscript is true */
2217 linestr_sv = newSV_type(SVt_PV);
2218 lex_start_flags |= LEX_START_COPIED;
2219 find_beginning(linestr_sv, rsfp);
2220 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2221 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2225 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2226 CvUNIQUE_on(PL_compcv);
2228 CvPADLIST(PL_compcv) = pad_new(0);
2230 PL_isarev = newHV();
2233 boot_core_UNIVERSAL();
2235 newXS("Internals::V", S_Internals_V, __FILE__);
2238 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
2240 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
2246 # ifdef HAS_SOCKS5_INIT
2247 socks5_init(argv[0]);
2253 init_predump_symbols();
2254 /* init_postdump_symbols not currently designed to be called */
2255 /* more than once (ENV isn't cleared first, for example) */
2256 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2258 init_postdump_symbols(argc,argv,env);
2260 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2261 * or explicitly in some platforms.
2262 * locale.c:Perl_init_i18nl10n() if the environment
2263 * look like the user wants to use UTF-8. */
2264 #if defined(__SYMBIAN32__)
2265 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2267 # ifndef PERL_IS_MINIPERL
2269 /* Requires init_predump_symbols(). */
2270 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2275 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2276 * and the default open disciplines. */
2277 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2278 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2280 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2281 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2282 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2284 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2285 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2286 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2288 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2289 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2290 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2292 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2293 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2296 sv_setpvs(sv, ":utf8\0:utf8");
2298 sv_setpvs(sv, ":utf8\0");
2301 sv_setpvs(sv, "\0:utf8");
2310 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2311 if (strEQ(s, "unsafe"))
2312 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2313 else if (strEQ(s, "safe"))
2314 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2316 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2323 if (!TAINTING_get &&
2324 (s = PerlEnv_getenv("PERL_XMLDUMP"))) {
2328 PL_xmlfp = PerlIO_stdout();
2330 PL_xmlfp = PerlIO_open(s, "w");
2332 Perl_croak(aTHX_ "Can't open %s", s);
2334 my_setenv("PERL_XMLDUMP", NULL); /* hide from subprocs */
2340 if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2341 PL_madskills = atoi(s);
2342 my_setenv("PERL_MADSKILLS", NULL); /* hide from subprocs */
2347 lex_start(linestr_sv, rsfp, lex_start_flags);
2348 SvREFCNT_dec(linestr_sv);
2350 PL_subname = newSVpvs("main");
2352 if (add_read_e_script)
2353 filter_add(read_e_script, NULL);
2355 /* now parse the script */
2357 SETERRNO(0,SS_NORMAL);
2358 if (yyparse(GRAMPROG) || PL_parser->error_count) {
2360 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2362 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2366 CopLINE_set(PL_curcop, 0);
2367 SET_CURSTASH(PL_defstash);
2369 SvREFCNT_dec(PL_e_script);
2377 SAVECOPFILE(PL_curcop);
2378 SAVECOPLINE(PL_curcop);
2379 gv_check(PL_defstash);
2388 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2389 dump_mstats("after compilation:");
2394 PL_restartjmpenv = NULL;
2400 =for apidoc perl_run
2402 Tells a Perl interpreter to run. See L<perlembed>.
2415 PERL_ARGS_ASSERT_PERL_RUN;
2416 #ifndef MULTIPLICITY
2417 PERL_UNUSED_ARG(my_perl);
2420 oldscope = PL_scopestack_ix;
2428 cxstack_ix = -1; /* start context stack again */
2430 case 0: /* normal completion */
2434 case 2: /* my_exit() */
2435 while (PL_scopestack_ix > oldscope)
2438 SET_CURSTASH(PL_defstash);
2439 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2440 PL_endav && !PL_minus_c) {
2441 PERL_SET_PHASE(PERL_PHASE_END);
2442 call_list(oldscope, PL_endav);
2445 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2446 dump_mstats("after execution: ");
2452 POPSTACK_TO(PL_mainstack);
2455 PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2466 S_run_body(pTHX_ I32 oldscope)
2469 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2470 PL_sawampersand ? "Enabling" : "Omitting",
2471 (unsigned int)(PL_sawampersand)));
2473 if (!PL_restartop) {
2477 exit(0); /* less likely to core dump than my_exit(0) */
2481 if (DEBUG_x_TEST || DEBUG_B_TEST)
2482 dump_all_perl(!DEBUG_B_TEST);
2484 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2488 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2491 if (PERLDB_SINGLE && PL_DBsingle)
2492 sv_setiv(PL_DBsingle, 1);
2494 PERL_SET_PHASE(PERL_PHASE_INIT);
2495 call_list(oldscope, PL_initav);
2497 #ifdef PERL_DEBUG_READONLY_OPS
2498 if (PL_main_root && PL_main_root->op_slabbed)
2499 Slab_to_ro(OpSLAB(PL_main_root));
2505 PERL_SET_PHASE(PERL_PHASE_RUN);
2508 PL_restartjmpenv = NULL;
2509 PL_op = PL_restartop;
2513 else if (PL_main_start) {
2514 CvDEPTH(PL_main_cv) = 1;
2515 PL_op = PL_main_start;
2519 assert(0); /* NOTREACHED */
2523 =head1 SV Manipulation Functions
2525 =for apidoc p||get_sv
2527 Returns the SV of the specified Perl scalar. C<flags> are passed to
2528 C<gv_fetchpv>. If C<GV_ADD> is set and the
2529 Perl variable does not exist then it will be created. If C<flags> is zero
2530 and the variable does not exist then NULL is returned.
2536 Perl_get_sv(pTHX_ const char *name, I32 flags)
2540 PERL_ARGS_ASSERT_GET_SV;
2542 gv = gv_fetchpv(name, flags, SVt_PV);
2549 =head1 Array Manipulation Functions
2551 =for apidoc p||get_av
2553 Returns the AV of the specified Perl global or package array with the given
2554 name (so it won't work on lexical variables). C<flags> are passed
2555 to C<gv_fetchpv>. If C<GV_ADD> is set and the
2556 Perl variable does not exist then it will be created. If C<flags> is zero
2557 and the variable does not exist then NULL is returned.
2559 Perl equivalent: C<@{"$name"}>.
2565 Perl_get_av(pTHX_ const char *name, I32 flags)
2567 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2569 PERL_ARGS_ASSERT_GET_AV;
2579 =head1 Hash Manipulation Functions
2581 =for apidoc p||get_hv
2583 Returns the HV of the specified Perl hash. C<flags> are passed to
2584 C<gv_fetchpv>. If C<GV_ADD> is set and the
2585 Perl variable does not exist then it will be created. If C<flags> is zero
2586 and the variable does not exist then NULL is returned.
2592 Perl_get_hv(pTHX_ const char *name, I32 flags)
2594 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2596 PERL_ARGS_ASSERT_GET_HV;
2606 =head1 CV Manipulation Functions
2608 =for apidoc p||get_cvn_flags
2610 Returns the CV of the specified Perl subroutine. C<flags> are passed to
2611 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2612 exist then it will be declared (which has the same effect as saying
2613 C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
2614 then NULL is returned.
2616 =for apidoc p||get_cv
2618 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2624 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2626 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2628 PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2630 /* XXX this is probably not what they think they're getting.
2631 * It has the same effect as "sub name;", i.e. just a forward
2633 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2634 return newSTUB(gv,0);
2641 /* Nothing in core calls this now, but we can't replace it with a macro and
2642 move it to mathoms.c as a macro would evaluate name twice. */
2644 Perl_get_cv(pTHX_ const char *name, I32 flags)
2646 PERL_ARGS_ASSERT_GET_CV;
2648 return get_cvn_flags(name, strlen(name), flags);
2651 /* Be sure to refetch the stack pointer after calling these routines. */
2655 =head1 Callback Functions
2657 =for apidoc p||call_argv
2659 Performs a callback to the specified named and package-scoped Perl subroutine
2660 with C<argv> (a NULL-terminated array of strings) as arguments. See L<perlcall>.
2662 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2668 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2670 /* See G_* flags in cop.h */
2671 /* null terminated arg list */
2676 PERL_ARGS_ASSERT_CALL_ARGV;
2681 mXPUSHs(newSVpv(*argv,0));
2686 return call_pv(sub_name, flags);
2690 =for apidoc p||call_pv
2692 Performs a callback to the specified Perl sub. See L<perlcall>.
2698 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2699 /* name of the subroutine */
2700 /* See G_* flags in cop.h */
2702 PERL_ARGS_ASSERT_CALL_PV;
2704 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2708 =for apidoc p||call_method
2710 Performs a callback to the specified Perl method. The blessed object must
2711 be on the stack. See L<perlcall>.
2717 Perl_call_method(pTHX_ const char *methname, I32 flags)
2718 /* name of the subroutine */
2719 /* See G_* flags in cop.h */
2723 PERL_ARGS_ASSERT_CALL_METHOD;
2725 len = strlen(methname);
2726 sv = flags & G_METHOD_NAMED
2727 ? sv_2mortal(newSVpvn_share(methname, len,0))
2728 : newSVpvn_flags(methname, len, SVs_TEMP);
2730 return call_sv(sv, flags | G_METHOD);
2733 /* May be called with any of a CV, a GV, or an SV containing the name. */
2735 =for apidoc p||call_sv
2737 Performs a callback to the Perl sub whose name is in the SV. See
2744 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2745 /* See G_* flags in cop.h */
2748 LOGOP myop; /* fake syntax tree node */
2754 bool oldcatch = CATCH_GET;
2756 OP* const oldop = PL_op;
2759 PERL_ARGS_ASSERT_CALL_SV;
2761 if (flags & G_DISCARD) {
2765 if (!(flags & G_WANT)) {
2766 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2771 Zero(&myop, 1, LOGOP);
2772 if (!(flags & G_NOARGS))
2773 myop.op_flags |= OPf_STACKED;
2774 myop.op_flags |= OP_GIMME_REVERSE(flags);
2778 EXTEND(PL_stack_sp, 1);
2779 if (!(flags & G_METHOD_NAMED))
2780 *++PL_stack_sp = sv;
2782 oldscope = PL_scopestack_ix;
2784 if (PERLDB_SUB && PL_curstash != PL_debstash
2785 /* Handle first BEGIN of -d. */
2786 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2787 /* Try harder, since this may have been a sighandler, thus
2788 * curstash may be meaningless. */
2789 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2790 && !(flags & G_NODEBUG))
2791 myop.op_private |= OPpENTERSUB_DB;
2793 if (flags & (G_METHOD|G_METHOD_NAMED)) {
2794 if ( flags & G_METHOD_NAMED ) {
2795 Zero(&method_svop, 1, SVOP);
2796 method_svop.op_next = (OP*)&myop;
2797 method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
2798 method_svop.op_type = OP_METHOD_NAMED;
2799 method_svop.op_sv = sv;
2800 PL_op = (OP*)&method_svop;
2802 Zero(&method_unop, 1, UNOP);
2803 method_unop.op_next = (OP*)&myop;
2804 method_unop.op_ppaddr = PL_ppaddr[OP_METHOD];
2805 method_unop.op_type = OP_METHOD;
2806 PL_op = (OP*)&method_unop;
2808 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2809 myop.op_type = OP_ENTERSUB;
2813 if (!(flags & G_EVAL)) {
2815 CALL_BODY_SUB((OP*)&myop);
2816 retval = PL_stack_sp - (PL_stack_base + oldmark);
2817 CATCH_SET(oldcatch);
2820 myop.op_other = (OP*)&myop;
2822 create_eval_scope(flags|G_FAKINGEVAL);
2830 CALL_BODY_SUB((OP*)&myop);
2831 retval = PL_stack_sp - (PL_stack_base + oldmark);
2832 if (!(flags & G_KEEPERR)) {
2840 /* my_exit() was called */
2841 SET_CURSTASH(PL_defstash);
2845 assert(0); /* NOTREACHED */
2848 PL_restartjmpenv = NULL;
2849 PL_op = PL_restartop;
2853 PL_stack_sp = PL_stack_base + oldmark;
2854 if ((flags & G_WANT) == G_ARRAY)
2858 *++PL_stack_sp = &PL_sv_undef;
2863 if (PL_scopestack_ix > oldscope)
2864 delete_eval_scope();
2868 if (flags & G_DISCARD) {
2869 PL_stack_sp = PL_stack_base + oldmark;
2878 /* Eval a string. The G_EVAL flag is always assumed. */
2881 =for apidoc p||eval_sv
2883 Tells Perl to C<eval> the string in the SV. It supports the same flags
2884 as C<call_sv>, with the obvious exception of G_EVAL. See L<perlcall>.
2890 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2892 /* See G_* flags in cop.h */
2896 UNOP myop; /* fake syntax tree node */
2897 VOL I32 oldmark = SP - PL_stack_base;
2900 OP* const oldop = PL_op;
2903 PERL_ARGS_ASSERT_EVAL_SV;
2905 if (flags & G_DISCARD) {
2912 Zero(&myop, 1, UNOP);
2913 EXTEND(PL_stack_sp, 1);
2914 *++PL_stack_sp = sv;
2916 if (!(flags & G_NOARGS))
2917 myop.op_flags = OPf_STACKED;
2918 myop.op_type = OP_ENTEREVAL;
2919 myop.op_flags |= OP_GIMME_REVERSE(flags);
2920 if (flags & G_KEEPERR)
2921 myop.op_flags |= OPf_SPECIAL;
2923 if (flags & G_RE_REPARSING)
2924 myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
2926 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2927 * before a PUSHEVAL, which corrupts the stack after a croak */
2928 TAINT_PROPER("eval_sv()");
2934 if (PL_op == (OP*)(&myop)) {
2935 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
2937 goto fail; /* failed in compilation */
2940 retval = PL_stack_sp - (PL_stack_base + oldmark);
2941 if (!(flags & G_KEEPERR)) {
2949 /* my_exit() was called */
2950 SET_CURSTASH(PL_defstash);
2954 assert(0); /* NOTREACHED */
2957 PL_restartjmpenv = NULL;
2958 PL_op = PL_restartop;
2963 PL_stack_sp = PL_stack_base + oldmark;
2964 if ((flags & G_WANT) == G_ARRAY)
2968 *++PL_stack_sp = &PL_sv_undef;
2974 if (flags & G_DISCARD) {
2975 PL_stack_sp = PL_stack_base + oldmark;
2985 =for apidoc p||eval_pv
2987 Tells Perl to C<eval> the given string and return an SV* result.
2993 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2996 SV* sv = newSVpv(p, 0);
2998 PERL_ARGS_ASSERT_EVAL_PV;
3000 eval_sv(sv, G_SCALAR);
3009 /* just check empty string or undef? */
3010 if (croak_on_error) {
3011 SV * const errsv = ERRSV;
3012 if(SvTRUE_NN(errsv))
3013 /* replace with croak_sv? */
3014 Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
3020 /* Require a module. */
3023 =head1 Embedding Functions
3025 =for apidoc p||require_pv
3027 Tells Perl to C<require> the file named by the string argument. It is
3028 analogous to the Perl code C<eval "require '$file'">. It's even
3029 implemented that way; consider using load_module instead.
3034 Perl_require_pv(pTHX_ const char *pv)
3040 PERL_ARGS_ASSERT_REQUIRE_PV;
3042 PUSHSTACKi(PERLSI_REQUIRE);
3044 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3045 eval_sv(sv_2mortal(sv), G_DISCARD);
3051 S_usage(pTHX) /* XXX move this out into a module ? */
3053 /* This message really ought to be max 23 lines.
3054 * Removed -h because the user already knows that option. Others? */
3056 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3057 minimum of 509 character string literals. */
3058 static const char * const usage_msg[] = {
3059 " -0[octal] specify record separator (\\0, if no argument)\n"
3060 " -a autosplit mode with -n or -p (splits $_ into @F)\n"
3061 " -C[number/list] enables the listed Unicode features\n"
3062 " -c check syntax only (runs BEGIN and CHECK blocks)\n"
3063 " -d[:debugger] run program under debugger\n"
3064 " -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n",
3065 " -e program one line of program (several -e's allowed, omit programfile)\n"
3066 " -E program like -e, but enables all optional features\n"
3067 " -f don't do $sitelib/sitecustomize.pl at startup\n"
3068 " -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
3069 " -i[extension] edit <> files in place (makes backup if extension supplied)\n"
3070 " -Idirectory specify @INC/#include directory (several -I's allowed)\n",
3071 " -l[octal] enable line ending processing, specifies line terminator\n"
3072 " -[mM][-]module execute \"use/no module...\" before executing program\n"
3073 " -n assume \"while (<>) { ... }\" loop around program\n"
3074 " -p assume loop like -n but print line also, like sed\n"
3075 " -s enable rudimentary parsing for switches after programfile\n"
3076 " -S look for programfile using PATH environment variable\n",
3077 " -t enable tainting warnings\n"
3078 " -T enable tainting checks\n"
3079 " -u dump core after parsing program\n"
3080 " -U allow unsafe operations\n"
3081 " -v print version, patchlevel and license\n"
3082 " -V[:variable] print configuration summary (or a single Config.pm variable)\n",
3083 " -w enable many useful warnings\n"
3084 " -W enable all warnings\n"
3085 " -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
3086 " -X disable all warnings\n"
3088 "Run 'perldoc perl' for more help with Perl.\n\n",
3091 const char * const *p = usage_msg;
3092 PerlIO *out = PerlIO_stdout();
3095 "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3098 PerlIO_puts(out, *p++);
3102 /* convert a string of -D options (or digits) into an int.
3103 * sets *s to point to the char after the options */
3107 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3109 static const char * const usage_msgd[] = {
3110 " Debugging flag values: (see also -d)\n"
3111 " p Tokenizing and parsing (with v, displays parse stack)\n"
3112 " s Stack snapshots (with v, displays all stacks)\n"
3113 " l Context (loop) stack processing\n"
3114 " t Trace execution\n"
3115 " o Method and overloading resolution\n",
3116 " c String/numeric conversions\n"
3117 " P Print profiling info, source file input state\n"
3118 " m Memory and SV allocation\n"
3119 " f Format processing\n"
3120 " r Regular expression parsing and execution\n"
3121 " x Syntax tree dump\n",
3122 " u Tainting checks\n"
3123 " H Hash dump -- usurps values()\n"
3124 " X Scratchpad allocation\n"
3126 " S Op slab allocation\n"
3128 " R Include reference counts of dumped variables (eg when using -Ds)\n",
3129 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3130 " v Verbose: use in conjunction with other flags\n"
3131 " C Copy On Write\n"
3132 " A Consistency checks on internal structures\n"
3133 " q quiet - currently only suppresses the 'EXECUTING' message\n"
3134 " M trace smart match resolution\n"
3135 " B dump suBroutine definitions, including special Blocks like BEGIN\n",
3140 PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3143 /* if adding extra options, remember to update DEBUG_MASK */
3144 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
3146 for (; isWORDCHAR(**s); (*s)++) {
3147 const char * const d = strchr(debopts,**s);
3149 i |= 1 << (d - debopts);
3150 else if (ckWARN_d(WARN_DEBUGGING))
3151 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3152 "invalid option -D%c, use -D'' to see choices\n", **s);
3155 else if (isDIGIT(**s)) {
3157 for (; isWORDCHAR(**s); (*s)++) ;
3159 else if (givehelp) {
3160 const char *const *p = usage_msgd;
3161 while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3164 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3165 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3166 "-Dp not implemented on this platform\n");
3172 /* This routine handles any switches that can be given during run */
3175 Perl_moreswitches(pTHX_ const char *s)
3179 const char option = *s; /* used to remember option in -m/-M code */
3181 PERL_ARGS_ASSERT_MORESWITCHES;
3189 SvREFCNT_dec(PL_rs);
3190 if (s[1] == 'x' && s[2]) {
3191 const char *e = s+=2;
3197 flags = PERL_SCAN_SILENT_ILLDIGIT;
3198 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3199 if (s + numlen < e) {
3200 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3204 PL_rs = newSVpvs("");
3205 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
3206 tmps = (U8*)SvPVX(PL_rs);
3207 uvchr_to_utf8(tmps, rschar);
3208 SvCUR_set(PL_rs, UNISKIP(rschar));
3213 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3214 if (rschar & ~((U8)~0))
3215 PL_rs = &PL_sv_undef;
3216 else if (!rschar && numlen >= 2)
3217 PL_rs = newSVpvs("");
3219 char ch = (char)rschar;
3220 PL_rs = newSVpvn(&ch, 1);
3223 sv_setsv(get_sv("/", GV_ADD), PL_rs);
3228 PL_unicode = parse_unicode_opts( (const char **)&s );
3229 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3237 while (*s && !isSPACE(*s)) ++s;
3238 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3250 forbid_setid('d', FALSE);
3253 /* -dt indicates to the debugger that threads will be used */
3254 if (*s == 't' && !isWORDCHAR(s[1])) {
3256 my_setenv("PERL5DB_THREADED", "1");
3259 /* The following permits -d:Mod to accepts arguments following an =
3260 in the fashion that -MSome::Mod does. */
3261 if (*s == ':' || *s == '=') {
3268 sv = newSVpvs("no Devel::");
3270 sv = newSVpvs("use Devel::");
3274 end = s + strlen(s);
3276 /* We now allow -d:Module=Foo,Bar and -d:-Module */
3277 while(isWORDCHAR(*s) || *s==':') ++s;
3279 sv_catpvn(sv, start, end - start);
3281 sv_catpvn(sv, start, s-start);
3282 /* Don't use NUL as q// delimiter here, this string goes in the
3284 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3287 my_setenv("PERL5DB", SvPV_nolen_const(sv));
3291 PL_perldb = PERLDB_ALL;
3298 forbid_setid('D', FALSE);
3300 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3301 #else /* !DEBUGGING */
3302 if (ckWARN_d(WARN_DEBUGGING))
3303 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3304 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3305 for (s++; isWORDCHAR(*s); s++) ;
3312 Safefree(PL_inplace);
3313 #if defined(__CYGWIN__) /* do backup extension automagically */
3314 if (*(s+1) == '\0') {
3315 PL_inplace = savepvs(".bak");
3318 #endif /* __CYGWIN__ */
3320 const char * const start = ++s;
3321 while (*s && !isSPACE(*s))
3324 PL_inplace = savepvn(start, s - start);
3328 if (*s == '-') /* Additional switches on #! line. */
3332 case 'I': /* -I handled both here and in parse_body() */
3333 forbid_setid('I', FALSE);
3335 while (*s && isSPACE(*s))
3340 /* ignore trailing spaces (possibly followed by other switches) */
3342 for (e = p; *e && !isSPACE(*e); e++) ;
3346 } while (*p && *p != '-');
3348 INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3354 Perl_croak(aTHX_ "No directory specified for -I");
3360 SvREFCNT_dec(PL_ors_sv);
3366 PL_ors_sv = newSVpvs("\n");
3367 numlen = 3 + (*s == '0');
3368 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3372 if (RsPARA(PL_rs)) {
3373 PL_ors_sv = newSVpvs("\n\n");
3376 PL_ors_sv = newSVsv(PL_rs);
3381 forbid_setid('M', FALSE); /* XXX ? */
3384 forbid_setid('m', FALSE); /* XXX ? */
3389 const char *use = "use ";
3391 /* -M-foo == 'no foo' */
3392 /* Leading space on " no " is deliberate, to make both
3393 possibilities the same length. */
3394 if (*s == '-') { use = " no "; ++s; }
3395 sv = newSVpvn(use,4);
3397 /* We allow -M'Module qw(Foo Bar)' */
3398 while(isWORDCHAR(*s) || *s==':') {
3407 Perl_croak(aTHX_ "Module name required with -%c option",
3410 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3411 "contains single ':'",
3412 (int)(s - start), start, option);
3413 end = s + strlen(s);
3415 sv_catpvn(sv, start, end - start);
3416 if (option == 'm') {
3418 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3419 sv_catpvs( sv, " ()");
3422 sv_catpvn(sv, start, s-start);
3423 /* Use NUL as q''-delimiter. */
3424 sv_catpvs(sv, " split(/,/,q\0");
3426 sv_catpvn(sv, s, end - s);
3427 sv_catpvs(sv, "\0)");
3430 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3433 Perl_croak(aTHX_ "Missing argument to -%c", option);
3444 forbid_setid('s', FALSE);
3445 PL_doswitches = TRUE;
3450 #if SILENT_NO_TAINT_SUPPORT
3451 /* silently ignore */
3452 #elif NO_TAINT_SUPPORT
3453 Perl_croak_nocontext("This perl was compiled without taint support. "
3454 "Cowardly refusing to run with -t or -T flags");
3462 PL_do_undump = TRUE;
3472 if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3473 PL_dowarn |= G_WARN_ON;
3478 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3479 if (!specialWARN(PL_compiling.cop_warnings))
3480 PerlMemShared_free(PL_compiling.cop_warnings);
3481 PL_compiling.cop_warnings = pWARN_ALL ;
3485 PL_dowarn = G_WARN_ALL_OFF;
3486 if (!specialWARN(PL_compiling.cop_warnings))
3487 PerlMemShared_free(PL_compiling.cop_warnings);
3488 PL_compiling.cop_warnings = pWARN_NONE ;
3495 if (s[0] == '-') /* Additional switches on #! line. */
3500 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3506 #ifdef ALTERNATE_SHEBANG
3507 case 'S': /* OS/2 needs -S on "extproc" line. */
3510 case 'e': case 'f': case 'x': case 'E':
3511 #ifndef ALTERNATE_SHEBANG
3515 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3518 "Unrecognized switch: -%.1s (-h will show valid options)",s
3528 PerlIO * PIO_stdout;
3529 if (!sv_derived_from(PL_patchlevel, "version"))
3530 upg_version(PL_patchlevel, TRUE);
3532 SV* level= vstringify(PL_patchlevel);
3533 #ifdef PERL_PATCHNUM
3534 # ifdef PERL_GIT_UNCOMMITTED_CHANGES
3535 SV *num = newSVpvs(PERL_PATCHNUM "*");
3537 SV *num = newSVpvs(PERL_PATCHNUM);
3540 STRLEN level_len, num_len;
3541 char * level_str, * num_str;
3542 num_str = SvPV(num, num_len);
3543 level_str = SvPV(level, level_len);
3544 if (num_len>=level_len && strnEQ(num_str,level_str,level_len)) {
3545 SvREFCNT_dec(level);
3548 Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
3553 PIO_stdout = PerlIO_stdout();
3554 PerlIO_printf(PIO_stdout,
3555 "\nThis is perl " STRINGIFY(PERL_REVISION)
3556 ", version " STRINGIFY(PERL_VERSION)
3557 ", subversion " STRINGIFY(PERL_SUBVERSION)
3558 " (%"SVf") built for " ARCHNAME, level
3560 SvREFCNT_dec(level);
3562 #if defined(LOCAL_PATCH_COUNT)
3563 if (LOCAL_PATCH_COUNT > 0)
3564 PerlIO_printf(PIO_stdout,
3565 "\n(with %d registered patch%s, "
3566 "see perl -V for more detail)",
3568 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3571 PerlIO_printf(PIO_stdout,
3572 "\n\nCopyright 1987-2013, Larry Wall\n");
3574 PerlIO_printf(PIO_stdout,
3575 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3578 PerlIO_printf(PIO_stdout,
3579 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3580 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3583 PerlIO_printf(PIO_stdout,
3584 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3585 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3588 PerlIO_printf(PIO_stdout,
3589 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3592 PerlIO_printf(PIO_stdout,
3593 "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3596 PerlIO_printf(PIO_stdout,
3597 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3600 PerlIO_printf(PIO_stdout,
3601 "WINCE port by Rainer Keuchel, 2001-2002\n"
3602 "Built on " __DATE__ " " __TIME__ "\n\n");
3605 #ifdef __SYMBIAN32__
3606 PerlIO_printf(PIO_stdout,
3607 "Symbian port by Nokia, 2004-2005\n");
3609 #ifdef BINARY_BUILD_NOTICE
3610 BINARY_BUILD_NOTICE;
3612 PerlIO_printf(PIO_stdout,
3614 Perl may be copied only under the terms of either the Artistic License or the\n\
3615 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3616 Complete documentation for Perl, including FAQ lists, should be found on\n\
3617 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3618 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3622 /* compliments of Tom Christiansen */
3624 /* unexec() can be found in the Gnu emacs distribution */
3625 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3628 #include <lib$routines.h>
3632 Perl_my_unexec(pTHX)
3634 PERL_UNUSED_CONTEXT;
3636 SV * prog = newSVpv(BIN_EXP, 0);
3637 SV * file = newSVpv(PL_origfilename, 0);
3641 sv_catpvs(prog, "/perl");
3642 sv_catpvs(file, ".perldump");
3644 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3645 /* unexec prints msg to stderr in case of failure */
3646 PerlProc_exit(status);
3649 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3650 # elif defined(WIN32) || defined(__CYGWIN__)
3651 Perl_croak(aTHX_ "dump is not supported");
3653 ABORT(); /* for use with undump */
3658 /* initialize curinterp */
3664 # define PERLVAR(prefix,var,type)
3665 # define PERLVARA(prefix,var,n,type)
3666 # if defined(PERL_IMPLICIT_CONTEXT)
3667 # define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init;
3668 # define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init;
3670 # define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init;
3671 # define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init;
3673 # include "intrpvar.h"
3679 # define PERLVAR(prefix,var,type)
3680 # define PERLVARA(prefix,var,n,type)
3681 # define PERLVARI(prefix,var,type,init) PL_##var = init;
3682 # define PERLVARIC(prefix,var,type,init) PL_##var = init;
3683 # include "intrpvar.h"
3693 S_init_main_stash(pTHX)
3698 PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
3699 /* We know that the string "main" will be in the global shared string
3700 table, so it's a small saving to use it rather than allocate another
3702 PL_curstname = newSVpvs_share("main");
3703 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3704 /* If we hadn't caused another reference to "main" to be in the shared
3705 string table above, then it would be worth reordering these two,
3706 because otherwise all we do is delete "main" from it as a consequence
3707 of the SvREFCNT_dec, only to add it again with hv_name_set */
3708 SvREFCNT_dec(GvHV(gv));
3709 hv_name_set(PL_defstash, "main", 4, 0);
3710 GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3712 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3714 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3715 GvMULTI_on(PL_incgv);
3716 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3717 SvREFCNT_inc_simple_void(PL_hintgv);
3718 GvMULTI_on(PL_hintgv);
3719 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3720 SvREFCNT_inc_simple_void(PL_defgv);
3721 PL_errgv = gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV);
3722 SvREFCNT_inc_simple_void(PL_errgv);
3723 GvMULTI_on(PL_errgv);
3724 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3725 SvREFCNT_inc_simple_void(PL_replgv);
3726 GvMULTI_on(PL_replgv);
3727 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
3728 #ifdef PERL_DONT_CREATE_GVSV
3731 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3733 SET_CURSTASH(PL_defstash);
3734 CopSTASH_set(&PL_compiling, PL_defstash);
3735 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3736 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3738 /* We must init $/ before switches are processed. */
3739 sv_setpvs(get_sv("/", GV_ADD), "\n");
3743 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
3746 PerlIO *rsfp = NULL;
3750 PERL_ARGS_ASSERT_OPEN_SCRIPT;
3753 PL_origfilename = savepvs("-e");
3756 /* if find_script() returns, it returns a malloc()-ed value */
3757 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3759 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3760 const char *s = scriptname + 8;
3766 * Tell apart "normal" usage of fdscript, e.g.
3767 * with bash on FreeBSD:
3768 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3769 * from usage in suidperl.
3770 * Does any "normal" usage leave garbage after the number???
3771 * Is it a mistake to use a similar /dev/fd/ construct for
3776 * Be supersafe and do some sanity-checks.
3777 * Still, can we be sure we got the right thing?
3780 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3783 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3785 scriptname = savepv(s + 1);
3786 Safefree(PL_origfilename);
3787 PL_origfilename = (char *)scriptname;
3792 CopFILE_free(PL_curcop);
3793 CopFILE_set(PL_curcop, PL_origfilename);
3794 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3795 scriptname = (char *)"";
3796 if (fdscript >= 0) {
3797 rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3799 else if (!*scriptname) {
3800 forbid_setid(0, *suidscript);
3804 #ifdef FAKE_BIT_BUCKET
3805 /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3806 * is called) and still have the "-e" work. (Believe it or not,
3807 * a /dev/null is required for the "-e" to work because source
3808 * filter magic is used to implement it. ) This is *not* a general
3809 * replacement for a /dev/null. What we do here is create a temp
3810 * file (an empty file), open up that as the script, and then
3811 * immediately close and unlink it. Close enough for jazz. */
3812 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3813 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3814 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3815 char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3816 FAKE_BIT_BUCKET_TEMPLATE
3818 const char * const err = "Failed to create a fake bit bucket";
3819 if (strEQ(scriptname, BIT_BUCKET)) {
3820 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3821 int tmpfd = mkstemp(tmpname);
3823 scriptname = tmpname;
3826 Perl_croak(aTHX_ err);
3829 scriptname = mktemp(tmpname);
3831 Perl_croak(aTHX_ err);
3836 rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3837 #ifdef FAKE_BIT_BUCKET
3838 if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3839 sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3840 && strlen(scriptname) == sizeof(tmpname) - 1) {
3843 scriptname = BIT_BUCKET;
3847 /* PSz 16 Sep 03 Keep neat error message */
3849 Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3851 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3852 CopFILE(PL_curcop), Strerror(errno));
3854 #if defined(HAS_FCNTL) && defined(F_SETFD)
3855 /* ensure close-on-exec */
3856 fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
3859 if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
3860 && S_ISDIR(tmpstatbuf.st_mode))
3861 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3869 * I_SYSSTATVFS HAS_FSTATVFS
3871 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3872 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3873 * here so that metaconfig picks them up. */
3876 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3877 /* Don't even need this function. */
3880 S_validate_suid(pTHX_ PerlIO *rsfp)
3882 const Uid_t my_uid = PerlProc_getuid();
3883 const Uid_t my_euid = PerlProc_geteuid();
3884 const Gid_t my_gid = PerlProc_getgid();
3885 const Gid_t my_egid = PerlProc_getegid();
3887 PERL_ARGS_ASSERT_VALIDATE_SUID;
3889 if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */
3892 PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3893 if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3895 (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3898 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3899 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3900 /* not set-id, must be wrapped */
3903 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3906 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3912 PERL_ARGS_ASSERT_FIND_BEGINNING;
3914 /* skip forward in input to the real script? */
3917 if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3918 Perl_croak(aTHX_ "No Perl script found in input\n");
3920 } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3921 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
3922 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3924 while (*s == ' ' || *s == '\t') s++;
3926 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3927 || s2[-1] == '_') s2--;
3928 if (strnEQ(s2-4,"perl",4))
3929 while ((s = moreswitches(s)))
3938 /* no need to do anything here any more if we don't
3940 #if !NO_TAINT_SUPPORT
3942 const Uid_t my_uid = PerlProc_getuid();
3943 const Uid_t my_euid = PerlProc_geteuid();
3944 const Gid_t my_gid = PerlProc_getgid();
3945 const Gid_t my_egid = PerlProc_getegid();
3947 /* Should not happen: */
3948 CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
3949 TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
3953 * Should go by suidscript, not uid!=euid: why disallow
3954 * system("ls") in scripts run from setuid things?
3955 * Or, is this run before we check arguments and set suidscript?
3956 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3957 * (We never have suidscript, can we be sure to have fdscript?)
3958 * Or must then go by UID checks? See comments in forbid_setid also.
3962 /* This is used very early in the lifetime of the program,
3963 * before even the options are parsed, so PL_tainting has
3964 * not been initialized properly. */
3966 Perl_doing_taint(int argc, char *argv[], char *envp[])
3968 #ifndef PERL_IMPLICIT_SYS
3969 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3970 * before we have an interpreter-- and the whole point of this
3971 * function is to be called at such an early stage. If you are on
3972 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3973 * "tainted because running with altered effective ids', you'll
3974 * have to add your own checks somewhere in here. The two most
3975 * known samples of 'implicitness' are Win32 and NetWare, neither
3976 * of which has much of concept of 'uids'. */
3977 Uid_t uid = PerlProc_getuid();
3978 Uid_t euid = PerlProc_geteuid();
3979 Gid_t gid = PerlProc_getgid();
3980 Gid_t egid = PerlProc_getegid();
3987 if (uid && (euid != uid || egid != gid))
3989 #endif /* !PERL_IMPLICIT_SYS */
3990 /* This is a really primitive check; environment gets ignored only
3991 * if -T are the first chars together; otherwise one gets
3992 * "Too late" message. */
3993 if ( argc > 1 && argv[1][0] == '-'
3994 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3999 /* Passing the flag as a single char rather than a string is a slight space
4000 optimisation. The only message that isn't /^-.$/ is
4001 "program input from stdin", which is substituted in place of '\0', which
4002 could never be a command line flag. */
4004 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
4007 char string[3] = "-x";
4008 const char *message = "program input from stdin";
4015 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4016 if (PerlProc_getuid() != PerlProc_geteuid())
4017 Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4018 if (PerlProc_getgid() != PerlProc_getegid())
4019 Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4020 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4022 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4026 Perl_init_dbargs(pTHX)
4028 AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
4033 /* Someone has already created it.
4034 It might have entries, and if we just turn off AvREAL(), they will
4035 "leak" until global destruction. */
4037 if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
4038 Perl_croak(aTHX_ "Cannot set tied @DB::args");
4040 AvREIFY_only(PL_dbargs);
4044 Perl_init_debugger(pTHX)
4047 HV * const ostash = PL_curstash;
4049 PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4051 Perl_init_dbargs(aTHX);
4052 PL_DBgv = MUTABLE_GV(
4053 SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV))
4055 PL_DBline = MUTABLE_GV(
4056 SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV))
4058 PL_DBsub = MUTABLE_GV(SvREFCNT_inc(
4059 gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV))
4061 PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4062 if (!SvIOK(PL_DBsingle))
4063 sv_setiv(PL_DBsingle, 0);
4064 PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4065 if (!SvIOK(PL_DBtrace))
4066 sv_setiv(PL_DBtrace, 0);
4067 PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4068 if (!SvIOK(PL_DBsignal))
4069 sv_setiv(PL_DBsignal, 0);
4070 SvREFCNT_dec(PL_curstash);
4071 PL_curstash = ostash;
4074 #ifndef STRESS_REALLOC
4075 #define REASONABLE(size) (size)
4077 #define REASONABLE(size) (1) /* unreasonable */
4081 Perl_init_stacks(pTHX)
4084 /* start with 128-item stack and 8K cxstack */
4085 PL_curstackinfo = new_stackinfo(REASONABLE(128),
4086 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4087 PL_curstackinfo->si_type = PERLSI_MAIN;
4088 PL_curstack = PL_curstackinfo->si_stack;
4089 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
4091 PL_stack_base = AvARRAY(PL_curstack);
4092 PL_stack_sp = PL_stack_base;
4093 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4095 Newx(PL_tmps_stack,REASONABLE(128),SV*);
4098 PL_tmps_max = REASONABLE(128);
4100 Newx(PL_markstack,REASONABLE(32),I32);
4101 PL_markstack_ptr = PL_markstack;
4102 PL_markstack_max = PL_markstack + REASONABLE(32);
4106 Newx(PL_scopestack,REASONABLE(32),I32);
4108 Newx(PL_scopestack_name,REASONABLE(32),const char*);
4110 PL_scopestack_ix = 0;
4111 PL_scopestack_max = REASONABLE(32);
4113 Newx(PL_savestack,REASONABLE(128),ANY);
4114 PL_savestack_ix = 0;
4115 PL_savestack_max = REASONABLE(128);
4124 while (PL_curstackinfo->si_next)
4125 PL_curstackinfo = PL_curstackinfo->si_next;
4126 while (PL_curstackinfo) {
4127 PERL_SI *p = PL_curstackinfo->si_prev;
4128 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4129 Safefree(PL_curstackinfo->si_cxstack);
4130 Safefree(PL_curstackinfo);
4131 PL_curstackinfo = p;
4133 Safefree(PL_tmps_stack);
4134 Safefree(PL_markstack);
4135 Safefree(PL_scopestack);
4137 Safefree(PL_scopestack_name);
4139 Safefree(PL_savestack);
4143 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4145 GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4146 AV *const isa = GvAVn(gv);
4149 PERL_ARGS_ASSERT_POPULATE_ISA;
4151 if(AvFILLp(isa) != -1)
4154 /* NOTE: No support for tied ISA */
4156 va_start(args, len);
4158 const char *const parent = va_arg(args, const char*);
4163 parent_len = va_arg(args, size_t);
4165 /* Arguments are supplied with a trailing :: */
4166 assert(parent_len > 2);
4167 assert(parent[parent_len - 1] == ':');
4168 assert(parent[parent_len - 2] == ':');
4169 av_push(isa, newSVpvn(parent, parent_len - 2));
4170 (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4177 S_init_predump_symbols(pTHX)
4183 sv_setpvs(get_sv("\"", GV_ADD), " ");
4184 PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4187 /* Historically, PVIOs were blessed into IO::Handle, unless
4188 FileHandle was loaded, in which case they were blessed into
4189 that. Action at a distance.
4190 However, if we simply bless into IO::Handle, we break code
4191 that assumes that PVIOs will have (among others) a seek
4192 method. IO::File inherits from IO::Handle and IO::Seekable,
4193 and provides the needed methods. But if we simply bless into
4194 it, then we break code that assumed that by loading
4195 IO::Handle, *it* would work.
4196 So a compromise is to set up the correct @IO::File::ISA,
4197 so that code that does C<use IO::Handle>; will still work.
4200 Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4201 STR_WITH_LEN("IO::Handle::"),
4202 STR_WITH_LEN("IO::Seekable::"),
4203 STR_WITH_LEN("Exporter::"),
4206 PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4207 GvMULTI_on(PL_stdingv);
4208 io = GvIOp(PL_stdingv);
4209 IoTYPE(io) = IoTYPE_RDONLY;
4210 IoIFP(io) = PerlIO_stdin();
4211 tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4213 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4215 tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4218 IoTYPE(io) = IoTYPE_WRONLY;
4219 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4221 tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4223 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4225 PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4226 GvMULTI_on(PL_stderrgv);
4227 io = GvIOp(PL_stderrgv);
4228 IoTYPE(io) = IoTYPE_WRONLY;
4229 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4230 tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4232 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4234 PL_statname = newSVpvs(""); /* last filename we did stat on */
4238 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4242 PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4244 argc--,argv++; /* skip name of script */
4245 if (PL_doswitches) {
4246 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4250 if (argv[0][1] == '-' && !argv[0][2]) {
4254 if ((s = strchr(argv[0], '='))) {
4255 const char *const start_name = argv[0] + 1;
4256 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4257 TRUE, SVt_PV)), s + 1);
4260 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4263 if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4264 SvREFCNT_inc_simple_void_NN(PL_argvgv);
4265 GvMULTI_on(PL_argvgv);
4266 av_clear(GvAVn(PL_argvgv));
4267 for (; argc > 0; argc--,argv++) {
4268 SV * const sv = newSVpv(argv[0],0);
4269 av_push(GvAV(PL_argvgv),sv);
4270 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4271 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4274 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4275 (void)sv_utf8_decode(sv);
4279 if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4280 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4281 "-i used with no filenames on the command line, "
4282 "reading from STDIN");
4286 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4291 PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4293 PL_toptarget = newSV_type(SVt_PVIV);
4294 sv_setpvs(PL_toptarget, "");
4295 PL_bodytarget = newSV_type(SVt_PVIV);
4296 sv_setpvs(PL_bodytarget, "");
4297 PL_formtarget = PL_bodytarget;
4301 init_argv_symbols(argc,argv);
4303 if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4304 sv_setpv(GvSV(tmpgv),PL_origfilename);
4306 if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4308 bool env_is_not_environ;
4309 SvREFCNT_inc_simple_void_NN(PL_envgv);
4310 GvMULTI_on(PL_envgv);
4311 hv = GvHVn(PL_envgv);
4312 hv_magic(hv, NULL, PERL_MAGIC_env);
4314 #ifdef USE_ENVIRON_ARRAY
4315 /* Note that if the supplied env parameter is actually a copy
4316 of the global environ then it may now point to free'd memory
4317 if the environment has been modified since. To avoid this
4318 problem we treat env==NULL as meaning 'use the default'
4322 env_is_not_environ = env != environ;
4323 if (env_is_not_environ
4324 # ifdef USE_ITHREADS
4325 && PL_curinterp == aTHX
4334 for (; *env; env++) {
4337 if (!(s = strchr(old_var,'=')) || s == old_var)
4340 #if defined(MSDOS) && !defined(DJGPP)
4342 (void)strupr(old_var);
4345 sv = newSVpv(s+1, 0);
4346 (void)hv_store(hv, old_var, s - old_var, sv, 0);
4347 if (env_is_not_environ)
4351 #endif /* USE_ENVIRON_ARRAY */
4352 #endif /* !PERL_MICRO */
4356 /* touch @F array to prevent spurious warnings 20020415 MJD */
4358 (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4363 S_init_perllib(pTHX)
4367 const char *perl5lib = NULL;
4370 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4374 if (!TAINTING_get) {
4376 perl5lib = PerlEnv_getenv("PERL5LIB");
4378 * It isn't possible to delete an environment variable with
4379 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4380 * case we treat PERL5LIB as undefined if it has a zero-length value.
4382 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4383 if (perl5lib && *perl5lib != '\0')
4387 incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4389 s = PerlEnv_getenv("PERLLIB");
4391 incpush_use_sep(s, 0, 0);
4394 /* Treat PERL5?LIB as a possible search list logical name -- the
4395 * "natural" VMS idiom for a Unix path string. We allow each
4396 * element to be a set of |-separated directories for compatibility.
4400 if (my_trnlnm("PERL5LIB",buf,0))
4402 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4403 } while (my_trnlnm("PERL5LIB",buf,++idx));
4405 while (my_trnlnm("PERLLIB",buf,idx++))
4406 incpush_use_sep(buf, 0, 0);
4411 #ifndef PERL_IS_MINIPERL
4412 /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4413 (and not the architecture specific directories from $ENV{PERL5LIB}) */
4415 /* Use the ~-expanded versions of APPLLIB (undocumented),
4416 SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4419 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4420 INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4424 /* sitearch is always relative to sitelib on Windows for
4425 * DLL-based path intuition to work correctly */
4426 # if !defined(WIN32)
4427 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4428 INCPUSH_CAN_RELOCATE);
4434 /* this picks up sitearch as well */
4435 s = win32_get_sitelib(PERL_FS_VERSION, &len);
4437 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4439 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4443 #ifdef PERL_VENDORARCH_EXP
4444 /* vendorarch is always relative to vendorlib on Windows for
4445 * DLL-based path intuition to work correctly */
4446 # if !defined(WIN32)
4447 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4448 INCPUSH_CAN_RELOCATE);
4452 #ifdef PERL_VENDORLIB_EXP
4454 /* this picks up vendorarch as well */
4455 s = win32_get_vendorlib(PERL_FS_VERSION, &len);
4457 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4459 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4460 INCPUSH_CAN_RELOCATE);
4465 S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4469 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4473 s = win32_get_privlib(PERL_FS_VERSION, &len);
4475 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4478 S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4480 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4484 #ifdef PERL_OTHERLIBDIRS
4485 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4486 INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4487 |INCPUSH_CAN_RELOCATE);
4490 if (!TAINTING_get) {
4493 * It isn't possible to delete an environment variable with
4494 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4495 * case we treat PERL5LIB as undefined if it has a zero-length value.
4497 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4498 if (perl5lib && *perl5lib != '\0')
4502 incpush_use_sep(perl5lib, 0,
4503 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4505 /* Treat PERL5?LIB as a possible search list logical name -- the
4506 * "natural" VMS idiom for a Unix path string. We allow each
4507 * element to be a set of |-separated directories for compatibility.
4511 if (my_trnlnm("PERL5LIB",buf,0))
4513 incpush_use_sep(buf, 0,
4514 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4515 } while (my_trnlnm("PERL5LIB",buf,++idx));
4519 /* Use the ~-expanded versions of APPLLIB (undocumented),
4520 SITELIB and VENDORLIB for older versions
4523 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4524 |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4527 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4528 /* Search for version-specific dirs below here */
4529 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4530 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4534 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4535 /* Search for version-specific dirs below here */
4536 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4537 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4540 #ifdef PERL_OTHERLIBDIRS
4541 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4542 INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4543 |INCPUSH_CAN_RELOCATE);
4545 #endif /* !PERL_IS_MINIPERL */
4548 S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4551 #if defined(DOSISH) || defined(__SYMBIAN32__)
4552 # define PERLLIB_SEP ';'
4555 # define PERLLIB_SEP '|'
4557 # define PERLLIB_SEP ':'
4560 #ifndef PERLLIB_MANGLE
4561 # define PERLLIB_MANGLE(s,n) (s)
4564 #ifndef PERL_IS_MINIPERL
4565 /* Push a directory onto @INC if it exists.
4566 Generate a new SV if we do this, to save needing to copy the SV we push
4569 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4574 PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4576 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4577 S_ISDIR(tmpstatbuf.st_mode)) {
4579 dir = newSVsv(stem);
4581 /* Truncate dir back to stem. */
4582 SvCUR_set(dir, SvCUR(stem));
4589 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4591 const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4594 PERL_ARGS_ASSERT_MAYBERELOCATE;
4597 /* I am not convinced that this is valid when PERLLIB_MANGLE is
4598 defined to so something (in os2/os2.c), but the code has been
4599 this way, ignoring any possible changed of length, since
4600 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4602 libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4608 if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4610 while (unix[len-1] == '/') len--; /* Cosmetic */
4611 sv_usepvn(libdir,unix,len);
4614 PerlIO_printf(Perl_error_log,
4615 "Failed to unixify @INC element \"%s\"\n",
4616 SvPV_nolen_const(libdir));
4620 /* Do the if() outside the #ifdef to avoid warnings about an unused
4623 #ifdef PERL_RELOCATABLE_INC
4625 * Relocatable include entries are marked with a leading .../
4628 * 0: Remove that leading ".../"
4629 * 1: Remove trailing executable name (anything after the last '/')
4630 * from the perl path to give a perl prefix
4632 * While the @INC element starts "../" and the prefix ends with a real
4633 * directory (ie not . or ..) chop that real directory off the prefix
4634 * and the leading "../" from the @INC element. ie a logical "../"
4636 * Finally concatenate the prefix and the remainder of the @INC element
4637 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4638 * generates /usr/local/lib/perl5
4640 const char *libpath = SvPVX(libdir);
4641 STRLEN libpath_len = SvCUR(libdir);
4642 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4644 SV * const caret_X = get_sv("\030", 0);
4645 /* Going to use the SV just as a scratch buffer holding a C
4651 /* $^X is *the* source of taint if tainting is on, hence
4652 SvPOK() won't be true. */
4654 assert(SvPOKp(caret_X));
4655 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4657 /* Firstly take off the leading .../
4658 If all else fail we'll do the paths relative to the current
4660 sv_chop(libdir, libpath + 4);
4661 /* Don't use SvPV as we're intentionally bypassing taining,
4662 mortal copies that the mg_get of tainting creates, and
4663 corruption that seems to come via the save stack.
4664 I guess that the save stack isn't correctly set up yet. */
4665 libpath = SvPVX(libdir);
4666 libpath_len = SvCUR(libdir);
4668 /* This would work more efficiently with memrchr, but as it's
4669 only a GNU extension we'd need to probe for it and
4670 implement our own. Not hard, but maybe not worth it? */
4672 prefix = SvPVX(prefix_sv);
4673 lastslash = strrchr(prefix, '/');
4675 /* First time in with the *lastslash = '\0' we just wipe off
4676 the trailing /perl from (say) /usr/foo/bin/perl
4680 while ((*lastslash = '\0'), /* Do that, come what may. */
4681 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4682 && (lastslash = strrchr(prefix, '/')))) {
4683 if (lastslash[1] == '\0'
4684 || (lastslash[1] == '.'
4685 && (lastslash[2] == '/' /* ends "/." */
4686 || (lastslash[2] == '/'
4687 && lastslash[3] == '/' /* or "/.." */
4689 /* Prefix ends "/" or "/." or "/..", any of which
4690 are fishy, so don't do any more logical cleanup.
4694 /* Remove leading "../" from path */
4697 /* Next iteration round the loop removes the last
4698 directory name from prefix by writing a '\0' in
4699 the while clause. */
4701 /* prefix has been terminated with a '\0' to the correct
4702 length. libpath points somewhere into the libdir SV.
4703 We need to join the 2 with '/' and drop the result into
4705 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4706 SvREFCNT_dec(libdir);
4707 /* And this is the new libdir. */
4710 (PerlProc_getuid() != PerlProc_geteuid() ||
4711 PerlProc_getgid() != PerlProc_getegid())) {
4712 /* Need to taint relocated paths if running set ID */
4713 SvTAINTED_on(libdir);
4716 SvREFCNT_dec(prefix_sv);
4724 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4727 #ifndef PERL_IS_MINIPERL
4728 const U8 using_sub_dirs
4729 = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4730 |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4731 const U8 add_versioned_sub_dirs
4732 = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4733 const U8 add_archonly_sub_dirs
4734 = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4735 #ifdef PERL_INC_VERSION_LIST
4736 const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
4739 const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
4740 const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4741 AV *const inc = GvAVn(PL_incgv);
4743 PERL_ARGS_ASSERT_INCPUSH;
4746 /* Could remove this vestigial extra block, if we don't mind a lot of
4747 re-indenting diff noise. */
4749 SV *const libdir = mayberelocate(dir, len, flags);
4750 /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4751 arranged to unshift #! line -I onto the front of @INC. However,
4752 -I can add version and architecture specific libraries, and they
4753 need to go first. The old code assumed that it was always
4754 pushing. Hence to make it work, need to push the architecture
4755 (etc) libraries onto a temporary array, then "unshift" that onto
4756 the front of @INC. */
4757 #ifndef PERL_IS_MINIPERL
4758 AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4761 * BEFORE pushing libdir onto @INC we may first push version- and
4762 * archname-specific sub-directories.
4764 if (using_sub_dirs) {
4765 SV *subdir = newSVsv(libdir);
4766 #ifdef PERL_INC_VERSION_LIST
4767 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4768 const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4769 const char * const *incver;
4772 if (add_versioned_sub_dirs) {
4773 /* .../version/archname if -d .../version/archname */
4774 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4775 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4777 /* .../version if -d .../version */
4778 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4779 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4782 #ifdef PERL_INC_VERSION_LIST
4784 for (incver = incverlist; *incver; incver++) {
4785 /* .../xxx if -d .../xxx */
4786 Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4787 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4792 if (add_archonly_sub_dirs) {
4793 /* .../archname if -d .../archname */
4794 sv_catpvs(subdir, "/" ARCHNAME);
4795 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4799 assert (SvREFCNT(subdir) == 1);
4800 SvREFCNT_dec(subdir);
4802 #endif /* !PERL_IS_MINIPERL */
4803 /* finally add this lib directory at the end of @INC */
4805 #ifdef PERL_IS_MINIPERL
4806 const Size_t extra = 0;
4808 Size_t extra = av_len(av) + 1;
4810 av_unshift(inc, extra + push_basedir);
4812 av_store(inc, extra, libdir);
4813 #ifndef PERL_IS_MINIPERL
4815 /* av owns a reference, av_store() expects to be donated a
4816 reference, and av expects to be sane when it's cleared.
4817 If I wanted to be naughty and wrong, I could peek inside the
4818 implementation of av_clear(), realise that it uses
4819 SvREFCNT_dec() too, so av's array could be a run of NULLs,
4820 and so directly steal from it (with a memcpy() to inc, and
4821 then memset() to NULL them out. But people copy code from the
4822 core expecting it to be best practise, so let's use the API.
4823 Although studious readers will note that I'm not checking any
4825 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4830 else if (push_basedir) {
4831 av_push(inc, libdir);
4834 if (!push_basedir) {
4835 assert (SvREFCNT(libdir) == 1);
4836 SvREFCNT_dec(libdir);
4842 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
4846 /* This logic has been broken out from S_incpush(). It may be possible to
4849 PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4851 /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
4852 * argument to incpush_use_sep. This allows creation of relocatable
4853 * Perl distributions that patch the binary at install time. Those
4854 * distributions will have to provide their own relocation tools; this
4855 * is not a feature otherwise supported by core Perl.
4857 #ifndef PERL_RELOCATABLE_INCPUSH
4864 /* Break at all separators */
4865 while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
4867 /* skip any consecutive separators */
4869 /* Uncomment the next line for PATH semantics */
4870 /* But you'll need to write tests */
4871 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4873 incpush(p, (STRLEN)(s - p), flags);
4878 incpush(p, (STRLEN)(end - p), flags);
4883 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4887 volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
4893 PERL_ARGS_ASSERT_CALL_LIST;
4895 while (av_len(paramList) >= 0) {
4896 cv = MUTABLE_CV(av_shift(paramList));
4898 if (paramList == PL_beginav) {
4899 /* save PL_beginav for compiler */
4900 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
4902 else if (paramList == PL_checkav) {
4903 /* save PL_checkav for compiler */
4904 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
4906 else if (paramList == PL_unitcheckav) {
4907 /* save PL_unitcheckav for compiler */
4908 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
4919 PL_madskills |= 16384;
4924 PL_madskills &= ~16384;
4927 (void)SvPV_const(atsv, len);
4929 PL_curcop = &PL_compiling;
4930 CopLINE_set(PL_curcop, oldline);
4931 if (paramList == PL_beginav)
4932 sv_catpvs(atsv, "BEGIN failed--compilation aborted");
4934 Perl_sv_catpvf(aTHX_ atsv,
4935 "%s failed--call queue aborted",
4936 paramList == PL_checkav ? "CHECK"
4937 : paramList == PL_initav ? "INIT"
4938 : paramList == PL_unitcheckav ? "UNITCHECK"
4940 while (PL_scopestack_ix > oldscope)
4943 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
4950 /* my_exit() was called */
4951 while (PL_scopestack_ix > oldscope)
4954 SET_CURSTASH(PL_defstash);
4955 PL_curcop = &PL_compiling;
4956 CopLINE_set(PL_curcop, oldline);
4959 assert(0); /* NOTREACHED */
4962 PL_curcop = &PL_compiling;
4963 CopLINE_set(PL_curcop, oldline);
4966 PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
4975 Perl_my_exit(pTHX_ U32 status)
4978 if (PL_exit_flags & PERL_EXIT_ABORT) {
4981 if (PL_exit_flags & PERL_EXIT_WARN) {
4982 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
4983 Perl_warn(aTHX_ "Unexpected exit %u", status);
4984 PL_exit_flags &= ~PERL_EXIT_ABORT;
4994 STATUS_EXIT_SET(status);
5001 Perl_my_failure_exit(pTHX)
5005 /* We have been called to fall on our sword. The desired exit code
5006 * should be already set in STATUS_UNIX, but could be shifted over
5007 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
5010 * If an error code has not been set, then force the issue.
5012 if (MY_POSIX_EXIT) {
5014 /* According to the die_exit.t tests, if errno is non-zero */
5015 /* It should be used for the error status. */
5017 if (errno == EVMSERR) {
5018 STATUS_NATIVE = vaxc$errno;
5021 /* According to die_exit.t tests, if the child_exit code is */
5022 /* also zero, then we need to exit with a code of 255 */
5023 if ((errno != 0) && (errno < 256))
5024 STATUS_UNIX_EXIT_SET(errno);
5025 else if (STATUS_UNIX < 255) {
5026 STATUS_UNIX_EXIT_SET(255);
5031 /* The exit code could have been set by $? or vmsish which
5032 * means that it may not have fatal set. So convert
5033 * success/warning codes to fatal with out changing
5034 * the POSIX status code. The severity makes VMS native
5035 * status handling work, while UNIX mode programs use the
5036 * the POSIX exit codes.
5038 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
5039 STATUS_NATIVE &= STS$M_COND_ID;
5040 STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
5044 /* Traditionally Perl on VMS always expects a Fatal Error. */
5045 if (vaxc$errno & 1) {
5047 /* So force success status to failure */
5048 if (STATUS_NATIVE & 1)
5053 STATUS_UNIX = EINTR; /* In case something cares */
5058 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5060 /* Encode the severity code */
5061 severity = STATUS_NATIVE & STS$M_SEVERITY;
5062 STATUS_UNIX = (severity ? severity : 1) << 8;
5064 /* Perl expects this to be a fatal error */
5065 if (severity != STS$K_SEVERE)
5074 STATUS_UNIX_SET(errno);
5076 exitstatus = STATUS_UNIX >> 8;
5077 if (exitstatus & 255)
5078 STATUS_UNIX_SET(exitstatus);
5080 STATUS_UNIX_SET(255);
5083 if (PL_exit_flags & PERL_EXIT_ABORT) {
5086 if (PL_exit_flags & PERL_EXIT_WARN) {
5087 PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
5088 Perl_warn(aTHX_ "Unexpected exit failure %u", PL_statusvalue);
5089 PL_exit_flags &= ~PERL_EXIT_ABORT;
5095 S_my_exit_jump(pTHX)
5100 SvREFCNT_dec(PL_e_script);
5104 POPSTACK_TO(PL_mainstack);
5112 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5115 const char * const p = SvPVX_const(PL_e_script);
5116 const char *nl = strchr(p, '\n');
5118 PERL_UNUSED_ARG(idx);
5119 PERL_UNUSED_ARG(maxlen);
5121 nl = (nl) ? nl+1 : SvEND(PL_e_script);
5123 filter_del(read_e_script);
5126 sv_catpvn(buf_sv, p, nl-p);
5127 sv_chop(PL_e_script, nl);
5133 * c-indentation-style: bsd
5135 * indent-tabs-mode: nil
5138 * ex: set ts=8 sts=4 sw=4 et: