4 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
5 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
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
28 #define PERL_IN_PERL_C
30 #include "patchlevel.h" /* for local_patches */
37 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
42 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
44 # include <sys/wait.h>
52 char control[CMSG_SPACE(sizeof(int))];
69 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
70 char *getenv (char *); /* Usually in <stdlib.h> */
73 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
75 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
76 /* Drop everything. Heck, don't even try to call it */
77 # define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) NOOP
79 /* Drop almost everything */
80 # define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp)
83 #define CALL_BODY_SUB(myop) \
84 if (PL_op == (myop)) \
85 PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
89 #define CALL_LIST_BODY(cv) \
90 PUSHMARK(PL_stack_sp); \
91 call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD);
94 S_init_tls_and_interp(PerlInterpreter *my_perl)
98 PERL_SET_INTERP(my_perl);
99 #if defined(USE_ITHREADS)
102 PERL_SET_THX(my_perl);
105 MUTEX_INIT(&PL_dollarzero_mutex);
106 MUTEX_INIT(&PL_my_ctx_mutex);
109 #if defined(USE_ITHREADS)
112 /* This always happens for non-ithreads */
115 PERL_SET_THX(my_perl);
120 /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
123 Perl_sys_init(int* argc, char*** argv)
127 PERL_ARGS_ASSERT_SYS_INIT;
129 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
130 PERL_UNUSED_ARG(argv);
131 PERL_SYS_INIT_BODY(argc, argv);
135 Perl_sys_init3(int* argc, char*** argv, char*** env)
139 PERL_ARGS_ASSERT_SYS_INIT3;
141 PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
142 PERL_UNUSED_ARG(argv);
143 PERL_UNUSED_ARG(env);
144 PERL_SYS_INIT3_BODY(argc, argv, env);
151 if (!PL_veto_cleanup) {
152 PERL_SYS_TERM_BODY();
157 #ifdef PERL_IMPLICIT_SYS
159 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
160 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
161 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
162 struct IPerlDir* ipD, struct IPerlSock* ipS,
163 struct IPerlProc* ipP)
165 PerlInterpreter *my_perl;
167 PERL_ARGS_ASSERT_PERL_ALLOC_USING;
169 /* Newx() needs interpreter, so call malloc() instead */
170 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
171 S_init_tls_and_interp(my_perl);
172 Zero(my_perl, 1, PerlInterpreter);
182 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
189 =head1 Embedding Functions
191 =for apidoc perl_alloc
193 Allocates a new Perl interpreter. See L<perlembed>.
201 PerlInterpreter *my_perl;
203 /* Newx() needs interpreter, so call malloc() instead */
204 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
206 S_init_tls_and_interp(my_perl);
207 #ifndef PERL_TRACK_MEMPOOL
208 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
210 Zero(my_perl, 1, PerlInterpreter);
211 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
215 #endif /* PERL_IMPLICIT_SYS */
218 =for apidoc perl_construct
220 Initializes a new Perl interpreter. See L<perlembed>.
226 perl_construct(pTHXx)
230 PERL_ARGS_ASSERT_PERL_CONSTRUCT;
234 PL_perl_destruct_level = 1;
236 PERL_UNUSED_ARG(my_perl);
237 if (PL_perl_destruct_level > 0)
240 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
242 /* set read-only and try to insure than we wont see REFCNT==0
245 SvREADONLY_on(&PL_sv_undef);
246 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
248 sv_setpv(&PL_sv_no,PL_No);
249 /* value lookup in void context - happens to have the side effect
250 of caching the numeric forms. However, as &PL_sv_no doesn't contain
251 a string that is a valid numer, we have to turn the public flags by
257 SvREADONLY_on(&PL_sv_no);
258 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
260 sv_setpv(&PL_sv_yes,PL_Yes);
263 SvREADONLY_on(&PL_sv_yes);
264 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
266 SvREADONLY_on(&PL_sv_placeholder);
267 SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
269 PL_sighandlerp = (Sighandler_t) Perl_sighandler;
270 #ifdef PERL_USES_PL_PIDSTATUS
271 PL_pidstatus = newHV();
274 PL_rs = newSVpvs("\n");
284 SET_NUMERIC_STANDARD();
286 #if defined(LOCAL_PATCH_COUNT)
287 PL_localpatches = local_patches; /* For possible -v */
290 #ifdef HAVE_INTERP_INTERN
294 PerlIO_init(aTHX); /* Hook to IO system */
296 PL_fdpid = newAV(); /* for remembering popen pids by fd */
297 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
298 PL_errors = newSVpvs("");
299 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
300 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
301 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
303 /* First entry is a list of empty elements. It needs to be initialised
304 else all hell breaks loose in S_find_uninit_var(). */
305 Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
306 PL_regex_pad = AvARRAY(PL_regex_padav);
308 #ifdef USE_REENTRANT_API
309 Perl_reentrant_init(aTHX);
312 /* Note that strtab is a rather special HV. Assumptions are made
313 about not iterating on it, and not adding tie magic to it.
314 It is properly deallocated in perl_destruct() */
317 HvSHAREKEYS_off(PL_strtab); /* mandatory */
318 hv_ksplit(PL_strtab, 512);
320 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
321 _dyld_lookup_and_bind
322 ("__environ", (unsigned long *) &environ_pointer, NULL);
326 # ifdef USE_ENVIRON_ARRAY
327 PL_origenviron = environ;
331 /* Use sysconf(_SC_CLK_TCK) if available, if not
332 * available or if the sysconf() fails, use the HZ.
333 * BeOS has those, but returns the wrong value.
334 * The HZ if not originally defined has been by now
335 * been defined as CLK_TCK, if available. */
336 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
337 PL_clocktick = sysconf(_SC_CLK_TCK);
338 if (PL_clocktick <= 0)
342 PL_stashcache = newHV();
344 PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
345 PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING);
348 if (!PL_mmap_page_size) {
349 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
351 SETERRNO(0, SS_NORMAL);
353 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
355 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
357 if ((long) PL_mmap_page_size < 0) {
359 SV * const error = ERRSV;
360 SvUPGRADE(error, SVt_PV);
361 Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
364 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
368 # ifdef HAS_GETPAGESIZE
369 PL_mmap_page_size = getpagesize();
371 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
372 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
376 if (PL_mmap_page_size <= 0)
377 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
378 (IV) PL_mmap_page_size);
380 #endif /* HAS_MMAP */
382 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
383 PL_timesbase.tms_utime = 0;
384 PL_timesbase.tms_stime = 0;
385 PL_timesbase.tms_cutime = 0;
386 PL_timesbase.tms_cstime = 0;
389 PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
391 PL_registered_mros = newHV();
392 /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
393 HvMAX(PL_registered_mros) = 0;
399 =for apidoc nothreadhook
401 Stub that provides thread hook for perl_destruct when there are
408 Perl_nothreadhook(pTHX)
414 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
416 Perl_dump_sv_child(pTHX_ SV *sv)
419 const int sock = PL_dumper_fd;
420 const int debug_fd = PerlIO_fileno(Perl_debug_log);
421 union control_un control;
424 struct cmsghdr *cmptr;
426 unsigned char buffer[256];
428 PERL_ARGS_ASSERT_DUMP_SV_CHILD;
430 if(sock == -1 || debug_fd == -1)
433 PerlIO_flush(Perl_debug_log);
435 /* All these shenanigans are to pass a file descriptor over to our child for
436 it to dump out to. We can't let it hold open the file descriptor when it
437 forks, as the file descriptor it will dump to can turn out to be one end
438 of pipe that some other process will wait on for EOF. (So as it would
439 be open, the wait would be forever.) */
441 msg.msg_control = control.control;
442 msg.msg_controllen = sizeof(control.control);
443 /* We're a connected socket so we don't need a destination */
449 cmptr = CMSG_FIRSTHDR(&msg);
450 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
451 cmptr->cmsg_level = SOL_SOCKET;
452 cmptr->cmsg_type = SCM_RIGHTS;
453 *((int *)CMSG_DATA(cmptr)) = 1;
455 vec[0].iov_base = (void*)&sv;
456 vec[0].iov_len = sizeof(sv);
457 got = sendmsg(sock, &msg, 0);
460 perror("Debug leaking scalars parent sendmsg failed");
463 if(got < sizeof(sv)) {
464 perror("Debug leaking scalars parent short sendmsg");
468 /* Return protocol is
470 unsigned char: length of location string (0 for empty)
471 unsigned char*: string (not terminated)
473 vec[0].iov_base = (void*)&returned_errno;
474 vec[0].iov_len = sizeof(returned_errno);
475 vec[1].iov_base = buffer;
478 got = readv(sock, vec, 2);
481 perror("Debug leaking scalars parent read failed");
482 PerlIO_flush(PerlIO_stderr());
485 if(got < sizeof(returned_errno) + 1) {
486 perror("Debug leaking scalars parent short read");
487 PerlIO_flush(PerlIO_stderr());
492 got = read(sock, buffer + 1, *buffer);
494 perror("Debug leaking scalars parent read 2 failed");
495 PerlIO_flush(PerlIO_stderr());
500 perror("Debug leaking scalars parent short read 2");
501 PerlIO_flush(PerlIO_stderr());
506 if (returned_errno || *buffer) {
507 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
508 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
509 returned_errno, strerror(returned_errno));
515 =for apidoc perl_destruct
517 Shuts down a Perl interpreter. See L<perlembed>.
526 VOL signed char destruct_level; /* see possible values in intrpvar.h */
528 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
532 PERL_ARGS_ASSERT_PERL_DESTRUCT;
534 PERL_UNUSED_ARG(my_perl);
537 assert(PL_scopestack_ix == 1);
539 /* wait for all pseudo-forked children to finish */
540 PERL_WAIT_FOR_CHILDREN;
542 destruct_level = PL_perl_destruct_level;
545 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
547 const int i = atoi(s);
548 if (destruct_level < i)
554 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
560 if (PL_endav && !PL_minus_c) {
561 PL_phase = PERL_PHASE_END;
562 call_list(PL_scopestack_ix, PL_endav);
568 assert(PL_scopestack_ix == 0);
570 /* Need to flush since END blocks can produce output */
573 if (PL_threadhook(aTHX)) {
574 /* Threads hook has vetoed further cleanup */
575 PL_veto_cleanup = TRUE;
579 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
580 if (destruct_level != 0) {
581 /* Fork here to create a child. Our child's job is to preserve the
582 state of scalars prior to destruction, so that we can instruct it
583 to dump any scalars that we later find have leaked.
584 There's no subtlety in this code - it assumes POSIX, and it doesn't
588 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
589 perror("Debug leaking scalars socketpair failed");
595 perror("Debug leaking scalars fork failed");
599 /* We are the child */
600 const int sock = fd[1];
601 const int debug_fd = PerlIO_fileno(Perl_debug_log);
604 /* Our success message is an integer 0, and a char 0 */
605 static const char success[sizeof(int) + 1] = {0};
609 /* We need to close all other file descriptors otherwise we end up
610 with interesting hangs, where the parent closes its end of a
611 pipe, and sits waiting for (another) child to terminate. Only
612 that child never terminates, because it never gets EOF, because
613 we also have the far end of the pipe open. We even need to
614 close the debugging fd, because sometimes it happens to be one
615 end of a pipe, and a process is waiting on the other end for
616 EOF. Normally it would be closed at some point earlier in
617 destruction, but if we happen to cause the pipe to remain open,
618 EOF never occurs, and we get an infinite hang. Hence all the
619 games to pass in a file descriptor if it's actually needed. */
621 f = sysconf(_SC_OPEN_MAX);
623 where = "sysconf failed";
634 union control_un control;
637 struct cmsghdr *cmptr;
641 msg.msg_control = control.control;
642 msg.msg_controllen = sizeof(control.control);
643 /* We're a connected socket so we don't need a source */
647 msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
649 vec[0].iov_base = (void*)⌖
650 vec[0].iov_len = sizeof(target);
652 got = recvmsg(sock, &msg, 0);
657 where = "recv failed";
660 if(got < sizeof(target)) {
661 where = "short recv";
665 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
669 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
670 where = "wrong cmsg_len";
673 if(cmptr->cmsg_level != SOL_SOCKET) {
674 where = "wrong cmsg_level";
677 if(cmptr->cmsg_type != SCM_RIGHTS) {
678 where = "wrong cmsg_type";
682 got_fd = *(int*)CMSG_DATA(cmptr);
683 /* For our last little bit of trickery, put the file descriptor
684 back into Perl_debug_log, as if we never actually closed it
686 if(got_fd != debug_fd) {
687 if (dup2(got_fd, debug_fd) == -1) {
694 PerlIO_flush(Perl_debug_log);
696 got = write(sock, &success, sizeof(success));
699 where = "write failed";
702 if(got < sizeof(success)) {
703 where = "short write";
710 int send_errno = errno;
711 unsigned char length = (unsigned char) strlen(where);
712 struct iovec failure[3] = {
713 {(void*)&send_errno, sizeof(send_errno)},
715 {(void*)where, length}
717 int got = writev(sock, failure, 3);
718 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
719 in the parent if we try to read from the socketpair after the
720 child has exited, even if there was data to read.
721 So sleep a bit to give the parent a fighting chance of
724 _exit((got == -1) ? errno : 0);
728 PL_dumper_fd = fd[0];
733 /* We must account for everything. */
735 /* Destroy the main CV and syntax tree */
736 /* Do this now, because destroying ops can cause new SVs to be generated
737 in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
738 PL_curcop to point to a valid op from which the filename structure
740 PL_curcop = &PL_compiling;
742 /* ensure comppad/curpad to refer to main's pad */
743 if (CvPADLIST(PL_main_cv)) {
744 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
746 op_free(PL_main_root);
749 PL_main_start = NULL;
750 /* note that PL_main_cv isn't usually actually freed at this point,
751 * due to the CvOUTSIDE refs from subs compiled within it. It will
752 * get freed once all the subs are freed in sv_clean_all(), for
753 * destruct_level > 0 */
754 SvREFCNT_dec(PL_main_cv);
756 PL_phase = PERL_PHASE_DESTRUCT;
758 /* Tell PerlIO we are about to tear things apart in case
759 we have layers which are using resources that should
763 PerlIO_destruct(aTHX);
765 if (PL_sv_objcount) {
767 * Try to destruct global references. We do this first so that the
768 * destructors and destructees still exist. Some sv's might remain.
769 * Non-referenced objects are on their own.
775 /* unhook hooks which will soon be, or use, destroyed data */
776 SvREFCNT_dec(PL_warnhook);
778 SvREFCNT_dec(PL_diehook);
781 /* call exit list functions */
782 while (PL_exitlistlen-- > 0)
783 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
785 Safefree(PL_exitlist);
790 SvREFCNT_dec(PL_registered_mros);
792 /* jettison our possibly duplicated environment */
793 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
794 * so we certainly shouldn't free it here
797 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
798 if (environ != PL_origenviron && !PL_use_safe_putenv
800 /* only main thread can free environ[0] contents */
801 && PL_curinterp == aTHX
807 for (i = 0; environ[i]; i++)
808 safesysfree(environ[i]);
810 /* Must use safesysfree() when working with environ. */
811 safesysfree(environ);
813 environ = PL_origenviron;
816 #endif /* !PERL_MICRO */
818 if (destruct_level == 0) {
820 DEBUG_P(debprofdump());
822 #if defined(PERLIO_LAYERS)
823 /* No more IO - including error messages ! */
824 PerlIO_cleanup(aTHX);
827 CopFILE_free(&PL_compiling);
828 CopSTASH_free(&PL_compiling);
830 /* The exit() function will do everything that needs doing. */
835 /* the syntax tree is shared between clones
836 * so op_free(PL_main_root) only ReREFCNT_dec's
837 * REGEXPs in the parent interpreter
838 * we need to manually ReREFCNT_dec for the clones
840 SvREFCNT_dec(PL_regex_padav);
841 PL_regex_padav = NULL;
845 SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
846 PL_stashcache = NULL;
848 /* loosen bonds of global variables */
850 /* XXX can PL_parser still be non-null here? */
851 if(PL_parser && PL_parser->rsfp) {
852 (void)PerlIO_close(PL_parser->rsfp);
853 PL_parser->rsfp = NULL;
857 Safefree(PL_splitstr);
867 PL_doswitches = FALSE;
868 PL_dowarn = G_WARN_OFF;
869 PL_sawampersand = FALSE; /* must save all match strings */
872 Safefree(PL_inplace);
874 SvREFCNT_dec(PL_patchlevel);
875 SvREFCNT_dec(PL_apiversion);
878 SvREFCNT_dec(PL_e_script);
884 /* magical thingies */
886 SvREFCNT_dec(PL_ofsgv); /* *, */
889 SvREFCNT_dec(PL_ors_sv); /* $\ */
892 SvREFCNT_dec(PL_rs); /* $/ */
895 Safefree(PL_osname); /* $^O */
898 SvREFCNT_dec(PL_statname);
902 /* defgv, aka *_ should be taken care of elsewhere */
904 /* clean up after study() */
905 SvREFCNT_dec(PL_lastscream);
906 PL_lastscream = NULL;
907 Safefree(PL_screamfirst);
909 Safefree(PL_screamnext);
913 Safefree(PL_efloatbuf);
917 /* startup and shutdown function lists */
918 SvREFCNT_dec(PL_beginav);
919 SvREFCNT_dec(PL_beginav_save);
920 SvREFCNT_dec(PL_endav);
921 SvREFCNT_dec(PL_checkav);
922 SvREFCNT_dec(PL_checkav_save);
923 SvREFCNT_dec(PL_unitcheckav);
924 SvREFCNT_dec(PL_unitcheckav_save);
925 SvREFCNT_dec(PL_initav);
927 PL_beginav_save = NULL;
930 PL_checkav_save = NULL;
931 PL_unitcheckav = NULL;
932 PL_unitcheckav_save = NULL;
935 /* shortcuts just get cleared */
944 PL_last_in_gv = NULL;
956 SvREFCNT_dec(PL_argvout_stack);
957 PL_argvout_stack = NULL;
959 SvREFCNT_dec(PL_modglobal);
961 SvREFCNT_dec(PL_preambleav);
962 PL_preambleav = NULL;
963 SvREFCNT_dec(PL_subname);
965 #ifdef PERL_USES_PL_PIDSTATUS
966 SvREFCNT_dec(PL_pidstatus);
969 SvREFCNT_dec(PL_toptarget);
971 SvREFCNT_dec(PL_bodytarget);
972 PL_bodytarget = NULL;
973 PL_formtarget = NULL;
975 /* free locale stuff */
976 #ifdef USE_LOCALE_COLLATE
977 Safefree(PL_collation_name);
978 PL_collation_name = NULL;
981 #ifdef USE_LOCALE_NUMERIC
982 Safefree(PL_numeric_name);
983 PL_numeric_name = NULL;
984 SvREFCNT_dec(PL_numeric_radix_sv);
985 PL_numeric_radix_sv = NULL;
988 /* clear utf8 character classes */
989 SvREFCNT_dec(PL_utf8_alnum);
990 SvREFCNT_dec(PL_utf8_ascii);
991 SvREFCNT_dec(PL_utf8_alpha);
992 SvREFCNT_dec(PL_utf8_space);
993 SvREFCNT_dec(PL_utf8_cntrl);
994 SvREFCNT_dec(PL_utf8_graph);
995 SvREFCNT_dec(PL_utf8_digit);
996 SvREFCNT_dec(PL_utf8_upper);
997 SvREFCNT_dec(PL_utf8_lower);
998 SvREFCNT_dec(PL_utf8_print);
999 SvREFCNT_dec(PL_utf8_punct);
1000 SvREFCNT_dec(PL_utf8_xdigit);
1001 SvREFCNT_dec(PL_utf8_mark);
1002 SvREFCNT_dec(PL_utf8_toupper);
1003 SvREFCNT_dec(PL_utf8_totitle);
1004 SvREFCNT_dec(PL_utf8_tolower);
1005 SvREFCNT_dec(PL_utf8_tofold);
1006 SvREFCNT_dec(PL_utf8_idstart);
1007 SvREFCNT_dec(PL_utf8_idcont);
1008 SvREFCNT_dec(PL_utf8_foldclosures);
1009 PL_utf8_alnum = NULL;
1010 PL_utf8_ascii = NULL;
1011 PL_utf8_alpha = NULL;
1012 PL_utf8_space = NULL;
1013 PL_utf8_cntrl = NULL;
1014 PL_utf8_graph = NULL;
1015 PL_utf8_digit = NULL;
1016 PL_utf8_upper = NULL;
1017 PL_utf8_lower = NULL;
1018 PL_utf8_print = NULL;
1019 PL_utf8_punct = NULL;
1020 PL_utf8_xdigit = NULL;
1021 PL_utf8_mark = NULL;
1022 PL_utf8_toupper = NULL;
1023 PL_utf8_totitle = NULL;
1024 PL_utf8_tolower = NULL;
1025 PL_utf8_tofold = NULL;
1026 PL_utf8_idstart = NULL;
1027 PL_utf8_idcont = NULL;
1028 PL_utf8_foldclosures = NULL;
1030 if (!specialWARN(PL_compiling.cop_warnings))
1031 PerlMemShared_free(PL_compiling.cop_warnings);
1032 PL_compiling.cop_warnings = NULL;
1033 cophh_free(CopHINTHASH_get(&PL_compiling));
1034 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
1035 CopFILE_free(&PL_compiling);
1036 CopSTASH_free(&PL_compiling);
1038 /* Prepare to destruct main symbol table. */
1041 /* break ref loop *:: <=> %:: */
1042 (void)hv_delete(hv, "main::", 6, G_DISCARD);
1045 SvREFCNT_dec(PL_curstname);
1046 PL_curstname = NULL;
1048 /* clear queued errors */
1049 SvREFCNT_dec(PL_errors);
1052 SvREFCNT_dec(PL_isarev);
1055 if (destruct_level >= 2) {
1056 if (PL_scopestack_ix != 0)
1057 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1058 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1059 (long)PL_scopestack_ix);
1060 if (PL_savestack_ix != 0)
1061 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1062 "Unbalanced saves: %ld more saves than restores\n",
1063 (long)PL_savestack_ix);
1064 if (PL_tmps_floor != -1)
1065 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1066 (long)PL_tmps_floor + 1);
1067 if (cxstack_ix != -1)
1068 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1069 (long)cxstack_ix + 1);
1072 #ifdef PERL_IMPLICIT_CONTEXT
1073 /* the entries in this list are allocated via SV PVX's, so get freed
1074 * in sv_clean_all */
1075 Safefree(PL_my_cxt_list);
1078 /* Now absolutely destruct everything, somehow or other, loops or no. */
1080 /* the 2 is for PL_fdpid and PL_strtab */
1081 while (sv_clean_all() > 2)
1084 AvREAL_off(PL_fdpid); /* no surviving entries */
1085 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
1088 #ifdef HAVE_INTERP_INTERN
1092 /* Destruct the global string table. */
1094 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1095 * so that sv_free() won't fail on them.
1096 * Now that the global string table is using a single hunk of memory
1097 * for both HE and HEK, we either need to explicitly unshare it the
1098 * correct way, or actually free things here.
1101 const I32 max = HvMAX(PL_strtab);
1102 HE * const * const array = HvARRAY(PL_strtab);
1103 HE *hent = array[0];
1106 if (hent && ckWARN_d(WARN_INTERNAL)) {
1107 HE * const next = HeNEXT(hent);
1108 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1109 "Unbalanced string table refcount: (%ld) for \"%s\"",
1110 (long)hent->he_valu.hent_refcount, HeKEY(hent));
1117 hent = array[riter];
1122 HvARRAY(PL_strtab) = 0;
1123 HvTOTALKEYS(PL_strtab) = 0;
1125 SvREFCNT_dec(PL_strtab);
1128 /* free the pointer tables used for cloning */
1129 ptr_table_free(PL_ptr_table);
1130 PL_ptr_table = (PTR_TBL_t*)NULL;
1133 /* free special SVs */
1135 SvREFCNT(&PL_sv_yes) = 0;
1136 sv_clear(&PL_sv_yes);
1137 SvANY(&PL_sv_yes) = NULL;
1138 SvFLAGS(&PL_sv_yes) = 0;
1140 SvREFCNT(&PL_sv_no) = 0;
1141 sv_clear(&PL_sv_no);
1142 SvANY(&PL_sv_no) = NULL;
1143 SvFLAGS(&PL_sv_no) = 0;
1147 for (i=0; i<=2; i++) {
1148 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1149 sv_clear(PERL_DEBUG_PAD(i));
1150 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1151 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1155 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1156 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1158 #ifdef DEBUG_LEAKING_SCALARS
1159 if (PL_sv_count != 0) {
1164 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1165 svend = &sva[SvREFCNT(sva)];
1166 for (sv = sva + 1; sv < svend; ++sv) {
1167 if (SvTYPE(sv) != SVTYPEMASK) {
1168 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1170 " refcnt=%"UVuf pTHX__FORMAT "\n"
1171 "\tallocated at %s:%d %s %s (parent 0x%"UVxf");"
1173 (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1175 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1177 sv->sv_debug_inpad ? "for" : "by",
1178 sv->sv_debug_optype ?
1179 PL_op_name[sv->sv_debug_optype]: "(none)",
1180 PTR2UV(sv->sv_debug_parent),
1183 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1184 Perl_dump_sv_child(aTHX_ sv);
1190 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1194 /* Wait for up to 4 seconds for child to terminate.
1195 This seems to be the least effort way of timing out on reaping
1197 struct timeval waitfor = {4, 0};
1198 int sock = PL_dumper_fd;
1202 FD_SET(sock, &rset);
1203 select(sock + 1, &rset, NULL, NULL, &waitfor);
1204 waitpid(child, &status, WNOHANG);
1209 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1215 #ifdef PERL_DEBUG_READONLY_OPS
1221 #if defined(PERLIO_LAYERS)
1222 /* No more IO - including error messages ! */
1223 PerlIO_cleanup(aTHX);
1226 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1227 as currently layers use it rather than NULL as a marker
1228 for no arg - and will try and SvREFCNT_dec it.
1230 SvREFCNT(&PL_sv_undef) = 0;
1231 SvREADONLY_off(&PL_sv_undef);
1233 Safefree(PL_origfilename);
1234 PL_origfilename = NULL;
1235 Safefree(PL_reg_start_tmp);
1236 PL_reg_start_tmp = (char**)NULL;
1237 PL_reg_start_tmpl = 0;
1238 Safefree(PL_reg_curpm);
1239 Safefree(PL_reg_poscache);
1240 free_tied_hv_pool();
1241 Safefree(PL_op_mask);
1242 Safefree(PL_psig_name);
1243 PL_psig_name = (SV**)NULL;
1244 PL_psig_ptr = (SV**)NULL;
1246 /* We need to NULL PL_psig_pend first, so that
1247 signal handlers know not to use it */
1248 int *psig_save = PL_psig_pend;
1249 PL_psig_pend = (int*)NULL;
1250 Safefree(psig_save);
1254 PL_tainting = FALSE;
1255 PL_taint_warn = FALSE;
1256 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
1259 DEBUG_P(debprofdump());
1261 #ifdef USE_REENTRANT_API
1262 Perl_reentrant_free(aTHX);
1267 while (PL_regmatch_slab) {
1268 regmatch_slab *s = PL_regmatch_slab;
1269 PL_regmatch_slab = PL_regmatch_slab->next;
1273 /* As the absolutely last thing, free the non-arena SV for mess() */
1276 /* we know that type == SVt_PVMG */
1278 /* it could have accumulated taint magic */
1281 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1282 moremagic = mg->mg_moremagic;
1283 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1285 Safefree(mg->mg_ptr);
1289 /* we know that type >= SVt_PV */
1290 SvPV_free(PL_mess_sv);
1291 Safefree(SvANY(PL_mess_sv));
1292 Safefree(PL_mess_sv);
1299 =for apidoc perl_free
1301 Releases a Perl interpreter. See L<perlembed>.
1311 PERL_ARGS_ASSERT_PERL_FREE;
1313 if (PL_veto_cleanup)
1316 #ifdef PERL_TRACK_MEMPOOL
1319 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1320 * value as we're probably hunting memory leaks then
1322 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
1323 if (!s || atoi(s) == 0) {
1324 const U32 old_debug = PL_debug;
1325 /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1326 thread at thread exit. */
1328 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1329 "free this thread's memory\n");
1330 PL_debug &= ~ DEBUG_m_FLAG;
1332 while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
1333 safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
1334 PL_debug = old_debug;
1339 #if defined(WIN32) || defined(NETWARE)
1340 # if defined(PERL_IMPLICIT_SYS)
1343 void *host = nw_internal_host;
1345 void *host = w32_internal_host;
1347 PerlMem_free(aTHXx);
1349 nw_delete_internal_host(host);
1351 win32_delete_internal_host(host);
1355 PerlMem_free(aTHXx);
1358 PerlMem_free(aTHXx);
1362 #if defined(USE_ITHREADS)
1363 /* provide destructors to clean up the thread key when libperl is unloaded */
1364 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1366 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1367 #pragma fini "perl_fini"
1368 #elif defined(__sun) && !defined(__GNUC__)
1369 #pragma fini (perl_fini)
1373 #if defined(__GNUC__)
1374 __attribute__((destructor))
1379 if (PL_curinterp && !PL_veto_cleanup)
1384 #endif /* THREADS */
1387 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1390 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1391 PL_exitlist[PL_exitlistlen].fn = fn;
1392 PL_exitlist[PL_exitlistlen].ptr = ptr;
1396 #ifdef HAS_PROCSELFEXE
1397 /* This is a function so that we don't hold on to MAXPATHLEN
1398 bytes of stack longer than necessary
1401 S_procself_val(pTHX_ SV *sv, const char *arg0)
1403 char buf[MAXPATHLEN];
1404 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1406 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1407 includes a spurious NUL which will cause $^X to fail in system
1408 or backticks (this will prevent extensions from being built and
1409 many tests from working). readlink is not meant to add a NUL.
1410 Normal readlink works fine.
1412 if (len > 0 && buf[len-1] == '\0') {
1416 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1417 returning the text "unknown" from the readlink rather than the path
1418 to the executable (or returning an error from the readlink). Any valid
1419 path has a '/' in it somewhere, so use that to validate the result.
1420 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1422 if (len > 0 && memchr(buf, '/', len)) {
1423 sv_setpvn(sv,buf,len);
1429 #endif /* HAS_PROCSELFEXE */
1432 S_set_caret_X(pTHX) {
1434 GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
1436 #ifdef HAS_PROCSELFEXE
1437 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1440 sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
1442 sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
1449 =for apidoc perl_parse
1451 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1457 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1464 PERL_ARGS_ASSERT_PERL_PARSE;
1465 #ifndef MULTIPLICITY
1466 PERL_UNUSED_ARG(my_perl);
1469 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1470 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
1471 * This MUST be done before any hash stores or fetches take place.
1472 * If you set PL_rehash_seed (and presumably also PL_rehash_seed_set)
1473 * yourself, it is your responsibility to provide a good random seed!
1474 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
1475 if (!PL_rehash_seed_set)
1476 PL_rehash_seed = get_hash_seed();
1478 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1480 if (s && (atoi(s) == 1))
1481 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
1483 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1488 if (PL_origalen != 0) {
1489 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1492 /* Set PL_origalen be the sum of the contiguous argv[]
1493 * elements plus the size of the env in case that it is
1494 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1495 * as the maximum modifiable length of $0. In the worst case
1496 * the area we are able to modify is limited to the size of
1497 * the original argv[0]. (See below for 'contiguous', though.)
1499 const char *s = NULL;
1502 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1503 /* Do the mask check only if the args seem like aligned. */
1505 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1507 /* See if all the arguments are contiguous in memory. Note
1508 * that 'contiguous' is a loose term because some platforms
1509 * align the argv[] and the envp[]. If the arguments look
1510 * like non-aligned, assume that they are 'strictly' or
1511 * 'traditionally' contiguous. If the arguments look like
1512 * aligned, we just check that they are within aligned
1513 * PTRSIZE bytes. As long as no system has something bizarre
1514 * like the argv[] interleaved with some other data, we are
1515 * fine. (Did I just evoke Murphy's Law?) --jhi */
1516 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1518 for (i = 1; i < PL_origargc; i++) {
1519 if ((PL_origargv[i] == s + 1
1521 || PL_origargv[i] == s + 2
1526 (PL_origargv[i] > s &&
1528 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1539 #ifndef PERL_USE_SAFE_PUTENV
1540 /* Can we grab env area too to be used as the area for $0? */
1541 if (s && PL_origenviron && !PL_use_safe_putenv) {
1542 if ((PL_origenviron[0] == s + 1)
1545 (PL_origenviron[0] > s &&
1546 PL_origenviron[0] <=
1547 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1550 #ifndef OS2 /* ENVIRON is read by the kernel too. */
1551 s = PL_origenviron[0];
1554 my_setenv("NoNe SuCh", NULL);
1555 /* Force copy of environment. */
1556 for (i = 1; PL_origenviron[i]; i++) {
1557 if (PL_origenviron[i] == s + 1
1560 (PL_origenviron[i] > s &&
1561 PL_origenviron[i] <=
1562 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1565 s = PL_origenviron[i];
1573 #endif /* !defined(PERL_USE_SAFE_PUTENV) */
1575 PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1580 /* Come here if running an undumped a.out. */
1582 PL_origfilename = savepv(argv[0]);
1583 PL_do_undump = FALSE;
1584 cxstack_ix = -1; /* start label stack again */
1586 assert (!PL_tainted);
1588 S_set_caret_X(aTHX);
1590 init_postdump_symbols(argc,argv,env);
1595 op_free(PL_main_root);
1596 PL_main_root = NULL;
1598 PL_main_start = NULL;
1599 SvREFCNT_dec(PL_main_cv);
1603 oldscope = PL_scopestack_ix;
1604 PL_dowarn = G_WARN_OFF;
1609 parse_body(env,xsinit);
1610 if (PL_unitcheckav) {
1611 call_list(oldscope, PL_unitcheckav);
1614 PL_phase = PERL_PHASE_CHECK;
1615 call_list(oldscope, PL_checkav);
1623 /* my_exit() was called */
1624 while (PL_scopestack_ix > oldscope)
1627 PL_curstash = PL_defstash;
1628 if (PL_unitcheckav) {
1629 call_list(oldscope, PL_unitcheckav);
1632 PL_phase = PERL_PHASE_CHECK;
1633 call_list(oldscope, PL_checkav);
1638 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1646 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1647 miniperl, and we need to see those flags reflected in the values here. */
1649 /* What this returns is subject to change. Use the public interface in Config.
1652 S_Internals_V(pTHX_ CV *cv)
1655 #ifdef LOCAL_PATCH_COUNT
1656 const int local_patch_count = LOCAL_PATCH_COUNT;
1658 const int local_patch_count = 0;
1660 const int entries = 3 + local_patch_count;
1662 static char non_bincompat_options[] =
1669 # ifdef PERL_DISABLE_PMC
1672 # ifdef PERL_DONT_CREATE_GVSV
1673 " PERL_DONT_CREATE_GVSV"
1675 # ifdef PERL_EXTERNAL_GLOB
1676 " PERL_EXTERNAL_GLOB"
1678 # ifdef PERL_IS_MINIPERL
1681 # ifdef PERL_MALLOC_WRAP
1684 # ifdef PERL_MEM_LOG
1687 # ifdef PERL_MEM_LOG_NOIMPL
1688 " PERL_MEM_LOG_NOIMPL"
1690 # ifdef PERL_USE_DEVEL
1693 # ifdef PERL_USE_SAFE_PUTENV
1694 " PERL_USE_SAFE_PUTENV"
1696 # ifdef USE_ATTRIBUTES_FOR_PERLIO
1697 " USE_ATTRIBUTES_FOR_PERLIO"
1699 # ifdef USE_FAST_STDIO
1702 # ifdef USE_PERL_ATOF
1705 # ifdef USE_SITECUSTOMIZE
1706 " USE_SITECUSTOMIZE"
1709 PERL_UNUSED_ARG(cv);
1710 PERL_UNUSED_ARG(items);
1712 EXTEND(SP, entries);
1714 PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
1715 PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
1716 sizeof(non_bincompat_options) - 1, SVs_TEMP));
1720 PUSHs(Perl_newSVpvn_flags(aTHX_
1721 STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__),
1724 PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
1728 PUSHs(&PL_sv_undef);
1731 for (i = 1; i <= local_patch_count; i++) {
1732 /* This will be an undef, if PL_localpatches[i] is NULL. */
1733 PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
1739 #define INCPUSH_UNSHIFT 0x01
1740 #define INCPUSH_ADD_OLD_VERS 0x02
1741 #define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04
1742 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS 0x08
1743 #define INCPUSH_NOT_BASEDIR 0x10
1744 #define INCPUSH_CAN_RELOCATE 0x20
1745 #define INCPUSH_ADD_SUB_DIRS \
1746 (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
1749 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1753 int argc = PL_origargc;
1754 char **argv = PL_origargv;
1755 const char *scriptname = NULL;
1756 VOL bool dosearch = FALSE;
1758 bool doextract = FALSE;
1759 const char *cddir = NULL;
1760 #ifdef USE_SITECUSTOMIZE
1761 bool minus_f = FALSE;
1763 SV *linestr_sv = newSV_type(SVt_PVIV);
1764 bool add_read_e_script = FALSE;
1766 PL_phase = PERL_PHASE_START;
1768 SvGROW(linestr_sv, 80);
1769 sv_setpvs(linestr_sv,"");
1775 for (argc--,argv++; argc > 0; argc--,argv++) {
1776 if (argv[0][0] != '-' || !argv[0][1])
1782 #ifndef PERL_STRICT_CR
1806 if ((s = moreswitches(s)))
1811 CHECK_MALLOC_TOO_LATE_FOR('t');
1812 if( !PL_tainting ) {
1813 PL_taint_warn = TRUE;
1819 CHECK_MALLOC_TOO_LATE_FOR('T');
1821 PL_taint_warn = FALSE;
1829 forbid_setid('e', FALSE);
1831 PL_e_script = newSVpvs("");
1832 add_read_e_script = TRUE;
1835 sv_catpv(PL_e_script, s);
1837 sv_catpv(PL_e_script, argv[1]);
1841 Perl_croak(aTHX_ "No code specified for -%c", c);
1842 sv_catpvs(PL_e_script, "\n");
1846 #ifdef USE_SITECUSTOMIZE
1852 case 'I': /* -I handled both here and in moreswitches() */
1853 forbid_setid('I', FALSE);
1854 if (!*++s && (s=argv[1]) != NULL) {
1858 STRLEN len = strlen(s);
1859 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
1862 Perl_croak(aTHX_ "No directory specified for -I");
1865 forbid_setid('S', FALSE);
1874 opts_prog = newSVpvs("use Config; Config::_V()");
1878 opts_prog = Perl_newSVpvf(aTHX_
1879 "use Config; Config::config_vars(qw%c%s%c)",
1883 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
1884 /* don't look for script or read stdin */
1885 scriptname = BIT_BUCKET;
1897 if (!*++s || isSPACE(*s)) {
1901 /* catch use of gnu style long options */
1902 if (strEQ(s, "version")) {
1906 if (strEQ(s, "help")) {
1913 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1924 #ifndef SECURE_INTERNAL_GETENV
1927 (s = PerlEnv_getenv("PERL5OPT")))
1931 if (*s == '-' && *(s+1) == 'T') {
1932 CHECK_MALLOC_TOO_LATE_FOR('T');
1934 PL_taint_warn = FALSE;
1937 char *popt_copy = NULL;
1950 if (!strchr("CDIMUdmtwW", *s))
1951 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1955 popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
1956 s = popt_copy + (s - d);
1964 if( !PL_tainting ) {
1965 PL_taint_warn = TRUE;
1976 #if defined(USE_SITECUSTOMIZE) && !defined(PERL_IS_MINIPERL)
1978 /* SITELIB_EXP is a function call on Win32.
1979 The games with local $! are to avoid setting errno if there is no
1980 sitecustomize script. */
1981 const char *const sitelib = SITELIB_EXP;
1982 (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
1984 "BEGIN { do {local $!; -f '%s/sitecustomize.pl'} && do '%s/sitecustomize.pl' }", sitelib, sitelib));
1989 scriptname = argv[0];
1992 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1994 else if (scriptname == NULL) {
1996 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2002 /* Set $^X early so that it can be used for relocatable paths in @INC */
2003 assert (!PL_tainted);
2005 S_set_caret_X(aTHX);
2010 bool suidscript = FALSE;
2012 open_script(scriptname, dosearch, &suidscript, &rsfp);
2014 validate_suid(validarg, scriptname, fdscript, suidscript,
2018 # if defined(SIGCHLD) || defined(SIGCLD)
2021 # define SIGCHLD SIGCLD
2023 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2024 if (sigstate == (Sighandler_t) SIG_IGN) {
2025 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2026 "Can't ignore signal CHLD, forcing to default");
2027 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2035 /* This will croak if suidscript is true, as -x cannot be used with
2037 forbid_setid('x', suidscript);
2038 /* Hence you can't get here if suidscript is true */
2040 find_beginning(linestr_sv, rsfp);
2041 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2042 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2046 PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2047 CvUNIQUE_on(PL_compcv);
2049 CvPADLIST(PL_compcv) = pad_new(0);
2051 PL_isarev = newHV();
2054 boot_core_UNIVERSAL();
2056 newXS("Internals::V", S_Internals_V, __FILE__);
2059 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
2061 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
2067 # ifdef HAS_SOCKS5_INIT
2068 socks5_init(argv[0]);
2074 init_predump_symbols();
2075 /* init_postdump_symbols not currently designed to be called */
2076 /* more than once (ENV isn't cleared first, for example) */
2077 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2079 init_postdump_symbols(argc,argv,env);
2081 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2082 * or explicitly in some platforms.
2083 * locale.c:Perl_init_i18nl10n() if the environment
2084 * look like the user wants to use UTF-8. */
2085 #if defined(__SYMBIAN32__)
2086 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2088 # ifndef PERL_IS_MINIPERL
2090 /* Requires init_predump_symbols(). */
2091 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2096 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2097 * and the default open disciplines. */
2098 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2099 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2101 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2102 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2103 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2105 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2106 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2107 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2109 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2110 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2111 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2113 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2114 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2117 sv_setpvs(sv, ":utf8\0:utf8");
2119 sv_setpvs(sv, ":utf8\0");
2122 sv_setpvs(sv, "\0:utf8");
2131 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2132 if (strEQ(s, "unsafe"))
2133 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2134 else if (strEQ(s, "safe"))
2135 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2137 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2144 if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
2148 PL_xmlfp = PerlIO_stdout();
2150 PL_xmlfp = PerlIO_open(s, "w");
2152 Perl_croak(aTHX_ "Can't open %s", s);
2154 my_setenv("PERL_XMLDUMP", NULL); /* hide from subprocs */
2160 if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2161 PL_madskills = atoi(s);
2162 my_setenv("PERL_MADSKILLS", NULL); /* hide from subprocs */
2167 lex_start(linestr_sv, rsfp, 0);
2168 PL_subname = newSVpvs("main");
2170 if (add_read_e_script)
2171 filter_add(read_e_script, NULL);
2173 /* now parse the script */
2175 SETERRNO(0,SS_NORMAL);
2176 if (yyparse(GRAMPROG) || PL_parser->error_count) {
2178 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2180 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2184 CopLINE_set(PL_curcop, 0);
2185 PL_curstash = PL_defstash;
2187 SvREFCNT_dec(PL_e_script);
2195 SAVECOPFILE(PL_curcop);
2196 SAVECOPLINE(PL_curcop);
2197 gv_check(PL_defstash);
2206 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2207 dump_mstats("after compilation:");
2212 PL_restartjmpenv = NULL;
2218 =for apidoc perl_run
2220 Tells a Perl interpreter to run. See L<perlembed>.
2233 PERL_ARGS_ASSERT_PERL_RUN;
2234 #ifndef MULTIPLICITY
2235 PERL_UNUSED_ARG(my_perl);
2238 oldscope = PL_scopestack_ix;
2246 cxstack_ix = -1; /* start context stack again */
2248 case 0: /* normal completion */
2252 case 2: /* my_exit() */
2253 while (PL_scopestack_ix > oldscope)
2256 PL_curstash = PL_defstash;
2257 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2258 PL_endav && !PL_minus_c) {
2259 PL_phase = PERL_PHASE_END;
2260 call_list(oldscope, PL_endav);
2263 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2264 dump_mstats("after execution: ");
2270 POPSTACK_TO(PL_mainstack);
2273 PerlIO_printf(Perl_error_log, "panic: restartop\n");
2284 S_run_body(pTHX_ I32 oldscope)
2287 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2288 PL_sawampersand ? "Enabling" : "Omitting"));
2290 if (!PL_restartop) {
2294 exit(0); /* less likely to core dump than my_exit(0) */
2298 if (DEBUG_x_TEST || DEBUG_B_TEST)
2299 dump_all_perl(!DEBUG_B_TEST);
2301 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2305 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2308 if (PERLDB_SINGLE && PL_DBsingle)
2309 sv_setiv(PL_DBsingle, 1);
2311 PL_phase = PERL_PHASE_INIT;
2312 call_list(oldscope, PL_initav);
2314 #ifdef PERL_DEBUG_READONLY_OPS
2315 Perl_pending_Slabs_to_ro(aTHX);
2321 PL_phase = PERL_PHASE_RUN;
2324 PL_restartjmpenv = NULL;
2325 PL_op = PL_restartop;
2329 else if (PL_main_start) {
2330 CvDEPTH(PL_main_cv) = 1;
2331 PL_op = PL_main_start;
2339 =head1 SV Manipulation Functions
2341 =for apidoc p||get_sv
2343 Returns the SV of the specified Perl scalar. C<flags> are passed to
2344 C<gv_fetchpv>. If C<GV_ADD> is set and the
2345 Perl variable does not exist then it will be created. If C<flags> is zero
2346 and the variable does not exist then NULL is returned.
2352 Perl_get_sv(pTHX_ const char *name, I32 flags)
2356 PERL_ARGS_ASSERT_GET_SV;
2358 gv = gv_fetchpv(name, flags, SVt_PV);
2365 =head1 Array Manipulation Functions
2367 =for apidoc p||get_av
2369 Returns the AV of the specified Perl array. C<flags> are passed to
2370 C<gv_fetchpv>. If C<GV_ADD> is set and the
2371 Perl variable does not exist then it will be created. If C<flags> is zero
2372 and the variable does not exist then NULL is returned.
2378 Perl_get_av(pTHX_ const char *name, I32 flags)
2380 GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2382 PERL_ARGS_ASSERT_GET_AV;
2392 =head1 Hash Manipulation Functions
2394 =for apidoc p||get_hv
2396 Returns the HV of the specified Perl hash. C<flags> are passed to
2397 C<gv_fetchpv>. If C<GV_ADD> is set and the
2398 Perl variable does not exist then it will be created. If C<flags> is zero
2399 and the variable does not exist then NULL is returned.
2405 Perl_get_hv(pTHX_ const char *name, I32 flags)
2407 GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2409 PERL_ARGS_ASSERT_GET_HV;
2419 =head1 CV Manipulation Functions
2421 =for apidoc p||get_cvn_flags
2423 Returns the CV of the specified Perl subroutine. C<flags> are passed to
2424 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2425 exist then it will be declared (which has the same effect as saying
2426 C<sub name;>). If C<GV_ADD> is not set and the subroutine does not exist
2427 then NULL is returned.
2429 =for apidoc p||get_cv
2431 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2437 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2439 GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2440 /* XXX this is probably not what they think they're getting.
2441 * It has the same effect as "sub name;", i.e. just a forward
2444 PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2446 if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2447 SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8);
2448 return newSUB(start_subparse(FALSE, 0),
2449 newSVOP(OP_CONST, 0, sv),
2457 /* Nothing in core calls this now, but we can't replace it with a macro and
2458 move it to mathoms.c as a macro would evaluate name twice. */
2460 Perl_get_cv(pTHX_ const char *name, I32 flags)
2462 PERL_ARGS_ASSERT_GET_CV;
2464 return get_cvn_flags(name, strlen(name), flags);
2467 /* Be sure to refetch the stack pointer after calling these routines. */
2471 =head1 Callback Functions
2473 =for apidoc p||call_argv
2475 Performs a callback to the specified Perl sub. See L<perlcall>.
2481 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2483 /* See G_* flags in cop.h */
2484 /* null terminated arg list */
2489 PERL_ARGS_ASSERT_CALL_ARGV;
2494 mXPUSHs(newSVpv(*argv,0));
2499 return call_pv(sub_name, flags);
2503 =for apidoc p||call_pv
2505 Performs a callback to the specified Perl sub. See L<perlcall>.
2511 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2512 /* name of the subroutine */
2513 /* See G_* flags in cop.h */
2515 PERL_ARGS_ASSERT_CALL_PV;
2517 return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2521 =for apidoc p||call_method
2523 Performs a callback to the specified Perl method. The blessed object must
2524 be on the stack. See L<perlcall>.
2530 Perl_call_method(pTHX_ const char *methname, I32 flags)
2531 /* name of the subroutine */
2532 /* See G_* flags in cop.h */
2535 PERL_ARGS_ASSERT_CALL_METHOD;
2537 len = strlen(methname);
2539 /* XXX: sv_2mortal(newSVpvn_share(methname, len)) can be faster */
2540 return call_sv(newSVpvn_flags(methname, len, SVs_TEMP), flags | G_METHOD);
2543 /* May be called with any of a CV, a GV, or an SV containing the name. */
2545 =for apidoc p||call_sv
2547 Performs a callback to the Perl sub whose name is in the SV. See
2554 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2555 /* See G_* flags in cop.h */
2558 LOGOP myop; /* fake syntax tree node */
2563 bool oldcatch = CATCH_GET;
2565 OP* const oldop = PL_op;
2568 PERL_ARGS_ASSERT_CALL_SV;
2570 if (flags & G_DISCARD) {
2574 if (!(flags & G_WANT)) {
2575 /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2580 Zero(&myop, 1, LOGOP);
2581 myop.op_next = NULL;
2582 if (!(flags & G_NOARGS))
2583 myop.op_flags |= OPf_STACKED;
2584 myop.op_flags |= OP_GIMME_REVERSE(flags);
2588 EXTEND(PL_stack_sp, 1);
2589 *++PL_stack_sp = sv;
2591 oldscope = PL_scopestack_ix;
2593 if (PERLDB_SUB && PL_curstash != PL_debstash
2594 /* Handle first BEGIN of -d. */
2595 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2596 /* Try harder, since this may have been a sighandler, thus
2597 * curstash may be meaningless. */
2598 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2599 && !(flags & G_NODEBUG))
2600 PL_op->op_private |= OPpENTERSUB_DB;
2602 if (flags & G_METHOD) {
2603 Zero(&method_op, 1, UNOP);
2604 method_op.op_next = PL_op;
2605 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2606 method_op.op_type = OP_METHOD;
2607 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2608 myop.op_type = OP_ENTERSUB;
2609 PL_op = (OP*)&method_op;
2612 if (!(flags & G_EVAL)) {
2614 CALL_BODY_SUB((OP*)&myop);
2615 retval = PL_stack_sp - (PL_stack_base + oldmark);
2616 CATCH_SET(oldcatch);
2619 myop.op_other = (OP*)&myop;
2621 create_eval_scope(flags|G_FAKINGEVAL);
2629 CALL_BODY_SUB((OP*)&myop);
2630 retval = PL_stack_sp - (PL_stack_base + oldmark);
2631 if (!(flags & G_KEEPERR)) {
2639 /* my_exit() was called */
2640 PL_curstash = PL_defstash;
2647 PL_restartjmpenv = NULL;
2648 PL_op = PL_restartop;
2652 PL_stack_sp = PL_stack_base + oldmark;
2653 if ((flags & G_WANT) == G_ARRAY)
2657 *++PL_stack_sp = &PL_sv_undef;
2662 if (PL_scopestack_ix > oldscope)
2663 delete_eval_scope();
2667 if (flags & G_DISCARD) {
2668 PL_stack_sp = PL_stack_base + oldmark;
2677 /* Eval a string. The G_EVAL flag is always assumed. */
2680 =for apidoc p||eval_sv
2682 Tells Perl to C<eval> the string in the SV. It supports the same flags
2683 as C<call_sv>, with the obvious exception of G_EVAL. See L<perlcall>.
2689 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2691 /* See G_* flags in cop.h */
2695 UNOP myop; /* fake syntax tree node */
2696 VOL I32 oldmark = SP - PL_stack_base;
2699 OP* const oldop = PL_op;
2702 PERL_ARGS_ASSERT_EVAL_SV;
2704 if (flags & G_DISCARD) {
2711 Zero(PL_op, 1, UNOP);
2712 EXTEND(PL_stack_sp, 1);
2713 *++PL_stack_sp = sv;
2715 if (!(flags & G_NOARGS))
2716 myop.op_flags = OPf_STACKED;
2717 myop.op_next = NULL;
2718 myop.op_type = OP_ENTEREVAL;
2719 myop.op_flags |= OP_GIMME_REVERSE(flags);
2720 if (flags & G_KEEPERR)
2721 myop.op_flags |= OPf_SPECIAL;
2723 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2724 * before a PUSHEVAL, which corrupts the stack after a croak */
2725 TAINT_PROPER("eval_sv()");
2731 if (PL_op == (OP*)(&myop)) {
2732 PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
2734 goto fail; /* failed in compilation */
2737 retval = PL_stack_sp - (PL_stack_base + oldmark);
2738 if (!(flags & G_KEEPERR)) {
2746 /* my_exit() was called */
2747 PL_curstash = PL_defstash;
2754 PL_restartjmpenv = NULL;
2755 PL_op = PL_restartop;
2760 PL_stack_sp = PL_stack_base + oldmark;
2761 if ((flags & G_WANT) == G_ARRAY)
2765 *++PL_stack_sp = &PL_sv_undef;
2771 if (flags & G_DISCARD) {
2772 PL_stack_sp = PL_stack_base + oldmark;
2782 =for apidoc p||eval_pv
2784 Tells Perl to C<eval> the given string and return an SV* result.
2790 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2794 SV* sv = newSVpv(p, 0);
2796 PERL_ARGS_ASSERT_EVAL_PV;
2798 eval_sv(sv, G_SCALAR);
2805 if (croak_on_error && SvTRUE(ERRSV)) {
2806 Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
2812 /* Require a module. */
2815 =head1 Embedding Functions
2817 =for apidoc p||require_pv
2819 Tells Perl to C<require> the file named by the string argument. It is
2820 analogous to the Perl code C<eval "require '$file'">. It's even
2821 implemented that way; consider using load_module instead.
2826 Perl_require_pv(pTHX_ const char *pv)
2832 PERL_ARGS_ASSERT_REQUIRE_PV;
2834 PUSHSTACKi(PERLSI_REQUIRE);
2836 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2837 eval_sv(sv_2mortal(sv), G_DISCARD);
2843 S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
2845 /* This message really ought to be max 23 lines.
2846 * Removed -h because the user already knows that option. Others? */
2848 /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
2849 minimum of 509 character string literals. */
2850 static const char * const usage_msg[] = {
2851 " -0[octal] specify record separator (\\0, if no argument)\n"
2852 " -a autosplit mode with -n or -p (splits $_ into @F)\n"
2853 " -C[number/list] enables the listed Unicode features\n"
2854 " -c check syntax only (runs BEGIN and CHECK blocks)\n"
2855 " -d[:debugger] run program under debugger\n"
2856 " -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n",
2857 " -e program one line of program (several -e's allowed, omit programfile)\n"
2858 " -E program like -e, but enables all optional features\n"
2859 " -f don't do $sitelib/sitecustomize.pl at startup\n"
2860 " -F/pattern/ split() pattern for -a switch (//'s are optional)\n"
2861 " -i[extension] edit <> files in place (makes backup if extension supplied)\n"
2862 " -Idirectory specify @INC/#include directory (several -I's allowed)\n",
2863 " -l[octal] enable line ending processing, specifies line terminator\n"
2864 " -[mM][-]module execute \"use/no module...\" before executing program\n"
2865 " -n assume \"while (<>) { ... }\" loop around program\n"
2866 " -p assume loop like -n but print line also, like sed\n"
2867 " -s enable rudimentary parsing for switches after programfile\n"
2868 " -S look for programfile using PATH environment variable\n",
2869 " -t enable tainting warnings\n"
2870 " -T enable tainting checks\n"
2871 " -u dump core after parsing program\n"
2872 " -U allow unsafe operations\n"
2873 " -v print version, patchlevel and license\n"
2874 " -V[:variable] print configuration summary (or a single Config.pm variable)\n",
2875 " -w enable many useful warnings\n"
2876 " -W enable all warnings\n"
2877 " -x[directory] ignore text before #!perl line (optionally cd to directory)\n"
2878 " -X disable all warnings\n"
2880 "Run 'perldoc perl' for more help with Perl.\n\n",
2883 const char * const *p = usage_msg;
2884 PerlIO *out = PerlIO_stdout();
2886 PERL_ARGS_ASSERT_USAGE;
2889 "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
2892 PerlIO_puts(out, *p++);
2895 /* convert a string of -D options (or digits) into an int.
2896 * sets *s to point to the char after the options */
2900 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2902 static const char * const usage_msgd[] = {
2903 " Debugging flag values: (see also -d)\n"
2904 " p Tokenizing and parsing (with v, displays parse stack)\n"
2905 " s Stack snapshots (with v, displays all stacks)\n"
2906 " l Context (loop) stack processing\n"
2907 " t Trace execution\n"
2908 " o Method and overloading resolution\n",
2909 " c String/numeric conversions\n"
2910 " P Print profiling info, source file input state\n"
2911 " m Memory and SV allocation\n"
2912 " f Format processing\n"
2913 " r Regular expression parsing and execution\n"
2914 " x Syntax tree dump\n",
2915 " u Tainting checks\n"
2916 " H Hash dump -- usurps values()\n"
2917 " X Scratchpad allocation\n"
2920 " R Include reference counts of dumped variables (eg when using -Ds)\n",
2921 " J Do not s,t,P-debug (Jump over) opcodes within package DB\n"
2922 " v Verbose: use in conjunction with other flags\n"
2923 " C Copy On Write\n"
2924 " A Consistency checks on internal structures\n"
2925 " q quiet - currently only suppresses the 'EXECUTING' message\n"
2926 " M trace smart match resolution\n"
2927 " B dump suBroutine definitions, including special Blocks like BEGIN\n",
2932 PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
2935 /* if adding extra options, remember to update DEBUG_MASK */
2936 static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
2938 for (; isALNUM(**s); (*s)++) {
2939 const char * const d = strchr(debopts,**s);
2941 i |= 1 << (d - debopts);
2942 else if (ckWARN_d(WARN_DEBUGGING))
2943 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2944 "invalid option -D%c, use -D'' to see choices\n", **s);
2947 else if (isDIGIT(**s)) {
2949 for (; isALNUM(**s); (*s)++) ;
2951 else if (givehelp) {
2952 const char *const *p = usage_msgd;
2953 while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
2956 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2957 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2958 "-Dp not implemented on this platform\n");
2964 /* This routine handles any switches that can be given during run */
2967 Perl_moreswitches(pTHX_ const char *s)
2971 const char option = *s; /* used to remember option in -m/-M code */
2973 PERL_ARGS_ASSERT_MORESWITCHES;
2981 SvREFCNT_dec(PL_rs);
2982 if (s[1] == 'x' && s[2]) {
2983 const char *e = s+=2;
2989 flags = PERL_SCAN_SILENT_ILLDIGIT;
2990 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2991 if (s + numlen < e) {
2992 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2996 PL_rs = newSVpvs("");
2997 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2998 tmps = (U8*)SvPVX(PL_rs);
2999 uvchr_to_utf8(tmps, rschar);
3000 SvCUR_set(PL_rs, UNISKIP(rschar));
3005 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3006 if (rschar & ~((U8)~0))
3007 PL_rs = &PL_sv_undef;
3008 else if (!rschar && numlen >= 2)
3009 PL_rs = newSVpvs("");
3011 char ch = (char)rschar;
3012 PL_rs = newSVpvn(&ch, 1);
3015 sv_setsv(get_sv("/", GV_ADD), PL_rs);
3020 PL_unicode = parse_unicode_opts( (const char **)&s );
3021 if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3027 while (*s && !isSPACE(*s)) ++s;
3028 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3039 forbid_setid('d', FALSE);
3042 /* -dt indicates to the debugger that threads will be used */
3043 if (*s == 't' && !isALNUM(s[1])) {
3045 my_setenv("PERL5DB_THREADED", "1");
3048 /* The following permits -d:Mod to accepts arguments following an =
3049 in the fashion that -MSome::Mod does. */
3050 if (*s == ':' || *s == '=') {
3057 sv = newSVpvs("no Devel::");
3059 sv = newSVpvs("use Devel::");
3063 end = s + strlen(s);
3065 /* We now allow -d:Module=Foo,Bar and -d:-Module */
3066 while(isALNUM(*s) || *s==':') ++s;
3068 sv_catpvn(sv, start, end - start);
3070 sv_catpvn(sv, start, s-start);
3071 /* Don't use NUL as q// delimiter here, this string goes in the
3073 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3076 my_setenv("PERL5DB", SvPV_nolen_const(sv));
3080 PL_perldb = PERLDB_ALL;
3087 forbid_setid('D', FALSE);
3089 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3090 #else /* !DEBUGGING */
3091 if (ckWARN_d(WARN_DEBUGGING))
3092 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3093 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3094 for (s++; isALNUM(*s); s++) ;
3099 usage(PL_origargv[0]);
3102 Safefree(PL_inplace);
3103 #if defined(__CYGWIN__) /* do backup extension automagically */
3104 if (*(s+1) == '\0') {
3105 PL_inplace = savepvs(".bak");
3108 #endif /* __CYGWIN__ */
3110 const char * const start = ++s;
3111 while (*s && !isSPACE(*s))
3114 PL_inplace = savepvn(start, s - start);
3118 if (*s == '-') /* Additional switches on #! line. */
3122 case 'I': /* -I handled both here and in parse_body() */
3123 forbid_setid('I', FALSE);
3125 while (*s && isSPACE(*s))
3130 /* ignore trailing spaces (possibly followed by other switches) */
3132 for (e = p; *e && !isSPACE(*e); e++) ;
3136 } while (*p && *p != '-');
3138 INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3144 Perl_croak(aTHX_ "No directory specified for -I");
3150 SvREFCNT_dec(PL_ors_sv);
3156 PL_ors_sv = newSVpvs("\n");
3157 numlen = 3 + (*s == '0');
3158 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3162 if (RsPARA(PL_rs)) {
3163 PL_ors_sv = newSVpvs("\n\n");
3166 PL_ors_sv = newSVsv(PL_rs);
3171 forbid_setid('M', FALSE); /* XXX ? */
3174 forbid_setid('m', FALSE); /* XXX ? */
3179 const char *use = "use ";
3181 /* -M-foo == 'no foo' */
3182 /* Leading space on " no " is deliberate, to make both
3183 possibilities the same length. */
3184 if (*s == '-') { use = " no "; ++s; }
3185 sv = newSVpvn(use,4);
3187 /* We allow -M'Module qw(Foo Bar)' */
3188 while(isALNUM(*s) || *s==':') {
3197 Perl_croak(aTHX_ "Module name required with -%c option",
3200 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3201 "contains single ':'",
3202 (int)(s - start), start, option);
3203 end = s + strlen(s);
3205 sv_catpvn(sv, start, end - start);
3206 if (option == 'm') {
3208 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3209 sv_catpvs( sv, " ()");
3212 sv_catpvn(sv, start, s-start);
3213 /* Use NUL as q''-delimiter. */
3214 sv_catpvs(sv, " split(/,/,q\0");
3216 sv_catpvn(sv, s, end - s);
3217 sv_catpvs(sv, "\0)");
3220 Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3223 Perl_croak(aTHX_ "Missing argument to -%c", option);
3234 forbid_setid('s', FALSE);
3235 PL_doswitches = TRUE;
3249 PL_do_undump = TRUE;
3257 if (!sv_derived_from(PL_patchlevel, "version"))
3258 upg_version(PL_patchlevel, TRUE);
3261 SV* level= vstringify(PL_patchlevel);
3262 #ifdef PERL_PATCHNUM
3263 # ifdef PERL_GIT_UNCOMMITTED_CHANGES
3264 SV *num = newSVpvs(PERL_PATCHNUM "*");
3266 SV *num = newSVpvs(PERL_PATCHNUM);
3269 if (sv_len(num)>=sv_len(level) && strnEQ(SvPV_nolen(num),SvPV_nolen(level),sv_len(level))) {
3270 SvREFCNT_dec(level);
3273 Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
3277 PerlIO_printf(PerlIO_stdout(),
3278 "\nThis is perl " STRINGIFY(PERL_REVISION)
3279 ", version " STRINGIFY(PERL_VERSION)
3280 ", subversion " STRINGIFY(PERL_SUBVERSION)
3281 " (%"SVf") built for " ARCHNAME, level
3283 SvREFCNT_dec(level);
3286 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3287 PerlIO_printf(PerlIO_stdout(),
3288 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
3289 SVfARG(vstringify(PL_patchlevel))));
3290 PerlIO_printf(PerlIO_stdout(),
3291 Perl_form(aTHX_ " built under %s at %s %s\n",
3292 OSNAME, __DATE__, __TIME__));
3293 PerlIO_printf(PerlIO_stdout(),
3294 Perl_form(aTHX_ " OS Specific Release: %s\n",
3297 #if defined(LOCAL_PATCH_COUNT)
3298 if (LOCAL_PATCH_COUNT > 0)
3299 PerlIO_printf(PerlIO_stdout(),
3300 "\n(with %d registered patch%s, "
3301 "see perl -V for more detail)",
3303 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3306 PerlIO_printf(PerlIO_stdout(),
3307 "\n\nCopyright 1987-2011, Larry Wall\n");
3309 PerlIO_printf(PerlIO_stdout(),
3310 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3313 PerlIO_printf(PerlIO_stdout(),
3314 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3315 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3318 PerlIO_printf(PerlIO_stdout(),
3319 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3320 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3323 PerlIO_printf(PerlIO_stdout(),
3324 "atariST series port, ++jrb bammi@cadence.com\n");
3327 PerlIO_printf(PerlIO_stdout(),
3328 "BeOS port Copyright Tom Spindler, 1997-1999\n");
3331 PerlIO_printf(PerlIO_stdout(),
3332 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3335 PerlIO_printf(PerlIO_stdout(),
3336 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3339 PerlIO_printf(PerlIO_stdout(),
3340 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3343 PerlIO_printf(PerlIO_stdout(),
3344 "VM/ESA port by Neale Ferguson, 1998-1999\n");
3347 PerlIO_printf(PerlIO_stdout(),
3348 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3351 PerlIO_printf(PerlIO_stdout(),
3352 "EPOC port by Olaf Flebbe, 1999-2002\n");
3355 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3356 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3359 #ifdef __SYMBIAN32__
3360 PerlIO_printf(PerlIO_stdout(),
3361 "Symbian port by Nokia, 2004-2005\n");
3363 #ifdef BINARY_BUILD_NOTICE
3364 BINARY_BUILD_NOTICE;
3366 PerlIO_printf(PerlIO_stdout(),
3368 Perl may be copied only under the terms of either the Artistic License or the\n\
3369 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3370 Complete documentation for Perl, including FAQ lists, should be found on\n\
3371 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3372 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3375 if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3376 PL_dowarn |= G_WARN_ON;
3381 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3382 if (!specialWARN(PL_compiling.cop_warnings))
3383 PerlMemShared_free(PL_compiling.cop_warnings);
3384 PL_compiling.cop_warnings = pWARN_ALL ;
3388 PL_dowarn = G_WARN_ALL_OFF;
3389 if (!specialWARN(PL_compiling.cop_warnings))
3390 PerlMemShared_free(PL_compiling.cop_warnings);
3391 PL_compiling.cop_warnings = pWARN_NONE ;
3398 if (s[0] == '-') /* Additional switches on #! line. */
3403 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3409 #ifdef ALTERNATE_SHEBANG
3410 case 'S': /* OS/2 needs -S on "extproc" line. */
3414 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3419 /* compliments of Tom Christiansen */
3421 /* unexec() can be found in the Gnu emacs distribution */
3422 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3425 Perl_my_unexec(pTHX)
3427 PERL_UNUSED_CONTEXT;
3429 SV * prog = newSVpv(BIN_EXP, 0);
3430 SV * file = newSVpv(PL_origfilename, 0);
3434 sv_catpvs(prog, "/perl");
3435 sv_catpvs(file, ".perldump");
3437 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3438 /* unexec prints msg to stderr in case of failure */
3439 PerlProc_exit(status);
3442 # include <lib$routines.h>
3443 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3444 # elif defined(WIN32) || defined(__CYGWIN__)
3445 Perl_croak(aTHX_ "dump is not supported");
3447 ABORT(); /* for use with undump */
3452 /* initialize curinterp */
3458 # define PERLVAR(var,type)
3459 # define PERLVARA(var,n,type)
3460 # if defined(PERL_IMPLICIT_CONTEXT)
3461 # define PERLVARI(var,type,init) aTHX->var = init;
3462 # define PERLVARIC(var,type,init) aTHX->var = init;
3464 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3465 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3467 # include "intrpvar.h"
3473 # define PERLVAR(var,type)
3474 # define PERLVARA(var,n,type)
3475 # define PERLVARI(var,type,init) PL_##var = init;
3476 # define PERLVARIC(var,type,init) PL_##var = init;
3477 # include "intrpvar.h"
3484 /* As these are inside a structure, PERLVARI isn't capable of initialising
3486 PL_reg_oldcurpm = PL_reg_curpm = NULL;
3487 PL_reg_poscache = PL_reg_starttry = NULL;
3491 S_init_main_stash(pTHX)
3496 PL_curstash = PL_defstash = newHV();
3497 /* We know that the string "main" will be in the global shared string
3498 table, so it's a small saving to use it rather than allocate another
3500 PL_curstname = newSVpvs_share("main");
3501 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3502 /* If we hadn't caused another reference to "main" to be in the shared
3503 string table above, then it would be worth reordering these two,
3504 because otherwise all we do is delete "main" from it as a consequence
3505 of the SvREFCNT_dec, only to add it again with hv_name_set */
3506 SvREFCNT_dec(GvHV(gv));
3507 hv_name_set(PL_defstash, "main", 4, 0);
3508 GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3510 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3512 SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3513 GvMULTI_on(PL_incgv);
3514 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3515 GvMULTI_on(PL_hintgv);
3516 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3517 SvREFCNT_inc_simple_void(PL_defgv);
3518 PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
3519 SvREFCNT_inc_simple_void(PL_errgv);
3520 GvMULTI_on(PL_errgv);
3521 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3522 GvMULTI_on(PL_replgv);
3523 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
3524 #ifdef PERL_DONT_CREATE_GVSV
3527 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3529 PL_curstash = PL_defstash;
3530 CopSTASH_set(&PL_compiling, PL_defstash);
3531 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3532 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3534 /* We must init $/ before switches are processed. */
3535 sv_setpvs(get_sv("/", GV_ADD), "\n");
3539 S_open_script(pTHX_ const char *scriptname, bool dosearch,
3540 bool *suidscript, PerlIO **rsfpp)
3545 PERL_ARGS_ASSERT_OPEN_SCRIPT;
3548 PL_origfilename = savepvs("-e");
3551 /* if find_script() returns, it returns a malloc()-ed value */
3552 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3554 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3555 const char *s = scriptname + 8;
3561 * Tell apart "normal" usage of fdscript, e.g.
3562 * with bash on FreeBSD:
3563 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3564 * from usage in suidperl.
3565 * Does any "normal" usage leave garbage after the number???
3566 * Is it a mistake to use a similar /dev/fd/ construct for
3571 * Be supersafe and do some sanity-checks.
3572 * Still, can we be sure we got the right thing?
3575 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3578 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3580 scriptname = savepv(s + 1);
3581 Safefree(PL_origfilename);
3582 PL_origfilename = (char *)scriptname;
3587 CopFILE_free(PL_curcop);
3588 CopFILE_set(PL_curcop, PL_origfilename);
3589 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3590 scriptname = (char *)"";
3591 if (fdscript >= 0) {
3592 *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3593 # if defined(HAS_FCNTL) && defined(F_SETFD)
3595 /* ensure close-on-exec */
3596 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3599 else if (!*scriptname) {
3600 forbid_setid(0, *suidscript);
3601 *rsfpp = PerlIO_stdin();
3604 #ifdef FAKE_BIT_BUCKET
3605 /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3606 * is called) and still have the "-e" work. (Believe it or not,
3607 * a /dev/null is required for the "-e" to work because source
3608 * filter magic is used to implement it. ) This is *not* a general
3609 * replacement for a /dev/null. What we do here is create a temp
3610 * file (an empty file), open up that as the script, and then
3611 * immediately close and unlink it. Close enough for jazz. */
3612 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3613 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3614 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3615 char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3616 FAKE_BIT_BUCKET_TEMPLATE
3618 const char * const err = "Failed to create a fake bit bucket";
3619 if (strEQ(scriptname, BIT_BUCKET)) {
3620 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3621 int tmpfd = mkstemp(tmpname);
3623 scriptname = tmpname;
3626 Perl_croak(aTHX_ err);
3629 scriptname = mktemp(tmpname);
3631 Perl_croak(aTHX_ err);
3636 *rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3637 #ifdef FAKE_BIT_BUCKET
3638 if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3639 sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3640 && strlen(scriptname) == sizeof(tmpname) - 1) {
3643 scriptname = BIT_BUCKET;
3645 # if defined(HAS_FCNTL) && defined(F_SETFD)
3647 /* ensure close-on-exec */
3648 fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
3652 /* PSz 16 Sep 03 Keep neat error message */
3654 Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3656 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3657 CopFILE(PL_curcop), Strerror(errno));
3663 * I_SYSSTATVFS HAS_FSTATVFS
3665 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3666 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3667 * here so that metaconfig picks them up. */
3670 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3671 /* Don't even need this function. */
3674 S_validate_suid(pTHX_ PerlIO *rsfp)
3676 PERL_ARGS_ASSERT_VALIDATE_SUID;
3678 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3681 PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3682 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3684 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3687 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3688 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3689 /* not set-id, must be wrapped */
3692 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3695 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3699 register const char *s2;
3701 PERL_ARGS_ASSERT_FIND_BEGINNING;
3703 /* skip forward in input to the real script? */
3706 if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3707 Perl_croak(aTHX_ "No Perl script found in input\n");
3709 } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3710 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
3711 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3713 while (*s == ' ' || *s == '\t') s++;
3715 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3716 || s2[-1] == '_') s2--;
3717 if (strnEQ(s2-4,"perl",4))
3718 while ((s = moreswitches(s)))
3728 PL_uid = PerlProc_getuid();
3729 PL_euid = PerlProc_geteuid();
3730 PL_gid = PerlProc_getgid();
3731 PL_egid = PerlProc_getegid();
3733 PL_uid |= PL_gid << 16;
3734 PL_euid |= PL_egid << 16;
3736 /* Should not happen: */
3737 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3738 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3741 * Should go by suidscript, not uid!=euid: why disallow
3742 * system("ls") in scripts run from setuid things?
3743 * Or, is this run before we check arguments and set suidscript?
3744 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3745 * (We never have suidscript, can we be sure to have fdscript?)
3746 * Or must then go by UID checks? See comments in forbid_setid also.
3750 /* This is used very early in the lifetime of the program,
3751 * before even the options are parsed, so PL_tainting has
3752 * not been initialized properly. */
3754 Perl_doing_taint(int argc, char *argv[], char *envp[])
3756 #ifndef PERL_IMPLICIT_SYS
3757 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3758 * before we have an interpreter-- and the whole point of this
3759 * function is to be called at such an early stage. If you are on
3760 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3761 * "tainted because running with altered effective ids', you'll
3762 * have to add your own checks somewhere in here. The two most
3763 * known samples of 'implicitness' are Win32 and NetWare, neither
3764 * of which has much of concept of 'uids'. */
3765 int uid = PerlProc_getuid();
3766 int euid = PerlProc_geteuid();
3767 int gid = PerlProc_getgid();
3768 int egid = PerlProc_getegid();
3775 if (uid && (euid != uid || egid != gid))
3777 #endif /* !PERL_IMPLICIT_SYS */
3778 /* This is a really primitive check; environment gets ignored only
3779 * if -T are the first chars together; otherwise one gets
3780 * "Too late" message. */
3781 if ( argc > 1 && argv[1][0] == '-'
3782 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3787 /* Passing the flag as a single char rather than a string is a slight space
3788 optimisation. The only message that isn't /^-.$/ is
3789 "program input from stdin", which is substituted in place of '\0', which
3790 could never be a command line flag. */
3792 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
3795 char string[3] = "-x";
3796 const char *message = "program input from stdin";
3803 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3804 if (PL_euid != PL_uid)
3805 Perl_croak(aTHX_ "No %s allowed while running setuid", message);
3806 if (PL_egid != PL_gid)
3807 Perl_croak(aTHX_ "No %s allowed while running setgid", message);
3808 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3810 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
3814 Perl_init_dbargs(pTHX)
3816 AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
3821 /* Someone has already created it.
3822 It might have entries, and if we just turn off AvREAL(), they will
3823 "leak" until global destruction. */
3826 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
3830 Perl_init_debugger(pTHX)
3833 HV * const ostash = PL_curstash;
3835 PL_curstash = PL_debstash;
3837 Perl_init_dbargs(aTHX);
3838 PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
3839 PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3840 PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
3841 PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
3842 if (!SvIOK(PL_DBsingle))
3843 sv_setiv(PL_DBsingle, 0);
3844 PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
3845 if (!SvIOK(PL_DBtrace))
3846 sv_setiv(PL_DBtrace, 0);
3847 PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
3848 if (!SvIOK(PL_DBsignal))
3849 sv_setiv(PL_DBsignal, 0);
3850 PL_curstash = ostash;
3853 #ifndef STRESS_REALLOC
3854 #define REASONABLE(size) (size)
3856 #define REASONABLE(size) (1) /* unreasonable */
3860 Perl_init_stacks(pTHX)
3863 /* start with 128-item stack and 8K cxstack */
3864 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3865 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3866 PL_curstackinfo->si_type = PERLSI_MAIN;
3867 PL_curstack = PL_curstackinfo->si_stack;
3868 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3870 PL_stack_base = AvARRAY(PL_curstack);
3871 PL_stack_sp = PL_stack_base;
3872 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3874 Newx(PL_tmps_stack,REASONABLE(128),SV*);
3877 PL_tmps_max = REASONABLE(128);
3879 Newx(PL_markstack,REASONABLE(32),I32);
3880 PL_markstack_ptr = PL_markstack;
3881 PL_markstack_max = PL_markstack + REASONABLE(32);
3885 Newx(PL_scopestack,REASONABLE(32),I32);
3887 Newx(PL_scopestack_name,REASONABLE(32),const char*);
3889 PL_scopestack_ix = 0;
3890 PL_scopestack_max = REASONABLE(32);
3892 Newx(PL_savestack,REASONABLE(128),ANY);
3893 PL_savestack_ix = 0;
3894 PL_savestack_max = REASONABLE(128);
3903 while (PL_curstackinfo->si_next)
3904 PL_curstackinfo = PL_curstackinfo->si_next;
3905 while (PL_curstackinfo) {
3906 PERL_SI *p = PL_curstackinfo->si_prev;
3907 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3908 Safefree(PL_curstackinfo->si_cxstack);
3909 Safefree(PL_curstackinfo);
3910 PL_curstackinfo = p;
3912 Safefree(PL_tmps_stack);
3913 Safefree(PL_markstack);
3914 Safefree(PL_scopestack);
3916 Safefree(PL_scopestack_name);
3918 Safefree(PL_savestack);
3922 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
3924 GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
3925 AV *const isa = GvAVn(gv);
3928 PERL_ARGS_ASSERT_POPULATE_ISA;
3930 if(AvFILLp(isa) != -1)
3933 /* NOTE: No support for tied ISA */
3935 va_start(args, len);
3937 const char *const parent = va_arg(args, const char*);
3942 parent_len = va_arg(args, size_t);
3944 /* Arguments are supplied with a trailing :: */
3945 assert(parent_len > 2);
3946 assert(parent[parent_len - 1] == ':');
3947 assert(parent[parent_len - 2] == ':');
3948 av_push(isa, newSVpvn(parent, parent_len - 2));
3949 (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
3956 S_init_predump_symbols(pTHX)
3962 sv_setpvs(get_sv("\"", GV_ADD), " ");
3963 PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
3966 /* Historically, PVIOs were blessed into IO::Handle, unless
3967 FileHandle was loaded, in which case they were blessed into
3968 that. Action at a distance.
3969 However, if we simply bless into IO::Handle, we break code
3970 that assumes that PVIOs will have (among others) a seek
3971 method. IO::File inherits from IO::Handle and IO::Seekable,
3972 and provides the needed methods. But if we simply bless into
3973 it, then we break code that assumed that by loading
3974 IO::Handle, *it* would work.
3975 So a compromise is to set up the correct @IO::File::ISA,
3976 so that code that does C<use IO::Handle>; will still work.
3979 Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
3980 STR_WITH_LEN("IO::Handle::"),
3981 STR_WITH_LEN("IO::Seekable::"),
3982 STR_WITH_LEN("Exporter::"),
3985 PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3986 GvMULTI_on(PL_stdingv);
3987 io = GvIOp(PL_stdingv);
3988 IoTYPE(io) = IoTYPE_RDONLY;
3989 IoIFP(io) = PerlIO_stdin();
3990 tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
3992 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
3994 tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
3997 IoTYPE(io) = IoTYPE_WRONLY;
3998 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4000 tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4002 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4004 PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4005 GvMULTI_on(PL_stderrgv);
4006 io = GvIOp(PL_stderrgv);
4007 IoTYPE(io) = IoTYPE_WRONLY;
4008 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4009 tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4011 GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4013 PL_statname = newSV(0); /* last filename we did stat on */
4017 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4021 PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4023 argc--,argv++; /* skip name of script */
4024 if (PL_doswitches) {
4025 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4029 if (argv[0][1] == '-' && !argv[0][2]) {
4033 if ((s = strchr(argv[0], '='))) {
4034 const char *const start_name = argv[0] + 1;
4035 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4036 TRUE, SVt_PV)), s + 1);
4039 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4042 if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4043 GvMULTI_on(PL_argvgv);
4044 (void)gv_AVadd(PL_argvgv);
4045 av_clear(GvAVn(PL_argvgv));
4046 for (; argc > 0; argc--,argv++) {
4047 SV * const sv = newSVpv(argv[0],0);
4048 av_push(GvAVn(PL_argvgv),sv);
4049 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4050 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4053 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4054 (void)sv_utf8_decode(sv);
4060 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4065 PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4067 PL_toptarget = newSV_type(SVt_PVFM);
4068 sv_setpvs(PL_toptarget, "");
4069 PL_bodytarget = newSV_type(SVt_PVFM);
4070 sv_setpvs(PL_bodytarget, "");
4071 PL_formtarget = PL_bodytarget;
4075 init_argv_symbols(argc,argv);
4077 if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4078 sv_setpv(GvSV(tmpgv),PL_origfilename);
4080 if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4082 bool env_is_not_environ;
4083 GvMULTI_on(PL_envgv);
4084 hv = GvHVn(PL_envgv);
4085 hv_magic(hv, NULL, PERL_MAGIC_env);
4087 #ifdef USE_ENVIRON_ARRAY
4088 /* Note that if the supplied env parameter is actually a copy
4089 of the global environ then it may now point to free'd memory
4090 if the environment has been modified since. To avoid this
4091 problem we treat env==NULL as meaning 'use the default'
4095 env_is_not_environ = env != environ;
4096 if (env_is_not_environ
4097 # ifdef USE_ITHREADS
4098 && PL_curinterp == aTHX
4107 for (; *env; env++) {
4110 if (!(s = strchr(old_var,'=')) || s == old_var)
4113 #if defined(MSDOS) && !defined(DJGPP)
4115 (void)strupr(old_var);
4118 sv = newSVpv(s+1, 0);
4119 (void)hv_store(hv, old_var, s - old_var, sv, 0);
4120 if (env_is_not_environ)
4124 #endif /* USE_ENVIRON_ARRAY */
4125 #endif /* !PERL_MICRO */
4128 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4129 SvREADONLY_off(GvSV(tmpgv));
4130 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4131 SvREADONLY_on(GvSV(tmpgv));
4133 #ifdef THREADS_HAVE_PIDS
4134 PL_ppid = (IV)getppid();
4137 /* touch @F array to prevent spurious warnings 20020415 MJD */
4139 (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4144 S_init_perllib(pTHX)
4148 const char *perl5lib = NULL;
4151 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4157 perl5lib = PerlEnv_getenv("PERL5LIB");
4159 * It isn't possible to delete an environment variable with
4160 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4161 * case we treat PERL5LIB as undefined if it has a zero-length value.
4163 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4164 if (perl5lib && *perl5lib != '\0')
4168 incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4170 s = PerlEnv_getenv("PERLLIB");
4172 incpush_use_sep(s, 0, 0);
4175 /* Treat PERL5?LIB as a possible search list logical name -- the
4176 * "natural" VMS idiom for a Unix path string. We allow each
4177 * element to be a set of |-separated directories for compatibility.
4181 if (my_trnlnm("PERL5LIB",buf,0))
4183 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4184 } while (my_trnlnm("PERL5LIB",buf,++idx));
4186 while (my_trnlnm("PERLLIB",buf,idx++))
4187 incpush_use_sep(buf, 0, 0);
4192 #ifndef PERL_IS_MINIPERL
4193 /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4194 (and not the architecture specific directories from $ENV{PERL5LIB}) */
4196 /* Use the ~-expanded versions of APPLLIB (undocumented),
4197 SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4200 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4201 INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4205 /* sitearch is always relative to sitelib on Windows for
4206 * DLL-based path intuition to work correctly */
4207 # if !defined(WIN32)
4208 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4209 INCPUSH_CAN_RELOCATE);
4215 /* this picks up sitearch as well */
4216 s = win32_get_sitelib(PERL_FS_VERSION, &len);
4218 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4220 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4224 #ifdef PERL_VENDORARCH_EXP
4225 /* vendorarch is always relative to vendorlib on Windows for
4226 * DLL-based path intuition to work correctly */
4227 # if !defined(WIN32)
4228 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4229 INCPUSH_CAN_RELOCATE);
4233 #ifdef PERL_VENDORLIB_EXP
4235 /* this picks up vendorarch as well */
4236 s = win32_get_vendorlib(PERL_FS_VERSION, &len);
4238 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4240 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4241 INCPUSH_CAN_RELOCATE);
4246 S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4250 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4254 s = win32_get_privlib(PERL_FS_VERSION, &len);
4256 incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4259 S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4261 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4265 #ifdef PERL_OTHERLIBDIRS
4266 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4267 INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4268 |INCPUSH_CAN_RELOCATE);
4274 * It isn't possible to delete an environment variable with
4275 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4276 * case we treat PERL5LIB as undefined if it has a zero-length value.
4278 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4279 if (perl5lib && *perl5lib != '\0')
4283 incpush_use_sep(perl5lib, 0,
4284 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4286 /* Treat PERL5?LIB as a possible search list logical name -- the
4287 * "natural" VMS idiom for a Unix path string. We allow each
4288 * element to be a set of |-separated directories for compatibility.
4292 if (my_trnlnm("PERL5LIB",buf,0))
4294 incpush_use_sep(buf, 0,
4295 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4296 } while (my_trnlnm("PERL5LIB",buf,++idx));
4300 /* Use the ~-expanded versions of APPLLIB (undocumented),
4301 SITELIB and VENDORLIB for older versions
4304 S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4305 |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4308 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4309 /* Search for version-specific dirs below here */
4310 S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4311 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4315 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4316 /* Search for version-specific dirs below here */
4317 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4318 INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4321 #ifdef PERL_OTHERLIBDIRS
4322 S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4323 INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4324 |INCPUSH_CAN_RELOCATE);
4326 #endif /* !PERL_IS_MINIPERL */
4329 S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4332 #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
4333 # define PERLLIB_SEP ';'
4336 # define PERLLIB_SEP '|'
4338 # define PERLLIB_SEP ':'
4341 #ifndef PERLLIB_MANGLE
4342 # define PERLLIB_MANGLE(s,n) (s)
4345 /* Push a directory onto @INC if it exists.
4346 Generate a new SV if we do this, to save needing to copy the SV we push
4349 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4354 PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4356 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4357 S_ISDIR(tmpstatbuf.st_mode)) {
4359 dir = newSVsv(stem);
4361 /* Truncate dir back to stem. */
4362 SvCUR_set(dir, SvCUR(stem));
4368 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4371 const U8 using_sub_dirs
4372 = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4373 |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4374 const U8 add_versioned_sub_dirs
4375 = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4376 const U8 add_archonly_sub_dirs
4377 = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4378 #ifdef PERL_INC_VERSION_LIST
4379 const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS;
4381 const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4382 const U8 unshift = (U8)flags & INCPUSH_UNSHIFT;
4383 const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4384 AV *const inc = GvAVn(PL_incgv);
4386 PERL_ARGS_ASSERT_INCPUSH;
4389 /* Could remove this vestigial extra block, if we don't mind a lot of
4390 re-indenting diff noise. */
4393 /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4394 arranged to unshift #! line -I onto the front of @INC. However,
4395 -I can add version and architecture specific libraries, and they
4396 need to go first. The old code assumed that it was always
4397 pushing. Hence to make it work, need to push the architecture
4398 (etc) libraries onto a temporary array, then "unshift" that onto
4399 the front of @INC. */
4400 AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4403 /* I am not convinced that this is valid when PERLLIB_MANGLE is
4404 defined to so something (in os2/os2.c), but the code has been
4405 this way, ignoring any possible changed of length, since
4406 760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4408 libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4410 libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0);
4413 /* Do the if() outside the #ifdef to avoid warnings about an unused
4416 #ifdef PERL_RELOCATABLE_INC
4418 * Relocatable include entries are marked with a leading .../
4421 * 0: Remove that leading ".../"
4422 * 1: Remove trailing executable name (anything after the last '/')
4423 * from the perl path to give a perl prefix
4425 * While the @INC element starts "../" and the prefix ends with a real
4426 * directory (ie not . or ..) chop that real directory off the prefix
4427 * and the leading "../" from the @INC element. ie a logical "../"
4429 * Finally concatenate the prefix and the remainder of the @INC element
4430 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4431 * generates /usr/local/lib/perl5
4433 const char *libpath = SvPVX(libdir);
4434 STRLEN libpath_len = SvCUR(libdir);
4435 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4437 SV * const caret_X = get_sv("\030", 0);
4438 /* Going to use the SV just as a scratch buffer holding a C
4444 /* $^X is *the* source of taint if tainting is on, hence
4445 SvPOK() won't be true. */
4447 assert(SvPOKp(caret_X));
4448 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4450 /* Firstly take off the leading .../
4451 If all else fail we'll do the paths relative to the current
4453 sv_chop(libdir, libpath + 4);
4454 /* Don't use SvPV as we're intentionally bypassing taining,
4455 mortal copies that the mg_get of tainting creates, and
4456 corruption that seems to come via the save stack.
4457 I guess that the save stack isn't correctly set up yet. */
4458 libpath = SvPVX(libdir);
4459 libpath_len = SvCUR(libdir);
4461 /* This would work more efficiently with memrchr, but as it's
4462 only a GNU extension we'd need to probe for it and
4463 implement our own. Not hard, but maybe not worth it? */
4465 prefix = SvPVX(prefix_sv);
4466 lastslash = strrchr(prefix, '/');
4468 /* First time in with the *lastslash = '\0' we just wipe off
4469 the trailing /perl from (say) /usr/foo/bin/perl
4473 while ((*lastslash = '\0'), /* Do that, come what may. */
4474 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4475 && (lastslash = strrchr(prefix, '/')))) {
4476 if (lastslash[1] == '\0'
4477 || (lastslash[1] == '.'
4478 && (lastslash[2] == '/' /* ends "/." */
4479 || (lastslash[2] == '/'
4480 && lastslash[3] == '/' /* or "/.." */
4482 /* Prefix ends "/" or "/." or "/..", any of which
4483 are fishy, so don't do any more logical cleanup.
4487 /* Remove leading "../" from path */
4490 /* Next iteration round the loop removes the last
4491 directory name from prefix by writing a '\0' in
4492 the while clause. */
4494 /* prefix has been terminated with a '\0' to the correct
4495 length. libpath points somewhere into the libdir SV.
4496 We need to join the 2 with '/' and drop the result into
4498 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4499 SvREFCNT_dec(libdir);
4500 /* And this is the new libdir. */
4503 (PL_uid != PL_euid || PL_gid != PL_egid)) {
4504 /* Need to taint relocated paths if running set ID */
4505 SvTAINTED_on(libdir);
4508 SvREFCNT_dec(prefix_sv);
4513 * BEFORE pushing libdir onto @INC we may first push version- and
4514 * archname-specific sub-directories.
4516 if (using_sub_dirs) {
4518 #ifdef PERL_INC_VERSION_LIST
4519 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4520 const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4521 const char * const *incver;
4528 if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4530 while (unix[len-1] == '/') len--; /* Cosmetic */
4531 sv_usepvn(libdir,unix,len);
4534 PerlIO_printf(Perl_error_log,
4535 "Failed to unixify @INC element \"%s\"\n",
4539 subdir = newSVsv(libdir);
4541 if (add_versioned_sub_dirs) {
4542 /* .../version/archname if -d .../version/archname */
4543 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4544 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4546 /* .../version if -d .../version */
4547 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4548 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4551 #ifdef PERL_INC_VERSION_LIST
4553 for (incver = incverlist; *incver; incver++) {
4554 /* .../xxx if -d .../xxx */
4555 Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4556 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4561 if (add_archonly_sub_dirs) {
4562 /* .../archname if -d .../archname */
4563 sv_catpvs(subdir, "/" ARCHNAME);
4564 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4568 assert (SvREFCNT(subdir) == 1);
4569 SvREFCNT_dec(subdir);
4572 /* finally add this lib directory at the end of @INC */
4574 U32 extra = av_len(av) + 1;
4575 av_unshift(inc, extra + push_basedir);
4577 av_store(inc, extra, libdir);
4579 /* av owns a reference, av_store() expects to be donated a
4580 reference, and av expects to be sane when it's cleared.
4581 If I wanted to be naughty and wrong, I could peek inside the
4582 implementation of av_clear(), realise that it uses
4583 SvREFCNT_dec() too, so av's array could be a run of NULLs,
4584 and so directly steal from it (with a memcpy() to inc, and
4585 then memset() to NULL them out. But people copy code from the
4586 core expecting it to be best practise, so let's use the API.
4587 Although studious readers will note that I'm not checking any
4589 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4593 else if (push_basedir) {
4594 av_push(inc, libdir);
4597 if (!push_basedir) {
4598 assert (SvREFCNT(libdir) == 1);
4599 SvREFCNT_dec(libdir);
4605 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
4609 /* This logic has been broken out from S_incpush(). It may be possible to
4612 PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4619 /* Break at all separators */
4620 while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
4622 /* skip any consecutive separators */
4624 /* Uncomment the next line for PATH semantics */
4625 /* But you'll need to write tests */
4626 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4628 incpush(p, (STRLEN)(s - p), flags);
4633 incpush(p, (STRLEN)(end - p), flags);
4638 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4642 volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
4648 PERL_ARGS_ASSERT_CALL_LIST;
4650 while (av_len(paramList) >= 0) {
4651 cv = MUTABLE_CV(av_shift(paramList));
4653 if (paramList == PL_beginav) {
4654 /* save PL_beginav for compiler */
4655 Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
4657 else if (paramList == PL_checkav) {
4658 /* save PL_checkav for compiler */
4659 Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
4661 else if (paramList == PL_unitcheckav) {
4662 /* save PL_unitcheckav for compiler */
4663 Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
4674 PL_madskills |= 16384;
4679 PL_madskills &= ~16384;
4682 (void)SvPV_const(atsv, len);
4684 PL_curcop = &PL_compiling;
4685 CopLINE_set(PL_curcop, oldline);
4686 if (paramList == PL_beginav)
4687 sv_catpvs(atsv, "BEGIN failed--compilation aborted");
4689 Perl_sv_catpvf(aTHX_ atsv,
4690 "%s failed--call queue aborted",
4691 paramList == PL_checkav ? "CHECK"
4692 : paramList == PL_initav ? "INIT"
4693 : paramList == PL_unitcheckav ? "UNITCHECK"
4695 while (PL_scopestack_ix > oldscope)
4698 Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv));
4705 /* my_exit() was called */
4706 while (PL_scopestack_ix > oldscope)
4709 PL_curstash = PL_defstash;
4710 PL_curcop = &PL_compiling;
4711 CopLINE_set(PL_curcop, oldline);
4717 PL_curcop = &PL_compiling;
4718 CopLINE_set(PL_curcop, oldline);
4721 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4730 Perl_my_exit(pTHX_ U32 status)
4741 STATUS_EXIT_SET(status);
4748 Perl_my_failure_exit(pTHX)
4752 /* We have been called to fall on our sword. The desired exit code
4753 * should be already set in STATUS_UNIX, but could be shifted over
4754 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
4757 * If an error code has not been set, then force the issue.
4759 if (MY_POSIX_EXIT) {
4761 /* According to the die_exit.t tests, if errno is non-zero */
4762 /* It should be used for the error status. */
4764 if (errno == EVMSERR) {
4765 STATUS_NATIVE = vaxc$errno;
4768 /* According to die_exit.t tests, if the child_exit code is */
4769 /* also zero, then we need to exit with a code of 255 */
4770 if ((errno != 0) && (errno < 256))
4771 STATUS_UNIX_EXIT_SET(errno);
4772 else if (STATUS_UNIX < 255) {
4773 STATUS_UNIX_EXIT_SET(255);
4778 /* The exit code could have been set by $? or vmsish which
4779 * means that it may not have fatal set. So convert
4780 * success/warning codes to fatal with out changing
4781 * the POSIX status code. The severity makes VMS native
4782 * status handling work, while UNIX mode programs use the
4783 * the POSIX exit codes.
4785 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
4786 STATUS_NATIVE &= STS$M_COND_ID;
4787 STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
4791 /* Traditionally Perl on VMS always expects a Fatal Error. */
4792 if (vaxc$errno & 1) {
4794 /* So force success status to failure */
4795 if (STATUS_NATIVE & 1)
4800 STATUS_UNIX = EINTR; /* In case something cares */
4805 STATUS_NATIVE = vaxc$errno; /* Should already be this */
4807 /* Encode the severity code */
4808 severity = STATUS_NATIVE & STS$M_SEVERITY;
4809 STATUS_UNIX = (severity ? severity : 1) << 8;
4811 /* Perl expects this to be a fatal error */
4812 if (severity != STS$K_SEVERE)
4821 STATUS_UNIX_SET(errno);
4823 exitstatus = STATUS_UNIX >> 8;
4824 if (exitstatus & 255)
4825 STATUS_UNIX_SET(exitstatus);
4827 STATUS_UNIX_SET(255);
4834 S_my_exit_jump(pTHX)
4839 SvREFCNT_dec(PL_e_script);
4843 POPSTACK_TO(PL_mainstack);
4851 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4854 const char * const p = SvPVX_const(PL_e_script);
4855 const char *nl = strchr(p, '\n');
4857 PERL_UNUSED_ARG(idx);
4858 PERL_UNUSED_ARG(maxlen);
4860 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4862 filter_del(read_e_script);
4865 sv_catpvn(buf_sv, p, nl-p);
4866 sv_chop(PL_e_script, nl);
4872 * c-indentation-style: bsd
4874 * indent-tabs-mode: t
4877 * ex: set ts=8 sts=4 sw=4 noet: