3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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);
151 MUTEX_INIT(&PL_dollarzero_mutex);
155 PERL_SET_THX(my_perl);
159 #ifdef PERL_IMPLICIT_SYS
161 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
162 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
163 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
164 struct IPerlDir* ipD, struct IPerlSock* ipS,
165 struct IPerlProc* ipP)
167 PerlInterpreter *my_perl;
168 /* Newx() needs interpreter, so call malloc() instead */
169 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
170 S_init_tls_and_interp(my_perl);
171 Zero(my_perl, 1, PerlInterpreter);
187 =head1 Embedding Functions
189 =for apidoc perl_alloc
191 Allocates a new Perl interpreter. See L<perlembed>.
199 PerlInterpreter *my_perl;
201 /* Newx() needs interpreter, so call malloc() instead */
202 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
204 S_init_tls_and_interp(my_perl);
205 return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
207 #endif /* PERL_IMPLICIT_SYS */
210 =for apidoc perl_construct
212 Initializes a new Perl interpreter. See L<perlembed>.
218 perl_construct(pTHXx)
221 PERL_UNUSED_ARG(my_perl);
224 PL_perl_destruct_level = 1;
226 if (PL_perl_destruct_level > 0)
229 /* Init the real globals (and main thread)? */
231 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
233 PL_linestr = NEWSV(65,79);
234 sv_upgrade(PL_linestr,SVt_PVIV);
236 if (!SvREADONLY(&PL_sv_undef)) {
237 /* set read-only and try to insure than we wont see REFCNT==0
240 SvREADONLY_on(&PL_sv_undef);
241 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
243 sv_setpv(&PL_sv_no,PL_No);
244 /* value lookup in void context - happens to have the side effect
245 of caching the numeric forms. */
248 SvREADONLY_on(&PL_sv_no);
249 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
251 sv_setpv(&PL_sv_yes,PL_Yes);
254 SvREADONLY_on(&PL_sv_yes);
255 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
257 SvREADONLY_on(&PL_sv_placeholder);
258 SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
261 PL_sighandlerp = (Sighandler_t) Perl_sighandler;
262 #ifdef PERL_USES_PL_PIDSTATUS
263 PL_pidstatus = newHV();
267 PL_rs = newSVpvn("\n", 1);
272 PL_lex_state = LEX_NOTPARSING;
278 SET_NUMERIC_STANDARD();
280 #if defined(LOCAL_PATCH_COUNT)
281 PL_localpatches = local_patches; /* For possible -v */
284 #ifdef HAVE_INTERP_INTERN
288 PerlIO_init(aTHX); /* Hook to IO system */
290 PL_fdpid = newAV(); /* for remembering popen pids by fd */
291 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
292 PL_errors = newSVpvn("",0);
293 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
294 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
295 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
297 PL_regex_padav = newAV();
298 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
299 PL_regex_pad = AvARRAY(PL_regex_padav);
301 #ifdef USE_REENTRANT_API
302 Perl_reentrant_init(aTHX);
305 /* Note that strtab is a rather special HV. Assumptions are made
306 about not iterating on it, and not adding tie magic to it.
307 It is properly deallocated in perl_destruct() */
310 HvSHAREKEYS_off(PL_strtab); /* mandatory */
311 hv_ksplit(PL_strtab, 512);
313 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
314 _dyld_lookup_and_bind
315 ("__environ", (unsigned long *) &environ_pointer, NULL);
319 # ifdef USE_ENVIRON_ARRAY
320 PL_origenviron = environ;
324 /* Use sysconf(_SC_CLK_TCK) if available, if not
325 * available or if the sysconf() fails, use the HZ.
326 * BeOS has those, but returns the wrong value.
327 * The HZ if not originally defined has been by now
328 * been defined as CLK_TCK, if available. */
329 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
330 PL_clocktick = sysconf(_SC_CLK_TCK);
331 if (PL_clocktick <= 0)
335 PL_stashcache = newHV();
337 PL_patchlevel = Perl_newSVpvf(aTHX_ "%d.%d.%d", (int)PERL_REVISION,
338 (int)PERL_VERSION, (int)PERL_SUBVERSION);
341 if (!PL_mmap_page_size) {
342 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
344 SETERRNO(0, SS_NORMAL);
346 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
348 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
350 if ((long) PL_mmap_page_size < 0) {
352 SV * const error = ERRSV;
353 (void) SvUPGRADE(error, SVt_PV);
354 Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
357 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
361 # ifdef HAS_GETPAGESIZE
362 PL_mmap_page_size = getpagesize();
364 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
365 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
369 if (PL_mmap_page_size <= 0)
370 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
371 (IV) PL_mmap_page_size);
373 #endif /* HAS_MMAP */
375 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
376 PL_timesbase.tms_utime = 0;
377 PL_timesbase.tms_stime = 0;
378 PL_timesbase.tms_cutime = 0;
379 PL_timesbase.tms_cstime = 0;
386 =for apidoc nothreadhook
388 Stub that provides thread hook for perl_destruct when there are
395 Perl_nothreadhook(pTHX)
400 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
402 Perl_dump_sv_child(pTHX_ SV *sv)
405 const int sock = PL_dumper_fd;
406 const int debug_fd = PerlIO_fileno(Perl_debug_log);
407 union control_un control;
410 struct cmsghdr *cmptr;
412 unsigned char buffer[256];
414 if(sock == -1 || debug_fd == -1)
417 PerlIO_flush(Perl_debug_log);
419 /* All these shenanigans are to pass a file descriptor over to our child for
420 it to dump out to. We can't let it hold open the file descriptor when it
421 forks, as the file descriptor it will dump to can turn out to be one end
422 of pipe that some other process will wait on for EOF. (So as it would
423 be open, the wait would be forever. */
425 msg.msg_control = control.control;
426 msg.msg_controllen = sizeof(control.control);
427 /* We're a connected socket so we don't need a destination */
433 cmptr = CMSG_FIRSTHDR(&msg);
434 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
435 cmptr->cmsg_level = SOL_SOCKET;
436 cmptr->cmsg_type = SCM_RIGHTS;
437 *((int *)CMSG_DATA(cmptr)) = 1;
439 vec[0].iov_base = (void*)&sv;
440 vec[0].iov_len = sizeof(sv);
441 got = sendmsg(sock, &msg, 0);
444 perror("Debug leaking scalars parent sendmsg failed");
447 if(got < sizeof(sv)) {
448 perror("Debug leaking scalars parent short sendmsg");
452 /* Return protocol is
454 unsigned char: length of location string (0 for empty)
455 unsigned char*: string (not terminated)
457 vec[0].iov_base = (void*)&returned_errno;
458 vec[0].iov_len = sizeof(returned_errno);
459 vec[1].iov_base = buffer;
462 got = readv(sock, vec, 2);
465 perror("Debug leaking scalars parent read failed");
466 PerlIO_flush(PerlIO_stderr());
469 if(got < sizeof(returned_errno) + 1) {
470 perror("Debug leaking scalars parent short read");
471 PerlIO_flush(PerlIO_stderr());
476 got = read(sock, buffer + 1, *buffer);
478 perror("Debug leaking scalars parent read 2 failed");
479 PerlIO_flush(PerlIO_stderr());
484 perror("Debug leaking scalars parent short read 2");
485 PerlIO_flush(PerlIO_stderr());
490 if (returned_errno || *buffer) {
491 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
492 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
493 returned_errno, strerror(returned_errno));
499 =for apidoc perl_destruct
501 Shuts down a Perl interpreter. See L<perlembed>.
510 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
512 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
516 PERL_UNUSED_ARG(my_perl);
518 /* wait for all pseudo-forked children to finish */
519 PERL_WAIT_FOR_CHILDREN;
521 destruct_level = PL_perl_destruct_level;
524 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
526 const int i = atoi(s);
527 if (destruct_level < i)
533 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
539 if (PL_endav && !PL_minus_c)
540 call_list(PL_scopestack_ix, PL_endav);
546 /* Need to flush since END blocks can produce output */
549 if (CALL_FPTR(PL_threadhook)(aTHX)) {
550 /* Threads hook has vetoed further cleanup */
554 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
555 if (destruct_level != 0) {
556 /* Fork here to create a child. Our child's job is to preserve the
557 state of scalars prior to destruction, so that we can instruct it
558 to dump any scalars that we later find have leaked.
559 There's no subtlety in this code - it assumes POSIX, and it doesn't
563 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
564 perror("Debug leaking scalars socketpair failed");
570 perror("Debug leaking scalars fork failed");
574 /* We are the child */
575 const int sock = fd[1];
576 const int debug_fd = PerlIO_fileno(Perl_debug_log);
579 /* Our success message is an integer 0, and a char 0 */
580 static const char success[sizeof(int) + 1];
584 /* We need to close all other file descriptors otherwise we end up
585 with interesting hangs, where the parent closes its end of a
586 pipe, and sits waiting for (another) child to terminate. Only
587 that child never terminates, because it never gets EOF, because
588 we also have the far end of the pipe open. We even need to
589 close the debugging fd, because sometimes it happens to be one
590 end of a pipe, and a process is waiting on the other end for
591 EOF. Normally it would be closed at some point earlier in
592 destruction, but if we happen to cause the pipe to remain open,
593 EOF never occurs, and we get an infinite hang. Hence all the
594 games to pass in a file descriptor if it's actually needed. */
596 f = sysconf(_SC_OPEN_MAX);
598 where = "sysconf failed";
609 union control_un control;
612 struct cmsghdr *cmptr;
616 msg.msg_control = control.control;
617 msg.msg_controllen = sizeof(control.control);
618 /* We're a connected socket so we don't need a source */
622 msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
624 vec[0].iov_base = (void*)⌖
625 vec[0].iov_len = sizeof(target);
627 got = recvmsg(sock, &msg, 0);
632 where = "recv failed";
635 if(got < sizeof(target)) {
636 where = "short recv";
640 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
644 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
645 where = "wrong cmsg_len";
648 if(cmptr->cmsg_level != SOL_SOCKET) {
649 where = "wrong cmsg_level";
652 if(cmptr->cmsg_type != SCM_RIGHTS) {
653 where = "wrong cmsg_type";
657 got_fd = *(int*)CMSG_DATA(cmptr);
658 /* For our last little bit of trickery, put the file descriptor
659 back into Perl_debug_log, as if we never actually closed it
661 if(got_fd != debug_fd) {
662 if (dup2(got_fd, debug_fd) == -1) {
669 PerlIO_flush(Perl_debug_log);
671 got = write(sock, &success, sizeof(success));
674 where = "write failed";
677 if(got < sizeof(success)) {
678 where = "short write";
685 int send_errno = errno;
686 unsigned char length = (unsigned char) strlen(where);
687 struct iovec failure[3] = {
688 {(void*)&send_errno, sizeof(send_errno)},
690 {(void*)where, length}
692 int got = writev(sock, failure, 3);
693 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
694 in the parent if we try to read from the socketpair after the
695 child has exited, even if there was data to read.
696 So sleep a bit to give the parent a fighting chance of
699 _exit((got == -1) ? errno : 0);
703 PL_dumper_fd = fd[0];
708 /* We must account for everything. */
710 /* Destroy the main CV and syntax tree */
711 /* Do this now, because destroying ops can cause new SVs to be generated
712 in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
713 PL_curcop to point to a valid op from which the filename structure
715 PL_curcop = &PL_compiling;
717 /* ensure comppad/curpad to refer to main's pad */
718 if (CvPADLIST(PL_main_cv)) {
719 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
721 op_free(PL_main_root);
722 PL_main_root = Nullop;
724 PL_main_start = Nullop;
725 SvREFCNT_dec(PL_main_cv);
729 /* Tell PerlIO we are about to tear things apart in case
730 we have layers which are using resources that should
734 PerlIO_destruct(aTHX);
736 if (PL_sv_objcount) {
738 * Try to destruct global references. We do this first so that the
739 * destructors and destructees still exist. Some sv's might remain.
740 * Non-referenced objects are on their own.
744 if (PL_defoutgv && !SvREFCNT(PL_defoutgv))
745 PL_defoutgv = Nullgv; /* may have been freed */
748 /* unhook hooks which will soon be, or use, destroyed data */
749 SvREFCNT_dec(PL_warnhook);
750 PL_warnhook = Nullsv;
751 SvREFCNT_dec(PL_diehook);
754 /* call exit list functions */
755 while (PL_exitlistlen-- > 0)
756 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
758 Safefree(PL_exitlist);
763 if (destruct_level == 0){
765 DEBUG_P(debprofdump());
767 #if defined(PERLIO_LAYERS)
768 /* No more IO - including error messages ! */
769 PerlIO_cleanup(aTHX);
772 /* The exit() function will do everything that needs doing. */
776 /* jettison our possibly duplicated environment */
777 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
778 * so we certainly shouldn't free it here
781 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
782 if (environ != PL_origenviron && !PL_use_safe_putenv
784 /* only main thread can free environ[0] contents */
785 && PL_curinterp == aTHX
791 for (i = 0; environ[i]; i++)
792 safesysfree(environ[i]);
794 /* Must use safesysfree() when working with environ. */
795 safesysfree(environ);
797 environ = PL_origenviron;
800 #endif /* !PERL_MICRO */
802 /* reset so print() ends up where we expect */
806 /* the syntax tree is shared between clones
807 * so op_free(PL_main_root) only ReREFCNT_dec's
808 * REGEXPs in the parent interpreter
809 * we need to manually ReREFCNT_dec for the clones
812 I32 i = AvFILLp(PL_regex_padav) + 1;
813 SV * const * const ary = AvARRAY(PL_regex_padav);
816 SV * const resv = ary[--i];
818 if (SvFLAGS(resv) & SVf_BREAK) {
819 /* this is PL_reg_curpm, already freed
820 * flag is set in regexec.c:S_regtry
822 SvFLAGS(resv) &= ~SVf_BREAK;
824 else if(SvREPADTMP(resv)) {
825 SvREPADTMP_off(resv);
827 else if(SvIOKp(resv)) {
828 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
833 SvREFCNT_dec(PL_regex_padav);
834 PL_regex_padav = Nullav;
838 SvREFCNT_dec((SV*) PL_stashcache);
839 PL_stashcache = NULL;
841 /* loosen bonds of global variables */
844 (void)PerlIO_close(PL_rsfp);
848 /* Filters for program text */
849 SvREFCNT_dec(PL_rsfp_filters);
850 PL_rsfp_filters = Nullav;
853 PL_preprocess = FALSE;
859 PL_doswitches = FALSE;
860 PL_dowarn = G_WARN_OFF;
861 PL_doextract = FALSE;
862 PL_sawampersand = FALSE; /* must save all match strings */
865 Safefree(PL_inplace);
867 SvREFCNT_dec(PL_patchlevel);
870 SvREFCNT_dec(PL_e_script);
871 PL_e_script = Nullsv;
876 /* magical thingies */
878 SvREFCNT_dec(PL_ofs_sv); /* $, */
881 SvREFCNT_dec(PL_ors_sv); /* $\ */
884 SvREFCNT_dec(PL_rs); /* $/ */
887 PL_multiline = 0; /* $* */
888 Safefree(PL_osname); /* $^O */
891 SvREFCNT_dec(PL_statname);
892 PL_statname = Nullsv;
895 /* defgv, aka *_ should be taken care of elsewhere */
897 /* clean up after study() */
898 SvREFCNT_dec(PL_lastscream);
899 PL_lastscream = Nullsv;
900 Safefree(PL_screamfirst);
902 Safefree(PL_screamnext);
906 Safefree(PL_efloatbuf);
907 PL_efloatbuf = Nullch;
910 /* startup and shutdown function lists */
911 SvREFCNT_dec(PL_beginav);
912 SvREFCNT_dec(PL_beginav_save);
913 SvREFCNT_dec(PL_endav);
914 SvREFCNT_dec(PL_checkav);
915 SvREFCNT_dec(PL_checkav_save);
916 SvREFCNT_dec(PL_initav);
918 PL_beginav_save = Nullav;
921 PL_checkav_save = Nullav;
924 /* shortcuts just get cleared */
930 PL_argvoutgv = Nullgv;
932 PL_stderrgv = Nullgv;
933 PL_last_in_gv = Nullgv;
938 PL_DBsingle = Nullsv;
940 PL_DBsignal = Nullsv;
941 PL_DBassertion = Nullsv;
944 PL_debstash = Nullhv;
946 SvREFCNT_dec(PL_argvout_stack);
947 PL_argvout_stack = Nullav;
949 SvREFCNT_dec(PL_modglobal);
950 PL_modglobal = Nullhv;
951 SvREFCNT_dec(PL_preambleav);
952 PL_preambleav = Nullav;
953 SvREFCNT_dec(PL_subname);
955 SvREFCNT_dec(PL_linestr);
957 #ifdef PERL_USES_PL_PIDSTATUS
958 SvREFCNT_dec(PL_pidstatus);
959 PL_pidstatus = Nullhv;
961 SvREFCNT_dec(PL_toptarget);
962 PL_toptarget = Nullsv;
963 SvREFCNT_dec(PL_bodytarget);
964 PL_bodytarget = Nullsv;
965 PL_formtarget = Nullsv;
967 /* free locale stuff */
968 #ifdef USE_LOCALE_COLLATE
969 Safefree(PL_collation_name);
970 PL_collation_name = Nullch;
973 #ifdef USE_LOCALE_NUMERIC
974 Safefree(PL_numeric_name);
975 PL_numeric_name = Nullch;
976 SvREFCNT_dec(PL_numeric_radix_sv);
977 PL_numeric_radix_sv = Nullsv;
980 /* clear utf8 character classes */
981 SvREFCNT_dec(PL_utf8_alnum);
982 SvREFCNT_dec(PL_utf8_alnumc);
983 SvREFCNT_dec(PL_utf8_ascii);
984 SvREFCNT_dec(PL_utf8_alpha);
985 SvREFCNT_dec(PL_utf8_space);
986 SvREFCNT_dec(PL_utf8_cntrl);
987 SvREFCNT_dec(PL_utf8_graph);
988 SvREFCNT_dec(PL_utf8_digit);
989 SvREFCNT_dec(PL_utf8_upper);
990 SvREFCNT_dec(PL_utf8_lower);
991 SvREFCNT_dec(PL_utf8_print);
992 SvREFCNT_dec(PL_utf8_punct);
993 SvREFCNT_dec(PL_utf8_xdigit);
994 SvREFCNT_dec(PL_utf8_mark);
995 SvREFCNT_dec(PL_utf8_toupper);
996 SvREFCNT_dec(PL_utf8_totitle);
997 SvREFCNT_dec(PL_utf8_tolower);
998 SvREFCNT_dec(PL_utf8_tofold);
999 SvREFCNT_dec(PL_utf8_idstart);
1000 SvREFCNT_dec(PL_utf8_idcont);
1001 PL_utf8_alnum = Nullsv;
1002 PL_utf8_alnumc = Nullsv;
1003 PL_utf8_ascii = Nullsv;
1004 PL_utf8_alpha = Nullsv;
1005 PL_utf8_space = Nullsv;
1006 PL_utf8_cntrl = Nullsv;
1007 PL_utf8_graph = Nullsv;
1008 PL_utf8_digit = Nullsv;
1009 PL_utf8_upper = Nullsv;
1010 PL_utf8_lower = Nullsv;
1011 PL_utf8_print = Nullsv;
1012 PL_utf8_punct = Nullsv;
1013 PL_utf8_xdigit = Nullsv;
1014 PL_utf8_mark = Nullsv;
1015 PL_utf8_toupper = Nullsv;
1016 PL_utf8_totitle = Nullsv;
1017 PL_utf8_tolower = Nullsv;
1018 PL_utf8_tofold = Nullsv;
1019 PL_utf8_idstart = Nullsv;
1020 PL_utf8_idcont = Nullsv;
1022 if (!specialWARN(PL_compiling.cop_warnings))
1023 SvREFCNT_dec(PL_compiling.cop_warnings);
1024 PL_compiling.cop_warnings = Nullsv;
1025 if (!specialCopIO(PL_compiling.cop_io))
1026 SvREFCNT_dec(PL_compiling.cop_io);
1027 PL_compiling.cop_io = Nullsv;
1028 CopFILE_free(&PL_compiling);
1029 CopSTASH_free(&PL_compiling);
1031 /* Prepare to destruct main symbol table. */
1036 SvREFCNT_dec(PL_curstname);
1037 PL_curstname = Nullsv;
1039 /* clear queued errors */
1040 SvREFCNT_dec(PL_errors);
1044 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
1045 if (PL_scopestack_ix != 0)
1046 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1047 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1048 (long)PL_scopestack_ix);
1049 if (PL_savestack_ix != 0)
1050 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1051 "Unbalanced saves: %ld more saves than restores\n",
1052 (long)PL_savestack_ix);
1053 if (PL_tmps_floor != -1)
1054 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1055 (long)PL_tmps_floor + 1);
1056 if (cxstack_ix != -1)
1057 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1058 (long)cxstack_ix + 1);
1061 /* Now absolutely destruct everything, somehow or other, loops or no. */
1062 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
1063 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
1065 /* the 2 is for PL_fdpid and PL_strtab */
1066 while (PL_sv_count > 2 && sv_clean_all())
1069 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
1070 SvFLAGS(PL_fdpid) |= SVt_PVAV;
1071 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
1072 SvFLAGS(PL_strtab) |= SVt_PVHV;
1074 AvREAL_off(PL_fdpid); /* no surviving entries */
1075 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
1078 #ifdef HAVE_INTERP_INTERN
1082 /* Destruct the global string table. */
1084 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1085 * so that sv_free() won't fail on them.
1086 * Now that the global string table is using a single hunk of memory
1087 * for both HE and HEK, we either need to explicitly unshare it the
1088 * correct way, or actually free things here.
1091 const I32 max = HvMAX(PL_strtab);
1092 HE * const * const array = HvARRAY(PL_strtab);
1093 HE *hent = array[0];
1096 if (hent && ckWARN_d(WARN_INTERNAL)) {
1097 HE * const next = HeNEXT(hent);
1098 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1099 "Unbalanced string table refcount: (%ld) for \"%s\"",
1100 (long)(HeVAL(hent) - Nullsv), HeKEY(hent));
1107 hent = array[riter];
1112 HvARRAY(PL_strtab) = 0;
1113 HvTOTALKEYS(PL_strtab) = 0;
1114 HvFILL(PL_strtab) = 0;
1116 SvREFCNT_dec(PL_strtab);
1119 /* free the pointer tables used for cloning */
1120 ptr_table_free(PL_ptr_table);
1121 PL_ptr_table = (PTR_TBL_t*)NULL;
1124 /* free special SVs */
1126 SvREFCNT(&PL_sv_yes) = 0;
1127 sv_clear(&PL_sv_yes);
1128 SvANY(&PL_sv_yes) = NULL;
1129 SvFLAGS(&PL_sv_yes) = 0;
1131 SvREFCNT(&PL_sv_no) = 0;
1132 sv_clear(&PL_sv_no);
1133 SvANY(&PL_sv_no) = NULL;
1134 SvFLAGS(&PL_sv_no) = 0;
1138 for (i=0; i<=2; i++) {
1139 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1140 sv_clear(PERL_DEBUG_PAD(i));
1141 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1142 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1146 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1147 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1149 #ifdef DEBUG_LEAKING_SCALARS
1150 if (PL_sv_count != 0) {
1155 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
1156 svend = &sva[SvREFCNT(sva)];
1157 for (sv = sva + 1; sv < svend; ++sv) {
1158 if (SvTYPE(sv) != SVTYPEMASK) {
1159 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1161 " refcnt=%"UVuf pTHX__FORMAT "\n"
1162 "\tallocated at %s:%d %s %s%s\n",
1163 sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
1164 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1166 sv->sv_debug_inpad ? "for" : "by",
1167 sv->sv_debug_optype ?
1168 PL_op_name[sv->sv_debug_optype]: "(none)",
1169 sv->sv_debug_cloned ? " (cloned)" : ""
1171 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1172 Perl_dump_sv_child(aTHX_ sv);
1178 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1182 /* Wait for up to 4 seconds for child to terminate.
1183 This seems to be the least effort way of timing out on reaping
1185 struct timeval waitfor = {4, 0};
1186 int sock = PL_dumper_fd;
1190 FD_SET(sock, &rset);
1191 select(sock + 1, &rset, NULL, NULL, &waitfor);
1192 waitpid(child, &status, WNOHANG);
1200 #if defined(PERLIO_LAYERS)
1201 /* No more IO - including error messages ! */
1202 PerlIO_cleanup(aTHX);
1205 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1206 as currently layers use it rather than Nullsv as a marker
1207 for no arg - and will try and SvREFCNT_dec it.
1209 SvREFCNT(&PL_sv_undef) = 0;
1210 SvREADONLY_off(&PL_sv_undef);
1212 Safefree(PL_origfilename);
1213 PL_origfilename = Nullch;
1214 Safefree(PL_reg_start_tmp);
1215 PL_reg_start_tmp = (char**)NULL;
1216 PL_reg_start_tmpl = 0;
1217 Safefree(PL_reg_curpm);
1218 Safefree(PL_reg_poscache);
1219 free_tied_hv_pool();
1220 Safefree(PL_op_mask);
1221 Safefree(PL_psig_ptr);
1222 PL_psig_ptr = (SV**)NULL;
1223 Safefree(PL_psig_name);
1224 PL_psig_name = (SV**)NULL;
1225 Safefree(PL_bitcount);
1226 PL_bitcount = Nullch;
1227 Safefree(PL_psig_pend);
1228 PL_psig_pend = (int*)NULL;
1229 PL_formfeed = Nullsv;
1231 PL_tainting = FALSE;
1232 PL_taint_warn = FALSE;
1233 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
1236 DEBUG_P(debprofdump());
1238 #ifdef USE_REENTRANT_API
1239 Perl_reentrant_free(aTHX);
1244 /* As the absolutely last thing, free the non-arena SV for mess() */
1247 /* we know that type == SVt_PVMG */
1249 /* it could have accumulated taint magic */
1252 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1253 moremagic = mg->mg_moremagic;
1254 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1256 Safefree(mg->mg_ptr);
1260 /* we know that type >= SVt_PV */
1261 SvPV_free(PL_mess_sv);
1262 Safefree(SvANY(PL_mess_sv));
1263 Safefree(PL_mess_sv);
1264 PL_mess_sv = Nullsv;
1270 =for apidoc perl_free
1272 Releases a Perl interpreter. See L<perlembed>.
1280 #if defined(WIN32) || defined(NETWARE)
1281 # if defined(PERL_IMPLICIT_SYS)
1283 void *host = nw_internal_host;
1285 void *host = w32_internal_host;
1287 PerlMem_free(aTHXx);
1289 nw_delete_internal_host(host);
1291 win32_delete_internal_host(host);
1294 PerlMem_free(aTHXx);
1297 PerlMem_free(aTHXx);
1301 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
1302 /* provide destructors to clean up the thread key when libperl is unloaded */
1303 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1305 #if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
1306 #pragma fini "perl_fini"
1310 #if defined(__GNUC__)
1311 __attribute__((destructor))
1321 #endif /* THREADS */
1324 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1326 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1327 PL_exitlist[PL_exitlistlen].fn = fn;
1328 PL_exitlist[PL_exitlistlen].ptr = ptr;
1332 #ifdef HAS_PROCSELFEXE
1333 /* This is a function so that we don't hold on to MAXPATHLEN
1334 bytes of stack longer than necessary
1337 S_procself_val(pTHX_ SV *sv, const char *arg0)
1339 char buf[MAXPATHLEN];
1340 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1342 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1343 includes a spurious NUL which will cause $^X to fail in system
1344 or backticks (this will prevent extensions from being built and
1345 many tests from working). readlink is not meant to add a NUL.
1346 Normal readlink works fine.
1348 if (len > 0 && buf[len-1] == '\0') {
1352 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1353 returning the text "unknown" from the readlink rather than the path
1354 to the executable (or returning an error from the readlink). Any valid
1355 path has a '/' in it somewhere, so use that to validate the result.
1356 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1358 if (len > 0 && memchr(buf, '/', len)) {
1359 sv_setpvn(sv,buf,len);
1365 #endif /* HAS_PROCSELFEXE */
1368 S_set_caret_X(pTHX) {
1369 GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
1371 #ifdef HAS_PROCSELFEXE
1372 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1375 sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
1377 sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
1384 =for apidoc perl_parse
1386 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1392 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1399 PERL_UNUSED_VAR(my_perl);
1401 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1404 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
1405 setuid perl scripts securely.\n");
1406 #endif /* IAMSUID */
1409 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1410 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
1411 * This MUST be done before any hash stores or fetches take place.
1412 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1413 * yourself, it is your responsibility to provide a good random seed!
1414 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
1415 if (!PL_rehash_seed_set)
1416 PL_rehash_seed = get_hash_seed();
1418 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1420 if (s && (atoi(s) == 1))
1421 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
1423 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1429 /* Set PL_origalen be the sum of the contiguous argv[]
1430 * elements plus the size of the env in case that it is
1431 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1432 * as the maximum modifiable length of $0. In the worst case
1433 * the area we are able to modify is limited to the size of
1434 * the original argv[0]. (See below for 'contiguous', though.)
1436 const char *s = NULL;
1439 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1440 /* Do the mask check only if the args seem like aligned. */
1442 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1444 /* See if all the arguments are contiguous in memory. Note
1445 * that 'contiguous' is a loose term because some platforms
1446 * align the argv[] and the envp[]. If the arguments look
1447 * like non-aligned, assume that they are 'strictly' or
1448 * 'traditionally' contiguous. If the arguments look like
1449 * aligned, we just check that they are within aligned
1450 * PTRSIZE bytes. As long as no system has something bizarre
1451 * like the argv[] interleaved with some other data, we are
1452 * fine. (Did I just evoke Murphy's Law?) --jhi */
1453 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1455 for (i = 1; i < PL_origargc; i++) {
1456 if ((PL_origargv[i] == s + 1
1458 || PL_origargv[i] == s + 2
1463 (PL_origargv[i] > s &&
1465 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1475 /* Can we grab env area too to be used as the area for $0? */
1476 if (PL_origenviron) {
1477 if ((PL_origenviron[0] == s + 1
1479 || (PL_origenviron[0] == s + 9 && (s += 8))
1484 (PL_origenviron[0] > s &&
1485 PL_origenviron[0] <=
1486 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1490 s = PL_origenviron[0];
1493 my_setenv("NoNe SuCh", Nullch);
1494 /* Force copy of environment. */
1495 for (i = 1; PL_origenviron[i]; i++) {
1496 if (PL_origenviron[i] == s + 1
1499 (PL_origenviron[i] > s &&
1500 PL_origenviron[i] <=
1501 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1504 s = PL_origenviron[i];
1512 PL_origalen = s - PL_origargv[0] + 1;
1517 /* Come here if running an undumped a.out. */
1519 PL_origfilename = savepv(argv[0]);
1520 PL_do_undump = FALSE;
1521 cxstack_ix = -1; /* start label stack again */
1523 assert (!PL_tainted);
1525 S_set_caret_X(aTHX);
1527 init_postdump_symbols(argc,argv,env);
1532 op_free(PL_main_root);
1533 PL_main_root = Nullop;
1535 PL_main_start = Nullop;
1536 SvREFCNT_dec(PL_main_cv);
1537 PL_main_cv = Nullcv;
1540 oldscope = PL_scopestack_ix;
1541 PL_dowarn = G_WARN_OFF;
1546 parse_body(env,xsinit);
1548 call_list(oldscope, PL_checkav);
1555 /* my_exit() was called */
1556 while (PL_scopestack_ix > oldscope)
1559 PL_curstash = PL_defstash;
1561 call_list(oldscope, PL_checkav);
1565 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1574 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1577 int argc = PL_origargc;
1578 char **argv = PL_origargv;
1579 const char *scriptname = NULL;
1580 VOL bool dosearch = FALSE;
1581 const char *validarg = "";
1584 const char *cddir = Nullch;
1585 #ifdef USE_SITECUSTOMIZE
1586 bool minus_f = FALSE;
1591 sv_setpvn(PL_linestr,"",0);
1592 sv = newSVpvn("",0); /* first used for -I flags */
1596 for (argc--,argv++; argc > 0; argc--,argv++) {
1597 if (argv[0][0] != '-' || !argv[0][1])
1601 validarg = " PHOOEY ";
1605 * Can we rely on the kernel to start scripts with argv[1] set to
1606 * contain all #! line switches (the whole line)? (argv[0] is set to
1607 * the interpreter name, argv[2] to the script name; argv[3] and
1608 * above may contain other arguments.)
1615 #ifndef PERL_STRICT_CR
1640 if ((s = moreswitches(s)))
1645 CHECK_MALLOC_TOO_LATE_FOR('t');
1646 if( !PL_tainting ) {
1647 PL_taint_warn = TRUE;
1653 CHECK_MALLOC_TOO_LATE_FOR('T');
1655 PL_taint_warn = FALSE;
1660 #ifdef MACOS_TRADITIONAL
1661 /* ignore -e for Dev:Pseudo argument */
1662 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1667 PL_e_script = newSVpvn("",0);
1668 filter_add(read_e_script, NULL);
1671 sv_catpv(PL_e_script, s);
1673 sv_catpv(PL_e_script, argv[1]);
1677 Perl_croak(aTHX_ "No code specified for -e");
1678 sv_catpv(PL_e_script, "\n");
1682 #ifdef USE_SITECUSTOMIZE
1688 case 'I': /* -I handled both here and in moreswitches() */
1690 if (!*++s && (s=argv[1]) != Nullch) {
1694 STRLEN len = strlen(s);
1695 const char * const p = savepvn(s, len);
1696 incpush(p, TRUE, TRUE, FALSE, FALSE);
1697 sv_catpvn(sv, "-I", 2);
1698 sv_catpvn(sv, p, len);
1699 sv_catpvn(sv, " ", 1);
1703 Perl_croak(aTHX_ "No directory specified for -I");
1707 PL_preprocess = TRUE;
1720 PL_preambleav = newAV();
1721 av_push(PL_preambleav,
1722 newSVpv("use Config;",0));
1726 opts_prog = newSVpv("print Config::myconfig(),",0);
1728 sv_catpv(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\",");
1730 sv_catpv(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\",");
1732 opts = SvCUR(opts_prog);
1734 Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:"
1738 # ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1739 " DEBUG_LEAKING_SCALARS_FORK_DUMP"
1741 # ifdef FAKE_THREADS
1744 # ifdef MULTIPLICITY
1750 # ifdef PERL_DONT_CREATE_GVSV
1751 " PERL_DONT_CREATE_GVSV"
1753 # ifdef PERL_GLOBAL_STRUCT
1754 " PERL_GLOBAL_STRUCT"
1756 # ifdef PERL_IMPLICIT_CONTEXT
1757 " PERL_IMPLICIT_CONTEXT"
1759 # ifdef PERL_IMPLICIT_SYS
1760 " PERL_IMPLICIT_SYS"
1762 # ifdef PERL_MALLOC_WRAP
1765 # ifdef PERL_NEED_APPCTX
1768 # ifdef PERL_NEED_TIMESBASE
1769 " PERL_NEED_TIMESBASE"
1771 # ifdef PERL_OLD_COPY_ON_WRITE
1772 " PERL_OLD_COPY_ON_WRITE"
1774 # ifdef PERL_USE_SAFE_PUTENV
1775 " PERL_USE_SAFE_PUTENV"
1777 #ifdef PERL_USES_PL_PIDSTATUS
1778 " PERL_USES_PL_PIDSTATUS"
1780 # ifdef PL_OP_SLAB_ALLOC
1783 # ifdef SPRINTF_RETURNS_STRLEN
1784 " SPRINTF_RETURNS_STRLEN"
1786 # ifdef THREADS_HAVE_PIDS
1787 " THREADS_HAVE_PIDS"
1789 # ifdef USE_5005THREADS
1792 # ifdef USE_64_BIT_ALL
1795 # ifdef USE_64_BIT_INT
1798 # ifdef USE_ITHREADS
1801 # ifdef USE_LARGE_FILES
1804 # ifdef USE_LONG_DOUBLE
1810 # ifdef USE_REENTRANT_API
1811 " USE_REENTRANT_API"
1816 # ifdef USE_SITECUSTOMIZE
1817 " USE_SITECUSTOMIZE"
1824 while (SvCUR(opts_prog) > opts+76) {
1825 /* find last space after "options: " and before col 76
1829 char * const pv = SvPV_nolen(opts_prog);
1830 const char c = pv[opts+76];
1832 space = strrchr(pv+opts+26, ' ');
1834 if (!space) break; /* "Can't happen" */
1836 /* break the line before that space */
1839 sv_insert(opts_prog, opts, 0,
1843 sv_catpv(opts_prog,"\\n\",");
1845 #if defined(LOCAL_PATCH_COUNT)
1846 if (LOCAL_PATCH_COUNT > 0) {
1849 "\" Locally applied patches:\\n\",");
1850 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1851 if (PL_localpatches[i])
1852 Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
1853 0, PL_localpatches[i], 0);
1857 Perl_sv_catpvf(aTHX_ opts_prog,
1858 "\" Built under %s\\n\"",OSNAME);
1861 Perl_sv_catpvf(aTHX_ opts_prog,
1862 ",\" Compiled at %s %s\\n\"",__DATE__,
1865 Perl_sv_catpvf(aTHX_ opts_prog,",\" Compiled on %s\\n\"",
1869 sv_catpv(opts_prog, "; $\"=\"\\n \"; "
1870 "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
1871 "sort grep {/^PERL/} keys %ENV; ");
1874 "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1877 "print \" \\%ENV:\\n @env\\n\" if @env;"
1878 "print \" \\@INC:\\n @INC\\n\";");
1882 opts_prog = Perl_newSVpvf(aTHX_
1883 "Config::config_vars(qw%c%s%c)",
1887 av_push(PL_preambleav, opts_prog);
1888 /* don't look for script or read stdin */
1889 scriptname = BIT_BUCKET;
1893 PL_doextract = TRUE;
1901 if (!*++s || isSPACE(*s)) {
1905 /* catch use of gnu style long options */
1906 if (strEQ(s, "version")) {
1910 if (strEQ(s, "help")) {
1917 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1923 #ifndef SECURE_INTERNAL_GETENV
1926 (s = PerlEnv_getenv("PERL5OPT")))
1928 const char *popt = s;
1931 if (*s == '-' && *(s+1) == 'T') {
1932 CHECK_MALLOC_TOO_LATE_FOR('T');
1934 PL_taint_warn = FALSE;
1937 char *popt_copy = Nullch;
1950 if (!strchr("CDIMUdmtwA", *s))
1951 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1955 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1956 s = popt_copy + (s - popt);
1957 d = popt_copy + (d - popt);
1964 if( !PL_tainting ) {
1965 PL_taint_warn = TRUE;
1975 #ifdef USE_SITECUSTOMIZE
1978 PL_preambleav = newAV();
1979 av_unshift(PL_preambleav, 1);
1980 (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
1984 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1985 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1989 scriptname = argv[0];
1992 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1994 else if (scriptname == Nullch) {
1996 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2002 /* Set $^X early so that it can be used for relocatable paths in @INC */
2003 assert (!PL_tainted);
2005 S_set_caret_X(aTHX);
2009 open_script(scriptname,dosearch,sv);
2011 validate_suid(validarg, scriptname);
2014 #if defined(SIGCHLD) || defined(SIGCLD)
2017 # define SIGCHLD SIGCLD
2019 Sighandler_t sigstate = rsignal_state(SIGCHLD);
2020 if (sigstate == (Sighandler_t) SIG_IGN) {
2021 if (ckWARN(WARN_SIGNAL))
2022 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2023 "Can't ignore signal CHLD, forcing to default");
2024 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2030 #ifdef MACOS_TRADITIONAL
2031 if (PL_doextract || gMacPerl_AlwaysExtract) {
2036 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2037 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2041 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
2042 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2043 CvUNIQUE_on(PL_compcv);
2045 CvPADLIST(PL_compcv) = pad_new(0);
2046 #ifdef USE_5005THREADS
2047 CvOWNER(PL_compcv) = 0;
2048 Newx(CvMUTEXP(PL_compcv), 1, perl_mutex);
2049 MUTEX_INIT(CvMUTEXP(PL_compcv));
2050 #endif /* USE_5005THREADS */
2053 boot_core_UNIVERSAL();
2054 boot_core_xsutils();
2057 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
2059 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
2065 # ifdef HAS_SOCKS5_INIT
2066 socks5_init(argv[0]);
2072 init_predump_symbols();
2073 /* init_postdump_symbols not currently designed to be called */
2074 /* more than once (ENV isn't cleared first, for example) */
2075 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2077 init_postdump_symbols(argc,argv,env);
2079 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2080 * or explicitly in some platforms.
2081 * locale.c:Perl_init_i18nl10n() if the environment
2082 * look like the user wants to use UTF-8. */
2083 #if defined(__SYMBIAN32__)
2084 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2087 /* Requires init_predump_symbols(). */
2088 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2093 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2094 * and the default open disciplines. */
2095 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2096 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2098 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2099 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2100 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2102 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2103 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2104 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2106 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2107 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2108 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
2109 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2110 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2113 sv_setpvn(sv, ":utf8\0:utf8", 11);
2115 sv_setpvn(sv, ":utf8\0", 6);
2118 sv_setpvn(sv, "\0:utf8", 6);
2124 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2125 if (strEQ(s, "unsafe"))
2126 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2127 else if (strEQ(s, "safe"))
2128 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2130 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2135 /* now parse the script */
2137 SETERRNO(0,SS_NORMAL);
2139 #ifdef MACOS_TRADITIONAL
2140 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
2142 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
2144 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2145 MacPerl_MPWFileName(PL_origfilename));
2149 if (yyparse() || PL_error_count) {
2151 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2153 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2158 CopLINE_set(PL_curcop, 0);
2159 PL_curstash = PL_defstash;
2160 PL_preprocess = FALSE;
2162 SvREFCNT_dec(PL_e_script);
2163 PL_e_script = Nullsv;
2170 SAVECOPFILE(PL_curcop);
2171 SAVECOPLINE(PL_curcop);
2172 gv_check(PL_defstash);
2179 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2180 dump_mstats("after compilation:");
2189 =for apidoc perl_run
2191 Tells a Perl interpreter to run. See L<perlembed>.
2203 PERL_UNUSED_ARG(my_perl);
2205 oldscope = PL_scopestack_ix;
2213 cxstack_ix = -1; /* start context stack again */
2215 case 0: /* normal completion */
2219 case 2: /* my_exit() */
2220 while (PL_scopestack_ix > oldscope)
2223 PL_curstash = PL_defstash;
2224 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2225 PL_endav && !PL_minus_c)
2226 call_list(oldscope, PL_endav);
2228 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2229 dump_mstats("after execution: ");
2235 POPSTACK_TO(PL_mainstack);
2238 PerlIO_printf(Perl_error_log, "panic: restartop\n");
2250 S_run_body(pTHX_ I32 oldscope)
2252 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2253 PL_sawampersand ? "Enabling" : "Omitting"));
2255 if (!PL_restartop) {
2256 DEBUG_x(dump_all());
2259 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2261 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
2265 #ifdef MACOS_TRADITIONAL
2266 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
2267 (gMacPerl_ErrorFormat ? "# " : ""),
2268 MacPerl_MPWFileName(PL_origfilename));
2270 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2274 if (PERLDB_SINGLE && PL_DBsingle)
2275 sv_setiv(PL_DBsingle, 1);
2277 call_list(oldscope, PL_initav);
2283 PL_op = PL_restartop;
2287 else if (PL_main_start) {
2288 CvDEPTH(PL_main_cv) = 1;
2289 PL_op = PL_main_start;
2297 =head1 SV Manipulation Functions
2299 =for apidoc p||get_sv
2301 Returns the SV of the specified Perl scalar. If C<create> is set and the
2302 Perl variable does not exist then it will be created. If C<create> is not
2303 set and the variable does not exist then NULL is returned.
2309 Perl_get_sv(pTHX_ const char *name, I32 create)
2312 #ifdef USE_5005THREADS
2313 if (name[1] == '\0' && !isALPHA(name[0])) {
2314 PADOFFSET tmp = find_threadsv(name);
2315 if (tmp != NOT_IN_PAD)
2316 return THREADSV(tmp);
2318 #endif /* USE_5005THREADS */
2319 gv = gv_fetchpv(name, create, SVt_PV);
2326 =head1 Array Manipulation Functions
2328 =for apidoc p||get_av
2330 Returns the AV of the specified Perl array. If C<create> is set and the
2331 Perl variable does not exist then it will be created. If C<create> is not
2332 set and the variable does not exist then NULL is returned.
2338 Perl_get_av(pTHX_ const char *name, I32 create)
2340 GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
2349 =head1 Hash Manipulation Functions
2351 =for apidoc p||get_hv
2353 Returns the HV of the specified Perl hash. If C<create> is set and the
2354 Perl variable does not exist then it will be created. If C<create> is not
2355 set and the variable does not exist then NULL is returned.
2361 Perl_get_hv(pTHX_ const char *name, I32 create)
2363 GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
2372 =head1 CV Manipulation Functions
2374 =for apidoc p||get_cv
2376 Returns the CV of the specified Perl subroutine. If C<create> is set and
2377 the Perl subroutine does not exist then it will be declared (which has the
2378 same effect as saying C<sub name;>). If C<create> is not set and the
2379 subroutine does not exist then NULL is returned.
2385 Perl_get_cv(pTHX_ const char *name, I32 create)
2387 GV* const gv = gv_fetchpv(name, create, SVt_PVCV);
2388 /* XXX unsafe for threads if eval_owner isn't held */
2389 /* XXX this is probably not what they think they're getting.
2390 * It has the same effect as "sub name;", i.e. just a forward
2392 if (create && !GvCVu(gv))
2393 return newSUB(start_subparse(FALSE, 0),
2394 newSVOP(OP_CONST, 0, newSVpv(name,0)),
2402 /* Be sure to refetch the stack pointer after calling these routines. */
2406 =head1 Callback Functions
2408 =for apidoc p||call_argv
2410 Performs a callback to the specified Perl sub. See L<perlcall>.
2416 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2418 /* See G_* flags in cop.h */
2419 /* null terminated arg list */
2426 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
2431 return call_pv(sub_name, flags);
2435 =for apidoc p||call_pv
2437 Performs a callback to the specified Perl sub. See L<perlcall>.
2443 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2444 /* name of the subroutine */
2445 /* See G_* flags in cop.h */
2447 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
2451 =for apidoc p||call_method
2453 Performs a callback to the specified Perl method. The blessed object must
2454 be on the stack. See L<perlcall>.
2460 Perl_call_method(pTHX_ const char *methname, I32 flags)
2461 /* name of the subroutine */
2462 /* See G_* flags in cop.h */
2464 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2467 /* May be called with any of a CV, a GV, or an SV containing the name. */
2469 =for apidoc p||call_sv
2471 Performs a callback to the Perl sub whose name is in the SV. See
2478 Perl_call_sv(pTHX_ SV *sv, I32 flags)
2479 /* See G_* flags in cop.h */
2482 LOGOP myop; /* fake syntax tree node */
2485 volatile I32 retval = 0;
2487 bool oldcatch = CATCH_GET;
2489 OP* const oldop = PL_op;
2492 if (flags & G_DISCARD) {
2497 Zero(&myop, 1, LOGOP);
2498 myop.op_next = Nullop;
2499 if (!(flags & G_NOARGS))
2500 myop.op_flags |= OPf_STACKED;
2501 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2502 (flags & G_ARRAY) ? OPf_WANT_LIST :
2507 EXTEND(PL_stack_sp, 1);
2508 *++PL_stack_sp = sv;
2510 oldscope = PL_scopestack_ix;
2512 if (PERLDB_SUB && PL_curstash != PL_debstash
2513 /* Handle first BEGIN of -d. */
2514 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2515 /* Try harder, since this may have been a sighandler, thus
2516 * curstash may be meaningless. */
2517 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2518 && !(flags & G_NODEBUG))
2519 PL_op->op_private |= OPpENTERSUB_DB;
2521 if (flags & G_METHOD) {
2522 Zero(&method_op, 1, UNOP);
2523 method_op.op_next = PL_op;
2524 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2525 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2526 PL_op = (OP*)&method_op;
2529 if (!(flags & G_EVAL)) {
2531 call_body((OP*)&myop, FALSE);
2532 retval = PL_stack_sp - (PL_stack_base + oldmark);
2533 CATCH_SET(oldcatch);
2536 myop.op_other = (OP*)&myop;
2538 /* we're trying to emulate pp_entertry() here */
2540 register PERL_CONTEXT *cx;
2541 const I32 gimme = GIMME_V;
2546 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
2548 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2550 PL_in_eval = EVAL_INEVAL;
2551 if (flags & G_KEEPERR)
2552 PL_in_eval |= EVAL_KEEPERR;
2554 sv_setpvn(ERRSV,"",0);
2562 call_body((OP*)&myop, FALSE);
2563 retval = PL_stack_sp - (PL_stack_base + oldmark);
2564 if (!(flags & G_KEEPERR))
2565 sv_setpvn(ERRSV,"",0);
2571 /* my_exit() was called */
2572 PL_curstash = PL_defstash;
2575 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2576 Perl_croak(aTHX_ "Callback called exit");
2581 PL_op = PL_restartop;
2585 PL_stack_sp = PL_stack_base + oldmark;
2586 if (flags & G_ARRAY)
2590 *++PL_stack_sp = &PL_sv_undef;
2595 if (PL_scopestack_ix > oldscope) {
2599 register PERL_CONTEXT *cx;
2606 PERL_UNUSED_VAR(newsp);
2607 PERL_UNUSED_VAR(gimme);
2608 PERL_UNUSED_VAR(optype);
2613 if (flags & G_DISCARD) {
2614 PL_stack_sp = PL_stack_base + oldmark;
2624 S_call_body(pTHX_ const OP *myop, bool is_eval)
2626 if (PL_op == myop) {
2628 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2630 PL_op = Perl_pp_entersub(aTHX); /* this does */
2636 /* Eval a string. The G_EVAL flag is always assumed. */
2639 =for apidoc p||eval_sv
2641 Tells Perl to C<eval> the string in the SV.
2647 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2649 /* See G_* flags in cop.h */
2652 UNOP myop; /* fake syntax tree node */
2653 volatile I32 oldmark = SP - PL_stack_base;
2654 volatile I32 retval = 0;
2656 OP* const oldop = PL_op;
2659 if (flags & G_DISCARD) {
2666 Zero(PL_op, 1, UNOP);
2667 EXTEND(PL_stack_sp, 1);
2668 *++PL_stack_sp = sv;
2670 if (!(flags & G_NOARGS))
2671 myop.op_flags = OPf_STACKED;
2672 myop.op_next = Nullop;
2673 myop.op_type = OP_ENTEREVAL;
2674 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2675 (flags & G_ARRAY) ? OPf_WANT_LIST :
2677 if (flags & G_KEEPERR)
2678 myop.op_flags |= OPf_SPECIAL;
2680 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2681 * before a PUSHEVAL, which corrupts the stack after a croak */
2682 TAINT_PROPER("eval_sv()");
2688 call_body((OP*)&myop,TRUE);
2689 retval = PL_stack_sp - (PL_stack_base + oldmark);
2690 if (!(flags & G_KEEPERR))
2691 sv_setpvn(ERRSV,"",0);
2697 /* my_exit() was called */
2698 PL_curstash = PL_defstash;
2701 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2702 Perl_croak(aTHX_ "Callback called exit");
2707 PL_op = PL_restartop;
2711 PL_stack_sp = PL_stack_base + oldmark;
2712 if (flags & G_ARRAY)
2716 *++PL_stack_sp = &PL_sv_undef;
2722 if (flags & G_DISCARD) {
2723 PL_stack_sp = PL_stack_base + oldmark;
2733 =for apidoc p||eval_pv
2735 Tells Perl to C<eval> the given string and return an SV* result.
2741 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2744 SV* sv = newSVpv(p, 0);
2746 eval_sv(sv, G_SCALAR);
2753 if (croak_on_error && SvTRUE(ERRSV)) {
2754 Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2760 /* Require a module. */
2763 =head1 Embedding Functions
2765 =for apidoc p||require_pv
2767 Tells Perl to C<require> the file named by the string argument. It is
2768 analogous to the Perl code C<eval "require '$file'">. It's even
2769 implemented that way; consider using load_module instead.
2774 Perl_require_pv(pTHX_ const char *pv)
2778 PUSHSTACKi(PERLSI_REQUIRE);
2780 sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
2781 eval_sv(sv_2mortal(sv), G_DISCARD);
2787 Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
2789 register GV * const gv = gv_fetchpv(sym,TRUE, SVt_PV);
2792 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2796 S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
2798 /* This message really ought to be max 23 lines.
2799 * Removed -h because the user already knows that option. Others? */
2801 static const char * const usage_msg[] = {
2802 "-0[octal] specify record separator (\\0, if no argument)",
2803 "-A[mod][=pattern] activate all/given assertions",
2804 "-a autosplit mode with -n or -p (splits $_ into @F)",
2805 "-C[number/list] enables the listed Unicode features",
2806 "-c check syntax only (runs BEGIN and CHECK blocks)",
2807 "-d[:debugger] run program under debugger",
2808 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2809 "-e program one line of program (several -e's allowed, omit programfile)",
2810 "-f don't do $sitelib/sitecustomize.pl at startup",
2811 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2812 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2813 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2814 "-l[octal] enable line ending processing, specifies line terminator",
2815 "-[mM][-]module execute \"use/no module...\" before executing program",
2816 "-n assume \"while (<>) { ... }\" loop around program",
2817 "-p assume loop like -n but print line also, like sed",
2818 "-P run program through C preprocessor before compilation",
2819 "-s enable rudimentary parsing for switches after programfile",
2820 "-S look for programfile using PATH environment variable",
2821 "-t enable tainting warnings",
2822 "-T enable tainting checks",
2823 "-u dump core after parsing program",
2824 "-U allow unsafe operations",
2825 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2826 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2827 "-w enable many useful warnings (RECOMMENDED)",
2828 "-W enable all warnings",
2829 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2830 "-X disable all warnings",
2834 const char * const *p = usage_msg;
2836 PerlIO_printf(PerlIO_stdout(),
2837 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2840 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2843 /* convert a string of -D options (or digits) into an int.
2844 * sets *s to point to the char after the options */
2848 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2850 static const char * const usage_msgd[] = {
2851 " Debugging flag values: (see also -d)",
2852 " p Tokenizing and parsing (with v, displays parse stack)",
2853 " s Stack snapshots (with v, displays all stacks)",
2854 " l Context (loop) stack processing",
2855 " t Trace execution",
2856 " o Method and overloading resolution",
2857 " c String/numeric conversions",
2858 " P Print profiling info, preprocessor command for -P, source file input state",
2859 " m Memory allocation",
2860 " f Format processing",
2861 " r Regular expression parsing and execution",
2862 " x Syntax tree dump",
2863 " u Tainting checks",
2864 " H Hash dump -- usurps values()",
2865 " X Scratchpad allocation",
2867 " S Thread synchronization",
2869 " R Include reference counts of dumped variables (eg when using -Ds)",
2870 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2871 " v Verbose: use in conjunction with other flags",
2873 " A Consistency checks on internal structures",
2874 " q quiet - currently only suppresses the 'EXECUTING' message",
2879 /* if adding extra options, remember to update DEBUG_MASK */
2880 static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
2882 for (; isALNUM(**s); (*s)++) {
2883 const char * const d = strchr(debopts,**s);
2885 i |= 1 << (d - debopts);
2886 else if (ckWARN_d(WARN_DEBUGGING))
2887 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2888 "invalid option -D%c, use -D'' to see choices\n", **s);
2891 else if (isDIGIT(**s)) {
2893 for (; isALNUM(**s); (*s)++) ;
2895 else if (givehelp) {
2896 const char *const *p = usage_msgd;
2897 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2900 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2901 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2902 "-Dp not implemented on this platform\n");
2908 /* This routine handles any switches that can be given during run */
2911 Perl_moreswitches(pTHX_ char *s)
2922 SvREFCNT_dec(PL_rs);
2923 if (s[1] == 'x' && s[2]) {
2924 const char *e = s+=2;
2930 flags = PERL_SCAN_SILENT_ILLDIGIT;
2931 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2932 if (s + numlen < e) {
2933 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2937 PL_rs = newSVpvn("", 0);
2938 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2939 tmps = (U8*)SvPVX(PL_rs);
2940 uvchr_to_utf8(tmps, rschar);
2941 SvCUR_set(PL_rs, UNISKIP(rschar));
2946 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2947 if (rschar & ~((U8)~0))
2948 PL_rs = &PL_sv_undef;
2949 else if (!rschar && numlen >= 2)
2950 PL_rs = newSVpvn("", 0);
2952 char ch = (char)rschar;
2953 PL_rs = newSVpvn(&ch, 1);
2956 sv_setsv(get_sv("/", TRUE), PL_rs);
2961 PL_unicode = parse_unicode_opts( (const char **)&s );
2966 while (*s && !isSPACE(*s)) ++s;
2968 PL_splitstr = savepv(PL_splitstr);
2982 /* -dt indicates to the debugger that threads will be used */
2983 if (*s == 't' && !isALNUM(s[1])) {
2985 my_setenv("PERL5DB_THREADED", "1");
2988 /* The following permits -d:Mod to accepts arguments following an =
2989 in the fashion that -MSome::Mod does. */
2990 if (*s == ':' || *s == '=') {
2992 SV * const sv = newSVpv("use Devel::", 0);
2994 /* We now allow -d:Module=Foo,Bar */
2995 while(isALNUM(*s) || *s==':') ++s;
2997 sv_catpv(sv, start);
2999 sv_catpvn(sv, start, s-start);
3000 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
3003 my_setenv("PERL5DB", SvPV_nolen_const(sv));
3006 PL_perldb = PERLDB_ALL;
3015 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3016 #else /* !DEBUGGING */
3017 if (ckWARN_d(WARN_DEBUGGING))
3018 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3019 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3020 for (s++; isALNUM(*s); s++) ;
3025 usage(PL_origargv[0]);
3028 Safefree(PL_inplace);
3029 #if defined(__CYGWIN__) /* do backup extension automagically */
3030 if (*(s+1) == '\0') {
3031 PL_inplace = savepv(".bak");
3034 #endif /* __CYGWIN__ */
3035 PL_inplace = savepv(s+1);
3036 for (s = PL_inplace; *s && !isSPACE(*s); s++)
3040 if (*s == '-') /* Additional switches on #! line. */
3044 case 'I': /* -I handled both here and in parse_body() */
3047 while (*s && isSPACE(*s))
3052 /* ignore trailing spaces (possibly followed by other switches) */
3054 for (e = p; *e && !isSPACE(*e); e++) ;
3058 } while (*p && *p != '-');
3059 e = savepvn(s, e-s);
3060 incpush(e, TRUE, TRUE, FALSE, FALSE);
3067 Perl_croak(aTHX_ "No directory specified for -I");
3073 SvREFCNT_dec(PL_ors_sv);
3079 PL_ors_sv = newSVpvn("\n",1);
3080 numlen = 3 + (*s == '0');
3081 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3085 if (RsPARA(PL_rs)) {
3086 PL_ors_sv = newSVpvn("\n\n",2);
3089 PL_ors_sv = newSVsv(PL_rs);
3096 PL_preambleav = newAV();
3099 char * const start = s;
3100 SV * const sv = newSVpv("use assertions::activate", 24);
3101 while(isALNUM(*s) || *s == ':') ++s;
3103 sv_catpvn(sv, "::", 2);
3104 sv_catpvn(sv, start, s-start);
3107 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
3110 else if (*s != '\0') {
3111 Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start);
3113 av_push(PL_preambleav, sv);
3117 forbid_setid("-M"); /* XXX ? */
3120 forbid_setid("-m"); /* XXX ? */
3124 const char *use = "use ";
3125 /* -M-foo == 'no foo' */
3126 /* Leading space on " no " is deliberate, to make both
3127 possibilities the same length. */
3128 if (*s == '-') { use = " no "; ++s; }
3129 sv = newSVpvn(use,4);
3131 /* We allow -M'Module qw(Foo Bar)' */
3132 while(isALNUM(*s) || *s==':') ++s;
3134 sv_catpv(sv, start);
3135 if (*(start-1) == 'm') {
3137 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3138 sv_catpv( sv, " ()");
3142 Perl_croak(aTHX_ "Module name required with -%c option",
3144 sv_catpvn(sv, start, s-start);
3145 sv_catpv(sv, " split(/,/,q");
3146 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
3148 sv_catpvn(sv, "\0)", 2);
3152 PL_preambleav = newAV();
3153 av_push(PL_preambleav, sv);
3156 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
3168 PL_doswitches = TRUE;
3182 #ifdef MACOS_TRADITIONAL
3183 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
3185 PL_do_undump = TRUE;
3193 if (!sv_derived_from(PL_patchlevel, "version"))
3194 (void *)upg_version(PL_patchlevel);
3196 PerlIO_printf(PerlIO_stdout(),
3197 Perl_form(aTHX_ "\nThis is perl, %"SVf" built for %s",
3198 vstringify(PL_patchlevel),
3201 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3202 PerlIO_printf(PerlIO_stdout(),
3203 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
3204 vstringify(PL_patchlevel)));
3205 PerlIO_printf(PerlIO_stdout(),
3206 Perl_form(aTHX_ " built under %s at %s %s\n",
3207 OSNAME, __DATE__, __TIME__));
3208 PerlIO_printf(PerlIO_stdout(),
3209 Perl_form(aTHX_ " OS Specific Release: %s\n",
3213 #if defined(LOCAL_PATCH_COUNT)
3214 if (LOCAL_PATCH_COUNT > 0)
3215 PerlIO_printf(PerlIO_stdout(),
3216 "\n(with %d registered patch%s, "
3217 "see perl -V for more detail)",
3218 (int)LOCAL_PATCH_COUNT,
3219 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3222 PerlIO_printf(PerlIO_stdout(),
3223 "\n\nCopyright 1987-2005, Larry Wall\n");
3224 #ifdef MACOS_TRADITIONAL
3225 PerlIO_printf(PerlIO_stdout(),
3226 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
3227 "maintained by Chris Nandor\n");
3230 PerlIO_printf(PerlIO_stdout(),
3231 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3234 PerlIO_printf(PerlIO_stdout(),
3235 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3236 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3239 PerlIO_printf(PerlIO_stdout(),
3240 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3241 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3244 PerlIO_printf(PerlIO_stdout(),
3245 "atariST series port, ++jrb bammi@cadence.com\n");
3248 PerlIO_printf(PerlIO_stdout(),
3249 "BeOS port Copyright Tom Spindler, 1997-1999\n");
3252 PerlIO_printf(PerlIO_stdout(),
3253 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3256 PerlIO_printf(PerlIO_stdout(),
3257 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3260 PerlIO_printf(PerlIO_stdout(),
3261 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3264 PerlIO_printf(PerlIO_stdout(),
3265 "VM/ESA port by Neale Ferguson, 1998-1999\n");
3268 PerlIO_printf(PerlIO_stdout(),
3269 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3272 PerlIO_printf(PerlIO_stdout(),
3273 "MiNT port by Guido Flohr, 1997-1999\n");
3276 PerlIO_printf(PerlIO_stdout(),
3277 "EPOC port by Olaf Flebbe, 1999-2002\n");
3280 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3281 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3284 #ifdef __SYMBIAN32__
3285 PerlIO_printf(PerlIO_stdout(),
3286 "Symbian port by Nokia, 2004-2005\n");
3288 #ifdef BINARY_BUILD_NOTICE
3289 BINARY_BUILD_NOTICE;
3291 PerlIO_printf(PerlIO_stdout(),
3293 Perl may be copied only under the terms of either the Artistic License or the\n\
3294 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3295 Complete documentation for Perl, including FAQ lists, should be found on\n\
3296 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3297 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3300 if (! (PL_dowarn & G_WARN_ALL_MASK))
3301 PL_dowarn |= G_WARN_ON;
3305 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3306 if (!specialWARN(PL_compiling.cop_warnings))
3307 SvREFCNT_dec(PL_compiling.cop_warnings);
3308 PL_compiling.cop_warnings = pWARN_ALL ;
3312 PL_dowarn = G_WARN_ALL_OFF;
3313 if (!specialWARN(PL_compiling.cop_warnings))
3314 SvREFCNT_dec(PL_compiling.cop_warnings);
3315 PL_compiling.cop_warnings = pWARN_NONE ;
3320 if (s[1] == '-') /* Additional switches on #! line. */
3325 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3331 #ifdef ALTERNATE_SHEBANG
3332 case 'S': /* OS/2 needs -S on "extproc" line. */
3340 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3345 /* compliments of Tom Christiansen */
3347 /* unexec() can be found in the Gnu emacs distribution */
3348 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3351 Perl_my_unexec(pTHX)
3359 prog = newSVpv(BIN_EXP, 0);
3360 sv_catpv(prog, "/perl");
3361 file = newSVpv(PL_origfilename, 0);
3362 sv_catpv(file, ".perldump");
3364 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3365 /* unexec prints msg to stderr in case of failure */
3366 PerlProc_exit(status);
3369 # include <lib$routines.h>
3370 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3372 ABORT(); /* for use with undump */
3377 /* initialize curinterp */
3383 # define PERLVAR(var,type)
3384 # define PERLVARA(var,n,type)
3385 # if defined(PERL_IMPLICIT_CONTEXT)
3386 # if defined(USE_5005THREADS)
3387 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3388 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3389 # else /* !USE_5005THREADS */
3390 # define PERLVARI(var,type,init) aTHX->var = init;
3391 # define PERLVARIC(var,type,init) aTHX->var = init;
3392 # endif /* USE_5005THREADS */
3394 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3395 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3397 # include "intrpvar.h"
3398 # ifndef USE_5005THREADS
3399 # include "thrdvar.h"
3406 # define PERLVAR(var,type)
3407 # define PERLVARA(var,n,type)
3408 # define PERLVARI(var,type,init) PL_##var = init;
3409 # define PERLVARIC(var,type,init) PL_##var = init;
3410 # include "intrpvar.h"
3411 # ifndef USE_5005THREADS
3412 # include "thrdvar.h"
3423 S_init_main_stash(pTHX)
3427 PL_curstash = PL_defstash = newHV();
3428 PL_curstname = newSVpvn("main",4);
3429 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
3430 SvREFCNT_dec(GvHV(gv));
3431 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
3433 hv_name_set(PL_defstash, "main", 4, 0);
3434 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
3435 GvMULTI_on(PL_incgv);
3436 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
3437 GvMULTI_on(PL_hintgv);
3438 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
3439 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
3440 GvMULTI_on(PL_errgv);
3441 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
3442 GvMULTI_on(PL_replgv);
3443 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
3444 #ifdef PERL_DONT_CREATE_GVSV
3447 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3448 sv_setpvn(ERRSV, "", 0);
3449 PL_curstash = PL_defstash;
3450 CopSTASH_set(&PL_compiling, PL_defstash);
3451 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3452 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
3453 /* We must init $/ before switches are processed. */
3454 sv_setpvn(get_sv("/", TRUE), "\n", 1);
3457 /* PSz 18 Nov 03 fdscript now global but do not change prototype */
3459 S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
3464 const char *cpp_discard_flag;
3473 PL_origfilename = savepvn("-e", 2);
3476 /* if find_script() returns, it returns a malloc()-ed value */
3477 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3479 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3480 const char *s = scriptname + 8;
3481 PL_fdscript = atoi(s);
3486 * Tell apart "normal" usage of fdscript, e.g.
3487 * with bash on FreeBSD:
3488 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3489 * from usage in suidperl.
3490 * Does any "normal" usage leave garbage after the number???
3491 * Is it a mistake to use a similar /dev/fd/ construct for
3496 * Be supersafe and do some sanity-checks.
3497 * Still, can we be sure we got the right thing?
3500 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3503 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3505 scriptname = savepv(s + 1);
3506 Safefree(PL_origfilename);
3507 PL_origfilename = (char *)scriptname;
3512 CopFILE_free(PL_curcop);
3513 CopFILE_set(PL_curcop, PL_origfilename);
3514 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3515 scriptname = (char *)"";
3516 if (PL_fdscript >= 0) {
3517 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
3518 # if defined(HAS_FCNTL) && defined(F_SETFD)
3520 /* ensure close-on-exec */
3521 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3526 Perl_croak(aTHX_ "sperl needs fd script\n"
3527 "You should not call sperl directly; do you need to "
3528 "change a #! line\nfrom sperl to perl?\n");
3531 * Do not open (or do other fancy stuff) while setuid.
3532 * Perl does the open, and hands script to suidperl on a fd;
3533 * suidperl only does some checks, sets up UIDs and re-execs
3534 * perl with that fd as it has always done.
3537 if (PL_suidscript != 1) {
3538 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3541 else if (PL_preprocess) {
3542 const char * const cpp_cfg = CPPSTDIN;
3543 SV * const cpp = newSVpvn("",0);
3544 SV * const cmd = NEWSV(0,0);
3546 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3547 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3548 if (strEQ(cpp_cfg, "cppstdin"))
3549 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3550 sv_catpv(cpp, cpp_cfg);
3553 sv_catpvn(sv, "-I", 2);
3554 sv_catpv(sv,PRIVLIB_EXP);
3557 DEBUG_P(PerlIO_printf(Perl_debug_log,
3558 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3559 scriptname, SvPVX_const (cpp), SvPVX_const (sv),
3562 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
3569 cpp_discard_flag = "";
3571 cpp_discard_flag = "-C";
3575 perl = os2_execname(aTHX);
3577 perl = PL_origargv[0];
3581 /* This strips off Perl comments which might interfere with
3582 the C pre-processor, including #!. #line directives are
3583 deliberately stripped to avoid confusion with Perl's version
3584 of #line. FWP played some golf with it so it will fit
3585 into VMS's 255 character buffer.
3588 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3590 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3592 Perl_sv_setpvf(aTHX_ cmd, "\
3593 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3594 perl, quote, code, quote, scriptname, cpp,
3595 cpp_discard_flag, sv, CPPMINUS);
3597 PL_doextract = FALSE;
3599 DEBUG_P(PerlIO_printf(Perl_debug_log,
3600 "PL_preprocess: cmd=\"%s\"\n",
3603 PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
3607 else if (!*scriptname) {
3608 forbid_setid("program input from stdin");
3609 PL_rsfp = PerlIO_stdin();
3612 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3613 # if defined(HAS_FCNTL) && defined(F_SETFD)
3615 /* ensure close-on-exec */
3616 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3619 #endif /* IAMSUID */
3621 /* PSz 16 Sep 03 Keep neat error message */
3623 Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3625 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3626 CopFILE(PL_curcop), Strerror(errno));
3631 * I_SYSSTATVFS HAS_FSTATVFS
3633 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3634 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3635 * here so that metaconfig picks them up. */
3639 S_fd_on_nosuid_fs(pTHX_ int fd)
3642 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3643 * but is needed also on machines without setreuid.
3644 * Seems safe enough to run as root.
3646 int check_okay = 0; /* able to do all the required sys/libcalls */
3647 int on_nosuid = 0; /* the fd is on a nosuid fs */
3649 * Need to check noexec also: nosuid might not be set, the average
3650 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3652 int on_noexec = 0; /* the fd is on a noexec fs */
3655 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3656 * fstatvfs() is UNIX98.
3657 * fstatfs() is 4.3 BSD.
3658 * ustat()+getmnt() is pre-4.3 BSD.
3659 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3660 * an irrelevant filesystem while trying to reach the right one.
3663 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3665 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3666 defined(HAS_FSTATVFS)
3667 # define FD_ON_NOSUID_CHECK_OKAY
3668 struct statvfs stfs;
3670 check_okay = fstatvfs(fd, &stfs) == 0;
3671 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
3673 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3674 on platforms where it is present. */
3675 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3677 # endif /* fstatvfs */
3679 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3680 defined(PERL_MOUNT_NOSUID) && \
3681 defined(PERL_MOUNT_NOEXEC) && \
3682 defined(HAS_FSTATFS) && \
3683 defined(HAS_STRUCT_STATFS) && \
3684 defined(HAS_STRUCT_STATFS_F_FLAGS)
3685 # define FD_ON_NOSUID_CHECK_OKAY
3688 check_okay = fstatfs(fd, &stfs) == 0;
3689 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3690 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3691 # endif /* fstatfs */
3693 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3694 defined(PERL_MOUNT_NOSUID) && \
3695 defined(PERL_MOUNT_NOEXEC) && \
3696 defined(HAS_FSTAT) && \
3697 defined(HAS_USTAT) && \
3698 defined(HAS_GETMNT) && \
3699 defined(HAS_STRUCT_FS_DATA) && \
3701 # define FD_ON_NOSUID_CHECK_OKAY
3704 if (fstat(fd, &fdst) == 0) {
3706 if (ustat(fdst.st_dev, &us) == 0) {
3708 /* NOSTAT_ONE here because we're not examining fields which
3709 * vary between that case and STAT_ONE. */
3710 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3711 size_t cmplen = sizeof(us.f_fname);
3712 if (sizeof(fsd.fd_req.path) < cmplen)
3713 cmplen = sizeof(fsd.fd_req.path);
3714 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3715 fdst.st_dev == fsd.fd_req.dev) {
3717 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3718 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3723 # endif /* fstat+ustat+getmnt */
3725 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3726 defined(HAS_GETMNTENT) && \
3727 defined(HAS_HASMNTOPT) && \
3728 defined(MNTOPT_NOSUID) && \
3729 defined(MNTOPT_NOEXEC)
3730 # define FD_ON_NOSUID_CHECK_OKAY
3731 FILE *mtab = fopen("/etc/mtab", "r");
3732 struct mntent *entry;
3735 if (mtab && (fstat(fd, &stb) == 0)) {
3736 while (entry = getmntent(mtab)) {
3737 if (stat(entry->mnt_dir, &fsb) == 0
3738 && fsb.st_dev == stb.st_dev)
3740 /* found the filesystem */
3742 if (hasmntopt(entry, MNTOPT_NOSUID))
3744 if (hasmntopt(entry, MNTOPT_NOEXEC))
3747 } /* A single fs may well fail its stat(). */
3752 # endif /* getmntent+hasmntopt */
3755 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3757 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3759 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3760 return ((!check_okay) || on_nosuid || on_noexec);
3762 #endif /* IAMSUID */
3765 S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
3770 #endif /* IAMSUID */
3772 /* do we need to emulate setuid on scripts? */
3774 /* This code is for those BSD systems that have setuid #! scripts disabled
3775 * in the kernel because of a security problem. Merely defining DOSUID
3776 * in perl will not fix that problem, but if you have disabled setuid
3777 * scripts in the kernel, this will attempt to emulate setuid and setgid
3778 * on scripts that have those now-otherwise-useless bits set. The setuid
3779 * root version must be called suidperl or sperlN.NNN. If regular perl
3780 * discovers that it has opened a setuid script, it calls suidperl with
3781 * the same argv that it had. If suidperl finds that the script it has
3782 * just opened is NOT setuid root, it sets the effective uid back to the
3783 * uid. We don't just make perl setuid root because that loses the
3784 * effective uid we had before invoking perl, if it was different from the
3787 * Description/comments above do not match current workings:
3788 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3789 * suidperl called with script open and name changed to /dev/fd/N/X;
3790 * suidperl croaks if script is not setuid;
3791 * making perl setuid would be a huge security risk (and yes, that
3792 * would lose any euid we might have had).
3794 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3795 * be defined in suidperl only. suidperl must be setuid root. The
3796 * Configure script will set this up for you if you want it.
3802 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3803 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3804 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3806 const char *linestr;
3809 if (PL_fdscript < 0 || PL_suidscript != 1)
3810 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3812 * Since the script is opened by perl, not suidperl, some of these
3813 * checks are superfluous. Leaving them in probably does not lower
3817 * Do checks even for systems with no HAS_SETREUID.
3818 * We used to swap, then re-swap UIDs with
3820 if (setreuid(PL_euid,PL_uid) < 0
3821 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3822 Perl_croak(aTHX_ "Can't swap uid and euid");
3825 if (setreuid(PL_uid,PL_euid) < 0
3826 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3827 Perl_croak(aTHX_ "Can't reswap uid and euid");
3831 /* On this access check to make sure the directories are readable,
3832 * there is actually a small window that the user could use to make
3833 * filename point to an accessible directory. So there is a faint
3834 * chance that someone could execute a setuid script down in a
3835 * non-accessible directory. I don't know what to do about that.
3836 * But I don't think it's too important. The manual lies when
3837 * it says access() is useful in setuid programs.
3839 * So, access() is pretty useless... but not harmful... do anyway.
3841 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3842 Perl_croak(aTHX_ "Can't access() script\n");
3845 /* If we can swap euid and uid, then we can determine access rights
3846 * with a simple stat of the file, and then compare device and
3847 * inode to make sure we did stat() on the same file we opened.
3848 * Then we just have to make sure he or she can execute it.
3851 * As the script is opened by perl, not suidperl, we do not need to
3852 * care much about access rights.
3854 * The 'script changed' check is needed, or we can get lied to
3855 * about $0 with e.g.
3856 * suidperl /dev/fd/4//bin/x 4<setuidscript
3857 * Without HAS_SETREUID, is it safe to stat() as root?
3859 * Are there any operating systems that pass /dev/fd/xxx for setuid
3860 * scripts, as suggested/described in perlsec(1)? Surely they do not
3861 * pass the script name as we do, so the "script changed" test would
3862 * fail for them... but we never get here with
3863 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3865 * This is one place where we must "lie" about return status: not
3866 * say if the stat() failed. We are doing this as root, and could
3867 * be tricked into reporting existence or not of files that the
3868 * "plain" user cannot even see.
3872 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3873 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3874 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3875 Perl_croak(aTHX_ "Setuid script changed\n");
3879 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3880 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3883 * We used to do this check as the "plain" user (after swapping
3884 * UIDs). But the check for nosuid and noexec filesystem is needed,
3885 * and should be done even without HAS_SETREUID. (Maybe those
3886 * operating systems do not have such mount options anyway...)
3887 * Seems safe enough to do as root.
3889 #if !defined(NO_NOSUID_CHECK)
3890 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3891 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3894 #endif /* IAMSUID */
3896 if (!S_ISREG(PL_statbuf.st_mode)) {
3897 Perl_croak(aTHX_ "Setuid script not plain file\n");
3899 if (PL_statbuf.st_mode & S_IWOTH)
3900 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3901 PL_doswitches = FALSE; /* -s is insecure in suid */
3902 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
3903 CopLINE_inc(PL_curcop);
3904 linestr = SvPV_nolen_const(PL_linestr);
3905 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3906 strnNE(linestr,"#!",2) ) /* required even on Sys V */
3907 Perl_croak(aTHX_ "No #! line");
3911 /* Sanity check on line length */
3912 if (strlen(s) < 1 || strlen(s) > 4000)
3913 Perl_croak(aTHX_ "Very long #! line");
3914 /* Allow more than a single space after #! */
3915 while (isSPACE(*s)) s++;
3916 /* Sanity check on buffer end */
3917 while ((*s) && !isSPACE(*s)) s++;
3918 for (s2 = s; (s2 > linestr &&
3919 (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
3920 || s2[-1] == '-')); s2--) ;
3921 /* Sanity check on buffer start */
3922 if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
3923 (s-9 < linestr || strnNE(s-9,"perl",4)) )
3924 Perl_croak(aTHX_ "Not a perl script");
3925 while (*s == ' ' || *s == '\t') s++;
3927 * #! arg must be what we saw above. They can invoke it by
3928 * mentioning suidperl explicitly, but they may not add any strange
3929 * arguments beyond what #! says if they do invoke suidperl that way.
3932 * The way validarg was set up, we rely on the kernel to start
3933 * scripts with argv[1] set to contain all #! line switches (the
3937 * Check that we got all the arguments listed in the #! line (not
3938 * just that there are no extraneous arguments). Might not matter
3939 * much, as switches from #! line seem to be acted upon (also), and
3940 * so may be checked and trapped in perl. But, security checks must
3941 * be done in suidperl and not deferred to perl. Note that suidperl
3942 * does not get around to parsing (and checking) the switches on
3943 * the #! line (but execs perl sooner).
3944 * Allow (require) a trailing newline (which may be of two
3945 * characters on some architectures?) (but no other trailing
3948 len = strlen(validarg);
3949 if (strEQ(validarg," PHOOEY ") ||
3950 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3951 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
3952 Perl_croak(aTHX_ "Args must match #! line");
3955 if (PL_fdscript < 0 &&
3956 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3957 PL_euid == PL_statbuf.st_uid)
3959 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3960 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
3961 #endif /* IAMSUID */
3963 if (PL_fdscript < 0 &&
3964 PL_euid) { /* oops, we're not the setuid root perl */
3966 * When root runs a setuid script, we do not go through the same
3967 * steps of execing sperl and then perl with fd scripts, but
3968 * simply set up UIDs within the same perl invocation; so do
3969 * not have the same checks (on options, whatever) that we have
3970 * for plain users. No problem really: would have to be a script
3971 * that does not actually work for plain users; and if root is
3972 * foolish and can be persuaded to run such an unsafe script, he
3973 * might run also non-setuid ones, and deserves what he gets.
3975 * Or, we might drop the PL_euid check above (and rely just on
3976 * PL_fdscript to avoid loops), and do the execs
3982 * Pass fd script to suidperl.
3983 * Exec suidperl, substituting fd script for scriptname.
3984 * Pass script name as "subdir" of fd, which perl will grok;
3985 * in fact will use that to distinguish this from "normal"
3986 * usage, see comments above.
3988 PerlIO_rewind(PL_rsfp);
3989 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3990 /* PSz 27 Feb 04 Sanity checks on scriptname */
3991 if ((!scriptname) || (!*scriptname) ) {
3992 Perl_croak(aTHX_ "No setuid script name\n");
3994 if (*scriptname == '-') {
3995 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3996 /* Or we might confuse it with an option when replacing
3997 * name in argument list, below (though we do pointer, not
3998 * string, comparisons).
4001 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
4002 if (!PL_origargv[which]) {
4003 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
4005 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
4006 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
4007 #if defined(HAS_FCNTL) && defined(F_SETFD)
4008 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
4011 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
4012 (int)PERL_REVISION, (int)PERL_VERSION,
4013 (int)PERL_SUBVERSION), PL_origargv);
4015 #endif /* IAMSUID */
4016 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
4019 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
4021 * This seems back to front: we try HAS_SETEGID first; if not available
4022 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
4023 * in the sense that we only want to set EGID; but are there any machines
4024 * with either of the latter, but not the former? Same with UID, later.
4027 (void)setegid(PL_statbuf.st_gid);
4030 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
4032 #ifdef HAS_SETRESGID
4033 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
4035 PerlProc_setgid(PL_statbuf.st_gid);
4039 if (PerlProc_getegid() != PL_statbuf.st_gid)
4040 Perl_croak(aTHX_ "Can't do setegid!\n");
4042 if (PL_statbuf.st_mode & S_ISUID) {
4043 if (PL_statbuf.st_uid != PL_euid)
4045 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
4048 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
4050 #ifdef HAS_SETRESUID
4051 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
4053 PerlProc_setuid(PL_statbuf.st_uid);
4057 if (PerlProc_geteuid() != PL_statbuf.st_uid)
4058 Perl_croak(aTHX_ "Can't do seteuid!\n");
4060 else if (PL_uid) { /* oops, mustn't run as root */
4062 (void)seteuid((Uid_t)PL_uid);
4065 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
4067 #ifdef HAS_SETRESUID
4068 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
4070 PerlProc_setuid((Uid_t)PL_uid);
4074 if (PerlProc_geteuid() != PL_uid)
4075 Perl_croak(aTHX_ "Can't do seteuid!\n");
4078 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
4079 Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
4082 else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
4083 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
4084 else if (PL_fdscript < 0 || PL_suidscript != 1)
4085 /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
4086 Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
4088 /* PSz 16 Sep 03 Keep neat error message */
4089 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
4092 /* We absolutely must clear out any saved ids here, so we */
4093 /* exec the real perl, substituting fd script for scriptname. */
4094 /* (We pass script name as "subdir" of fd, which perl will grok.) */
4096 * It might be thought that using setresgid and/or setresuid (changed to
4097 * set the saved IDs) above might obviate the need to exec, and we could
4098 * go on to "do the perl thing".
4100 * Is there such a thing as "saved GID", and is that set for setuid (but
4101 * not setgid) execution like suidperl? Without exec, it would not be
4102 * cleared for setuid (but not setgid) scripts (or might need a dummy
4105 * We need suidperl to do the exact same argument checking that perl
4106 * does. Thus it cannot be very small; while it could be significantly
4107 * smaller, it is safer (simpler?) to make it essentially the same
4108 * binary as perl (but they are not identical). - Maybe could defer that
4109 * check to the invoked perl, and suidperl be a tiny wrapper instead;
4110 * but prefer to do thorough checks in suidperl itself. Such deferral
4111 * would make suidperl security rely on perl, a design no-no.
4113 * Setuid things should be short and simple, thus easy to understand and
4114 * verify. They should do their "own thing", without influence by
4115 * attackers. It may help if their internal execution flow is fixed,
4116 * regardless of platform: it may be best to exec anyway.
4118 * Suidperl should at least be conceptually simple: a wrapper only,
4119 * never to do any real perl. Maybe we should put
4121 * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
4123 * into the perly bits.
4125 PerlIO_rewind(PL_rsfp);
4126 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
4128 * Keep original arguments: suidperl already has fd script.
4130 /* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
4131 /* if (!PL_origargv[which]) { */
4132 /* errno = EPERM; */
4133 /* Perl_croak(aTHX_ "Permission denied\n"); */
4135 /* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */
4136 /* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
4137 #if defined(HAS_FCNTL) && defined(F_SETFD)
4138 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
4141 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
4142 (int)PERL_REVISION, (int)PERL_VERSION,
4143 (int)PERL_SUBVERSION), PL_origargv);/* try again */
4145 Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
4146 #endif /* IAMSUID */
4148 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
4149 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
4150 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
4151 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
4153 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
4156 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4157 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4158 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4159 /* not set-id, must be wrapped */
4167 S_find_beginning(pTHX)
4170 register const char *s2;
4171 #ifdef MACOS_TRADITIONAL
4175 /* skip forward in input to the real script? */
4178 #ifdef MACOS_TRADITIONAL
4179 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
4181 while (PL_doextract || gMacPerl_AlwaysExtract) {
4182 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
4183 if (!gMacPerl_AlwaysExtract)
4184 Perl_croak(aTHX_ "No Perl script found in input\n");
4186 if (PL_doextract) /* require explicit override ? */
4187 if (!OverrideExtract(PL_origfilename))
4188 Perl_croak(aTHX_ "User aborted script\n");
4190 PL_doextract = FALSE;
4192 /* Pater peccavi, file does not have #! */
4193 PerlIO_rewind(PL_rsfp);
4198 while (PL_doextract) {
4199 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
4200 Perl_croak(aTHX_ "No Perl script found in input\n");
4203 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
4204 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
4205 PL_doextract = FALSE;
4206 while (*s && !(isSPACE (*s) || *s == '#')) s++;
4208 while (*s == ' ' || *s == '\t') s++;
4210 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4211 || s2[-1] == '_') s2--;
4212 if (strnEQ(s2-4,"perl",4))
4213 while ((s = moreswitches(s)))
4216 #ifdef MACOS_TRADITIONAL
4217 /* We are always searching for the #!perl line in MacPerl,
4218 * so if we find it, still keep the line count correct
4219 * by counting lines we already skipped over
4221 for (; maclines > 0 ; maclines--)
4222 PerlIO_ungetc(PL_rsfp, '\n');
4226 /* gMacPerl_AlwaysExtract is false in MPW tool */
4227 } else if (gMacPerl_AlwaysExtract) {
4238 PL_uid = PerlProc_getuid();
4239 PL_euid = PerlProc_geteuid();
4240 PL_gid = PerlProc_getgid();
4241 PL_egid = PerlProc_getegid();
4243 PL_uid |= PL_gid << 16;
4244 PL_euid |= PL_egid << 16;
4246 /* Should not happen: */
4247 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4248 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4251 * Should go by suidscript, not uid!=euid: why disallow
4252 * system("ls") in scripts run from setuid things?
4253 * Or, is this run before we check arguments and set suidscript?
4254 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4255 * (We never have suidscript, can we be sure to have fdscript?)
4256 * Or must then go by UID checks? See comments in forbid_setid also.
4260 /* This is used very early in the lifetime of the program,
4261 * before even the options are parsed, so PL_tainting has
4262 * not been initialized properly. */
4264 Perl_doing_taint(int argc, char *argv[], char *envp[])
4266 #ifndef PERL_IMPLICIT_SYS
4267 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4268 * before we have an interpreter-- and the whole point of this
4269 * function is to be called at such an early stage. If you are on
4270 * a system with PERL_IMPLICIT_SYS but you do have a concept of
4271 * "tainted because running with altered effective ids', you'll
4272 * have to add your own checks somewhere in here. The two most
4273 * known samples of 'implicitness' are Win32 and NetWare, neither
4274 * of which has much of concept of 'uids'. */
4275 int uid = PerlProc_getuid();
4276 int euid = PerlProc_geteuid();
4277 int gid = PerlProc_getgid();
4278 int egid = PerlProc_getegid();
4285 if (uid && (euid != uid || egid != gid))
4287 #endif /* !PERL_IMPLICIT_SYS */
4288 /* This is a really primitive check; environment gets ignored only
4289 * if -T are the first chars together; otherwise one gets
4290 * "Too late" message. */
4291 if ( argc > 1 && argv[1][0] == '-'
4292 && (argv[1][1] == 't' || argv[1][1] == 'T') )
4298 S_forbid_setid(pTHX_ const char *s)
4300 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4301 if (PL_euid != PL_uid)
4302 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
4303 if (PL_egid != PL_gid)
4304 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
4305 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4307 * Checks for UID/GID above "wrong": why disallow
4308 * perl -e 'print "Hello\n"'
4309 * from within setuid things?? Simply drop them: replaced by
4310 * fdscript/suidscript and #ifdef IAMSUID checks below.
4312 * This may be too late for command-line switches. Will catch those on
4313 * the #! line, after finding the script name and setting up
4314 * fdscript/suidscript. Note that suidperl does not get around to
4315 * parsing (and checking) the switches on the #! line, but checks that
4316 * the two sets are identical.
4318 * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
4319 * instead, or would that be "too late"? (We never have suidscript, can
4320 * we be sure to have fdscript?)
4322 * Catch things with suidscript (in descendant of suidperl), even with
4323 * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
4324 * below; but I am paranoid.
4326 * Also see comments about root running a setuid script, elsewhere.
4328 if (PL_suidscript >= 0)
4329 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
4331 /* PSz 11 Nov 03 Catch it in suidperl, always! */
4332 Perl_croak(aTHX_ "No %s allowed in suidperl", s);
4333 #endif /* IAMSUID */
4337 Perl_init_debugger(pTHX)
4339 HV * const ostash = PL_curstash;
4341 PL_curstash = PL_debstash;
4342 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
4343 AvREAL_off(PL_dbargs);
4344 PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
4345 PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4346 PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
4347 PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
4348 sv_setiv(PL_DBsingle, 0);
4349 PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
4350 sv_setiv(PL_DBtrace, 0);
4351 PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
4352 sv_setiv(PL_DBsignal, 0);
4353 PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
4354 sv_setiv(PL_DBassertion, 0);
4355 PL_curstash = ostash;
4358 #ifndef STRESS_REALLOC
4359 #define REASONABLE(size) (size)
4361 #define REASONABLE(size) (1) /* unreasonable */
4365 Perl_init_stacks(pTHX)
4367 /* start with 128-item stack and 8K cxstack */
4368 PL_curstackinfo = new_stackinfo(REASONABLE(128),
4369 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4370 PL_curstackinfo->si_type = PERLSI_MAIN;
4371 PL_curstack = PL_curstackinfo->si_stack;
4372 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
4374 PL_stack_base = AvARRAY(PL_curstack);
4375 PL_stack_sp = PL_stack_base;
4376 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4378 Newx(PL_tmps_stack,REASONABLE(128),SV*);
4381 PL_tmps_max = REASONABLE(128);
4383 Newx(PL_markstack,REASONABLE(32),I32);
4384 PL_markstack_ptr = PL_markstack;
4385 PL_markstack_max = PL_markstack + REASONABLE(32);
4389 Newx(PL_scopestack,REASONABLE(32),I32);
4390 PL_scopestack_ix = 0;
4391 PL_scopestack_max = REASONABLE(32);
4393 Newx(PL_savestack,REASONABLE(128),ANY);
4394 PL_savestack_ix = 0;
4395 PL_savestack_max = REASONABLE(128);
4403 while (PL_curstackinfo->si_next)
4404 PL_curstackinfo = PL_curstackinfo->si_next;
4405 while (PL_curstackinfo) {
4406 PERL_SI *p = PL_curstackinfo->si_prev;
4407 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4408 Safefree(PL_curstackinfo->si_cxstack);
4409 Safefree(PL_curstackinfo);
4410 PL_curstackinfo = p;
4412 Safefree(PL_tmps_stack);
4413 Safefree(PL_markstack);
4414 Safefree(PL_scopestack);
4415 Safefree(PL_savestack);
4424 lex_start(PL_linestr);
4426 PL_subname = newSVpvn("main",4);
4430 S_init_predump_symbols(pTHX)
4435 sv_setpvn(get_sv("\"", TRUE), " ", 1);
4436 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
4437 GvMULTI_on(PL_stdingv);
4438 io = GvIOp(PL_stdingv);
4439 IoTYPE(io) = IoTYPE_RDONLY;
4440 IoIFP(io) = PerlIO_stdin();
4441 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
4443 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4445 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
4448 IoTYPE(io) = IoTYPE_WRONLY;
4449 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4451 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
4453 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4455 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
4456 GvMULTI_on(PL_stderrgv);
4457 io = GvIOp(PL_stderrgv);
4458 IoTYPE(io) = IoTYPE_WRONLY;
4459 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4460 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
4462 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4464 PL_statname = NEWSV(66,0); /* last filename we did stat on */
4466 Safefree(PL_osname);
4467 PL_osname = savepv(OSNAME);
4471 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4473 argc--,argv++; /* skip name of script */
4474 if (PL_doswitches) {
4475 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4479 if (argv[0][1] == '-' && !argv[0][2]) {
4483 if ((s = strchr(argv[0], '='))) {
4485 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
4488 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
4491 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4492 GvMULTI_on(PL_argvgv);
4493 (void)gv_AVadd(PL_argvgv);
4494 av_clear(GvAVn(PL_argvgv));
4495 for (; argc > 0; argc--,argv++) {
4496 SV * const sv = newSVpv(argv[0],0);
4497 av_push(GvAVn(PL_argvgv),sv);
4498 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4499 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4502 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4503 (void)sv_utf8_decode(sv);
4509 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4514 PL_toptarget = NEWSV(0,0);
4515 sv_upgrade(PL_toptarget, SVt_PVFM);
4516 sv_setpvn(PL_toptarget, "", 0);
4517 PL_bodytarget = NEWSV(0,0);
4518 sv_upgrade(PL_bodytarget, SVt_PVFM);
4519 sv_setpvn(PL_bodytarget, "", 0);
4520 PL_formtarget = PL_bodytarget;
4524 init_argv_symbols(argc,argv);
4526 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
4527 #ifdef MACOS_TRADITIONAL
4528 /* $0 is not majick on a Mac */
4529 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4531 sv_setpv(GvSV(tmpgv),PL_origfilename);
4532 magicname("0", "0", 1);
4535 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
4537 GvMULTI_on(PL_envgv);
4538 hv = GvHVn(PL_envgv);
4539 hv_magic(hv, Nullgv, PERL_MAGIC_env);
4541 #ifdef USE_ENVIRON_ARRAY
4542 /* Note that if the supplied env parameter is actually a copy
4543 of the global environ then it may now point to free'd memory
4544 if the environment has been modified since. To avoid this
4545 problem we treat env==NULL as meaning 'use the default'
4550 # ifdef USE_ITHREADS
4551 && PL_curinterp == aTHX
4555 environ[0] = Nullch;
4558 char** origenv = environ;
4561 for (; *env; env++) {
4562 if (!(s = strchr(*env,'=')) || s == *env)
4564 #if defined(MSDOS) && !defined(DJGPP)
4569 sv = newSVpv(s+1, 0);
4570 (void)hv_store(hv, *env, s - *env, sv, 0);
4573 if (origenv != environ) {
4574 /* realloc has shifted us */
4575 env = (env - origenv) + environ;
4580 #endif /* USE_ENVIRON_ARRAY */
4581 #endif /* !PERL_MICRO */
4584 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4585 SvREADONLY_off(GvSV(tmpgv));
4586 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4587 SvREADONLY_on(GvSV(tmpgv));
4589 #ifdef THREADS_HAVE_PIDS
4590 PL_ppid = (IV)getppid();
4593 /* touch @F array to prevent spurious warnings 20020415 MJD */
4595 (void) get_av("main::F", TRUE | GV_ADDMULTI);
4597 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4598 (void) get_av("main::-", TRUE | GV_ADDMULTI);
4599 (void) get_av("main::+", TRUE | GV_ADDMULTI);
4603 S_init_perllib(pTHX)
4608 s = PerlEnv_getenv("PERL5LIB");
4610 * It isn't possible to delete an environment variable with
4611 * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4612 * case we treat PERL5LIB as undefined if it has a zero-length value.
4614 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4615 if (s && *s != '\0')
4619 incpush(s, TRUE, TRUE, TRUE, FALSE);
4621 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
4623 /* Treat PERL5?LIB as a possible search list logical name -- the
4624 * "natural" VMS idiom for a Unix path string. We allow each
4625 * element to be a set of |-separated directories for compatibility.
4629 if (my_trnlnm("PERL5LIB",buf,0))
4630 do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4632 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
4636 /* Use the ~-expanded versions of APPLLIB (undocumented),
4637 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4640 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
4644 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4646 #ifdef MACOS_TRADITIONAL
4649 SV * privdir = NEWSV(55, 0);
4650 char * macperl = PerlEnv_getenv("MACPERL");
4655 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4656 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4657 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4658 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4659 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4660 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4662 SvREFCNT_dec(privdir);
4665 incpush(":", FALSE, FALSE, TRUE, FALSE);
4668 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4671 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
4673 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4677 /* sitearch is always relative to sitelib on Windows for
4678 * DLL-based path intuition to work correctly */
4679 # if !defined(WIN32)
4680 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4686 /* this picks up sitearch as well */
4687 incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
4689 incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
4693 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
4694 incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
4697 #ifdef PERL_VENDORARCH_EXP
4698 /* vendorarch is always relative to vendorlib on Windows for
4699 * DLL-based path intuition to work correctly */
4700 # if !defined(WIN32)
4701 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4705 #ifdef PERL_VENDORLIB_EXP
4707 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE); /* this picks up vendorarch as well */
4709 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4713 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4714 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
4717 #ifdef PERL_OTHERLIBDIRS
4718 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
4722 incpush(".", FALSE, FALSE, TRUE, FALSE);
4723 #endif /* MACOS_TRADITIONAL */
4726 #if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
4727 # define PERLLIB_SEP ';'
4730 # define PERLLIB_SEP '|'
4732 # if defined(MACOS_TRADITIONAL)
4733 # define PERLLIB_SEP ','
4735 # define PERLLIB_SEP ':'
4739 #ifndef PERLLIB_MANGLE
4740 # define PERLLIB_MANGLE(s,n) (s)
4743 /* Push a directory onto @INC if it exists.
4744 Generate a new SV if we do this, to save needing to copy the SV we push
4747 S_incpush_if_exists(pTHX_ SV *dir)
4750 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4751 S_ISDIR(tmpstatbuf.st_mode)) {
4752 av_push(GvAVn(PL_incgv), dir);
4759 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
4762 SV *subdir = Nullsv;
4763 const char *p = dir;
4768 if (addsubdirs || addoldvers) {
4769 subdir = NEWSV(0,0);
4772 /* Break at all separators */
4774 SV *libdir = NEWSV(55,0);
4777 /* skip any consecutive separators */
4779 while ( *p == PERLLIB_SEP ) {
4780 /* Uncomment the next line for PATH semantics */
4781 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4786 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
4787 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4792 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4793 p = Nullch; /* break out */
4795 #ifdef MACOS_TRADITIONAL
4796 if (!strchr(SvPVX(libdir), ':')) {
4799 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4801 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4802 sv_catpv(libdir, ":");
4805 /* Do the if() outside the #ifdef to avoid warnings about an unused
4808 #ifdef PERL_RELOCATABLE_INC
4810 * Relocatable include entries are marked with a leading .../
4813 * 0: Remove that leading ".../"
4814 * 1: Remove trailing executable name (anything after the last '/')
4815 * from the perl path to give a perl prefix
4817 * While the @INC element starts "../" and the prefix ends with a real
4818 * directory (ie not . or ..) chop that real directory off the prefix
4819 * and the leading "../" from the @INC element. ie a logical "../"
4821 * Finally concatenate the prefix and the remainder of the @INC element
4822 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4823 * generates /usr/local/lib/perl5
4825 const char *libpath = SvPVX(libdir);
4826 STRLEN libpath_len = SvCUR(libdir);
4827 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4829 SV * const caret_X = get_sv("\030", 0);
4830 /* Going to use the SV just as a scratch buffer holding a C
4836 /* $^X is *the* source of taint if tainting is on, hence
4837 SvPOK() won't be true. */
4839 assert(SvPOKp(caret_X));
4840 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
4841 /* Firstly take off the leading .../
4842 If all else fail we'll do the paths relative to the current
4844 sv_chop(libdir, libpath + 4);
4845 /* Don't use SvPV as we're intentionally bypassing taining,
4846 mortal copies that the mg_get of tainting creates, and
4847 corruption that seems to come via the save stack.
4848 I guess that the save stack isn't correctly set up yet. */
4849 libpath = SvPVX(libdir);
4850 libpath_len = SvCUR(libdir);
4852 /* This would work more efficiently with memrchr, but as it's
4853 only a GNU extension we'd need to probe for it and
4854 implement our own. Not hard, but maybe not worth it? */
4856 prefix = SvPVX(prefix_sv);
4857 lastslash = strrchr(prefix, '/');
4859 /* First time in with the *lastslash = '\0' we just wipe off
4860 the trailing /perl from (say) /usr/foo/bin/perl
4864 while ((*lastslash = '\0'), /* Do that, come what may. */
4865 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4866 && (lastslash = strrchr(prefix, '/')))) {
4867 if (lastslash[1] == '\0'
4868 || (lastslash[1] == '.'
4869 && (lastslash[2] == '/' /* ends "/." */
4870 || (lastslash[2] == '/'
4871 && lastslash[3] == '/' /* or "/.." */
4873 /* Prefix ends "/" or "/." or "/..", any of which
4874 are fishy, so don't do any more logical cleanup.
4878 /* Remove leading "../" from path */
4881 /* Next iteration round the loop removes the last
4882 directory name from prefix by writing a '\0' in
4883 the while clause. */
4885 /* prefix has been terminated with a '\0' to the correct
4886 length. libpath points somewhere into the libdir SV.
4887 We need to join the 2 with '/' and drop the result into
4889 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4890 SvREFCNT_dec(libdir);
4891 /* And this is the new libdir. */
4894 (PL_uid != PL_euid || PL_gid != PL_egid)) {
4895 /* Need to taint reloccated paths if running set ID */
4896 SvTAINTED_on(libdir);
4899 SvREFCNT_dec(prefix_sv);
4904 * BEFORE pushing libdir onto @INC we may first push version- and
4905 * archname-specific sub-directories.
4907 if (addsubdirs || addoldvers) {
4908 #ifdef PERL_INC_VERSION_LIST
4909 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4910 const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4911 const char * const *incver;
4917 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
4919 while (unix[len-1] == '/') len--; /* Cosmetic */
4920 sv_usepvn(libdir,unix,len);
4923 PerlIO_printf(Perl_error_log,
4924 "Failed to unixify @INC element \"%s\"\n",
4928 #ifdef MACOS_TRADITIONAL
4929 #define PERL_AV_SUFFIX_FMT ""
4930 #define PERL_ARCH_FMT "%s:"
4931 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
4933 #define PERL_AV_SUFFIX_FMT "/"
4934 #define PERL_ARCH_FMT "/%s"
4935 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
4937 /* .../version/archname if -d .../version/archname */
4938 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
4940 (int)PERL_REVISION, (int)PERL_VERSION,
4941 (int)PERL_SUBVERSION, ARCHNAME);
4942 subdir = S_incpush_if_exists(aTHX_ subdir);
4944 /* .../version if -d .../version */
4945 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
4946 (int)PERL_REVISION, (int)PERL_VERSION,
4947 (int)PERL_SUBVERSION);
4948 subdir = S_incpush_if_exists(aTHX_ subdir);
4950 /* .../archname if -d .../archname */
4951 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
4952 subdir = S_incpush_if_exists(aTHX_ subdir);
4956 #ifdef PERL_INC_VERSION_LIST
4958 for (incver = incverlist; *incver; incver++) {
4959 /* .../xxx if -d .../xxx */
4960 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
4961 subdir = S_incpush_if_exists(aTHX_ subdir);
4967 /* finally push this lib directory on the end of @INC */
4968 av_push(GvAVn(PL_incgv), libdir);
4971 assert (SvREFCNT(subdir) == 1);
4972 SvREFCNT_dec(subdir);
4976 #ifdef USE_5005THREADS
4977 STATIC struct perl_thread *
4978 S_init_main_thread(pTHX)
4980 #if !defined(PERL_IMPLICIT_CONTEXT)
4981 struct perl_thread *thr;
4985 Newxz(thr, 1, struct perl_thread);
4986 PL_curcop = &PL_compiling;
4987 thr->interp = PERL_GET_INTERP;
4988 thr->cvcache = newHV();
4989 thr->threadsv = newAV();
4990 /* thr->threadsvp is set when find_threadsv is called */
4991 thr->specific = newAV();
4992 thr->flags = THRf_R_JOINABLE;
4993 MUTEX_INIT(&thr->mutex);
4994 /* Handcraft thrsv similarly to mess_sv */
4995 Newx(PL_thrsv, 1, SV);
4997 SvFLAGS(PL_thrsv) = SVt_PV;
4998 SvANY(PL_thrsv) = (void*)xpv;
4999 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
5000 SvPV_set(PL_thrsvr, (char*)thr);
5001 SvCUR_set(PL_thrsv, sizeof(thr));
5002 SvLEN_set(PL_thrsv, sizeof(thr));
5003 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
5004 thr->oursv = PL_thrsv;
5005 PL_chopset = " \n-";
5008 MUTEX_LOCK(&PL_threads_mutex);
5014 MUTEX_UNLOCK(&PL_threads_mutex);
5016 #ifdef HAVE_THREAD_INTERN
5017 Perl_init_thread_intern(thr);
5020 #ifdef SET_THREAD_SELF
5021 SET_THREAD_SELF(thr);
5023 thr->self = pthread_self();
5024 #endif /* SET_THREAD_SELF */
5028 * These must come after the thread self setting
5029 * because sv_setpvn does SvTAINT and the taint
5030 * fields thread selfness being set.
5032 PL_toptarget = NEWSV(0,0);
5033 sv_upgrade(PL_toptarget, SVt_PVFM);
5034 sv_setpvn(PL_toptarget, "", 0);
5035 PL_bodytarget = NEWSV(0,0);
5036 sv_upgrade(PL_bodytarget, SVt_PVFM);
5037 sv_setpvn(PL_bodytarget, "", 0);
5038 PL_formtarget = PL_bodytarget;
5039 thr->errsv = newSVpvn("", 0);
5040 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5043 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
5044 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
5045 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
5046 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
5047 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
5048 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
5050 PL_reginterp_cnt = 0;
5054 #endif /* USE_5005THREADS */
5057 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
5061 const line_t oldline = CopLINE(PL_curcop);
5067 while (av_len(paramList) >= 0) {
5068 cv = (CV*)av_shift(paramList);
5070 if (paramList == PL_beginav) {
5071 /* save PL_beginav for compiler */
5072 if (! PL_beginav_save)
5073 PL_beginav_save = newAV();
5074 av_push(PL_beginav_save, (SV*)cv);
5076 else if (paramList == PL_checkav) {
5077 /* save PL_checkav for compiler */
5078 if (! PL_checkav_save)
5079 PL_checkav_save = newAV();
5080 av_push(PL_checkav_save, (SV*)cv);
5090 (void)SvPV_const(atsv, len);
5092 PL_curcop = &PL_compiling;
5093 CopLINE_set(PL_curcop, oldline);
5094 if (paramList == PL_beginav)
5095 sv_catpv(atsv, "BEGIN failed--compilation aborted");
5097 Perl_sv_catpvf(aTHX_ atsv,
5098 "%s failed--call queue aborted",
5099 paramList == PL_checkav ? "CHECK"
5100 : paramList == PL_initav ? "INIT"
5102 while (PL_scopestack_ix > oldscope)
5105 Perl_croak(aTHX_ "%"SVf"", atsv);
5112 /* my_exit() was called */
5113 while (PL_scopestack_ix > oldscope)
5116 PL_curstash = PL_defstash;
5117 PL_curcop = &PL_compiling;
5118 CopLINE_set(PL_curcop, oldline);
5120 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
5121 if (paramList == PL_beginav)
5122 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
5124 Perl_croak(aTHX_ "%s failed--call queue aborted",
5125 paramList == PL_checkav ? "CHECK"
5126 : paramList == PL_initav ? "INIT"
5133 PL_curcop = &PL_compiling;
5134 CopLINE_set(PL_curcop, oldline);
5137 PerlIO_printf(Perl_error_log, "panic: restartop\n");
5146 S_call_list_body(pTHX_ CV *cv)
5148 PUSHMARK(PL_stack_sp);
5149 call_sv((SV*)cv, G_EVAL|G_DISCARD);
5154 Perl_my_exit(pTHX_ U32 status)
5156 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
5157 thr, (unsigned long) status));
5166 STATUS_EXIT_SET(status);
5173 Perl_my_failure_exit(pTHX)
5176 /* We have been called to fall on our sword. The desired exit code
5177 * should be already set in STATUS_UNIX, but could be shifted over
5178 * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
5181 * If an error code has not been set, then force the issue.
5183 if (MY_POSIX_EXIT) {
5185 /* In POSIX_EXIT mode follow Perl documentations and use 255 for
5186 * the exit code when there isn't an error.
5189 if (STATUS_UNIX == 0)
5190 STATUS_UNIX_EXIT_SET(255);
5192 STATUS_UNIX_EXIT_SET(STATUS_UNIX);
5194 /* The exit code could have been set by $? or vmsish which
5195 * means that it may not be fatal. So convert
5196 * success/warning codes to fatal.
5198 if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0)
5199 STATUS_UNIX_EXIT_SET(255);
5203 /* Traditionally Perl on VMS always expects a Fatal Error. */
5204 if (vaxc$errno & 1) {
5206 /* So force success status to failure */
5207 if (STATUS_NATIVE & 1)
5212 STATUS_UNIX = EINTR; /* In case something cares */
5217 STATUS_NATIVE = vaxc$errno; /* Should already be this */
5219 /* Encode the severity code */
5220 severity = STATUS_NATIVE & STS$M_SEVERITY;
5221 STATUS_UNIX = (severity ? severity : 1) << 8;
5223 /* Perl expects this to be a fatal error */
5224 if (severity != STS$K_SEVERE)
5233 STATUS_UNIX_SET(errno);
5235 exitstatus = STATUS_UNIX >> 8;
5236 if (exitstatus & 255)
5237 STATUS_UNIX_SET(exitstatus);
5239 STATUS_UNIX_SET(255);
5246 S_my_exit_jump(pTHX)
5249 register PERL_CONTEXT *cx;
5254 SvREFCNT_dec(PL_e_script);
5255 PL_e_script = Nullsv;
5258 POPSTACK_TO(PL_mainstack);
5259 if (cxstack_ix >= 0) {
5262 POPBLOCK(cx,PL_curpm);
5267 PERL_UNUSED_VAR(gimme);
5268 PERL_UNUSED_VAR(newsp);
5272 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5274 const char * const p = SvPVX_const(PL_e_script);
5275 const char *nl = strchr(p, '\n');
5277 PERL_UNUSED_ARG(idx);
5278 PERL_UNUSED_ARG(maxlen);
5280 nl = (nl) ? nl+1 : SvEND(PL_e_script);
5282 filter_del(read_e_script);
5285 sv_catpvn(buf_sv, p, nl-p);
5286 sv_chop(PL_e_script, nl);
5292 * c-indentation-style: bsd
5294 * indent-tabs-mode: t
5297 * ex: set ts=8 sts=4 sw=4 noet: