3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
15 /* This file contains the top-level functions that are used to create, use
16 * and destroy a perl interpreter, plus the functions used by XS code to
17 * call back into perl. Note that it does not contain the actual main()
18 * function of the interpreter; that can be found in perlmain.c
23 * Be proud that perl(1) may proclaim:
24 * Setuid Perl scripts are safer than C programs ...
25 * Do not abandon (deprecate) suidperl. Do not advocate C wrappers.
27 * The flow was: perl starts, notices script is suid, execs suidperl with same
28 * arguments; suidperl opens script, checks many things, sets itself with
29 * right UID, execs perl with similar arguments but with script pre-opened on
30 * /dev/fd/xxx; perl checks script is as should be and does work. This was
31 * insecure: see perlsec(1) for many problems with this approach.
33 * The "correct" flow should be: perl starts, opens script and notices it is
34 * suid, checks many things, execs suidperl with similar arguments but with
35 * script on /dev/fd/xxx; suidperl checks script and /dev/fd/xxx object are
36 * same, checks arguments match #! line, sets itself with right UID, execs
37 * perl with same arguments; perl checks many things and does work.
39 * (Opening the script in perl instead of suidperl, we "lose" scripts that
40 * are readable to the target UID but not to the invoker. Where did
41 * unreadable scripts work anyway?)
43 * For now, suidperl and perl are pretty much the same large and cumbersome
44 * program, so suidperl can check its argument list (see comments elsewhere).
47 * Original bug report:
48 * http://bugs.perl.org/index.html?req=bug_id&bug_id=20010322.218
49 * http://rt.perl.org/rt2/Ticket/Display.html?id=6511
50 * Comments and discussion with Debian:
51 * http://bugs.debian.org/203426
52 * http://bugs.debian.org/220486
53 * Debian Security Advisory DSA 431-1 (does not fully fix problem):
54 * http://www.debian.org/security/2004/dsa-431
56 * http://cve.mitre.org/cgi-bin/cvename.cgi?name=CAN-2003-0618
57 * Previous versions of this patch sent to perl5-porters:
58 * http://www.mail-archive.com/perl5-porters@perl.org/msg71953.html
59 * http://www.mail-archive.com/perl5-porters@perl.org/msg75245.html
60 * http://www.mail-archive.com/perl5-porters@perl.org/msg75563.html
61 * http://www.mail-archive.com/perl5-porters@perl.org/msg75635.html
63 Paul Szabo - psz@maths.usyd.edu.au http://www.maths.usyd.edu.au:8000/u/psz/
64 School of Mathematics and Statistics University of Sydney 2006 Australia
68 * Use truthful, neat, specific error messages.
69 * Cannot always hide the truth; security must not depend on doing so.
73 * Use global(?), thread-local fdscript for easier checks.
74 * (I do not understand how we could possibly get a thread race:
75 * do not all threads go through the same initialization? Or in
76 * fact, are not threads started only after we get the script and
77 * so know what to do? Oh well, make things super-safe...)
81 #define PERL_IN_PERL_C
83 #include "patchlevel.h" /* for local_patches */
87 char *nw_get_sitelib(const char *pl);
90 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
95 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
97 # include <sys/wait.h>
100 # include <sys/uio.h>
105 char control[CMSG_SPACE(sizeof(int))];
122 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
123 char *getenv (char *); /* Usually in <stdlib.h> */
126 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
134 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
141 S_init_tls_and_interp(PerlInterpreter *my_perl)
145 PERL_SET_INTERP(my_perl);
146 #if defined(USE_ITHREADS)
149 PERL_SET_THX(my_perl);
152 MUTEX_INIT(&PL_dollarzero_mutex);
154 #ifdef PERL_IMPLICIT_CONTEXT
155 MUTEX_INIT(&PL_my_ctx_mutex);
159 PERL_SET_THX(my_perl);
163 #ifdef PERL_IMPLICIT_SYS
165 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
166 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
167 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
168 struct IPerlDir* ipD, struct IPerlSock* ipS,
169 struct IPerlProc* ipP)
171 PerlInterpreter *my_perl;
172 /* Newx() needs interpreter, so call malloc() instead */
173 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
174 S_init_tls_and_interp(my_perl);
175 Zero(my_perl, 1, PerlInterpreter);
185 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
192 =head1 Embedding Functions
194 =for apidoc perl_alloc
196 Allocates a new Perl interpreter. See L<perlembed>.
204 PerlInterpreter *my_perl;
206 /* Newx() needs interpreter, so call malloc() instead */
207 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
209 S_init_tls_and_interp(my_perl);
210 #ifndef PERL_TRACK_MEMPOOL
211 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
213 Zero(my_perl, 1, PerlInterpreter);
214 INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
218 #endif /* PERL_IMPLICIT_SYS */
221 =for apidoc perl_construct
223 Initializes a new Perl interpreter. See L<perlembed>.
229 perl_construct(pTHXx)
235 PL_perl_destruct_level = 1;
237 if (PL_perl_destruct_level > 0)
240 /* Init the real globals (and main thread)? */
242 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
244 PL_linestr = newSV(79);
245 sv_upgrade(PL_linestr,SVt_PVIV);
247 if (!SvREADONLY(&PL_sv_undef)) {
248 /* set read-only and try to insure than we wont see REFCNT==0
251 SvREADONLY_on(&PL_sv_undef);
252 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
254 sv_setpv(&PL_sv_no,PL_No);
255 /* value lookup in void context - happens to have the side effect
256 of caching the numeric forms. */
259 SvREADONLY_on(&PL_sv_no);
260 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
262 sv_setpv(&PL_sv_yes,PL_Yes);
265 SvREADONLY_on(&PL_sv_yes);
266 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
268 SvREADONLY_on(&PL_sv_placeholder);
269 SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
272 PL_sighandlerp = (Sighandler_t) Perl_sighandler;
273 #ifdef PERL_USES_PL_PIDSTATUS
274 PL_pidstatus = newHV();
278 PL_rs = newSVpvs("\n");
283 PL_lex_state = LEX_NOTPARSING;
289 SET_NUMERIC_STANDARD();
291 #if defined(LOCAL_PATCH_COUNT)
292 PL_localpatches = local_patches; /* For possible -v */
295 #ifdef HAVE_INTERP_INTERN
299 PerlIO_init(aTHX); /* Hook to IO system */
301 PL_fdpid = newAV(); /* for remembering popen pids by fd */
302 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
303 PL_errors = newSVpvs("");
304 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
305 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
306 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
308 PL_regex_padav = newAV();
309 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
310 PL_regex_pad = AvARRAY(PL_regex_padav);
312 #ifdef USE_REENTRANT_API
313 Perl_reentrant_init(aTHX);
316 /* Note that strtab is a rather special HV. Assumptions are made
317 about not iterating on it, and not adding tie magic to it.
318 It is properly deallocated in perl_destruct() */
321 HvSHAREKEYS_off(PL_strtab); /* mandatory */
322 hv_ksplit(PL_strtab, 512);
324 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
325 _dyld_lookup_and_bind
326 ("__environ", (unsigned long *) &environ_pointer, NULL);
330 # ifdef USE_ENVIRON_ARRAY
331 PL_origenviron = environ;
335 /* Use sysconf(_SC_CLK_TCK) if available, if not
336 * available or if the sysconf() fails, use the HZ.
337 * BeOS has those, but returns the wrong value.
338 * The HZ if not originally defined has been by now
339 * been defined as CLK_TCK, if available. */
340 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
341 PL_clocktick = sysconf(_SC_CLK_TCK);
342 if (PL_clocktick <= 0)
346 PL_stashcache = newHV();
348 PL_patchlevel = Perl_newSVpvf(aTHX_ "%d.%d.%d", (int)PERL_REVISION,
349 (int)PERL_VERSION, (int)PERL_SUBVERSION);
352 if (!PL_mmap_page_size) {
353 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
355 SETERRNO(0, SS_NORMAL);
357 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
359 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
361 if ((long) PL_mmap_page_size < 0) {
363 SV * const error = ERRSV;
364 SvUPGRADE(error, SVt_PV);
365 Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
368 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
372 # ifdef HAS_GETPAGESIZE
373 PL_mmap_page_size = getpagesize();
375 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
376 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
380 if (PL_mmap_page_size <= 0)
381 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
382 (IV) PL_mmap_page_size);
384 #endif /* HAS_MMAP */
386 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
387 PL_timesbase.tms_utime = 0;
388 PL_timesbase.tms_stime = 0;
389 PL_timesbase.tms_cutime = 0;
390 PL_timesbase.tms_cstime = 0;
401 =for apidoc nothreadhook
403 Stub that provides thread hook for perl_destruct when there are
410 Perl_nothreadhook(pTHX)
416 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
418 Perl_dump_sv_child(pTHX_ SV *sv)
421 const int sock = PL_dumper_fd;
422 const int debug_fd = PerlIO_fileno(Perl_debug_log);
423 union control_un control;
426 struct cmsghdr *cmptr;
428 unsigned char buffer[256];
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 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
528 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
534 /* wait for all pseudo-forked children to finish */
535 PERL_WAIT_FOR_CHILDREN;
537 destruct_level = PL_perl_destruct_level;
540 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
542 const int i = atoi(s);
543 if (destruct_level < i)
549 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
555 if (PL_endav && !PL_minus_c)
556 call_list(PL_scopestack_ix, PL_endav);
562 /* Need to flush since END blocks can produce output */
565 if (CALL_FPTR(PL_threadhook)(aTHX)) {
566 /* Threads hook has vetoed further cleanup */
570 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
571 if (destruct_level != 0) {
572 /* Fork here to create a child. Our child's job is to preserve the
573 state of scalars prior to destruction, so that we can instruct it
574 to dump any scalars that we later find have leaked.
575 There's no subtlety in this code - it assumes POSIX, and it doesn't
579 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
580 perror("Debug leaking scalars socketpair failed");
586 perror("Debug leaking scalars fork failed");
590 /* We are the child */
591 const int sock = fd[1];
592 const int debug_fd = PerlIO_fileno(Perl_debug_log);
595 /* Our success message is an integer 0, and a char 0 */
596 static const char success[sizeof(int) + 1];
600 /* We need to close all other file descriptors otherwise we end up
601 with interesting hangs, where the parent closes its end of a
602 pipe, and sits waiting for (another) child to terminate. Only
603 that child never terminates, because it never gets EOF, because
604 we also have the far end of the pipe open. We even need to
605 close the debugging fd, because sometimes it happens to be one
606 end of a pipe, and a process is waiting on the other end for
607 EOF. Normally it would be closed at some point earlier in
608 destruction, but if we happen to cause the pipe to remain open,
609 EOF never occurs, and we get an infinite hang. Hence all the
610 games to pass in a file descriptor if it's actually needed. */
612 f = sysconf(_SC_OPEN_MAX);
614 where = "sysconf failed";
625 union control_un control;
628 struct cmsghdr *cmptr;
632 msg.msg_control = control.control;
633 msg.msg_controllen = sizeof(control.control);
634 /* We're a connected socket so we don't need a source */
638 msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
640 vec[0].iov_base = (void*)⌖
641 vec[0].iov_len = sizeof(target);
643 got = recvmsg(sock, &msg, 0);
648 where = "recv failed";
651 if(got < sizeof(target)) {
652 where = "short recv";
656 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
660 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
661 where = "wrong cmsg_len";
664 if(cmptr->cmsg_level != SOL_SOCKET) {
665 where = "wrong cmsg_level";
668 if(cmptr->cmsg_type != SCM_RIGHTS) {
669 where = "wrong cmsg_type";
673 got_fd = *(int*)CMSG_DATA(cmptr);
674 /* For our last little bit of trickery, put the file descriptor
675 back into Perl_debug_log, as if we never actually closed it
677 if(got_fd != debug_fd) {
678 if (dup2(got_fd, debug_fd) == -1) {
685 PerlIO_flush(Perl_debug_log);
687 got = write(sock, &success, sizeof(success));
690 where = "write failed";
693 if(got < sizeof(success)) {
694 where = "short write";
701 int send_errno = errno;
702 unsigned char length = (unsigned char) strlen(where);
703 struct iovec failure[3] = {
704 {(void*)&send_errno, sizeof(send_errno)},
706 {(void*)where, length}
708 int got = writev(sock, failure, 3);
709 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
710 in the parent if we try to read from the socketpair after the
711 child has exited, even if there was data to read.
712 So sleep a bit to give the parent a fighting chance of
715 _exit((got == -1) ? errno : 0);
719 PL_dumper_fd = fd[0];
724 /* We must account for everything. */
726 /* Destroy the main CV and syntax tree */
727 /* Do this now, because destroying ops can cause new SVs to be generated
728 in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
729 PL_curcop to point to a valid op from which the filename structure
731 PL_curcop = &PL_compiling;
733 /* ensure comppad/curpad to refer to main's pad */
734 if (CvPADLIST(PL_main_cv)) {
735 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
737 op_free(PL_main_root);
740 PL_main_start = NULL;
741 SvREFCNT_dec(PL_main_cv);
745 /* Tell PerlIO we are about to tear things apart in case
746 we have layers which are using resources that should
750 PerlIO_destruct(aTHX);
752 if (PL_sv_objcount) {
754 * Try to destruct global references. We do this first so that the
755 * destructors and destructees still exist. Some sv's might remain.
756 * Non-referenced objects are on their own.
760 if (PL_defoutgv && !SvREFCNT(PL_defoutgv))
761 PL_defoutgv = NULL; /* may have been freed */
764 /* unhook hooks which will soon be, or use, destroyed data */
765 SvREFCNT_dec(PL_warnhook);
767 SvREFCNT_dec(PL_diehook);
770 /* call exit list functions */
771 while (PL_exitlistlen-- > 0)
772 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
774 Safefree(PL_exitlist);
779 if (destruct_level == 0){
781 DEBUG_P(debprofdump());
783 #if defined(PERLIO_LAYERS)
784 /* No more IO - including error messages ! */
785 PerlIO_cleanup(aTHX);
788 /* The exit() function will do everything that needs doing. */
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 /* reset so print() ends up where we expect */
822 /* the syntax tree is shared between clones
823 * so op_free(PL_main_root) only ReREFCNT_dec's
824 * REGEXPs in the parent interpreter
825 * we need to manually ReREFCNT_dec for the clones
828 I32 i = AvFILLp(PL_regex_padav) + 1;
829 SV * const * const ary = AvARRAY(PL_regex_padav);
832 SV * const resv = ary[--i];
834 if (SvFLAGS(resv) & SVf_BREAK) {
835 /* this is PL_reg_curpm, already freed
836 * flag is set in regexec.c:S_regtry
838 SvFLAGS(resv) &= ~SVf_BREAK;
840 else if(SvREPADTMP(resv)) {
841 SvREPADTMP_off(resv);
843 else if(SvIOKp(resv)) {
844 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
849 SvREFCNT_dec(PL_regex_padav);
850 PL_regex_padav = NULL;
854 SvREFCNT_dec((SV*) PL_stashcache);
855 PL_stashcache = NULL;
857 /* loosen bonds of global variables */
860 (void)PerlIO_close(PL_rsfp);
864 /* Filters for program text */
865 SvREFCNT_dec(PL_rsfp_filters);
866 PL_rsfp_filters = NULL;
869 PL_preprocess = FALSE;
875 PL_doswitches = FALSE;
876 PL_dowarn = G_WARN_OFF;
877 PL_doextract = FALSE;
878 PL_sawampersand = FALSE; /* must save all match strings */
881 Safefree(PL_inplace);
883 SvREFCNT_dec(PL_patchlevel);
886 SvREFCNT_dec(PL_e_script);
892 /* magical thingies */
894 SvREFCNT_dec(PL_ofs_sv); /* $, */
897 SvREFCNT_dec(PL_ors_sv); /* $\ */
900 SvREFCNT_dec(PL_rs); /* $/ */
903 Safefree(PL_osname); /* $^O */
906 SvREFCNT_dec(PL_statname);
910 /* defgv, aka *_ should be taken care of elsewhere */
912 /* clean up after study() */
913 SvREFCNT_dec(PL_lastscream);
914 PL_lastscream = NULL;
915 Safefree(PL_screamfirst);
917 Safefree(PL_screamnext);
921 Safefree(PL_efloatbuf);
925 /* startup and shutdown function lists */
926 SvREFCNT_dec(PL_beginav);
927 SvREFCNT_dec(PL_beginav_save);
928 SvREFCNT_dec(PL_endav);
929 SvREFCNT_dec(PL_checkav);
930 SvREFCNT_dec(PL_checkav_save);
931 SvREFCNT_dec(PL_initav);
933 PL_beginav_save = NULL;
936 PL_checkav_save = NULL;
939 /* shortcuts just get cleared */
948 PL_last_in_gv = NULL;
956 PL_DBassertion = NULL;
961 SvREFCNT_dec(PL_argvout_stack);
962 PL_argvout_stack = NULL;
964 SvREFCNT_dec(PL_modglobal);
966 SvREFCNT_dec(PL_preambleav);
967 PL_preambleav = NULL;
968 SvREFCNT_dec(PL_subname);
970 SvREFCNT_dec(PL_linestr);
972 #ifdef PERL_USES_PL_PIDSTATUS
973 SvREFCNT_dec(PL_pidstatus);
976 SvREFCNT_dec(PL_toptarget);
978 SvREFCNT_dec(PL_bodytarget);
979 PL_bodytarget = NULL;
980 PL_formtarget = NULL;
982 /* free locale stuff */
983 #ifdef USE_LOCALE_COLLATE
984 Safefree(PL_collation_name);
985 PL_collation_name = NULL;
988 #ifdef USE_LOCALE_NUMERIC
989 Safefree(PL_numeric_name);
990 PL_numeric_name = NULL;
991 SvREFCNT_dec(PL_numeric_radix_sv);
992 PL_numeric_radix_sv = NULL;
995 /* clear utf8 character classes */
996 SvREFCNT_dec(PL_utf8_alnum);
997 SvREFCNT_dec(PL_utf8_alnumc);
998 SvREFCNT_dec(PL_utf8_ascii);
999 SvREFCNT_dec(PL_utf8_alpha);
1000 SvREFCNT_dec(PL_utf8_space);
1001 SvREFCNT_dec(PL_utf8_cntrl);
1002 SvREFCNT_dec(PL_utf8_graph);
1003 SvREFCNT_dec(PL_utf8_digit);
1004 SvREFCNT_dec(PL_utf8_upper);
1005 SvREFCNT_dec(PL_utf8_lower);
1006 SvREFCNT_dec(PL_utf8_print);
1007 SvREFCNT_dec(PL_utf8_punct);
1008 SvREFCNT_dec(PL_utf8_xdigit);
1009 SvREFCNT_dec(PL_utf8_mark);
1010 SvREFCNT_dec(PL_utf8_toupper);
1011 SvREFCNT_dec(PL_utf8_totitle);
1012 SvREFCNT_dec(PL_utf8_tolower);
1013 SvREFCNT_dec(PL_utf8_tofold);
1014 SvREFCNT_dec(PL_utf8_idstart);
1015 SvREFCNT_dec(PL_utf8_idcont);
1016 PL_utf8_alnum = NULL;
1017 PL_utf8_alnumc = NULL;
1018 PL_utf8_ascii = NULL;
1019 PL_utf8_alpha = NULL;
1020 PL_utf8_space = NULL;
1021 PL_utf8_cntrl = NULL;
1022 PL_utf8_graph = NULL;
1023 PL_utf8_digit = NULL;
1024 PL_utf8_upper = NULL;
1025 PL_utf8_lower = NULL;
1026 PL_utf8_print = NULL;
1027 PL_utf8_punct = NULL;
1028 PL_utf8_xdigit = NULL;
1029 PL_utf8_mark = NULL;
1030 PL_utf8_toupper = NULL;
1031 PL_utf8_totitle = NULL;
1032 PL_utf8_tolower = NULL;
1033 PL_utf8_tofold = NULL;
1034 PL_utf8_idstart = NULL;
1035 PL_utf8_idcont = NULL;
1037 if (!specialWARN(PL_compiling.cop_warnings))
1038 SvREFCNT_dec(PL_compiling.cop_warnings);
1039 PL_compiling.cop_warnings = NULL;
1040 if (!specialCopIO(PL_compiling.cop_io))
1041 SvREFCNT_dec(PL_compiling.cop_io);
1042 PL_compiling.cop_io = NULL;
1043 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
1044 PL_compiling.cop_hints = NULL;
1045 CopFILE_free(&PL_compiling);
1046 CopSTASH_free(&PL_compiling);
1048 /* Prepare to destruct main symbol table. */
1053 SvREFCNT_dec(PL_curstname);
1054 PL_curstname = NULL;
1056 /* clear queued errors */
1057 SvREFCNT_dec(PL_errors);
1061 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
1062 if (PL_scopestack_ix != 0)
1063 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1064 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1065 (long)PL_scopestack_ix);
1066 if (PL_savestack_ix != 0)
1067 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1068 "Unbalanced saves: %ld more saves than restores\n",
1069 (long)PL_savestack_ix);
1070 if (PL_tmps_floor != -1)
1071 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1072 (long)PL_tmps_floor + 1);
1073 if (cxstack_ix != -1)
1074 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1075 (long)cxstack_ix + 1);
1078 /* Now absolutely destruct everything, somehow or other, loops or no. */
1079 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
1080 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
1082 /* the 2 is for PL_fdpid and PL_strtab */
1083 while (PL_sv_count > 2 && sv_clean_all())
1086 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
1087 SvFLAGS(PL_fdpid) |= SVt_PVAV;
1088 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
1089 SvFLAGS(PL_strtab) |= SVt_PVHV;
1091 AvREAL_off(PL_fdpid); /* no surviving entries */
1092 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
1095 #ifdef HAVE_INTERP_INTERN
1099 /* Destruct the global string table. */
1101 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1102 * so that sv_free() won't fail on them.
1103 * Now that the global string table is using a single hunk of memory
1104 * for both HE and HEK, we either need to explicitly unshare it the
1105 * correct way, or actually free things here.
1108 const I32 max = HvMAX(PL_strtab);
1109 HE * const * const array = HvARRAY(PL_strtab);
1110 HE *hent = array[0];
1113 if (hent && ckWARN_d(WARN_INTERNAL)) {
1114 HE * const next = HeNEXT(hent);
1115 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1116 "Unbalanced string table refcount: (%ld) for \"%s\"",
1117 (long)hent->he_valu.hent_refcount, HeKEY(hent));
1124 hent = array[riter];
1129 HvARRAY(PL_strtab) = 0;
1130 HvTOTALKEYS(PL_strtab) = 0;
1131 HvFILL(PL_strtab) = 0;
1133 SvREFCNT_dec(PL_strtab);
1136 /* free the pointer tables used for cloning */
1137 ptr_table_free(PL_ptr_table);
1138 PL_ptr_table = (PTR_TBL_t*)NULL;
1141 /* free special SVs */
1143 SvREFCNT(&PL_sv_yes) = 0;
1144 sv_clear(&PL_sv_yes);
1145 SvANY(&PL_sv_yes) = NULL;
1146 SvFLAGS(&PL_sv_yes) = 0;
1148 SvREFCNT(&PL_sv_no) = 0;
1149 sv_clear(&PL_sv_no);
1150 SvANY(&PL_sv_no) = NULL;
1151 SvFLAGS(&PL_sv_no) = 0;
1155 for (i=0; i<=2; i++) {
1156 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1157 sv_clear(PERL_DEBUG_PAD(i));
1158 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1159 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1163 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1164 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1166 #ifdef DEBUG_LEAKING_SCALARS
1167 if (PL_sv_count != 0) {
1172 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
1173 svend = &sva[SvREFCNT(sva)];
1174 for (sv = sva + 1; sv < svend; ++sv) {
1175 if (SvTYPE(sv) != SVTYPEMASK) {
1176 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1178 " refcnt=%"UVuf pTHX__FORMAT "\n"
1179 "\tallocated at %s:%d %s %s%s\n",
1180 sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
1181 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1183 sv->sv_debug_inpad ? "for" : "by",
1184 sv->sv_debug_optype ?
1185 PL_op_name[sv->sv_debug_optype]: "(none)",
1186 sv->sv_debug_cloned ? " (cloned)" : ""
1188 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1189 Perl_dump_sv_child(aTHX_ sv);
1195 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1199 /* Wait for up to 4 seconds for child to terminate.
1200 This seems to be the least effort way of timing out on reaping
1202 struct timeval waitfor = {4, 0};
1203 int sock = PL_dumper_fd;
1207 FD_SET(sock, &rset);
1208 select(sock + 1, &rset, NULL, NULL, &waitfor);
1209 waitpid(child, &status, WNOHANG);
1217 #if defined(PERLIO_LAYERS)
1218 /* No more IO - including error messages ! */
1219 PerlIO_cleanup(aTHX);
1222 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1223 as currently layers use it rather than NULL as a marker
1224 for no arg - and will try and SvREFCNT_dec it.
1226 SvREFCNT(&PL_sv_undef) = 0;
1227 SvREADONLY_off(&PL_sv_undef);
1229 Safefree(PL_origfilename);
1230 PL_origfilename = NULL;
1231 Safefree(PL_reg_start_tmp);
1232 PL_reg_start_tmp = (char**)NULL;
1233 PL_reg_start_tmpl = 0;
1234 Safefree(PL_reg_curpm);
1235 Safefree(PL_reg_poscache);
1236 free_tied_hv_pool();
1237 Safefree(PL_op_mask);
1238 Safefree(PL_psig_ptr);
1239 PL_psig_ptr = (SV**)NULL;
1240 Safefree(PL_psig_name);
1241 PL_psig_name = (SV**)NULL;
1242 Safefree(PL_bitcount);
1244 Safefree(PL_psig_pend);
1245 PL_psig_pend = (int*)NULL;
1248 PL_tainting = FALSE;
1249 PL_taint_warn = FALSE;
1250 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
1253 DEBUG_P(debprofdump());
1255 #ifdef USE_REENTRANT_API
1256 Perl_reentrant_free(aTHX);
1261 while (PL_regmatch_slab) {
1262 regmatch_slab *s = PL_regmatch_slab;
1263 PL_regmatch_slab = PL_regmatch_slab->next;
1267 /* As the absolutely last thing, free the non-arena SV for mess() */
1270 /* we know that type == SVt_PVMG */
1272 /* it could have accumulated taint magic */
1275 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1276 moremagic = mg->mg_moremagic;
1277 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1279 Safefree(mg->mg_ptr);
1283 /* we know that type >= SVt_PV */
1284 SvPV_free(PL_mess_sv);
1285 Safefree(SvANY(PL_mess_sv));
1286 Safefree(PL_mess_sv);
1293 =for apidoc perl_free
1295 Releases a Perl interpreter. See L<perlembed>.
1303 #ifdef PERL_TRACK_MEMPOOL
1306 * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1307 * value as we're probably hunting memory leaks then
1309 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
1310 if (!s || atoi(s) == 0) {
1311 /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1312 thread at thread exit. */
1313 while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
1314 safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
1319 #if defined(WIN32) || defined(NETWARE)
1320 # if defined(PERL_IMPLICIT_SYS)
1323 void *host = nw_internal_host;
1325 void *host = w32_internal_host;
1327 PerlMem_free(aTHXx);
1329 nw_delete_internal_host(host);
1331 win32_delete_internal_host(host);
1335 PerlMem_free(aTHXx);
1338 PerlMem_free(aTHXx);
1342 #if defined(USE_ITHREADS)
1343 /* provide destructors to clean up the thread key when libperl is unloaded */
1344 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1346 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1347 #pragma fini "perl_fini"
1348 #elif defined(__sun) && !defined(__GNUC__)
1349 #pragma fini (perl_fini)
1353 #if defined(__GNUC__)
1354 __attribute__((destructor))
1364 #endif /* THREADS */
1367 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1370 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1371 PL_exitlist[PL_exitlistlen].fn = fn;
1372 PL_exitlist[PL_exitlistlen].ptr = ptr;
1376 #ifdef HAS_PROCSELFEXE
1377 /* This is a function so that we don't hold on to MAXPATHLEN
1378 bytes of stack longer than necessary
1381 S_procself_val(pTHX_ SV *sv, const char *arg0)
1383 char buf[MAXPATHLEN];
1384 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1386 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1387 includes a spurious NUL which will cause $^X to fail in system
1388 or backticks (this will prevent extensions from being built and
1389 many tests from working). readlink is not meant to add a NUL.
1390 Normal readlink works fine.
1392 if (len > 0 && buf[len-1] == '\0') {
1396 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1397 returning the text "unknown" from the readlink rather than the path
1398 to the executable (or returning an error from the readlink). Any valid
1399 path has a '/' in it somewhere, so use that to validate the result.
1400 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1402 if (len > 0 && memchr(buf, '/', len)) {
1403 sv_setpvn(sv,buf,len);
1409 #endif /* HAS_PROCSELFEXE */
1412 S_set_caret_X(pTHX) {
1414 GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
1416 #ifdef HAS_PROCSELFEXE
1417 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1420 sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
1422 sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
1429 =for apidoc perl_parse
1431 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1437 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1444 PERL_UNUSED_VAR(my_perl);
1446 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1449 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
1450 setuid perl scripts securely.\n");
1451 #endif /* IAMSUID */
1454 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1455 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
1456 * This MUST be done before any hash stores or fetches take place.
1457 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1458 * yourself, it is your responsibility to provide a good random seed!
1459 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
1460 if (!PL_rehash_seed_set)
1461 PL_rehash_seed = get_hash_seed();
1463 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1465 if (s && (atoi(s) == 1))
1466 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
1468 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1473 if (PL_origalen != 0) {
1474 PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1477 /* Set PL_origalen be the sum of the contiguous argv[]
1478 * elements plus the size of the env in case that it is
1479 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1480 * as the maximum modifiable length of $0. In the worst case
1481 * the area we are able to modify is limited to the size of
1482 * the original argv[0]. (See below for 'contiguous', though.)
1484 const char *s = NULL;
1487 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1488 /* Do the mask check only if the args seem like aligned. */
1490 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1492 /* See if all the arguments are contiguous in memory. Note
1493 * that 'contiguous' is a loose term because some platforms
1494 * align the argv[] and the envp[]. If the arguments look
1495 * like non-aligned, assume that they are 'strictly' or
1496 * 'traditionally' contiguous. If the arguments look like
1497 * aligned, we just check that they are within aligned
1498 * PTRSIZE bytes. As long as no system has something bizarre
1499 * like the argv[] interleaved with some other data, we are
1500 * fine. (Did I just evoke Murphy's Law?) --jhi */
1501 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1503 for (i = 1; i < PL_origargc; i++) {
1504 if ((PL_origargv[i] == s + 1
1506 || PL_origargv[i] == s + 2
1511 (PL_origargv[i] > s &&
1513 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1523 /* Can we grab env area too to be used as the area for $0? */
1524 if (s && PL_origenviron) {
1525 if ((PL_origenviron[0] == s + 1
1527 || (PL_origenviron[0] == s + 9 && (s += 8))
1532 (PL_origenviron[0] > s &&
1533 PL_origenviron[0] <=
1534 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1538 s = PL_origenviron[0];
1541 my_setenv("NoNe SuCh", NULL);
1542 /* Force copy of environment. */
1543 for (i = 1; PL_origenviron[i]; i++) {
1544 if (PL_origenviron[i] == s + 1
1547 (PL_origenviron[i] > s &&
1548 PL_origenviron[i] <=
1549 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1552 s = PL_origenviron[i];
1560 PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1565 /* Come here if running an undumped a.out. */
1567 PL_origfilename = savepv(argv[0]);
1568 PL_do_undump = FALSE;
1569 cxstack_ix = -1; /* start label stack again */
1571 assert (!PL_tainted);
1573 S_set_caret_X(aTHX);
1575 init_postdump_symbols(argc,argv,env);
1580 op_free(PL_main_root);
1581 PL_main_root = NULL;
1583 PL_main_start = NULL;
1584 SvREFCNT_dec(PL_main_cv);
1588 oldscope = PL_scopestack_ix;
1589 PL_dowarn = G_WARN_OFF;
1594 parse_body(env,xsinit);
1596 call_list(oldscope, PL_checkav);
1603 /* my_exit() was called */
1604 while (PL_scopestack_ix > oldscope)
1607 PL_curstash = PL_defstash;
1609 call_list(oldscope, PL_checkav);
1613 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1622 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1625 int argc = PL_origargc;
1626 char **argv = PL_origargv;
1627 const char *scriptname = NULL;
1628 VOL bool dosearch = FALSE;
1629 const char *validarg = "";
1632 const char *cddir = NULL;
1633 #ifdef USE_SITECUSTOMIZE
1634 bool minus_f = FALSE;
1637 sv_setpvn(PL_linestr,"",0);
1638 sv = newSVpvs(""); /* first used for -I flags */
1642 for (argc--,argv++; argc > 0; argc--,argv++) {
1643 if (argv[0][0] != '-' || !argv[0][1])
1647 validarg = " PHOOEY ";
1651 * Can we rely on the kernel to start scripts with argv[1] set to
1652 * contain all #! line switches (the whole line)? (argv[0] is set to
1653 * the interpreter name, argv[2] to the script name; argv[3] and
1654 * above may contain other arguments.)
1661 #ifndef PERL_STRICT_CR
1686 if ((s = moreswitches(s)))
1691 CHECK_MALLOC_TOO_LATE_FOR('t');
1692 if( !PL_tainting ) {
1693 PL_taint_warn = TRUE;
1699 CHECK_MALLOC_TOO_LATE_FOR('T');
1701 PL_taint_warn = FALSE;
1709 #ifdef MACOS_TRADITIONAL
1710 /* ignore -e for Dev:Pseudo argument */
1711 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1714 forbid_setid('e', -1);
1716 PL_e_script = newSVpvs("");
1717 filter_add(read_e_script, NULL);
1720 sv_catpv(PL_e_script, s);
1722 sv_catpv(PL_e_script, argv[1]);
1726 Perl_croak(aTHX_ "No code specified for -%c", *s);
1727 sv_catpvs(PL_e_script, "\n");
1731 #ifdef USE_SITECUSTOMIZE
1737 case 'I': /* -I handled both here and in moreswitches() */
1738 forbid_setid('I', -1);
1739 if (!*++s && (s=argv[1]) != NULL) {
1743 STRLEN len = strlen(s);
1744 const char * const p = savepvn(s, len);
1745 incpush(p, TRUE, TRUE, FALSE, FALSE);
1746 sv_catpvs(sv, "-I");
1747 sv_catpvn(sv, p, len);
1752 Perl_croak(aTHX_ "No directory specified for -I");
1755 forbid_setid('P', -1);
1756 PL_preprocess = TRUE;
1760 forbid_setid('S', -1);
1769 PL_preambleav = newAV();
1770 av_push(PL_preambleav,
1771 newSVpvs("use Config;"));
1775 opts_prog = newSVpvs("print Config::myconfig(),");
1777 sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\",");
1779 sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\",");
1781 opts = SvCUR(opts_prog);
1783 Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:"
1787 # ifdef DEBUG_LEAKING_SCALARS
1788 " DEBUG_LEAKING_SCALARS"
1790 # ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1791 " DEBUG_LEAKING_SCALARS_FORK_DUMP"
1793 # ifdef FAKE_THREADS
1796 # ifdef MULTIPLICITY
1805 # ifdef PERL_DONT_CREATE_GVSV
1806 " PERL_DONT_CREATE_GVSV"
1808 # ifdef PERL_GLOBAL_STRUCT
1809 " PERL_GLOBAL_STRUCT"
1811 # ifdef PERL_IMPLICIT_CONTEXT
1812 " PERL_IMPLICIT_CONTEXT"
1814 # ifdef PERL_IMPLICIT_SYS
1815 " PERL_IMPLICIT_SYS"
1820 # ifdef PERL_MALLOC_WRAP
1823 # ifdef PERL_NEED_APPCTX
1826 # ifdef PERL_NEED_TIMESBASE
1827 " PERL_NEED_TIMESBASE"
1829 # ifdef PERL_OLD_COPY_ON_WRITE
1830 " PERL_OLD_COPY_ON_WRITE"
1832 # ifdef PERL_TRACK_MEMPOOL
1833 " PERL_TRACK_MEMPOOL"
1835 # ifdef PERL_USE_SAFE_PUTENV
1836 " PERL_USE_SAFE_PUTENV"
1838 #ifdef PERL_USES_PL_PIDSTATUS
1839 " PERL_USES_PL_PIDSTATUS"
1841 # ifdef PL_OP_SLAB_ALLOC
1844 # ifdef THREADS_HAVE_PIDS
1845 " THREADS_HAVE_PIDS"
1847 # ifdef USE_64_BIT_ALL
1850 # ifdef USE_64_BIT_INT
1853 # ifdef USE_ITHREADS
1856 # ifdef USE_LARGE_FILES
1859 # ifdef USE_LONG_DOUBLE
1865 # ifdef USE_REENTRANT_API
1866 " USE_REENTRANT_API"
1871 # ifdef USE_SITECUSTOMIZE
1872 " USE_SITECUSTOMIZE"
1879 while (SvCUR(opts_prog) > opts+76) {
1880 /* find last space after "options: " and before col 76
1884 char * const pv = SvPV_nolen(opts_prog);
1885 const char c = pv[opts+76];
1887 space = strrchr(pv+opts+26, ' ');
1889 if (!space) break; /* "Can't happen" */
1891 /* break the line before that space */
1894 Perl_sv_insert(aTHX_ opts_prog, opts, 0,
1895 STR_WITH_LEN("\\n "));
1898 sv_catpvs(opts_prog,"\\n\",");
1900 #if defined(LOCAL_PATCH_COUNT)
1901 if (LOCAL_PATCH_COUNT > 0) {
1903 sv_catpvs(opts_prog,
1904 "\" Locally applied patches:\\n\",");
1905 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1906 if (PL_localpatches[i])
1907 Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
1908 0, PL_localpatches[i], 0);
1912 Perl_sv_catpvf(aTHX_ opts_prog,
1913 "\" Built under %s\\n\"",OSNAME);
1916 Perl_sv_catpvf(aTHX_ opts_prog,
1917 ",\" Compiled at %s %s\\n\"",__DATE__,
1920 Perl_sv_catpvf(aTHX_ opts_prog,",\" Compiled on %s\\n\"",
1924 sv_catpvs(opts_prog, "; $\"=\"\\n \"; "
1925 "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
1926 "sort grep {/^PERL/} keys %ENV; ");
1928 sv_catpvs(opts_prog,
1929 "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1931 sv_catpvs(opts_prog,
1932 "print \" \\%ENV:\\n @env\\n\" if @env;"
1933 "print \" \\@INC:\\n @INC\\n\";");
1937 opts_prog = Perl_newSVpvf(aTHX_
1938 "Config::config_vars(qw%c%s%c)",
1942 av_push(PL_preambleav, opts_prog);
1943 /* don't look for script or read stdin */
1944 scriptname = BIT_BUCKET;
1948 PL_doextract = TRUE;
1956 if (!*++s || isSPACE(*s)) {
1960 /* catch use of gnu style long options */
1961 if (strEQ(s, "version")) {
1965 if (strEQ(s, "help")) {
1972 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1978 #ifndef SECURE_INTERNAL_GETENV
1981 (s = PerlEnv_getenv("PERL5OPT")))
1983 const char *popt = s;
1986 if (*s == '-' && *(s+1) == 'T') {
1987 CHECK_MALLOC_TOO_LATE_FOR('T');
1989 PL_taint_warn = FALSE;
1992 char *popt_copy = NULL;
2005 if (!strchr("CDIMUdmtwA", *s))
2006 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2010 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
2011 s = popt_copy + (s - popt);
2012 d = popt_copy + (d - popt);
2019 if( !PL_tainting ) {
2020 PL_taint_warn = TRUE;
2030 #ifdef USE_SITECUSTOMIZE
2033 PL_preambleav = newAV();
2034 av_unshift(PL_preambleav, 1);
2035 (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
2039 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
2040 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
2044 scriptname = argv[0];
2047 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
2049 else if (scriptname == NULL) {
2051 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2057 /* Set $^X early so that it can be used for relocatable paths in @INC */
2058 assert (!PL_tainted);
2060 S_set_caret_X(aTHX);
2067 = open_script(scriptname, dosearch, sv, &suidscript);
2069 validate_suid(validarg, scriptname, fdscript, suidscript);
2072 # if defined(SIGCHLD) || defined(SIGCLD)
2075 # define SIGCHLD SIGCLD
2077 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2078 if (sigstate == (Sighandler_t) SIG_IGN) {
2079 if (ckWARN(WARN_SIGNAL))
2080 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2081 "Can't ignore signal CHLD, forcing to default");
2082 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2089 #ifdef MACOS_TRADITIONAL
2090 || gMacPerl_AlwaysExtract
2094 /* This will croak if suidscript is >= 0, as -x cannot be used with
2096 forbid_setid('x', suidscript);
2097 /* Hence you can't get here if suidscript >= 0 */
2100 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2101 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2105 PL_main_cv = PL_compcv = (CV*)newSV(0);
2106 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2107 CvUNIQUE_on(PL_compcv);
2109 CvPADLIST(PL_compcv) = pad_new(0);
2112 boot_core_UNIVERSAL();
2113 boot_core_xsutils();
2116 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
2118 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
2124 # ifdef HAS_SOCKS5_INIT
2125 socks5_init(argv[0]);
2131 init_predump_symbols();
2132 /* init_postdump_symbols not currently designed to be called */
2133 /* more than once (ENV isn't cleared first, for example) */
2134 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2136 init_postdump_symbols(argc,argv,env);
2138 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2139 * or explicitly in some platforms.
2140 * locale.c:Perl_init_i18nl10n() if the environment
2141 * look like the user wants to use UTF-8. */
2142 #if defined(__SYMBIAN32__)
2143 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2146 /* Requires init_predump_symbols(). */
2147 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2152 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2153 * and the default open disciplines. */
2154 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2155 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2157 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2158 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2159 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2161 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2162 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2163 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2165 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2166 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2167 (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2169 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2170 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2173 sv_setpvn(sv, ":utf8\0:utf8", 11);
2175 sv_setpvn(sv, ":utf8\0", 6);
2178 sv_setpvn(sv, "\0:utf8", 6);
2184 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2185 if (strEQ(s, "unsafe"))
2186 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2187 else if (strEQ(s, "safe"))
2188 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2190 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2194 if ((s = PerlEnv_getenv("PERL_XMLDUMP"))) {
2198 PL_xmlfp = PerlIO_stdout();
2200 PL_xmlfp = PerlIO_open(s, "w");
2202 Perl_croak(aTHX_ "Can't open %s", s);
2204 my_setenv("PERL_XMLDUMP", Nullch); /* hide from subprocs */
2206 if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2207 PL_madskills = atoi(s);
2208 my_setenv("PERL_MADSKILLS", Nullch); /* hide from subprocs */
2214 /* now parse the script */
2216 SETERRNO(0,SS_NORMAL);
2218 #ifdef MACOS_TRADITIONAL
2219 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
2221 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
2223 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2224 MacPerl_MPWFileName(PL_origfilename));
2228 if (yyparse() || PL_error_count) {
2230 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2232 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2237 CopLINE_set(PL_curcop, 0);
2238 PL_curstash = PL_defstash;
2239 PL_preprocess = FALSE;
2241 SvREFCNT_dec(PL_e_script);
2249 SAVECOPFILE(PL_curcop);
2250 SAVECOPLINE(PL_curcop);
2251 gv_check(PL_defstash);
2258 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2259 dump_mstats("after compilation:");
2268 =for apidoc perl_run
2270 Tells a Perl interpreter to run. See L<perlembed>.
2283 PERL_UNUSED_CONTEXT;
2285 oldscope = PL_scopestack_ix;
2293 cxstack_ix = -1; /* start context stack again */
2295 case 0: /* normal completion */
2299 case 2: /* my_exit() */
2300 while (PL_scopestack_ix > oldscope)
2303 PL_curstash = PL_defstash;
2304 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2305 PL_endav && !PL_minus_c)
2306 call_list(oldscope, PL_endav);
2308 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2309 dump_mstats("after execution: ");
2315 POPSTACK_TO(PL_mainstack);
2318 PerlIO_printf(Perl_error_log, "panic: restartop\n");
2330 S_run_body(pTHX_ I32 oldscope)
2333 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2334 PL_sawampersand ? "Enabling" : "Omitting"));
2336 if (!PL_restartop) {
2340 exit(0); /* less likely to core dump than my_exit(0) */
2343 DEBUG_x(dump_all());
2346 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2348 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
2352 #ifdef MACOS_TRADITIONAL
2353 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
2354 (gMacPerl_ErrorFormat ? "# " : ""),
2355 MacPerl_MPWFileName(PL_origfilename));
2357 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2361 if (PERLDB_SINGLE && PL_DBsingle)
2362 sv_setiv(PL_DBsingle, 1);
2364 call_list(oldscope, PL_initav);
2370 PL_op = PL_restartop;
2374 else if (PL_main_start) {
2375 CvDEPTH(PL_main_cv) = 1;
2376 PL_op = PL_main_start;
2384 =head1 SV Manipulation Functions
2386 =for apidoc p||get_sv
2388 Returns the SV of the specified Perl scalar. If C<create> is set and the
2389 Perl variable does not exist then it will be created. If C<create> is not
2390 set and the variable does not exist then NULL is returned.
2396 Perl_get_sv(pTHX_ const char *name, I32 create)
2399 gv = gv_fetchpv(name, create, SVt_PV);
2406 =head1 Array Manipulation Functions
2408 =for apidoc p||get_av
2410 Returns the AV of the specified Perl array. If C<create> is set and the
2411 Perl variable does not exist then it will be created. If C<create> is not
2412 set and the variable does not exist then NULL is returned.
2418 Perl_get_av(pTHX_ const char *name, I32 create)
2420 GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
2429 =head1 Hash Manipulation Functions
2431 =for apidoc p||get_hv
2433 Returns the HV of the specified Perl hash. If C<create> is set and the
2434 Perl variable does not exist then it will be created. If C<create> is not
2435 set and the variable does not exist then NULL is returned.
2441 Perl_get_hv(pTHX_ const char *name, I32 create)
2443 GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
2452 =head1 CV Manipulation Functions
2454 =for apidoc p||get_cv
2456 Returns the CV of the specified Perl subroutine. If C<create> is set and
2457 the Perl subroutine does not exist then it will be declared (which has the
2458 same effect as saying C<sub name;>). If C<create> is not set and the
2459 subroutine does not exist then NULL is returned.
2465 Perl_get_cv(pTHX_ const char *name, I32 create)
2467 GV* const gv = gv_fetchpv(name, create, SVt_PVCV);
2468 /* XXX unsafe for threads if eval_owner isn't held */
2469 /* XXX this is probably not what they think they're getting.
2470 * It has the same effect as "sub name;", i.e. just a forward
2472 if (create && !GvCVu(gv))
2473 return newSUB(start_subparse(FALSE, 0),
2474 newSVOP(OP_CONST, 0, newSVpv(name,0)),
2481 /* Be sure to refetch the stack pointer after calling these routines. */
2485 =head1 Callback Functions
2487 =for apidoc p||call_argv
2489 Performs a callback to the specified Perl sub. See L<perlcall>.
2495 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2497 /* See G_* flags in cop.h */
2498 /* null terminated arg list */
2506 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
2511 return call_pv(sub_name, flags);
2515 =for apidoc p||call_pv
2517 Performs a callback to the specified Perl sub. See L<perlcall>.
2523 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2524 /* name of the subroutine */
2525 /* See G_* flags in cop.h */
2527 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
2531 =for apidoc p||call_method
2533 Performs a callback to the specified Perl method. The blessed object must
2534 be on the stack. See L<perlcall>.
2540 Perl_call_method(pTHX_ const char *methname, I32 flags)
2541 /* name of the subroutine */
2542 /* See G_* flags in cop.h */
2544 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2547 /* May be called with any of a CV, a GV, or an SV containing the name. */
2549 =for apidoc p||call_sv
2551 Performs a callback to the Perl sub whose name is in the SV. See
2558 Perl_call_sv(pTHX_ SV *sv, I32 flags)
2559 /* See G_* flags in cop.h */
2562 LOGOP myop; /* fake syntax tree node */
2565 volatile I32 retval = 0;
2567 bool oldcatch = CATCH_GET;
2569 OP* const oldop = PL_op;
2572 if (flags & G_DISCARD) {
2577 Zero(&myop, 1, LOGOP);
2578 myop.op_next = NULL;
2579 if (!(flags & G_NOARGS))
2580 myop.op_flags |= OPf_STACKED;
2581 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2582 (flags & G_ARRAY) ? OPf_WANT_LIST :
2587 EXTEND(PL_stack_sp, 1);
2588 *++PL_stack_sp = sv;
2590 oldscope = PL_scopestack_ix;
2592 if (PERLDB_SUB && PL_curstash != PL_debstash
2593 /* Handle first BEGIN of -d. */
2594 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2595 /* Try harder, since this may have been a sighandler, thus
2596 * curstash may be meaningless. */
2597 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2598 && !(flags & G_NODEBUG))
2599 PL_op->op_private |= OPpENTERSUB_DB;
2601 if (flags & G_METHOD) {
2602 Zero(&method_op, 1, UNOP);
2603 method_op.op_next = PL_op;
2604 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2605 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2606 PL_op = (OP*)&method_op;
2609 if (!(flags & G_EVAL)) {
2611 call_body((OP*)&myop, FALSE);
2612 retval = PL_stack_sp - (PL_stack_base + oldmark);
2613 CATCH_SET(oldcatch);
2616 myop.op_other = (OP*)&myop;
2618 create_eval_scope(flags|G_FAKINGEVAL);
2626 call_body((OP*)&myop, FALSE);
2627 retval = PL_stack_sp - (PL_stack_base + oldmark);
2628 if (!(flags & G_KEEPERR))
2629 sv_setpvn(ERRSV,"",0);
2635 /* my_exit() was called */
2636 PL_curstash = PL_defstash;
2639 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2640 Perl_croak(aTHX_ "Callback called exit");
2645 PL_op = PL_restartop;
2649 PL_stack_sp = PL_stack_base + oldmark;
2650 if (flags & G_ARRAY)
2654 *++PL_stack_sp = &PL_sv_undef;
2659 if (PL_scopestack_ix > oldscope)
2660 delete_eval_scope();
2664 if (flags & G_DISCARD) {
2665 PL_stack_sp = PL_stack_base + oldmark;
2675 S_call_body(pTHX_ const OP *myop, bool is_eval)
2678 if (PL_op == myop) {
2680 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2682 PL_op = Perl_pp_entersub(aTHX); /* this does */
2688 /* Eval a string. The G_EVAL flag is always assumed. */
2691 =for apidoc p||eval_sv
2693 Tells Perl to C<eval> the string in the SV.
2699 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2701 /* See G_* flags in cop.h */
2705 UNOP myop; /* fake syntax tree node */
2706 volatile I32 oldmark = SP - PL_stack_base;
2707 volatile I32 retval = 0;
2709 OP* const oldop = PL_op;
2712 if (flags & G_DISCARD) {
2719 Zero(PL_op, 1, UNOP);
2720 EXTEND(PL_stack_sp, 1);
2721 *++PL_stack_sp = sv;
2723 if (!(flags & G_NOARGS))
2724 myop.op_flags = OPf_STACKED;
2725 myop.op_next = NULL;
2726 myop.op_type = OP_ENTEREVAL;
2727 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2728 (flags & G_ARRAY) ? OPf_WANT_LIST :
2730 if (flags & G_KEEPERR)
2731 myop.op_flags |= OPf_SPECIAL;
2733 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2734 * before a PUSHEVAL, which corrupts the stack after a croak */
2735 TAINT_PROPER("eval_sv()");
2741 call_body((OP*)&myop,TRUE);
2742 retval = PL_stack_sp - (PL_stack_base + oldmark);
2743 if (!(flags & G_KEEPERR))
2744 sv_setpvn(ERRSV,"",0);
2750 /* my_exit() was called */
2751 PL_curstash = PL_defstash;
2754 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2755 Perl_croak(aTHX_ "Callback called exit");
2760 PL_op = PL_restartop;
2764 PL_stack_sp = PL_stack_base + oldmark;
2765 if (flags & G_ARRAY)
2769 *++PL_stack_sp = &PL_sv_undef;
2775 if (flags & G_DISCARD) {
2776 PL_stack_sp = PL_stack_base + oldmark;
2786 =for apidoc p||eval_pv
2788 Tells Perl to C<eval> the given string and return an SV* result.
2794 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2798 SV* sv = newSVpv(p, 0);
2800 eval_sv(sv, G_SCALAR);
2807 if (croak_on_error && SvTRUE(ERRSV)) {
2808 Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2814 /* Require a module. */
2817 =head1 Embedding Functions
2819 =for apidoc p||require_pv
2821 Tells Perl to C<require> the file named by the string argument. It is
2822 analogous to the Perl code C<eval "require '$file'">. It's even
2823 implemented that way; consider using load_module instead.
2828 Perl_require_pv(pTHX_ const char *pv)
2833 PUSHSTACKi(PERLSI_REQUIRE);
2835 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2836 eval_sv(sv_2mortal(sv), G_DISCARD);
2842 Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
2844 register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV);
2847 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2851 S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
2853 /* This message really ought to be max 23 lines.
2854 * Removed -h because the user already knows that option. Others? */
2856 static const char * const usage_msg[] = {
2857 "-0[octal] specify record separator (\\0, if no argument)",
2858 "-A[mod][=pattern] activate all/given assertions",
2859 "-a autosplit mode with -n or -p (splits $_ into @F)",
2860 "-C[number/list] enables the listed Unicode features",
2861 "-c check syntax only (runs BEGIN and CHECK blocks)",
2862 "-d[:debugger] run program under debugger",
2863 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2864 "-e program one line of program (several -e's allowed, omit programfile)",
2865 "-E program like -e, but enables all optional features",
2866 "-f don't do $sitelib/sitecustomize.pl at startup",
2867 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2868 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2869 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2870 "-l[octal] enable line ending processing, specifies line terminator",
2871 "-[mM][-]module execute \"use/no module...\" before executing program",
2872 "-n assume \"while (<>) { ... }\" loop around program",
2873 "-p assume loop like -n but print line also, like sed",
2874 "-P run program through C preprocessor before compilation",
2875 "-s enable rudimentary parsing for switches after programfile",
2876 "-S look for programfile using PATH environment variable",
2877 "-t enable tainting warnings",
2878 "-T enable tainting checks",
2879 "-u dump core after parsing program",
2880 "-U allow unsafe operations",
2881 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2882 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2883 "-w enable many useful warnings (RECOMMENDED)",
2884 "-W enable all warnings",
2885 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2886 "-X disable all warnings",
2890 const char * const *p = usage_msg;
2892 PerlIO_printf(PerlIO_stdout(),
2893 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2896 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2899 /* convert a string of -D options (or digits) into an int.
2900 * sets *s to point to the char after the options */
2904 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2906 static const char * const usage_msgd[] = {
2907 " Debugging flag values: (see also -d)",
2908 " p Tokenizing and parsing (with v, displays parse stack)",
2909 " s Stack snapshots (with v, displays all stacks)",
2910 " l Context (loop) stack processing",
2911 " t Trace execution",
2912 " o Method and overloading resolution",
2913 " c String/numeric conversions",
2914 " P Print profiling info, preprocessor command for -P, source file input state",
2915 " m Memory allocation",
2916 " f Format processing",
2917 " r Regular expression parsing and execution",
2918 " x Syntax tree dump",
2919 " u Tainting checks",
2920 " H Hash dump -- usurps values()",
2921 " X Scratchpad allocation",
2923 " S Thread synchronization",
2925 " R Include reference counts of dumped variables (eg when using -Ds)",
2926 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2927 " v Verbose: use in conjunction with other flags",
2929 " A Consistency checks on internal structures",
2930 " q quiet - currently only suppresses the 'EXECUTING' message",
2935 /* if adding extra options, remember to update DEBUG_MASK */
2936 static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
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_printf(PerlIO_stdout(), "%s\n", *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_ char *s)
2978 SvREFCNT_dec(PL_rs);
2979 if (s[1] == 'x' && s[2]) {
2980 const char *e = s+=2;
2986 flags = PERL_SCAN_SILENT_ILLDIGIT;
2987 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2988 if (s + numlen < e) {
2989 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2993 PL_rs = newSVpvs("");
2994 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2995 tmps = (U8*)SvPVX(PL_rs);
2996 uvchr_to_utf8(tmps, rschar);
2997 SvCUR_set(PL_rs, UNISKIP(rschar));
3002 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3003 if (rschar & ~((U8)~0))
3004 PL_rs = &PL_sv_undef;
3005 else if (!rschar && numlen >= 2)
3006 PL_rs = newSVpvs("");
3008 char ch = (char)rschar;
3009 PL_rs = newSVpvn(&ch, 1);
3012 sv_setsv(get_sv("/", TRUE), PL_rs);
3017 PL_unicode = parse_unicode_opts( (const char **)&s );
3022 while (*s && !isSPACE(*s)) ++s;
3023 PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3034 forbid_setid('d', -1);
3037 /* -dt indicates to the debugger that threads will be used */
3038 if (*s == 't' && !isALNUM(s[1])) {
3040 my_setenv("PERL5DB_THREADED", "1");
3043 /* The following permits -d:Mod to accepts arguments following an =
3044 in the fashion that -MSome::Mod does. */
3045 if (*s == ':' || *s == '=') {
3047 SV * const sv = newSVpvs("use Devel::");
3049 /* We now allow -d:Module=Foo,Bar */
3050 while(isALNUM(*s) || *s==':') ++s;
3052 sv_catpv(sv, start);
3054 sv_catpvn(sv, start, s-start);
3055 /* Don't use NUL as q// delimiter here, this string goes in the
3057 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3060 my_setenv("PERL5DB", SvPV_nolen_const(sv));
3063 PL_perldb = PERLDB_ALL;
3070 forbid_setid('D', -1);
3072 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3073 #else /* !DEBUGGING */
3074 if (ckWARN_d(WARN_DEBUGGING))
3075 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3076 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3077 for (s++; isALNUM(*s); s++) ;
3082 usage(PL_origargv[0]);
3085 Safefree(PL_inplace);
3086 #if defined(__CYGWIN__) /* do backup extension automagically */
3087 if (*(s+1) == '\0') {
3088 PL_inplace = savepvs(".bak");
3091 #endif /* __CYGWIN__ */
3093 const char * const start = ++s;
3094 while (*s && !isSPACE(*s))
3097 PL_inplace = savepvn(start, s - start);
3101 if (*s == '-') /* Additional switches on #! line. */
3105 case 'I': /* -I handled both here and in parse_body() */
3106 forbid_setid('I', -1);
3108 while (*s && isSPACE(*s))
3113 /* ignore trailing spaces (possibly followed by other switches) */
3115 for (e = p; *e && !isSPACE(*e); e++) ;
3119 } while (*p && *p != '-');
3120 e = savepvn(s, e-s);
3121 incpush(e, TRUE, TRUE, FALSE, FALSE);
3128 Perl_croak(aTHX_ "No directory specified for -I");
3134 SvREFCNT_dec(PL_ors_sv);
3140 PL_ors_sv = newSVpvs("\n");
3141 numlen = 3 + (*s == '0');
3142 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3146 if (RsPARA(PL_rs)) {
3147 PL_ors_sv = newSVpvs("\n\n");
3150 PL_ors_sv = newSVsv(PL_rs);
3155 forbid_setid('A', -1);
3157 PL_preambleav = newAV();
3160 char * const start = s;
3161 SV * const sv = newSVpvs("use assertions::activate");
3162 while(isALNUM(*s) || *s == ':') ++s;
3164 sv_catpvs(sv, "::");
3165 sv_catpvn(sv, start, s-start);
3168 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
3171 else if (*s != '\0') {
3172 Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start);
3174 av_push(PL_preambleav, sv);
3178 forbid_setid('M', -1); /* XXX ? */
3181 forbid_setid('m', -1); /* XXX ? */
3185 const char *use = "use ";
3186 /* -M-foo == 'no foo' */
3187 /* Leading space on " no " is deliberate, to make both
3188 possibilities the same length. */
3189 if (*s == '-') { use = " no "; ++s; }
3190 sv = newSVpvn(use,4);
3192 /* We allow -M'Module qw(Foo Bar)' */
3193 while(isALNUM(*s) || *s==':') ++s;
3195 sv_catpv(sv, start);
3196 if (*(start-1) == 'm') {
3198 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3199 sv_catpvs( sv, " ()");
3203 Perl_croak(aTHX_ "Module name required with -%c option",
3205 sv_catpvn(sv, start, s-start);
3206 sv_catpvs(sv, " split(/,/,q");
3207 sv_catpvs(sv, "\0"); /* Use NUL as q//-delimiter. */
3209 sv_catpvs(sv, "\0)");
3213 PL_preambleav = newAV();
3214 av_push(PL_preambleav, sv);
3217 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
3228 forbid_setid('s', -1);
3229 PL_doswitches = TRUE;
3243 #ifdef MACOS_TRADITIONAL
3244 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
3246 PL_do_undump = TRUE;
3254 if (!sv_derived_from(PL_patchlevel, "version"))
3255 upg_version(PL_patchlevel);
3257 PerlIO_printf(PerlIO_stdout(),
3258 Perl_form(aTHX_ "\nThis is perl, %"SVf
3259 #ifdef PERL_PATCHNUM
3260 " DEVEL" STRINGIFY(PERL_PATCHNUM)
3263 vstringify(PL_patchlevel),
3266 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3267 PerlIO_printf(PerlIO_stdout(),
3268 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
3269 vstringify(PL_patchlevel)));
3270 PerlIO_printf(PerlIO_stdout(),
3271 Perl_form(aTHX_ " built under %s at %s %s\n",
3272 OSNAME, __DATE__, __TIME__));
3273 PerlIO_printf(PerlIO_stdout(),
3274 Perl_form(aTHX_ " OS Specific Release: %s\n",
3278 #if defined(LOCAL_PATCH_COUNT)
3279 if (LOCAL_PATCH_COUNT > 0)
3280 PerlIO_printf(PerlIO_stdout(),
3281 "\n(with %d registered patch%s, "
3282 "see perl -V for more detail)",
3283 (int)LOCAL_PATCH_COUNT,
3284 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3287 PerlIO_printf(PerlIO_stdout(),
3288 "\n\nCopyright 1987-2006, Larry Wall\n");
3289 #ifdef MACOS_TRADITIONAL
3290 PerlIO_printf(PerlIO_stdout(),
3291 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
3292 "maintained by Chris Nandor\n");
3295 PerlIO_printf(PerlIO_stdout(),
3296 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3299 PerlIO_printf(PerlIO_stdout(),
3300 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3301 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3304 PerlIO_printf(PerlIO_stdout(),
3305 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3306 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3309 PerlIO_printf(PerlIO_stdout(),
3310 "atariST series port, ++jrb bammi@cadence.com\n");
3313 PerlIO_printf(PerlIO_stdout(),
3314 "BeOS port Copyright Tom Spindler, 1997-1999\n");
3317 PerlIO_printf(PerlIO_stdout(),
3318 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3321 PerlIO_printf(PerlIO_stdout(),
3322 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3325 PerlIO_printf(PerlIO_stdout(),
3326 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3329 PerlIO_printf(PerlIO_stdout(),
3330 "VM/ESA port by Neale Ferguson, 1998-1999\n");
3333 PerlIO_printf(PerlIO_stdout(),
3334 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3337 PerlIO_printf(PerlIO_stdout(),
3338 "MiNT port by Guido Flohr, 1997-1999\n");
3341 PerlIO_printf(PerlIO_stdout(),
3342 "EPOC port by Olaf Flebbe, 1999-2002\n");
3345 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3346 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3349 #ifdef __SYMBIAN32__
3350 PerlIO_printf(PerlIO_stdout(),
3351 "Symbian port by Nokia, 2004-2005\n");
3353 #ifdef BINARY_BUILD_NOTICE
3354 BINARY_BUILD_NOTICE;
3356 PerlIO_printf(PerlIO_stdout(),
3358 Perl may be copied only under the terms of either the Artistic License or the\n\
3359 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3360 Complete documentation for Perl, including FAQ lists, should be found on\n\
3361 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3362 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3365 if (! (PL_dowarn & G_WARN_ALL_MASK))
3366 PL_dowarn |= G_WARN_ON;
3370 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3371 if (!specialWARN(PL_compiling.cop_warnings))
3372 SvREFCNT_dec(PL_compiling.cop_warnings);
3373 PL_compiling.cop_warnings = pWARN_ALL ;
3377 PL_dowarn = G_WARN_ALL_OFF;
3378 if (!specialWARN(PL_compiling.cop_warnings))
3379 SvREFCNT_dec(PL_compiling.cop_warnings);
3380 PL_compiling.cop_warnings = pWARN_NONE ;
3385 if (s[1] == '-') /* Additional switches on #! line. */
3390 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3396 #ifdef ALTERNATE_SHEBANG
3397 case 'S': /* OS/2 needs -S on "extproc" line. */
3405 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3410 /* compliments of Tom Christiansen */
3412 /* unexec() can be found in the Gnu emacs distribution */
3413 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3416 Perl_my_unexec(pTHX)
3418 PERL_UNUSED_CONTEXT;
3420 SV * prog = newSVpv(BIN_EXP, 0);
3421 SV * file = newSVpv(PL_origfilename, 0);
3425 sv_catpvs(prog, "/perl");
3426 sv_catpvs(file, ".perldump");
3428 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3429 /* unexec prints msg to stderr in case of failure */
3430 PerlProc_exit(status);
3433 # include <lib$routines.h>
3434 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3435 # elif defined(WIN32) || defined(__CYGWIN__)
3436 Perl_croak(aTHX_ "dump is not supported");
3438 ABORT(); /* for use with undump */
3443 /* initialize curinterp */
3449 # define PERLVAR(var,type)
3450 # define PERLVARA(var,n,type)
3451 # if defined(PERL_IMPLICIT_CONTEXT)
3452 # define PERLVARI(var,type,init) aTHX->var = init;
3453 # define PERLVARIC(var,type,init) aTHX->var = init;
3455 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3456 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3458 # include "intrpvar.h"
3459 # include "thrdvar.h"
3465 # define PERLVAR(var,type)
3466 # define PERLVARA(var,n,type)
3467 # define PERLVARI(var,type,init) PL_##var = init;
3468 # define PERLVARIC(var,type,init) PL_##var = init;
3469 # include "intrpvar.h"
3470 # include "thrdvar.h"
3477 /* As these are inside a structure, PERLVARI isn't capable of initialising
3480 PL_reg_oldcurpm = PL_reg_curpm = NULL;
3481 PL_reg_poscache = PL_reg_starttry = NULL;
3485 S_init_main_stash(pTHX)
3490 PL_curstash = PL_defstash = newHV();
3491 /* We know that the string "main" will be in the global shared string
3492 table, so it's a small saving to use it rather than allocate another
3494 PL_curstname = newSVpvs_share("main");
3495 gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3496 /* If we hadn't caused another reference to "main" to be in the shared
3497 string table above, then it would be worth reordering these two,
3498 because otherwise all we do is delete "main" from it as a consequence
3499 of the SvREFCNT_dec, only to add it again with hv_name_set */
3500 SvREFCNT_dec(GvHV(gv));
3501 hv_name_set(PL_defstash, "main", 4, 0);
3502 GvHV(gv) = (HV*)SvREFCNT_inc_simple(PL_defstash);
3504 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3506 SvREFCNT_inc_simple(PL_incgv); /* Don't allow it to be freed */
3507 GvMULTI_on(PL_incgv);
3508 PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3509 GvMULTI_on(PL_hintgv);
3510 PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3511 SvREFCNT_inc_simple(PL_defgv);
3512 PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
3513 SvREFCNT_inc_simple(PL_errgv);
3514 GvMULTI_on(PL_errgv);
3515 PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3516 GvMULTI_on(PL_replgv);
3517 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
3518 #ifdef PERL_DONT_CREATE_GVSV
3521 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3522 sv_setpvn(ERRSV, "", 0);
3523 PL_curstash = PL_defstash;
3524 CopSTASH_set(&PL_compiling, PL_defstash);
3525 PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3526 PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3528 /* We must init $/ before switches are processed. */
3529 sv_setpvn(get_sv("/", TRUE), "\n", 1);
3533 S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
3539 const char *cpp_discard_flag;
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 PL_rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3593 # if defined(HAS_FCNTL) && defined(F_SETFD)
3595 /* ensure close-on-exec */
3596 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3601 Perl_croak(aTHX_ "sperl needs fd script\n"
3602 "You should not call sperl directly; do you need to "
3603 "change a #! line\nfrom sperl to perl?\n");
3606 * Do not open (or do other fancy stuff) while setuid.
3607 * Perl does the open, and hands script to suidperl on a fd;
3608 * suidperl only does some checks, sets up UIDs and re-execs
3609 * perl with that fd as it has always done.
3612 if (*suidscript != 1) {
3613 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3616 else if (PL_preprocess) {
3617 const char * const cpp_cfg = CPPSTDIN;
3618 SV * const cpp = newSVpvs("");
3619 SV * const cmd = newSV(0);
3621 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3622 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3623 if (strEQ(cpp_cfg, "cppstdin"))
3624 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3625 sv_catpv(cpp, cpp_cfg);
3628 sv_catpvs(sv, "-I");
3629 sv_catpv(sv,PRIVLIB_EXP);
3632 DEBUG_P(PerlIO_printf(Perl_debug_log,
3633 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3634 scriptname, SvPVX_const (cpp), SvPVX_const (sv),
3637 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
3644 cpp_discard_flag = "";
3646 cpp_discard_flag = "-C";
3650 perl = os2_execname(aTHX);
3652 perl = PL_origargv[0];
3656 /* This strips off Perl comments which might interfere with
3657 the C pre-processor, including #!. #line directives are
3658 deliberately stripped to avoid confusion with Perl's version
3659 of #line. FWP played some golf with it so it will fit
3660 into VMS's 255 character buffer.
3663 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3665 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3667 Perl_sv_setpvf(aTHX_ cmd, "\
3668 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3669 perl, quote, code, quote, scriptname, cpp,
3670 cpp_discard_flag, sv, CPPMINUS);
3672 PL_doextract = FALSE;
3674 DEBUG_P(PerlIO_printf(Perl_debug_log,
3675 "PL_preprocess: cmd=\"%s\"\n",
3678 PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
3682 else if (!*scriptname) {
3683 forbid_setid(0, *suidscript);
3684 PL_rsfp = PerlIO_stdin();
3687 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3688 # if defined(HAS_FCNTL) && defined(F_SETFD)
3690 /* ensure close-on-exec */
3691 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3694 #endif /* IAMSUID */
3696 /* PSz 16 Sep 03 Keep neat error message */
3698 Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3700 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3701 CopFILE(PL_curcop), Strerror(errno));
3707 * I_SYSSTATVFS HAS_FSTATVFS
3709 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3710 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3711 * here so that metaconfig picks them up. */
3715 S_fd_on_nosuid_fs(pTHX_ int fd)
3718 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3719 * but is needed also on machines without setreuid.
3720 * Seems safe enough to run as root.
3722 int check_okay = 0; /* able to do all the required sys/libcalls */
3723 int on_nosuid = 0; /* the fd is on a nosuid fs */
3725 * Need to check noexec also: nosuid might not be set, the average
3726 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3728 int on_noexec = 0; /* the fd is on a noexec fs */
3731 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3732 * fstatvfs() is UNIX98.
3733 * fstatfs() is 4.3 BSD.
3734 * ustat()+getmnt() is pre-4.3 BSD.
3735 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3736 * an irrelevant filesystem while trying to reach the right one.
3739 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3741 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3742 defined(HAS_FSTATVFS)
3743 # define FD_ON_NOSUID_CHECK_OKAY
3744 struct statvfs stfs;
3746 check_okay = fstatvfs(fd, &stfs) == 0;
3747 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
3749 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3750 on platforms where it is present. */
3751 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3753 # endif /* fstatvfs */
3755 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3756 defined(PERL_MOUNT_NOSUID) && \
3757 defined(PERL_MOUNT_NOEXEC) && \
3758 defined(HAS_FSTATFS) && \
3759 defined(HAS_STRUCT_STATFS) && \
3760 defined(HAS_STRUCT_STATFS_F_FLAGS)
3761 # define FD_ON_NOSUID_CHECK_OKAY
3764 check_okay = fstatfs(fd, &stfs) == 0;
3765 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3766 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3767 # endif /* fstatfs */
3769 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3770 defined(PERL_MOUNT_NOSUID) && \
3771 defined(PERL_MOUNT_NOEXEC) && \
3772 defined(HAS_FSTAT) && \
3773 defined(HAS_USTAT) && \
3774 defined(HAS_GETMNT) && \
3775 defined(HAS_STRUCT_FS_DATA) && \
3777 # define FD_ON_NOSUID_CHECK_OKAY
3780 if (fstat(fd, &fdst) == 0) {
3782 if (ustat(fdst.st_dev, &us) == 0) {
3784 /* NOSTAT_ONE here because we're not examining fields which
3785 * vary between that case and STAT_ONE. */
3786 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3787 size_t cmplen = sizeof(us.f_fname);
3788 if (sizeof(fsd.fd_req.path) < cmplen)
3789 cmplen = sizeof(fsd.fd_req.path);
3790 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3791 fdst.st_dev == fsd.fd_req.dev) {
3793 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3794 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3799 # endif /* fstat+ustat+getmnt */
3801 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3802 defined(HAS_GETMNTENT) && \
3803 defined(HAS_HASMNTOPT) && \
3804 defined(MNTOPT_NOSUID) && \
3805 defined(MNTOPT_NOEXEC)
3806 # define FD_ON_NOSUID_CHECK_OKAY
3807 FILE *mtab = fopen("/etc/mtab", "r");
3808 struct mntent *entry;
3811 if (mtab && (fstat(fd, &stb) == 0)) {
3812 while (entry = getmntent(mtab)) {
3813 if (stat(entry->mnt_dir, &fsb) == 0
3814 && fsb.st_dev == stb.st_dev)
3816 /* found the filesystem */
3818 if (hasmntopt(entry, MNTOPT_NOSUID))
3820 if (hasmntopt(entry, MNTOPT_NOEXEC))
3823 } /* A single fs may well fail its stat(). */
3828 # endif /* getmntent+hasmntopt */
3831 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3833 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3835 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3836 return ((!check_okay) || on_nosuid || on_noexec);
3838 #endif /* IAMSUID */
3841 S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
3842 int fdscript, int suidscript)
3847 #endif /* IAMSUID */
3849 /* do we need to emulate setuid on scripts? */
3851 /* This code is for those BSD systems that have setuid #! scripts disabled
3852 * in the kernel because of a security problem. Merely defining DOSUID
3853 * in perl will not fix that problem, but if you have disabled setuid
3854 * scripts in the kernel, this will attempt to emulate setuid and setgid
3855 * on scripts that have those now-otherwise-useless bits set. The setuid
3856 * root version must be called suidperl or sperlN.NNN. If regular perl
3857 * discovers that it has opened a setuid script, it calls suidperl with
3858 * the same argv that it had. If suidperl finds that the script it has
3859 * just opened is NOT setuid root, it sets the effective uid back to the
3860 * uid. We don't just make perl setuid root because that loses the
3861 * effective uid we had before invoking perl, if it was different from the
3864 * Description/comments above do not match current workings:
3865 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3866 * suidperl called with script open and name changed to /dev/fd/N/X;
3867 * suidperl croaks if script is not setuid;
3868 * making perl setuid would be a huge security risk (and yes, that
3869 * would lose any euid we might have had).
3871 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3872 * be defined in suidperl only. suidperl must be setuid root. The
3873 * Configure script will set this up for you if you want it.
3879 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3880 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3881 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3883 const char *linestr;
3887 if (fdscript < 0 || suidscript != 1)
3888 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3890 * Since the script is opened by perl, not suidperl, some of these
3891 * checks are superfluous. Leaving them in probably does not lower
3895 * Do checks even for systems with no HAS_SETREUID.
3896 * We used to swap, then re-swap UIDs with
3898 if (setreuid(PL_euid,PL_uid) < 0
3899 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3900 Perl_croak(aTHX_ "Can't swap uid and euid");
3903 if (setreuid(PL_uid,PL_euid) < 0
3904 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3905 Perl_croak(aTHX_ "Can't reswap uid and euid");
3909 /* On this access check to make sure the directories are readable,
3910 * there is actually a small window that the user could use to make
3911 * filename point to an accessible directory. So there is a faint
3912 * chance that someone could execute a setuid script down in a
3913 * non-accessible directory. I don't know what to do about that.
3914 * But I don't think it's too important. The manual lies when
3915 * it says access() is useful in setuid programs.
3917 * So, access() is pretty useless... but not harmful... do anyway.
3919 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3920 Perl_croak(aTHX_ "Can't access() script\n");
3923 /* If we can swap euid and uid, then we can determine access rights
3924 * with a simple stat of the file, and then compare device and
3925 * inode to make sure we did stat() on the same file we opened.
3926 * Then we just have to make sure he or she can execute it.
3929 * As the script is opened by perl, not suidperl, we do not need to
3930 * care much about access rights.
3932 * The 'script changed' check is needed, or we can get lied to
3933 * about $0 with e.g.
3934 * suidperl /dev/fd/4//bin/x 4<setuidscript
3935 * Without HAS_SETREUID, is it safe to stat() as root?
3937 * Are there any operating systems that pass /dev/fd/xxx for setuid
3938 * scripts, as suggested/described in perlsec(1)? Surely they do not
3939 * pass the script name as we do, so the "script changed" test would
3940 * fail for them... but we never get here with
3941 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3943 * This is one place where we must "lie" about return status: not
3944 * say if the stat() failed. We are doing this as root, and could
3945 * be tricked into reporting existence or not of files that the
3946 * "plain" user cannot even see.
3950 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3951 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3952 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3953 Perl_croak(aTHX_ "Setuid script changed\n");
3957 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3958 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3961 * We used to do this check as the "plain" user (after swapping
3962 * UIDs). But the check for nosuid and noexec filesystem is needed,
3963 * and should be done even without HAS_SETREUID. (Maybe those
3964 * operating systems do not have such mount options anyway...)
3965 * Seems safe enough to do as root.
3967 #if !defined(NO_NOSUID_CHECK)
3968 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3969 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3972 #endif /* IAMSUID */
3974 if (!S_ISREG(PL_statbuf.st_mode)) {
3975 Perl_croak(aTHX_ "Setuid script not plain file\n");
3977 if (PL_statbuf.st_mode & S_IWOTH)
3978 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3979 PL_doswitches = FALSE; /* -s is insecure in suid */
3980 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
3981 CopLINE_inc(PL_curcop);
3982 if (sv_gets(PL_linestr, PL_rsfp, 0) == NULL)
3983 Perl_croak(aTHX_ "No #! line");
3984 linestr = SvPV_nolen_const(PL_linestr);
3985 /* required even on Sys V */
3986 if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
3987 Perl_croak(aTHX_ "No #! line");
3991 /* Sanity check on line length */
3992 s_end = s + strlen(s);
3993 if (s_end == s || (s_end - s) > 4000)
3994 Perl_croak(aTHX_ "Very long #! line");
3995 /* Allow more than a single space after #! */
3996 while (isSPACE(*s)) s++;
3997 /* Sanity check on buffer end */
3998 while ((*s) && !isSPACE(*s)) s++;
3999 for (s2 = s; (s2 > linestr &&
4000 (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
4001 || s2[-1] == '-')); s2--) ;
4002 /* Sanity check on buffer start */
4003 if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
4004 (s-9 < linestr || strnNE(s-9,"perl",4)) )
4005 Perl_croak(aTHX_ "Not a perl script");
4006 while (*s == ' ' || *s == '\t') s++;
4008 * #! arg must be what we saw above. They can invoke it by
4009 * mentioning suidperl explicitly, but they may not add any strange
4010 * arguments beyond what #! says if they do invoke suidperl that way.
4013 * The way validarg was set up, we rely on the kernel to start
4014 * scripts with argv[1] set to contain all #! line switches (the
4018 * Check that we got all the arguments listed in the #! line (not
4019 * just that there are no extraneous arguments). Might not matter
4020 * much, as switches from #! line seem to be acted upon (also), and
4021 * so may be checked and trapped in perl. But, security checks must
4022 * be done in suidperl and not deferred to perl. Note that suidperl
4023 * does not get around to parsing (and checking) the switches on
4024 * the #! line (but execs perl sooner).
4025 * Allow (require) a trailing newline (which may be of two
4026 * characters on some architectures?) (but no other trailing
4029 len = strlen(validarg);
4030 if (strEQ(validarg," PHOOEY ") ||
4031 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
4032 !((s_end - s) == len+1
4033 || ((s_end - s) == len+2 && isSPACE(s[len+1]))))
4034 Perl_croak(aTHX_ "Args must match #! line");
4038 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
4039 PL_euid == PL_statbuf.st_uid)
4041 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4042 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
4043 #endif /* IAMSUID */
4046 PL_euid) { /* oops, we're not the setuid root perl */
4048 * When root runs a setuid script, we do not go through the same
4049 * steps of execing sperl and then perl with fd scripts, but
4050 * simply set up UIDs within the same perl invocation; so do
4051 * not have the same checks (on options, whatever) that we have
4052 * for plain users. No problem really: would have to be a script
4053 * that does not actually work for plain users; and if root is
4054 * foolish and can be persuaded to run such an unsafe script, he
4055 * might run also non-setuid ones, and deserves what he gets.
4057 * Or, we might drop the PL_euid check above (and rely just on
4058 * fdscript to avoid loops), and do the execs
4064 * Pass fd script to suidperl.
4065 * Exec suidperl, substituting fd script for scriptname.
4066 * Pass script name as "subdir" of fd, which perl will grok;
4067 * in fact will use that to distinguish this from "normal"
4068 * usage, see comments above.
4070 PerlIO_rewind(PL_rsfp);
4071 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
4072 /* PSz 27 Feb 04 Sanity checks on scriptname */
4073 if ((!scriptname) || (!*scriptname) ) {
4074 Perl_croak(aTHX_ "No setuid script name\n");
4076 if (*scriptname == '-') {
4077 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
4078 /* Or we might confuse it with an option when replacing
4079 * name in argument list, below (though we do pointer, not
4080 * string, comparisons).
4083 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
4084 if (!PL_origargv[which]) {
4085 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
4087 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
4088 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
4089 #if defined(HAS_FCNTL) && defined(F_SETFD)
4090 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
4093 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
4094 (int)PERL_REVISION, (int)PERL_VERSION,
4095 (int)PERL_SUBVERSION), PL_origargv);
4097 #endif /* IAMSUID */
4098 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
4101 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
4103 * This seems back to front: we try HAS_SETEGID first; if not available
4104 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
4105 * in the sense that we only want to set EGID; but are there any machines
4106 * with either of the latter, but not the former? Same with UID, later.
4109 (void)setegid(PL_statbuf.st_gid);
4112 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
4114 #ifdef HAS_SETRESGID
4115 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
4117 PerlProc_setgid(PL_statbuf.st_gid);
4121 if (PerlProc_getegid() != PL_statbuf.st_gid)
4122 Perl_croak(aTHX_ "Can't do setegid!\n");
4124 if (PL_statbuf.st_mode & S_ISUID) {
4125 if (PL_statbuf.st_uid != PL_euid)
4127 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
4130 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
4132 #ifdef HAS_SETRESUID
4133 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
4135 PerlProc_setuid(PL_statbuf.st_uid);
4139 if (PerlProc_geteuid() != PL_statbuf.st_uid)
4140 Perl_croak(aTHX_ "Can't do seteuid!\n");
4142 else if (PL_uid) { /* oops, mustn't run as root */
4144 (void)seteuid((Uid_t)PL_uid);
4147 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
4149 #ifdef HAS_SETRESUID
4150 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
4152 PerlProc_setuid((Uid_t)PL_uid);
4156 if (PerlProc_geteuid() != PL_uid)
4157 Perl_croak(aTHX_ "Can't do seteuid!\n");
4160 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
4161 Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
4164 else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
4165 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
4166 else if (fdscript < 0 || suidscript != 1)
4167 /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
4168 Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
4170 /* PSz 16 Sep 03 Keep neat error message */
4171 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
4174 /* We absolutely must clear out any saved ids here, so we */
4175 /* exec the real perl, substituting fd script for scriptname. */
4176 /* (We pass script name as "subdir" of fd, which perl will grok.) */
4178 * It might be thought that using setresgid and/or setresuid (changed to
4179 * set the saved IDs) above might obviate the need to exec, and we could
4180 * go on to "do the perl thing".
4182 * Is there such a thing as "saved GID", and is that set for setuid (but
4183 * not setgid) execution like suidperl? Without exec, it would not be
4184 * cleared for setuid (but not setgid) scripts (or might need a dummy
4187 * We need suidperl to do the exact same argument checking that perl
4188 * does. Thus it cannot be very small; while it could be significantly
4189 * smaller, it is safer (simpler?) to make it essentially the same
4190 * binary as perl (but they are not identical). - Maybe could defer that
4191 * check to the invoked perl, and suidperl be a tiny wrapper instead;
4192 * but prefer to do thorough checks in suidperl itself. Such deferral
4193 * would make suidperl security rely on perl, a design no-no.
4195 * Setuid things should be short and simple, thus easy to understand and
4196 * verify. They should do their "own thing", without influence by
4197 * attackers. It may help if their internal execution flow is fixed,
4198 * regardless of platform: it may be best to exec anyway.
4200 * Suidperl should at least be conceptually simple: a wrapper only,
4201 * never to do any real perl. Maybe we should put
4203 * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
4205 * into the perly bits.
4207 PerlIO_rewind(PL_rsfp);
4208 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
4210 * Keep original arguments: suidperl already has fd script.
4212 /* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
4213 /* if (!PL_origargv[which]) { */
4214 /* errno = EPERM; */
4215 /* Perl_croak(aTHX_ "Permission denied\n"); */
4217 /* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */
4218 /* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
4219 #if defined(HAS_FCNTL) && defined(F_SETFD)
4220 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
4223 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
4224 (int)PERL_REVISION, (int)PERL_VERSION,
4225 (int)PERL_SUBVERSION), PL_origargv);/* try again */
4227 Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
4228 #endif /* IAMSUID */
4230 PERL_UNUSED_ARG(fdscript);
4231 PERL_UNUSED_ARG(suidscript);
4232 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
4233 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
4234 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
4235 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
4237 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
4240 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4241 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4242 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4243 /* not set-id, must be wrapped */
4246 PERL_UNUSED_ARG(validarg);
4247 PERL_UNUSED_ARG(scriptname);
4251 S_find_beginning(pTHX)
4255 register const char *s2;
4256 #ifdef MACOS_TRADITIONAL
4260 /* skip forward in input to the real script? */
4262 #ifdef MACOS_TRADITIONAL
4263 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
4265 while (PL_doextract || gMacPerl_AlwaysExtract) {
4266 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
4267 if (!gMacPerl_AlwaysExtract)
4268 Perl_croak(aTHX_ "No Perl script found in input\n");
4270 if (PL_doextract) /* require explicit override ? */
4271 if (!OverrideExtract(PL_origfilename))
4272 Perl_croak(aTHX_ "User aborted script\n");
4274 PL_doextract = FALSE;
4276 /* Pater peccavi, file does not have #! */
4277 PerlIO_rewind(PL_rsfp);
4282 while (PL_doextract) {
4283 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == NULL)
4284 Perl_croak(aTHX_ "No Perl script found in input\n");
4287 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
4288 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
4289 PL_doextract = FALSE;
4290 while (*s && !(isSPACE (*s) || *s == '#')) s++;
4292 while (*s == ' ' || *s == '\t') s++;
4294 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4295 || s2[-1] == '_') s2--;
4296 if (strnEQ(s2-4,"perl",4))
4297 while ((s = moreswitches(s)))
4300 #ifdef MACOS_TRADITIONAL
4301 /* We are always searching for the #!perl line in MacPerl,
4302 * so if we find it, still keep the line count correct
4303 * by counting lines we already skipped over
4305 for (; maclines > 0 ; maclines--)
4306 PerlIO_ungetc(PL_rsfp, '\n');
4310 /* gMacPerl_AlwaysExtract is false in MPW tool */
4311 } else if (gMacPerl_AlwaysExtract) {
4323 PL_uid = PerlProc_getuid();
4324 PL_euid = PerlProc_geteuid();
4325 PL_gid = PerlProc_getgid();
4326 PL_egid = PerlProc_getegid();
4328 PL_uid |= PL_gid << 16;
4329 PL_euid |= PL_egid << 16;
4331 /* Should not happen: */
4332 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4333 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4336 * Should go by suidscript, not uid!=euid: why disallow
4337 * system("ls") in scripts run from setuid things?
4338 * Or, is this run before we check arguments and set suidscript?
4339 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4340 * (We never have suidscript, can we be sure to have fdscript?)
4341 * Or must then go by UID checks? See comments in forbid_setid also.
4345 /* This is used very early in the lifetime of the program,
4346 * before even the options are parsed, so PL_tainting has
4347 * not been initialized properly. */
4349 Perl_doing_taint(int argc, char *argv[], char *envp[])
4351 #ifndef PERL_IMPLICIT_SYS
4352 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4353 * before we have an interpreter-- and the whole point of this
4354 * function is to be called at such an early stage. If you are on
4355 * a system with PERL_IMPLICIT_SYS but you do have a concept of
4356 * "tainted because running with altered effective ids', you'll
4357 * have to add your own checks somewhere in here. The two most
4358 * known samples of 'implicitness' are Win32 and NetWare, neither
4359 * of which has much of concept of 'uids'. */
4360 int uid = PerlProc_getuid();
4361 int euid = PerlProc_geteuid();
4362 int gid = PerlProc_getgid();
4363 int egid = PerlProc_getegid();
4370 if (uid && (euid != uid || egid != gid))
4372 #endif /* !PERL_IMPLICIT_SYS */
4373 /* This is a really primitive check; environment gets ignored only
4374 * if -T are the first chars together; otherwise one gets
4375 * "Too late" message. */
4376 if ( argc > 1 && argv[1][0] == '-'
4377 && (argv[1][1] == 't' || argv[1][1] == 'T') )
4382 /* Passing the flag as a single char rather than a string is a slight space
4383 optimisation. The only message that isn't /^-.$/ is
4384 "program input from stdin", which is substituted in place of '\0', which
4385 could never be a command line flag. */
4387 S_forbid_setid(pTHX_ const char flag, const int suidscript)
4390 char string[3] = "-x";
4391 const char *message = "program input from stdin";
4398 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4399 if (PL_euid != PL_uid)
4400 Perl_croak(aTHX_ "No %s allowed while running setuid", message);
4401 if (PL_egid != PL_gid)
4402 Perl_croak(aTHX_ "No %s allowed while running setgid", message);
4403 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4405 * Checks for UID/GID above "wrong": why disallow
4406 * perl -e 'print "Hello\n"'
4407 * from within setuid things?? Simply drop them: replaced by
4408 * fdscript/suidscript and #ifdef IAMSUID checks below.
4410 * This may be too late for command-line switches. Will catch those on
4411 * the #! line, after finding the script name and setting up
4412 * fdscript/suidscript. Note that suidperl does not get around to
4413 * parsing (and checking) the switches on the #! line, but checks that
4414 * the two sets are identical.
4416 * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
4417 * instead, or would that be "too late"? (We never have suidscript, can
4418 * we be sure to have fdscript?)
4420 * Catch things with suidscript (in descendant of suidperl), even with
4421 * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
4422 * below; but I am paranoid.
4424 * Also see comments about root running a setuid script, elsewhere.
4426 if (suidscript >= 0)
4427 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
4429 /* PSz 11 Nov 03 Catch it in suidperl, always! */
4430 Perl_croak(aTHX_ "No %s allowed in suidperl", message);
4431 #endif /* IAMSUID */
4435 Perl_init_debugger(pTHX)
4438 HV * const ostash = PL_curstash;
4440 PL_curstash = PL_debstash;
4441 PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", GV_ADDMULTI,
4443 AvREAL_off(PL_dbargs);
4444 PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
4445 PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4446 PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
4447 PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4448 sv_setiv(PL_DBsingle, 0);
4449 PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4450 sv_setiv(PL_DBtrace, 0);
4451 PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4452 sv_setiv(PL_DBsignal, 0);
4453 PL_DBassertion = GvSV((gv_fetchpvs("DB::assertion", GV_ADDMULTI, SVt_PV)));
4454 sv_setiv(PL_DBassertion, 0);
4455 PL_curstash = ostash;
4458 #ifndef STRESS_REALLOC
4459 #define REASONABLE(size) (size)
4461 #define REASONABLE(size) (1) /* unreasonable */
4465 Perl_init_stacks(pTHX)
4468 /* start with 128-item stack and 8K cxstack */
4469 PL_curstackinfo = new_stackinfo(REASONABLE(128),
4470 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4471 PL_curstackinfo->si_type = PERLSI_MAIN;
4472 PL_curstack = PL_curstackinfo->si_stack;
4473 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
4475 PL_stack_base = AvARRAY(PL_curstack);
4476 PL_stack_sp = PL_stack_base;
4477 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4479 Newx(PL_tmps_stack,REASONABLE(128),SV*);
4482 PL_tmps_max = REASONABLE(128);
4484 Newx(PL_markstack,REASONABLE(32),I32);
4485 PL_markstack_ptr = PL_markstack;
4486 PL_markstack_max = PL_markstack + REASONABLE(32);
4490 Newx(PL_scopestack,REASONABLE(32),I32);
4491 PL_scopestack_ix = 0;
4492 PL_scopestack_max = REASONABLE(32);
4494 Newx(PL_savestack,REASONABLE(128),ANY);
4495 PL_savestack_ix = 0;
4496 PL_savestack_max = REASONABLE(128);
4505 while (PL_curstackinfo->si_next)
4506 PL_curstackinfo = PL_curstackinfo->si_next;
4507 while (PL_curstackinfo) {
4508 PERL_SI *p = PL_curstackinfo->si_prev;
4509 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4510 Safefree(PL_curstackinfo->si_cxstack);
4511 Safefree(PL_curstackinfo);
4512 PL_curstackinfo = p;
4514 Safefree(PL_tmps_stack);
4515 Safefree(PL_markstack);
4516 Safefree(PL_scopestack);
4517 Safefree(PL_savestack);
4527 lex_start(PL_linestr);
4529 PL_subname = newSVpvs("main");
4533 S_init_predump_symbols(pTHX)
4539 sv_setpvn(get_sv("\"", TRUE), " ", 1);
4540 PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4541 GvMULTI_on(PL_stdingv);
4542 io = GvIOp(PL_stdingv);
4543 IoTYPE(io) = IoTYPE_RDONLY;
4544 IoIFP(io) = PerlIO_stdin();
4545 tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4547 GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
4549 tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4552 IoTYPE(io) = IoTYPE_WRONLY;
4553 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4555 tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4557 GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
4559 PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4560 GvMULTI_on(PL_stderrgv);
4561 io = GvIOp(PL_stderrgv);
4562 IoTYPE(io) = IoTYPE_WRONLY;
4563 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4564 tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4566 GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io);
4568 PL_statname = newSV(0); /* last filename we did stat on */
4570 Safefree(PL_osname);
4571 PL_osname = savepv(OSNAME);
4575 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4578 argc--,argv++; /* skip name of script */
4579 if (PL_doswitches) {
4580 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4584 if (argv[0][1] == '-' && !argv[0][2]) {
4588 if ((s = strchr(argv[0], '='))) {
4589 const char *const start_name = argv[0] + 1;
4590 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4591 TRUE, SVt_PV)), s + 1);
4594 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4597 if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4598 GvMULTI_on(PL_argvgv);
4599 (void)gv_AVadd(PL_argvgv);
4600 av_clear(GvAVn(PL_argvgv));
4601 for (; argc > 0; argc--,argv++) {
4602 SV * const sv = newSVpv(argv[0],0);
4603 av_push(GvAVn(PL_argvgv),sv);
4604 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4605 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4608 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4609 (void)sv_utf8_decode(sv);
4615 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4620 PL_toptarget = newSV(0);
4621 sv_upgrade(PL_toptarget, SVt_PVFM);
4622 sv_setpvn(PL_toptarget, "", 0);
4623 PL_bodytarget = newSV(0);
4624 sv_upgrade(PL_bodytarget, SVt_PVFM);
4625 sv_setpvn(PL_bodytarget, "", 0);
4626 PL_formtarget = PL_bodytarget;
4630 init_argv_symbols(argc,argv);
4632 if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4633 #ifdef MACOS_TRADITIONAL
4634 /* $0 is not majick on a Mac */
4635 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4637 sv_setpv(GvSV(tmpgv),PL_origfilename);
4638 magicname("0", "0", 1);
4641 if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4643 GvMULTI_on(PL_envgv);
4644 hv = GvHVn(PL_envgv);
4645 hv_magic(hv, NULL, PERL_MAGIC_env);
4647 #ifdef USE_ENVIRON_ARRAY
4648 /* Note that if the supplied env parameter is actually a copy
4649 of the global environ then it may now point to free'd memory
4650 if the environment has been modified since. To avoid this
4651 problem we treat env==NULL as meaning 'use the default'
4656 # ifdef USE_ITHREADS
4657 && PL_curinterp == aTHX
4664 char** origenv = environ;
4667 for (; *env; env++) {
4668 if (!(s = strchr(*env,'=')) || s == *env)
4670 #if defined(MSDOS) && !defined(DJGPP)
4675 sv = newSVpv(s+1, 0);
4676 (void)hv_store(hv, *env, s - *env, sv, 0);
4679 if (origenv != environ) {
4680 /* realloc has shifted us */
4681 env = (env - origenv) + environ;
4686 #endif /* USE_ENVIRON_ARRAY */
4687 #endif /* !PERL_MICRO */
4690 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4691 SvREADONLY_off(GvSV(tmpgv));
4692 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4693 SvREADONLY_on(GvSV(tmpgv));
4695 #ifdef THREADS_HAVE_PIDS
4696 PL_ppid = (IV)getppid();
4699 /* touch @F array to prevent spurious warnings 20020415 MJD */
4701 (void) get_av("main::F", TRUE | GV_ADDMULTI);
4703 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4704 (void) get_av("main::-", TRUE | GV_ADDMULTI);
4705 (void) get_av("main::+", TRUE | GV_ADDMULTI);
4709 S_init_perllib(pTHX)
4715 s = PerlEnv_getenv("PERL5LIB");
4717 * It isn't possible to delete an environment variable with
4718 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4719 * case we treat PERL5LIB as undefined if it has a zero-length value.
4721 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4722 if (s && *s != '\0')
4726 incpush(s, TRUE, TRUE, TRUE, FALSE);
4728 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
4730 /* Treat PERL5?LIB as a possible search list logical name -- the
4731 * "natural" VMS idiom for a Unix path string. We allow each
4732 * element to be a set of |-separated directories for compatibility.
4736 if (my_trnlnm("PERL5LIB",buf,0))
4737 do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4739 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
4743 /* Use the ~-expanded versions of APPLLIB (undocumented),
4744 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4747 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
4751 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4753 #ifdef MACOS_TRADITIONAL
4756 SV * privdir = newSV(0);
4757 char * macperl = PerlEnv_getenv("MACPERL");
4762 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4763 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4764 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4765 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4766 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4767 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4769 SvREFCNT_dec(privdir);
4772 incpush(":", FALSE, FALSE, TRUE, FALSE);
4775 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4778 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
4780 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4784 /* sitearch is always relative to sitelib on Windows for
4785 * DLL-based path intuition to work correctly */
4786 # if !defined(WIN32)
4787 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4793 /* this picks up sitearch as well */
4794 incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
4796 incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
4800 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4801 /* Search for version-specific dirs below here */
4802 incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
4805 #ifdef PERL_VENDORARCH_EXP
4806 /* vendorarch is always relative to vendorlib on Windows for
4807 * DLL-based path intuition to work correctly */
4808 # if !defined(WIN32)
4809 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4813 #ifdef PERL_VENDORLIB_EXP
4815 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE); /* this picks up vendorarch as well */
4817 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4821 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4822 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
4825 #ifdef PERL_OTHERLIBDIRS
4826 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
4830 incpush(".", FALSE, FALSE, TRUE, FALSE);
4831 #endif /* MACOS_TRADITIONAL */
4834 #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
4835 # define PERLLIB_SEP ';'
4838 # define PERLLIB_SEP '|'
4840 # if defined(MACOS_TRADITIONAL)
4841 # define PERLLIB_SEP ','
4843 # define PERLLIB_SEP ':'
4847 #ifndef PERLLIB_MANGLE
4848 # define PERLLIB_MANGLE(s,n) (s)
4851 /* Push a directory onto @INC if it exists.
4852 Generate a new SV if we do this, to save needing to copy the SV we push
4855 S_incpush_if_exists(pTHX_ SV *dir)
4859 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4860 S_ISDIR(tmpstatbuf.st_mode)) {
4861 av_push(GvAVn(PL_incgv), dir);
4868 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
4873 const char *p = dir;
4878 if (addsubdirs || addoldvers) {
4882 /* Break at all separators */
4884 SV *libdir = newSV(0);
4887 /* skip any consecutive separators */
4889 while ( *p == PERLLIB_SEP ) {
4890 /* Uncomment the next line for PATH semantics */
4891 /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4896 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != NULL ) {
4897 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4902 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4903 p = NULL; /* break out */
4905 #ifdef MACOS_TRADITIONAL
4906 if (!strchr(SvPVX(libdir), ':')) {
4909 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4911 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4912 sv_catpvs(libdir, ":");
4915 /* Do the if() outside the #ifdef to avoid warnings about an unused
4918 #ifdef PERL_RELOCATABLE_INC
4920 * Relocatable include entries are marked with a leading .../
4923 * 0: Remove that leading ".../"
4924 * 1: Remove trailing executable name (anything after the last '/')
4925 * from the perl path to give a perl prefix
4927 * While the @INC element starts "../" and the prefix ends with a real
4928 * directory (ie not . or ..) chop that real directory off the prefix
4929 * and the leading "../" from the @INC element. ie a logical "../"
4931 * Finally concatenate the prefix and the remainder of the @INC element
4932 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4933 * generates /usr/local/lib/perl5
4935 const char *libpath = SvPVX(libdir);
4936 STRLEN libpath_len = SvCUR(libdir);
4937 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4939 SV * const caret_X = get_sv("\030", 0);
4940 /* Going to use the SV just as a scratch buffer holding a C
4946 /* $^X is *the* source of taint if tainting is on, hence
4947 SvPOK() won't be true. */
4949 assert(SvPOKp(caret_X));
4950 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
4951 /* Firstly take off the leading .../
4952 If all else fail we'll do the paths relative to the current
4954 sv_chop(libdir, libpath + 4);
4955 /* Don't use SvPV as we're intentionally bypassing taining,
4956 mortal copies that the mg_get of tainting creates, and
4957 corruption that seems to come via the save stack.
4958 I guess that the save stack isn't correctly set up yet. */
4959 libpath = SvPVX(libdir);
4960 libpath_len = SvCUR(libdir);
4962 /* This would work more efficiently with memrchr, but as it's
4963 only a GNU extension we'd need to probe for it and
4964 implement our own. Not hard, but maybe not worth it? */
4966 prefix = SvPVX(prefix_sv);
4967 lastslash = strrchr(prefix, '/');
4969 /* First time in with the *lastslash = '\0' we just wipe off
4970 the trailing /perl from (say) /usr/foo/bin/perl
4974 while ((*lastslash = '\0'), /* Do that, come what may. */
4975 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4976 && (lastslash = strrchr(prefix, '/')))) {
4977 if (lastslash[1] == '\0'
4978 || (lastslash[1] == '.'
4979 && (lastslash[2] == '/' /* ends "/." */
4980 || (lastslash[2] == '/'
4981 && lastslash[3] == '/' /* or "/.." */
4983 /* Prefix ends "/" or "/." or "/..", any of which
4984 are fishy, so don't do any more logical cleanup.
4988 /* Remove leading "../" from path */
4991 /* Next iteration round the loop removes the last
4992 directory name from prefix by writing a '\0' in
4993 the while clause. */
4995 /* prefix has been terminated with a '\0' to the correct
4996 length. libpath points somewhere into the libdir SV.
4997 We need to join the 2 with '/' and drop the result into
4999 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
5000 SvREFCNT_dec(libdir);
5001 /* And this is the new libdir. */
5004 (PL_uid != PL_euid || PL_gid != PL_egid)) {
5005 /* Need to taint reloccated paths if running set ID */
5006 SvTAINTED_on(libdir);
5009 SvREFCNT_dec(prefix_sv);
5014 * BEFORE pushing libdir onto @INC we may first push version- and
5015 * archname-specific sub-directories.
5017 if (addsubdirs || addoldvers) {
5018 #ifdef PERL_INC_VERSION_LIST
5019 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
5020 const char * const incverlist[] = { PERL_INC_VERSION_LIST };
5021 const char * const *incver;
5027 if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
5029 while (unix[len-1] == '/') len--; /* Cosmetic */
5030 sv_usepvn(libdir,unix,len);
5033 PerlIO_printf(Perl_error_log,
5034 "Failed to unixify @INC element \"%s\"\n",
5038 #ifdef MACOS_TRADITIONAL
5039 #define PERL_AV_SUFFIX_FMT ""
5040 #define PERL_ARCH_FMT "%s:"
5041 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
5043 #define PERL_AV_SUFFIX_FMT "/"
5044 #define PERL_ARCH_FMT "/%s"
5045 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
5047 /* .../version/archname if -d .../version/archname */
5048 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
5050 (int)PERL_REVISION, (int)PERL_VERSION,
5051 (int)PERL_SUBVERSION, ARCHNAME);
5052 subdir = S_incpush_if_exists(aTHX_ subdir);
5054 /* .../version if -d .../version */
5055 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
5056 (int)PERL_REVISION, (int)PERL_VERSION,
5057 (int)PERL_SUBVERSION);
5058 subdir = S_incpush_if_exists(aTHX_ subdir);
5060 /* .../archname if -d .../archname */
5061 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
5062 subdir = S_incpush_if_exists(aTHX_ subdir);
5066 #ifdef PERL_INC_VERSION_LIST
5068 for (incver = incverlist; *incver; incver++) {
5069 /* .../xxx if -d .../xxx */
5070 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
5071 subdir = S_incpush_if_exists(aTHX_ subdir);
5077 /* finally push this lib directory on the end of @INC */
5078 av_push(GvAVn(PL_incgv), libdir);
5081 assert (SvREFCNT(subdir) == 1);
5082 SvREFCNT_dec(subdir);
5088 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
5092 const line_t oldline = CopLINE(PL_curcop);
5098 while (av_len(paramList) >= 0) {
5099 cv = (CV*)av_shift(paramList);
5101 if (paramList == PL_beginav) {
5102 /* save PL_beginav for compiler */
5103 if (! PL_beginav_save)
5104 PL_beginav_save = newAV();
5105 av_push(PL_beginav_save, (SV*)cv);
5107 else if (paramList == PL_checkav) {
5108 /* save PL_checkav for compiler */
5109 if (! PL_checkav_save)
5110 PL_checkav_save = newAV();
5111 av_push(PL_checkav_save, (SV*)cv);
5122 PL_madskills |= 16384;
5127 PL_madskills &= ~16384;
5130 (void)SvPV_const(atsv, len);
5131 if (PL_madskills && PL_minus_c && paramList == PL_beginav)
5132 break; /* not really trying to run, so just wing it */
5134 PL_curcop = &PL_compiling;
5135 CopLINE_set(PL_curcop, oldline);
5136 if (paramList == PL_beginav)
5137 sv_catpvs(atsv, "BEGIN failed--compilation aborted");
5139 Perl_sv_catpvf(aTHX_ atsv,
5140 "%s failed--call queue aborted",
5141 paramList == PL_checkav ? "CHECK"
5142 : paramList == PL_initav ? "INIT"
5144 while (PL_scopestack_ix > oldscope)
5147 Perl_croak(aTHX_ "%"SVf"", atsv);
5154 /* my_exit() was called */
5155 while (PL_scopestack_ix > oldscope)
5158 PL_curstash = PL_defstash;
5159 PL_curcop = &PL_compiling;
5160 CopLINE_set(PL_curcop, oldline);
5162 if (PL_madskills && PL_minus_c && paramList == PL_beginav)
5163 return; /* not really trying to run, so just wing it */
5164 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
5165 if (paramList == PL_beginav)
5166 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
5168 Perl_croak(aTHX_ "%s failed--call queue aborted",
5169 paramList == PL_checkav ? "CHECK"
5170 : paramList == PL_initav ? "INIT"
5177 PL_curcop = &PL_compiling;
5178 CopLINE_set(PL_curcop, oldline);
5181 PerlIO_printf(Perl_error_log, "panic: restartop\n");
5190 S_call_list_body(pTHX_ CV *cv)
5193 PUSHMARK(PL_stack_sp);
5194 call_sv((SV*)cv, G_EVAL|G_DISCARD);
5199 Perl_my_exit(pTHX_ U32 status)
5202 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
5203 thr, (unsigned long) status));
5212 STATUS_EXIT_SET(status);
5219 Perl_my_failure_exit(pTHX)
5223 /* We have been called to fall on our sword. The desired exit code
5224 * should be already set in STATUS_UNIX, but could be shifted over
5225 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
5228 * If an error code has not been set, then force the issue.
5230 if (MY_POSIX_EXIT) {
5232 /* In POSIX_EXIT mode follow Perl documentations and use 255 for
5233 * the exit code when there isn't an error.
5236 if (STATUS_UNIX == 0)
5237 STATUS_UNIX_EXIT_SET(255);
5239 STATUS_UNIX_EXIT_SET(STATUS_UNIX);
5241 /* The exit code could have been set by $? or vmsish which
5242 * means that it may not be fatal. So convert
5243 * success/warning codes to fatal.
5245 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0)
5246 STATUS_UNIX_EXIT_SET(255);
5250 /* Traditionally Perl on VMS always expects a Fatal Error. */
5251 if (vaxc$errno & 1) {
5253 /* So force success status to failure */
5254 if (STATUS_NATIVE & 1)
5259 STATUS_UNIX = EINTR; /* In case something cares */
5264 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5266 /* Encode the severity code */
5267 severity = STATUS_NATIVE & STS$M_SEVERITY;
5268 STATUS_UNIX = (severity ? severity : 1) << 8;
5270 /* Perl expects this to be a fatal error */
5271 if (severity != STS$K_SEVERE)
5280 STATUS_UNIX_SET(errno);
5282 exitstatus = STATUS_UNIX >> 8;
5283 if (exitstatus & 255)
5284 STATUS_UNIX_SET(exitstatus);
5286 STATUS_UNIX_SET(255);
5293 S_my_exit_jump(pTHX)
5298 SvREFCNT_dec(PL_e_script);
5302 POPSTACK_TO(PL_mainstack);
5310 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5313 const char * const p = SvPVX_const(PL_e_script);
5314 const char *nl = strchr(p, '\n');
5316 PERL_UNUSED_ARG(idx);
5317 PERL_UNUSED_ARG(maxlen);
5319 nl = (nl) ? nl+1 : SvEND(PL_e_script);
5321 filter_del(read_e_script);
5324 sv_catpvn(buf_sv, p, nl-p);
5325 sv_chop(PL_e_script, nl);
5331 * c-indentation-style: bsd
5333 * indent-tabs-mode: t
5336 * ex: set ts=8 sts=4 sw=4 noet: