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 /* New() 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 /* New() 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 = Perl_sighandler;
262 PL_pidstatus = newHV();
265 PL_rs = newSVpvn("\n", 1);
270 PL_lex_state = LEX_NOTPARSING;
276 SET_NUMERIC_STANDARD();
278 #if defined(LOCAL_PATCH_COUNT)
279 PL_localpatches = local_patches; /* For possible -v */
282 #ifdef HAVE_INTERP_INTERN
286 PerlIO_init(aTHX); /* Hook to IO system */
288 PL_fdpid = newAV(); /* for remembering popen pids by fd */
289 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
290 PL_errors = newSVpvn("",0);
291 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
292 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
293 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
295 PL_regex_padav = newAV();
296 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
297 PL_regex_pad = AvARRAY(PL_regex_padav);
299 #ifdef USE_REENTRANT_API
300 Perl_reentrant_init(aTHX);
303 /* Note that strtab is a rather special HV. Assumptions are made
304 about not iterating on it, and not adding tie magic to it.
305 It is properly deallocated in perl_destruct() */
308 HvSHAREKEYS_off(PL_strtab); /* mandatory */
309 hv_ksplit(PL_strtab, 512);
311 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
312 _dyld_lookup_and_bind
313 ("__environ", (unsigned long *) &environ_pointer, NULL);
317 # ifdef USE_ENVIRON_ARRAY
318 PL_origenviron = environ;
322 /* Use sysconf(_SC_CLK_TCK) if available, if not
323 * available or if the sysconf() fails, use the HZ.
324 * BeOS has those, but returns the wrong value.
325 * The HZ if not originally defined has been by now
326 * been defined as CLK_TCK, if available. */
327 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
328 PL_clocktick = sysconf(_SC_CLK_TCK);
329 if (PL_clocktick <= 0)
333 PL_stashcache = newHV();
335 PL_patchlevel = Perl_newSVpvf(aTHX_ "%d.%d.%d", (int)PERL_REVISION,
336 (int)PERL_VERSION, (int)PERL_SUBVERSION);
339 if (!PL_mmap_page_size) {
340 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
342 SETERRNO(0, SS_NORMAL);
344 PL_mmap_page_size = sysconf(_SC_PAGESIZE);
346 PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
348 if ((long) PL_mmap_page_size < 0) {
351 (void) SvUPGRADE(error, SVt_PV);
352 Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
355 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
359 # ifdef HAS_GETPAGESIZE
360 PL_mmap_page_size = getpagesize();
362 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
363 PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
367 if (PL_mmap_page_size <= 0)
368 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
369 (IV) PL_mmap_page_size);
371 #endif /* HAS_MMAP */
373 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
374 PL_timesbase.tms_utime = 0;
375 PL_timesbase.tms_stime = 0;
376 PL_timesbase.tms_cutime = 0;
377 PL_timesbase.tms_cstime = 0;
384 =for apidoc nothreadhook
386 Stub that provides thread hook for perl_destruct when there are
393 Perl_nothreadhook(pTHX)
398 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
400 Perl_dump_sv_child(pTHX_ SV *sv)
403 const int sock = PL_dumper_fd;
404 const int debug_fd = PerlIO_fileno(Perl_debug_log);
405 union control_un control;
408 struct cmsghdr *cmptr;
410 unsigned char buffer[256];
412 if(sock == -1 || debug_fd == -1)
415 PerlIO_flush(Perl_debug_log);
417 /* All these shenanigans are to pass a file descriptor over to our child for
418 it to dump out to. We can't let it hold open the file descriptor when it
419 forks, as the file descriptor it will dump to can turn out to be one end
420 of pipe that some other process will wait on for EOF. (So as it would
421 be open, the wait would be forever. */
423 msg.msg_control = control.control;
424 msg.msg_controllen = sizeof(control.control);
425 /* We're a connected socket so we don't need a destination */
431 cmptr = CMSG_FIRSTHDR(&msg);
432 cmptr->cmsg_len = CMSG_LEN(sizeof(int));
433 cmptr->cmsg_level = SOL_SOCKET;
434 cmptr->cmsg_type = SCM_RIGHTS;
435 *((int *)CMSG_DATA(cmptr)) = 1;
437 vec[0].iov_base = (void*)&sv;
438 vec[0].iov_len = sizeof(sv);
439 got = sendmsg(sock, &msg, 0);
442 perror("Debug leaking scalars parent sendmsg failed");
445 if(got < sizeof(sv)) {
446 perror("Debug leaking scalars parent short sendmsg");
450 /* Return protocol is
452 unsigned char: length of location string (0 for empty)
453 unsigned char*: string (not terminated)
455 vec[0].iov_base = (void*)&returned_errno;
456 vec[0].iov_len = sizeof(returned_errno);
457 vec[1].iov_base = buffer;
460 got = readv(sock, vec, 2);
463 perror("Debug leaking scalars parent read failed");
464 PerlIO_flush(PerlIO_stderr());
467 if(got < sizeof(returned_errno) + 1) {
468 perror("Debug leaking scalars parent short read");
469 PerlIO_flush(PerlIO_stderr());
474 got = read(sock, buffer + 1, *buffer);
476 perror("Debug leaking scalars parent read 2 failed");
477 PerlIO_flush(PerlIO_stderr());
482 perror("Debug leaking scalars parent short read 2");
483 PerlIO_flush(PerlIO_stderr());
488 if (returned_errno || *buffer) {
489 Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
490 " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
491 returned_errno, strerror(returned_errno));
497 =for apidoc perl_destruct
499 Shuts down a Perl interpreter. See L<perlembed>.
508 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
510 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
514 PERL_UNUSED_ARG(my_perl);
516 /* wait for all pseudo-forked children to finish */
517 PERL_WAIT_FOR_CHILDREN;
519 destruct_level = PL_perl_destruct_level;
522 const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
524 const int i = atoi(s);
525 if (destruct_level < i)
531 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
537 if (PL_endav && !PL_minus_c)
538 call_list(PL_scopestack_ix, PL_endav);
544 /* Need to flush since END blocks can produce output */
547 if (CALL_FPTR(PL_threadhook)(aTHX)) {
548 /* Threads hook has vetoed further cleanup */
549 return STATUS_NATIVE_EXPORT;
552 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
553 if (destruct_level != 0) {
554 /* Fork here to create a child. Our child's job is to preserve the
555 state of scalars prior to destruction, so that we can instruct it
556 to dump any scalars that we later find have leaked.
557 There's no subtlety in this code - it assumes POSIX, and it doesn't
561 if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
562 perror("Debug leaking scalars socketpair failed");
568 perror("Debug leaking scalars fork failed");
572 /* We are the child */
573 const int sock = fd[1];
574 const int debug_fd = PerlIO_fileno(Perl_debug_log);
577 /* Our success message is an integer 0, and a char 0 */
578 static const char success[sizeof(int) + 1];
582 /* We need to close all other file descriptors otherwise we end up
583 with interesting hangs, where the parent closes its end of a
584 pipe, and sits waiting for (another) child to terminate. Only
585 that child never terminates, because it never gets EOF, because
586 we also have the far end of the pipe open. We even need to
587 close the debugging fd, because sometimes it happens to be one
588 end of a pipe, and a process is waiting on the other end for
589 EOF. Normally it would be closed at some point earlier in
590 destruction, but if we happen to cause the pipe to remain open,
591 EOF never occurs, and we get an infinite hang. Hence all the
592 games to pass in a file descriptor if it's actually needed. */
594 f = sysconf(_SC_OPEN_MAX);
596 where = "sysconf failed";
607 union control_un control;
610 struct cmsghdr *cmptr;
614 msg.msg_control = control.control;
615 msg.msg_controllen = sizeof(control.control);
616 /* We're a connected socket so we don't need a source */
620 msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
622 vec[0].iov_base = (void*)⌖
623 vec[0].iov_len = sizeof(target);
625 got = recvmsg(sock, &msg, 0);
630 where = "recv failed";
633 if(got < sizeof(target)) {
634 where = "short recv";
638 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
642 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
643 where = "wrong cmsg_len";
646 if(cmptr->cmsg_level != SOL_SOCKET) {
647 where = "wrong cmsg_level";
650 if(cmptr->cmsg_type != SCM_RIGHTS) {
651 where = "wrong cmsg_type";
655 got_fd = *(int*)CMSG_DATA(cmptr);
656 /* For our last little bit of trickery, put the file descriptor
657 back into Perl_debug_log, as if we never actually closed it
659 if(got_fd != debug_fd) {
660 if (dup2(got_fd, debug_fd) == -1) {
667 PerlIO_flush(Perl_debug_log);
669 got = write(sock, &success, sizeof(success));
672 where = "write failed";
675 if(got < sizeof(success)) {
676 where = "short write";
683 int send_errno = errno;
684 unsigned char length = (unsigned char) strlen(where);
685 struct iovec failure[3] = {
686 {(void*)&send_errno, sizeof(send_errno)},
688 {(void*)where, length}
690 int got = writev(sock, failure, 3);
691 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
692 in the parent if we try to read from the socketpair after the
693 child has exited, even if there was data to read.
694 So sleep a bit to give the parent a fighting chance of
697 _exit((got == -1) ? errno : 0);
701 PL_dumper_fd = fd[0];
706 /* We must account for everything. */
708 /* Destroy the main CV and syntax tree */
709 /* Do this now, because destroying ops can cause new SVs to be generated
710 in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
711 PL_curcop to point to a valid op from which the filename structure
713 PL_curcop = &PL_compiling;
715 /* ensure comppad/curpad to refer to main's pad */
716 if (CvPADLIST(PL_main_cv)) {
717 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
719 op_free(PL_main_root);
720 PL_main_root = Nullop;
722 PL_main_start = Nullop;
723 SvREFCNT_dec(PL_main_cv);
727 /* Tell PerlIO we are about to tear things apart in case
728 we have layers which are using resources that should
732 PerlIO_destruct(aTHX);
734 if (PL_sv_objcount) {
736 * Try to destruct global references. We do this first so that the
737 * destructors and destructees still exist. Some sv's might remain.
738 * Non-referenced objects are on their own.
744 /* unhook hooks which will soon be, or use, destroyed data */
745 SvREFCNT_dec(PL_warnhook);
746 PL_warnhook = Nullsv;
747 SvREFCNT_dec(PL_diehook);
750 /* call exit list functions */
751 while (PL_exitlistlen-- > 0)
752 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
754 Safefree(PL_exitlist);
759 if (destruct_level == 0){
761 DEBUG_P(debprofdump());
763 #if defined(PERLIO_LAYERS)
764 /* No more IO - including error messages ! */
765 PerlIO_cleanup(aTHX);
768 /* The exit() function will do everything that needs doing. */
769 return STATUS_NATIVE_EXPORT;
772 /* jettison our possibly duplicated environment */
773 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
774 * so we certainly shouldn't free it here
777 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
778 if (environ != PL_origenviron && !PL_use_safe_putenv
780 /* only main thread can free environ[0] contents */
781 && PL_curinterp == aTHX
787 for (i = 0; environ[i]; i++)
788 safesysfree(environ[i]);
790 /* Must use safesysfree() when working with environ. */
791 safesysfree(environ);
793 environ = PL_origenviron;
796 #endif /* !PERL_MICRO */
798 /* reset so print() ends up where we expect */
802 /* the syntax tree is shared between clones
803 * so op_free(PL_main_root) only ReREFCNT_dec's
804 * REGEXPs in the parent interpreter
805 * we need to manually ReREFCNT_dec for the clones
808 I32 i = AvFILLp(PL_regex_padav) + 1;
809 SV **ary = AvARRAY(PL_regex_padav);
814 if (SvFLAGS(resv) & SVf_BREAK) {
815 /* this is PL_reg_curpm, already freed
816 * flag is set in regexec.c:S_regtry
818 SvFLAGS(resv) &= ~SVf_BREAK;
820 else if(SvREPADTMP(resv)) {
821 SvREPADTMP_off(resv);
823 else if(SvIOKp(resv)) {
824 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
829 SvREFCNT_dec(PL_regex_padav);
830 PL_regex_padav = Nullav;
834 SvREFCNT_dec((SV*) PL_stashcache);
835 PL_stashcache = NULL;
837 /* loosen bonds of global variables */
840 (void)PerlIO_close(PL_rsfp);
844 /* Filters for program text */
845 SvREFCNT_dec(PL_rsfp_filters);
846 PL_rsfp_filters = Nullav;
849 PL_preprocess = FALSE;
855 PL_doswitches = FALSE;
856 PL_dowarn = G_WARN_OFF;
857 PL_doextract = FALSE;
858 PL_sawampersand = FALSE; /* must save all match strings */
861 Safefree(PL_inplace);
863 SvREFCNT_dec(PL_patchlevel);
866 SvREFCNT_dec(PL_e_script);
867 PL_e_script = Nullsv;
872 /* magical thingies */
874 SvREFCNT_dec(PL_ofs_sv); /* $, */
877 SvREFCNT_dec(PL_ors_sv); /* $\ */
880 SvREFCNT_dec(PL_rs); /* $/ */
883 PL_multiline = 0; /* $* */
884 Safefree(PL_osname); /* $^O */
887 SvREFCNT_dec(PL_statname);
888 PL_statname = Nullsv;
891 /* defgv, aka *_ should be taken care of elsewhere */
893 /* clean up after study() */
894 SvREFCNT_dec(PL_lastscream);
895 PL_lastscream = Nullsv;
896 Safefree(PL_screamfirst);
898 Safefree(PL_screamnext);
902 Safefree(PL_efloatbuf);
903 PL_efloatbuf = Nullch;
906 /* startup and shutdown function lists */
907 SvREFCNT_dec(PL_beginav);
908 SvREFCNT_dec(PL_beginav_save);
909 SvREFCNT_dec(PL_endav);
910 SvREFCNT_dec(PL_checkav);
911 SvREFCNT_dec(PL_checkav_save);
912 SvREFCNT_dec(PL_initav);
914 PL_beginav_save = Nullav;
917 PL_checkav_save = Nullav;
920 /* shortcuts just get cleared */
926 PL_argvoutgv = Nullgv;
928 PL_stderrgv = Nullgv;
929 PL_last_in_gv = Nullgv;
934 PL_DBsingle = Nullsv;
936 PL_DBsignal = Nullsv;
937 PL_DBassertion = Nullsv;
940 PL_debstash = Nullhv;
942 SvREFCNT_dec(PL_argvout_stack);
943 PL_argvout_stack = Nullav;
945 SvREFCNT_dec(PL_modglobal);
946 PL_modglobal = Nullhv;
947 SvREFCNT_dec(PL_preambleav);
948 PL_preambleav = Nullav;
949 SvREFCNT_dec(PL_subname);
951 SvREFCNT_dec(PL_linestr);
953 SvREFCNT_dec(PL_pidstatus);
954 PL_pidstatus = Nullhv;
955 SvREFCNT_dec(PL_toptarget);
956 PL_toptarget = Nullsv;
957 SvREFCNT_dec(PL_bodytarget);
958 PL_bodytarget = Nullsv;
959 PL_formtarget = Nullsv;
961 /* free locale stuff */
962 #ifdef USE_LOCALE_COLLATE
963 Safefree(PL_collation_name);
964 PL_collation_name = Nullch;
967 #ifdef USE_LOCALE_NUMERIC
968 Safefree(PL_numeric_name);
969 PL_numeric_name = Nullch;
970 SvREFCNT_dec(PL_numeric_radix_sv);
971 PL_numeric_radix_sv = Nullsv;
974 /* clear utf8 character classes */
975 SvREFCNT_dec(PL_utf8_alnum);
976 SvREFCNT_dec(PL_utf8_alnumc);
977 SvREFCNT_dec(PL_utf8_ascii);
978 SvREFCNT_dec(PL_utf8_alpha);
979 SvREFCNT_dec(PL_utf8_space);
980 SvREFCNT_dec(PL_utf8_cntrl);
981 SvREFCNT_dec(PL_utf8_graph);
982 SvREFCNT_dec(PL_utf8_digit);
983 SvREFCNT_dec(PL_utf8_upper);
984 SvREFCNT_dec(PL_utf8_lower);
985 SvREFCNT_dec(PL_utf8_print);
986 SvREFCNT_dec(PL_utf8_punct);
987 SvREFCNT_dec(PL_utf8_xdigit);
988 SvREFCNT_dec(PL_utf8_mark);
989 SvREFCNT_dec(PL_utf8_toupper);
990 SvREFCNT_dec(PL_utf8_totitle);
991 SvREFCNT_dec(PL_utf8_tolower);
992 SvREFCNT_dec(PL_utf8_tofold);
993 SvREFCNT_dec(PL_utf8_idstart);
994 SvREFCNT_dec(PL_utf8_idcont);
995 PL_utf8_alnum = Nullsv;
996 PL_utf8_alnumc = Nullsv;
997 PL_utf8_ascii = Nullsv;
998 PL_utf8_alpha = Nullsv;
999 PL_utf8_space = Nullsv;
1000 PL_utf8_cntrl = Nullsv;
1001 PL_utf8_graph = Nullsv;
1002 PL_utf8_digit = Nullsv;
1003 PL_utf8_upper = Nullsv;
1004 PL_utf8_lower = Nullsv;
1005 PL_utf8_print = Nullsv;
1006 PL_utf8_punct = Nullsv;
1007 PL_utf8_xdigit = Nullsv;
1008 PL_utf8_mark = Nullsv;
1009 PL_utf8_toupper = Nullsv;
1010 PL_utf8_totitle = Nullsv;
1011 PL_utf8_tolower = Nullsv;
1012 PL_utf8_tofold = Nullsv;
1013 PL_utf8_idstart = Nullsv;
1014 PL_utf8_idcont = Nullsv;
1016 if (!specialWARN(PL_compiling.cop_warnings))
1017 SvREFCNT_dec(PL_compiling.cop_warnings);
1018 PL_compiling.cop_warnings = Nullsv;
1019 if (!specialCopIO(PL_compiling.cop_io))
1020 SvREFCNT_dec(PL_compiling.cop_io);
1021 PL_compiling.cop_io = Nullsv;
1022 CopFILE_free(&PL_compiling);
1023 CopSTASH_free(&PL_compiling);
1025 /* Prepare to destruct main symbol table. */
1030 SvREFCNT_dec(PL_curstname);
1031 PL_curstname = Nullsv;
1033 /* clear queued errors */
1034 SvREFCNT_dec(PL_errors);
1038 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
1039 if (PL_scopestack_ix != 0)
1040 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1041 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1042 (long)PL_scopestack_ix);
1043 if (PL_savestack_ix != 0)
1044 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1045 "Unbalanced saves: %ld more saves than restores\n",
1046 (long)PL_savestack_ix);
1047 if (PL_tmps_floor != -1)
1048 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1049 (long)PL_tmps_floor + 1);
1050 if (cxstack_ix != -1)
1051 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1052 (long)cxstack_ix + 1);
1055 /* Now absolutely destruct everything, somehow or other, loops or no. */
1056 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
1057 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
1059 /* the 2 is for PL_fdpid and PL_strtab */
1060 while (PL_sv_count > 2 && sv_clean_all())
1063 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
1064 SvFLAGS(PL_fdpid) |= SVt_PVAV;
1065 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
1066 SvFLAGS(PL_strtab) |= SVt_PVHV;
1068 AvREAL_off(PL_fdpid); /* no surviving entries */
1069 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
1072 #ifdef HAVE_INTERP_INTERN
1076 /* Destruct the global string table. */
1078 /* Yell and reset the HeVAL() slots that are still holding refcounts,
1079 * so that sv_free() won't fail on them.
1080 * Now that the global string table is using a single hunk of memory
1081 * for both HE and HEK, we either need to explicitly unshare it the
1082 * correct way, or actually free things here.
1085 const I32 max = HvMAX(PL_strtab);
1086 HE **array = HvARRAY(PL_strtab);
1087 HE *hent = array[0];
1090 if (hent && ckWARN_d(WARN_INTERNAL)) {
1091 HE *next = HeNEXT(hent);
1092 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1093 "Unbalanced string table refcount: (%d) for \"%s\"",
1094 HeVAL(hent) - Nullsv, HeKEY(hent));
1101 hent = array[riter];
1106 HvARRAY(PL_strtab) = 0;
1107 HvTOTALKEYS(PL_strtab) = 0;
1108 HvFILL(PL_strtab) = 0;
1110 SvREFCNT_dec(PL_strtab);
1113 /* free the pointer tables used for cloning */
1114 ptr_table_free(PL_ptr_table);
1115 PL_ptr_table = (PTR_TBL_t*)NULL;
1118 /* free special SVs */
1120 SvREFCNT(&PL_sv_yes) = 0;
1121 sv_clear(&PL_sv_yes);
1122 SvANY(&PL_sv_yes) = NULL;
1123 SvFLAGS(&PL_sv_yes) = 0;
1125 SvREFCNT(&PL_sv_no) = 0;
1126 sv_clear(&PL_sv_no);
1127 SvANY(&PL_sv_no) = NULL;
1128 SvFLAGS(&PL_sv_no) = 0;
1132 for (i=0; i<=2; i++) {
1133 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1134 sv_clear(PERL_DEBUG_PAD(i));
1135 SvANY(PERL_DEBUG_PAD(i)) = NULL;
1136 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1140 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1141 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1143 #ifdef DEBUG_LEAKING_SCALARS
1144 if (PL_sv_count != 0) {
1149 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
1150 svend = &sva[SvREFCNT(sva)];
1151 for (sv = sva + 1; sv < svend; ++sv) {
1152 if (SvTYPE(sv) != SVTYPEMASK) {
1153 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1155 " refcnt=%"UVuf pTHX__FORMAT "\n"
1156 "\tallocated at %s:%d %s %s%s\n",
1157 sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
1158 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1160 sv->sv_debug_inpad ? "for" : "by",
1161 sv->sv_debug_optype ?
1162 PL_op_name[sv->sv_debug_optype]: "(none)",
1163 sv->sv_debug_cloned ? " (cloned)" : ""
1165 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1166 Perl_dump_sv_child(aTHX_ sv);
1172 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1176 /* Wait for up to 4 seconds for child to terminate.
1177 This seems to be the least effort way of timing out on reaping
1179 struct timeval waitfor = {4, 0};
1180 int sock = PL_dumper_fd;
1184 FD_SET(sock, &rset);
1185 select(sock + 1, &rset, NULL, NULL, &waitfor);
1186 waitpid(child, &status, WNOHANG);
1194 #if defined(PERLIO_LAYERS)
1195 /* No more IO - including error messages ! */
1196 PerlIO_cleanup(aTHX);
1199 /* sv_undef needs to stay immortal until after PerlIO_cleanup
1200 as currently layers use it rather than Nullsv as a marker
1201 for no arg - and will try and SvREFCNT_dec it.
1203 SvREFCNT(&PL_sv_undef) = 0;
1204 SvREADONLY_off(&PL_sv_undef);
1206 Safefree(PL_origfilename);
1207 PL_origfilename = Nullch;
1208 Safefree(PL_reg_start_tmp);
1209 PL_reg_start_tmp = (char**)NULL;
1210 PL_reg_start_tmpl = 0;
1212 Safefree(PL_reg_curpm);
1213 Safefree(PL_reg_poscache);
1214 free_tied_hv_pool();
1215 Safefree(PL_op_mask);
1216 Safefree(PL_psig_ptr);
1217 PL_psig_ptr = (SV**)NULL;
1218 Safefree(PL_psig_name);
1219 PL_psig_name = (SV**)NULL;
1220 Safefree(PL_bitcount);
1221 PL_bitcount = Nullch;
1222 Safefree(PL_psig_pend);
1223 PL_psig_pend = (int*)NULL;
1224 PL_formfeed = Nullsv;
1226 PL_tainting = FALSE;
1227 PL_taint_warn = FALSE;
1228 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
1231 DEBUG_P(debprofdump());
1233 #ifdef USE_REENTRANT_API
1234 Perl_reentrant_free(aTHX);
1239 /* As the absolutely last thing, free the non-arena SV for mess() */
1242 /* we know that type == SVt_PVMG */
1244 /* it could have accumulated taint magic */
1247 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1248 moremagic = mg->mg_moremagic;
1249 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1251 Safefree(mg->mg_ptr);
1255 /* we know that type >= SVt_PV */
1256 SvPV_free(PL_mess_sv);
1257 Safefree(SvANY(PL_mess_sv));
1258 Safefree(PL_mess_sv);
1259 PL_mess_sv = Nullsv;
1261 return STATUS_NATIVE_EXPORT;
1265 =for apidoc perl_free
1267 Releases a Perl interpreter. See L<perlembed>.
1275 #if defined(WIN32) || defined(NETWARE)
1276 # if defined(PERL_IMPLICIT_SYS)
1278 void *host = nw_internal_host;
1280 void *host = w32_internal_host;
1282 PerlMem_free(aTHXx);
1284 nw_delete_internal_host(host);
1286 win32_delete_internal_host(host);
1289 PerlMem_free(aTHXx);
1292 PerlMem_free(aTHXx);
1296 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
1297 /* provide destructors to clean up the thread key when libperl is unloaded */
1298 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1300 #if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
1301 #pragma fini "perl_fini"
1305 #if defined(__GNUC__)
1306 __attribute__((destructor))
1316 #endif /* THREADS */
1319 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1321 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1322 PL_exitlist[PL_exitlistlen].fn = fn;
1323 PL_exitlist[PL_exitlistlen].ptr = ptr;
1327 #ifdef HAS_PROCSELFEXE
1328 /* This is a function so that we don't hold on to MAXPATHLEN
1329 bytes of stack longer than necessary
1332 S_procself_val(pTHX_ SV *sv, const char *arg0)
1334 char buf[MAXPATHLEN];
1335 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1337 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1338 includes a spurious NUL which will cause $^X to fail in system
1339 or backticks (this will prevent extensions from being built and
1340 many tests from working). readlink is not meant to add a NUL.
1341 Normal readlink works fine.
1343 if (len > 0 && buf[len-1] == '\0') {
1347 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1348 returning the text "unknown" from the readlink rather than the path
1349 to the executable (or returning an error from the readlink). Any valid
1350 path has a '/' in it somewhere, so use that to validate the result.
1351 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1353 if (len > 0 && memchr(buf, '/', len)) {
1354 sv_setpvn(sv,buf,len);
1360 #endif /* HAS_PROCSELFEXE */
1363 S_set_caret_X(pTHX) {
1364 GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
1366 #ifdef HAS_PROCSELFEXE
1367 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1370 sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
1372 sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
1379 =for apidoc perl_parse
1381 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1387 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1394 PERL_UNUSED_VAR(my_perl);
1396 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1399 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
1400 setuid perl scripts securely.\n");
1401 #endif /* IAMSUID */
1404 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1405 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
1406 * This MUST be done before any hash stores or fetches take place.
1407 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1408 * yourself, it is your responsibility to provide a good random seed!
1409 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
1410 if (!PL_rehash_seed_set)
1411 PL_rehash_seed = get_hash_seed();
1413 const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1415 if (s && (atoi(s) == 1))
1416 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
1418 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1424 /* Set PL_origalen be the sum of the contiguous argv[]
1425 * elements plus the size of the env in case that it is
1426 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
1427 * as the maximum modifiable length of $0. In the worst case
1428 * the area we are able to modify is limited to the size of
1429 * the original argv[0]. (See below for 'contiguous', though.)
1431 const char *s = NULL;
1434 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1435 /* Do the mask check only if the args seem like aligned. */
1437 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1439 /* See if all the arguments are contiguous in memory. Note
1440 * that 'contiguous' is a loose term because some platforms
1441 * align the argv[] and the envp[]. If the arguments look
1442 * like non-aligned, assume that they are 'strictly' or
1443 * 'traditionally' contiguous. If the arguments look like
1444 * aligned, we just check that they are within aligned
1445 * PTRSIZE bytes. As long as no system has something bizarre
1446 * like the argv[] interleaved with some other data, we are
1447 * fine. (Did I just evoke Murphy's Law?) --jhi */
1448 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1450 for (i = 1; i < PL_origargc; i++) {
1451 if ((PL_origargv[i] == s + 1
1453 || PL_origargv[i] == s + 2
1458 (PL_origargv[i] > s &&
1460 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1470 /* Can we grab env area too to be used as the area for $0? */
1471 if (PL_origenviron) {
1472 if ((PL_origenviron[0] == s + 1
1474 || (PL_origenviron[0] == s + 9 && (s += 8))
1479 (PL_origenviron[0] > s &&
1480 PL_origenviron[0] <=
1481 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1485 s = PL_origenviron[0];
1488 my_setenv("NoNe SuCh", Nullch);
1489 /* Force copy of environment. */
1490 for (i = 1; PL_origenviron[i]; i++) {
1491 if (PL_origenviron[i] == s + 1
1494 (PL_origenviron[i] > s &&
1495 PL_origenviron[i] <=
1496 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1499 s = PL_origenviron[i];
1507 PL_origalen = s - PL_origargv[0] + 1;
1512 /* Come here if running an undumped a.out. */
1514 PL_origfilename = savepv(argv[0]);
1515 PL_do_undump = FALSE;
1516 cxstack_ix = -1; /* start label stack again */
1518 assert (!PL_tainted);
1520 S_set_caret_X(aTHX);
1522 init_postdump_symbols(argc,argv,env);
1527 op_free(PL_main_root);
1528 PL_main_root = Nullop;
1530 PL_main_start = Nullop;
1531 SvREFCNT_dec(PL_main_cv);
1532 PL_main_cv = Nullcv;
1535 oldscope = PL_scopestack_ix;
1536 PL_dowarn = G_WARN_OFF;
1541 parse_body(env,xsinit);
1543 call_list(oldscope, PL_checkav);
1550 /* my_exit() was called */
1551 while (PL_scopestack_ix > oldscope)
1554 PL_curstash = PL_defstash;
1556 call_list(oldscope, PL_checkav);
1557 ret = STATUS_NATIVE_EXPORT;
1560 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1569 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1572 int argc = PL_origargc;
1573 char **argv = PL_origargv;
1574 const char *scriptname = NULL;
1575 VOL bool dosearch = FALSE;
1576 const char *validarg = "";
1579 const char *cddir = Nullch;
1580 #ifdef USE_SITECUSTOMIZE
1581 bool minus_f = FALSE;
1586 sv_setpvn(PL_linestr,"",0);
1587 sv = newSVpvn("",0); /* first used for -I flags */
1591 for (argc--,argv++; argc > 0; argc--,argv++) {
1592 if (argv[0][0] != '-' || !argv[0][1])
1596 validarg = " PHOOEY ";
1600 * Can we rely on the kernel to start scripts with argv[1] set to
1601 * contain all #! line switches (the whole line)? (argv[0] is set to
1602 * the interpreter name, argv[2] to the script name; argv[3] and
1603 * above may contain other arguments.)
1610 #ifndef PERL_STRICT_CR
1635 if ((s = moreswitches(s)))
1640 CHECK_MALLOC_TOO_LATE_FOR('t');
1641 if( !PL_tainting ) {
1642 PL_taint_warn = TRUE;
1648 CHECK_MALLOC_TOO_LATE_FOR('T');
1650 PL_taint_warn = FALSE;
1655 #ifdef MACOS_TRADITIONAL
1656 /* ignore -e for Dev:Pseudo argument */
1657 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1662 PL_e_script = newSVpvn("",0);
1663 filter_add(read_e_script, NULL);
1666 sv_catpv(PL_e_script, s);
1668 sv_catpv(PL_e_script, argv[1]);
1672 Perl_croak(aTHX_ "No code specified for -e");
1673 sv_catpv(PL_e_script, "\n");
1677 #ifdef USE_SITECUSTOMIZE
1683 case 'I': /* -I handled both here and in moreswitches() */
1685 if (!*++s && (s=argv[1]) != Nullch) {
1690 STRLEN len = strlen(s);
1691 p = savepvn(s, len);
1692 incpush(p, TRUE, TRUE, FALSE, FALSE);
1693 sv_catpvn(sv, "-I", 2);
1694 sv_catpvn(sv, p, len);
1695 sv_catpvn(sv, " ", 1);
1699 Perl_croak(aTHX_ "No directory specified for -I");
1703 PL_preprocess = TRUE;
1713 PL_preambleav = newAV();
1714 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1718 PL_Sv = newSVpv("print myconfig();",0);
1720 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1722 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1724 opts = SvCUR(PL_Sv);
1726 sv_catpv(PL_Sv,"\" Compile-time options:");
1728 sv_catpv(PL_Sv," DEBUGGING");
1730 # ifdef MULTIPLICITY
1731 sv_catpv(PL_Sv," MULTIPLICITY");
1733 # ifdef USE_5005THREADS
1734 sv_catpv(PL_Sv," USE_5005THREADS");
1736 # ifdef USE_ITHREADS
1737 sv_catpv(PL_Sv," USE_ITHREADS");
1739 # ifdef USE_64_BIT_INT
1740 sv_catpv(PL_Sv," USE_64_BIT_INT");
1742 # ifdef USE_64_BIT_ALL
1743 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1745 # ifdef USE_LONG_DOUBLE
1746 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1748 # ifdef USE_LARGE_FILES
1749 sv_catpv(PL_Sv," USE_LARGE_FILES");
1752 sv_catpv(PL_Sv," USE_SOCKS");
1754 # ifdef USE_SITECUSTOMIZE
1755 sv_catpv(PL_Sv," USE_SITECUSTOMIZE");
1757 # ifdef PERL_IMPLICIT_CONTEXT
1758 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1760 # ifdef PERL_IMPLICIT_SYS
1761 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1764 while (SvCUR(PL_Sv) > opts+76) {
1765 /* find last space after "options: " and before col 76 */
1768 char *pv = SvPV_nolen(PL_Sv);
1769 const char c = pv[opts+76];
1771 space = strrchr(pv+opts+26, ' ');
1773 if (!space) break; /* "Can't happen" */
1775 /* break the line before that space */
1778 sv_insert(PL_Sv, opts, 0,
1782 sv_catpv(PL_Sv,"\\n\",");
1784 #if defined(LOCAL_PATCH_COUNT)
1785 if (LOCAL_PATCH_COUNT > 0) {
1787 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1788 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1789 if (PL_localpatches[i])
1790 Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
1791 0, PL_localpatches[i], 0);
1795 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1798 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1800 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1803 sv_catpv(PL_Sv, "; \
1805 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1808 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1811 print \" \\%ENV:\\n @env\\n\" if @env; \
1812 print \" \\@INC:\\n @INC\\n\";");
1816 PL_Sv = Perl_newSVpvf(aTHX_ "config_vars(qw%c%s%c)", 0, s, 0);
1819 av_push(PL_preambleav, PL_Sv);
1820 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1823 PL_doextract = TRUE;
1831 if (!*++s || isSPACE(*s)) {
1835 /* catch use of gnu style long options */
1836 if (strEQ(s, "version")) {
1840 if (strEQ(s, "help")) {
1847 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1853 #ifndef SECURE_INTERNAL_GETENV
1856 (s = PerlEnv_getenv("PERL5OPT")))
1858 const char *popt = s;
1861 if (*s == '-' && *(s+1) == 'T') {
1862 CHECK_MALLOC_TOO_LATE_FOR('T');
1864 PL_taint_warn = FALSE;
1867 char *popt_copy = Nullch;
1880 if (!strchr("DIMUdmtwA", *s))
1881 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1885 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1886 s = popt_copy + (s - popt);
1887 d = popt_copy + (d - popt);
1894 if( !PL_tainting ) {
1895 PL_taint_warn = TRUE;
1905 #ifdef USE_SITECUSTOMIZE
1908 PL_preambleav = newAV();
1909 av_unshift(PL_preambleav, 1);
1910 (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
1914 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1915 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1919 scriptname = argv[0];
1922 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1924 else if (scriptname == Nullch) {
1926 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1932 /* Set $^X early so that it can be used for relocatable paths in @INC */
1933 assert (!PL_tainted);
1935 S_set_caret_X(aTHX);
1939 open_script(scriptname,dosearch,sv);
1941 validate_suid(validarg, scriptname);
1944 #if defined(SIGCHLD) || defined(SIGCLD)
1947 # define SIGCHLD SIGCLD
1949 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1950 if (sigstate == SIG_IGN) {
1951 if (ckWARN(WARN_SIGNAL))
1952 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1953 "Can't ignore signal CHLD, forcing to default");
1954 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1960 #ifdef MACOS_TRADITIONAL
1961 if (PL_doextract || gMacPerl_AlwaysExtract) {
1966 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
1967 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1971 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1972 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1973 CvUNIQUE_on(PL_compcv);
1975 CvPADLIST(PL_compcv) = pad_new(0);
1976 #ifdef USE_5005THREADS
1977 CvOWNER(PL_compcv) = 0;
1978 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1979 MUTEX_INIT(CvMUTEXP(PL_compcv));
1980 #endif /* USE_5005THREADS */
1983 boot_core_UNIVERSAL();
1984 boot_core_xsutils();
1987 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1989 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1995 # ifdef HAS_SOCKS5_INIT
1996 socks5_init(argv[0]);
2002 init_predump_symbols();
2003 /* init_postdump_symbols not currently designed to be called */
2004 /* more than once (ENV isn't cleared first, for example) */
2005 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
2007 init_postdump_symbols(argc,argv,env);
2009 /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2010 * or explicitly in some platforms.
2011 * locale.c:Perl_init_i18nl10n() if the environment
2012 * look like the user wants to use UTF-8. */
2013 #if defined(SYMBIAN)
2014 PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2017 /* Requires init_predump_symbols(). */
2018 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2023 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2024 * and the default open disciplines. */
2025 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2026 PL_stdingv && (io = GvIO(PL_stdingv)) &&
2028 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2029 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2030 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2032 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2033 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2034 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2036 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2037 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2038 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
2039 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
2040 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2043 sv_setpvn(sv, ":utf8\0:utf8", 11);
2045 sv_setpvn(sv, ":utf8\0", 6);
2048 sv_setpvn(sv, "\0:utf8", 6);
2054 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2055 if (strEQ(s, "unsafe"))
2056 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
2057 else if (strEQ(s, "safe"))
2058 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2060 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2065 /* now parse the script */
2067 SETERRNO(0,SS_NORMAL);
2069 #ifdef MACOS_TRADITIONAL
2070 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
2072 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
2074 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2075 MacPerl_MPWFileName(PL_origfilename));
2079 if (yyparse() || PL_error_count) {
2081 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2083 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2088 CopLINE_set(PL_curcop, 0);
2089 PL_curstash = PL_defstash;
2090 PL_preprocess = FALSE;
2092 SvREFCNT_dec(PL_e_script);
2093 PL_e_script = Nullsv;
2100 SAVECOPFILE(PL_curcop);
2101 SAVECOPLINE(PL_curcop);
2102 gv_check(PL_defstash);
2109 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2110 dump_mstats("after compilation:");
2119 =for apidoc perl_run
2121 Tells a Perl interpreter to run. See L<perlembed>.
2133 PERL_UNUSED_ARG(my_perl);
2135 oldscope = PL_scopestack_ix;
2143 cxstack_ix = -1; /* start context stack again */
2145 case 0: /* normal completion */
2149 case 2: /* my_exit() */
2150 while (PL_scopestack_ix > oldscope)
2153 PL_curstash = PL_defstash;
2154 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2155 PL_endav && !PL_minus_c)
2156 call_list(oldscope, PL_endav);
2158 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2159 dump_mstats("after execution: ");
2161 ret = STATUS_NATIVE_EXPORT;
2165 POPSTACK_TO(PL_mainstack);
2168 PerlIO_printf(Perl_error_log, "panic: restartop\n");
2180 S_run_body(pTHX_ I32 oldscope)
2182 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
2183 PL_sawampersand ? "Enabling" : "Omitting"));
2185 if (!PL_restartop) {
2186 DEBUG_x(dump_all());
2188 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2189 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
2193 #ifdef MACOS_TRADITIONAL
2194 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
2195 (gMacPerl_ErrorFormat ? "# " : ""),
2196 MacPerl_MPWFileName(PL_origfilename));
2198 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2202 if (PERLDB_SINGLE && PL_DBsingle)
2203 sv_setiv(PL_DBsingle, 1);
2205 call_list(oldscope, PL_initav);
2211 PL_op = PL_restartop;
2215 else if (PL_main_start) {
2216 CvDEPTH(PL_main_cv) = 1;
2217 PL_op = PL_main_start;
2225 =head1 SV Manipulation Functions
2227 =for apidoc p||get_sv
2229 Returns the SV of the specified Perl scalar. If C<create> is set and the
2230 Perl variable does not exist then it will be created. If C<create> is not
2231 set and the variable does not exist then NULL is returned.
2237 Perl_get_sv(pTHX_ const char *name, I32 create)
2240 #ifdef USE_5005THREADS
2241 if (name[1] == '\0' && !isALPHA(name[0])) {
2242 PADOFFSET tmp = find_threadsv(name);
2243 if (tmp != NOT_IN_PAD)
2244 return THREADSV(tmp);
2246 #endif /* USE_5005THREADS */
2247 gv = gv_fetchpv(name, create, SVt_PV);
2254 =head1 Array Manipulation Functions
2256 =for apidoc p||get_av
2258 Returns the AV of the specified Perl array. If C<create> is set and the
2259 Perl variable does not exist then it will be created. If C<create> is not
2260 set and the variable does not exist then NULL is returned.
2266 Perl_get_av(pTHX_ const char *name, I32 create)
2268 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
2277 =head1 Hash Manipulation Functions
2279 =for apidoc p||get_hv
2281 Returns the HV of the specified Perl hash. If C<create> is set and the
2282 Perl variable does not exist then it will be created. If C<create> is not
2283 set and the variable does not exist then NULL is returned.
2289 Perl_get_hv(pTHX_ const char *name, I32 create)
2291 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
2300 =head1 CV Manipulation Functions
2302 =for apidoc p||get_cv
2304 Returns the CV of the specified Perl subroutine. If C<create> is set and
2305 the Perl subroutine does not exist then it will be declared (which has the
2306 same effect as saying C<sub name;>). If C<create> is not set and the
2307 subroutine does not exist then NULL is returned.
2313 Perl_get_cv(pTHX_ const char *name, I32 create)
2315 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
2316 /* XXX unsafe for threads if eval_owner isn't held */
2317 /* XXX this is probably not what they think they're getting.
2318 * It has the same effect as "sub name;", i.e. just a forward
2320 if (create && !GvCVu(gv))
2321 return newSUB(start_subparse(FALSE, 0),
2322 newSVOP(OP_CONST, 0, newSVpv(name,0)),
2330 /* Be sure to refetch the stack pointer after calling these routines. */
2334 =head1 Callback Functions
2336 =for apidoc p||call_argv
2338 Performs a callback to the specified Perl sub. See L<perlcall>.
2344 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
2346 /* See G_* flags in cop.h */
2347 /* null terminated arg list */
2354 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
2359 return call_pv(sub_name, flags);
2363 =for apidoc p||call_pv
2365 Performs a callback to the specified Perl sub. See L<perlcall>.
2371 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2372 /* name of the subroutine */
2373 /* See G_* flags in cop.h */
2375 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
2379 =for apidoc p||call_method
2381 Performs a callback to the specified Perl method. The blessed object must
2382 be on the stack. See L<perlcall>.
2388 Perl_call_method(pTHX_ const char *methname, I32 flags)
2389 /* name of the subroutine */
2390 /* See G_* flags in cop.h */
2392 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
2395 /* May be called with any of a CV, a GV, or an SV containing the name. */
2397 =for apidoc p||call_sv
2399 Performs a callback to the Perl sub whose name is in the SV. See
2406 Perl_call_sv(pTHX_ SV *sv, I32 flags)
2407 /* See G_* flags in cop.h */
2410 LOGOP myop; /* fake syntax tree node */
2413 volatile I32 retval = 0;
2415 bool oldcatch = CATCH_GET;
2420 if (flags & G_DISCARD) {
2425 Zero(&myop, 1, LOGOP);
2426 myop.op_next = Nullop;
2427 if (!(flags & G_NOARGS))
2428 myop.op_flags |= OPf_STACKED;
2429 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2430 (flags & G_ARRAY) ? OPf_WANT_LIST :
2435 EXTEND(PL_stack_sp, 1);
2436 *++PL_stack_sp = sv;
2438 oldscope = PL_scopestack_ix;
2440 if (PERLDB_SUB && PL_curstash != PL_debstash
2441 /* Handle first BEGIN of -d. */
2442 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2443 /* Try harder, since this may have been a sighandler, thus
2444 * curstash may be meaningless. */
2445 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
2446 && !(flags & G_NODEBUG))
2447 PL_op->op_private |= OPpENTERSUB_DB;
2449 if (flags & G_METHOD) {
2450 Zero(&method_op, 1, UNOP);
2451 method_op.op_next = PL_op;
2452 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2453 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2454 PL_op = (OP*)&method_op;
2457 if (!(flags & G_EVAL)) {
2459 call_body((OP*)&myop, FALSE);
2460 retval = PL_stack_sp - (PL_stack_base + oldmark);
2461 CATCH_SET(oldcatch);
2464 myop.op_other = (OP*)&myop;
2466 /* we're trying to emulate pp_entertry() here */
2468 register PERL_CONTEXT *cx;
2469 const I32 gimme = GIMME_V;
2474 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
2476 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2478 PL_in_eval = EVAL_INEVAL;
2479 if (flags & G_KEEPERR)
2480 PL_in_eval |= EVAL_KEEPERR;
2482 sv_setpvn(ERRSV,"",0);
2490 call_body((OP*)&myop, FALSE);
2491 retval = PL_stack_sp - (PL_stack_base + oldmark);
2492 if (!(flags & G_KEEPERR))
2493 sv_setpvn(ERRSV,"",0);
2499 /* my_exit() was called */
2500 PL_curstash = PL_defstash;
2503 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2504 Perl_croak(aTHX_ "Callback called exit");
2509 PL_op = PL_restartop;
2513 PL_stack_sp = PL_stack_base + oldmark;
2514 if (flags & G_ARRAY)
2518 *++PL_stack_sp = &PL_sv_undef;
2523 if (PL_scopestack_ix > oldscope) {
2527 register PERL_CONTEXT *cx;
2534 PERL_UNUSED_VAR(newsp);
2535 PERL_UNUSED_VAR(gimme);
2536 PERL_UNUSED_VAR(optype);
2541 if (flags & G_DISCARD) {
2542 PL_stack_sp = PL_stack_base + oldmark;
2552 S_call_body(pTHX_ const OP *myop, bool is_eval)
2554 if (PL_op == myop) {
2556 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2558 PL_op = Perl_pp_entersub(aTHX); /* this does */
2564 /* Eval a string. The G_EVAL flag is always assumed. */
2567 =for apidoc p||eval_sv
2569 Tells Perl to C<eval> the string in the SV.
2575 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2577 /* See G_* flags in cop.h */
2580 UNOP myop; /* fake syntax tree node */
2581 volatile I32 oldmark = SP - PL_stack_base;
2582 volatile I32 retval = 0;
2587 if (flags & G_DISCARD) {
2594 Zero(PL_op, 1, UNOP);
2595 EXTEND(PL_stack_sp, 1);
2596 *++PL_stack_sp = sv;
2598 if (!(flags & G_NOARGS))
2599 myop.op_flags = OPf_STACKED;
2600 myop.op_next = Nullop;
2601 myop.op_type = OP_ENTEREVAL;
2602 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2603 (flags & G_ARRAY) ? OPf_WANT_LIST :
2605 if (flags & G_KEEPERR)
2606 myop.op_flags |= OPf_SPECIAL;
2608 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2609 * before a PUSHEVAL, which corrupts the stack after a croak */
2610 TAINT_PROPER("eval_sv()");
2616 call_body((OP*)&myop,TRUE);
2617 retval = PL_stack_sp - (PL_stack_base + oldmark);
2618 if (!(flags & G_KEEPERR))
2619 sv_setpvn(ERRSV,"",0);
2625 /* my_exit() was called */
2626 PL_curstash = PL_defstash;
2629 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2630 Perl_croak(aTHX_ "Callback called exit");
2635 PL_op = PL_restartop;
2639 PL_stack_sp = PL_stack_base + oldmark;
2640 if (flags & G_ARRAY)
2644 *++PL_stack_sp = &PL_sv_undef;
2650 if (flags & G_DISCARD) {
2651 PL_stack_sp = PL_stack_base + oldmark;
2661 =for apidoc p||eval_pv
2663 Tells Perl to C<eval> the given string and return an SV* result.
2669 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2672 SV* sv = newSVpv(p, 0);
2674 eval_sv(sv, G_SCALAR);
2681 if (croak_on_error && SvTRUE(ERRSV)) {
2682 Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
2688 /* Require a module. */
2691 =head1 Embedding Functions
2693 =for apidoc p||require_pv
2695 Tells Perl to C<require> the file named by the string argument. It is
2696 analogous to the Perl code C<eval "require '$file'">. It's even
2697 implemented that way; consider using load_module instead.
2702 Perl_require_pv(pTHX_ const char *pv)
2706 PUSHSTACKi(PERLSI_REQUIRE);
2708 sv = sv_newmortal();
2709 sv_setpv(sv, "require '");
2712 eval_sv(sv, G_DISCARD);
2718 Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
2722 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2723 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2727 S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
2729 /* This message really ought to be max 23 lines.
2730 * Removed -h because the user already knows that option. Others? */
2732 static const char * const usage_msg[] = {
2733 "-0[octal] specify record separator (\\0, if no argument)",
2734 "-A[mod][=pattern] activate all/given assertions",
2735 "-a autosplit mode with -n or -p (splits $_ into @F)",
2736 "-C[number/list] enables the listed Unicode features",
2737 "-c check syntax only (runs BEGIN and CHECK blocks)",
2738 "-d[:debugger] run program under debugger",
2739 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2740 "-e program one line of program (several -e's allowed, omit programfile)",
2741 "-f don't do $sitelib/sitecustomize.pl at startup",
2742 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2743 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2744 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2745 "-l[octal] enable line ending processing, specifies line terminator",
2746 "-[mM][-]module execute \"use/no module...\" before executing program",
2747 "-n assume \"while (<>) { ... }\" loop around program",
2748 "-p assume loop like -n but print line also, like sed",
2749 "-P run program through C preprocessor before compilation",
2750 "-s enable rudimentary parsing for switches after programfile",
2751 "-S look for programfile using PATH environment variable",
2752 "-t enable tainting warnings",
2753 "-T enable tainting checks",
2754 "-u dump core after parsing program",
2755 "-U allow unsafe operations",
2756 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2757 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2758 "-w enable many useful warnings (RECOMMENDED)",
2759 "-W enable all warnings",
2760 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2761 "-X disable all warnings",
2765 const char * const *p = usage_msg;
2767 PerlIO_printf(PerlIO_stdout(),
2768 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2771 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2774 /* convert a string of -D options (or digits) into an int.
2775 * sets *s to point to the char after the options */
2779 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
2781 static const char * const usage_msgd[] = {
2782 " Debugging flag values: (see also -d)",
2783 " p Tokenizing and parsing (with v, displays parse stack)",
2784 " s Stack snapshots (with v, displays all stacks)",
2785 " l Context (loop) stack processing",
2786 " t Trace execution",
2787 " o Method and overloading resolution",
2788 " c String/numeric conversions",
2789 " P Print profiling info, preprocessor command for -P, source file input state",
2790 " m Memory allocation",
2791 " f Format processing",
2792 " r Regular expression parsing and execution",
2793 " x Syntax tree dump",
2794 " u Tainting checks",
2795 " H Hash dump -- usurps values()",
2796 " X Scratchpad allocation",
2798 " S Thread synchronization",
2800 " R Include reference counts of dumped variables (eg when using -Ds)",
2801 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2802 " v Verbose: use in conjunction with other flags",
2804 " A Consistency checks on internal structures",
2805 " q quiet - currently only suppresses the 'EXECUTING' message",
2810 /* if adding extra options, remember to update DEBUG_MASK */
2811 static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
2813 for (; isALNUM(**s); (*s)++) {
2814 const char *d = strchr(debopts,**s);
2816 i |= 1 << (d - debopts);
2817 else if (ckWARN_d(WARN_DEBUGGING))
2818 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2819 "invalid option -D%c, use -D'' to see choices\n", **s);
2822 else if (isDIGIT(**s)) {
2824 for (; isALNUM(**s); (*s)++) ;
2826 else if (givehelp) {
2827 char **p = (char **)usage_msgd;
2828 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2831 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2832 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2833 "-Dp not implemented on this platform\n");
2839 /* This routine handles any switches that can be given during run */
2842 Perl_moreswitches(pTHX_ char *s)
2853 SvREFCNT_dec(PL_rs);
2854 if (s[1] == 'x' && s[2]) {
2855 const char *e = s+=2;
2861 flags = PERL_SCAN_SILENT_ILLDIGIT;
2862 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2863 if (s + numlen < e) {
2864 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2868 PL_rs = newSVpvn("", 0);
2869 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2870 tmps = (U8*)SvPVX(PL_rs);
2871 uvchr_to_utf8(tmps, rschar);
2872 SvCUR_set(PL_rs, UNISKIP(rschar));
2877 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2878 if (rschar & ~((U8)~0))
2879 PL_rs = &PL_sv_undef;
2880 else if (!rschar && numlen >= 2)
2881 PL_rs = newSVpvn("", 0);
2883 char ch = (char)rschar;
2884 PL_rs = newSVpvn(&ch, 1);
2887 sv_setsv(get_sv("/", TRUE), PL_rs);
2892 PL_unicode = parse_unicode_opts( (const char **)&s );
2897 while (*s && !isSPACE(*s)) ++s;
2899 PL_splitstr = savepv(PL_splitstr);
2913 /* -dt indicates to the debugger that threads will be used */
2914 if (*s == 't' && !isALNUM(s[1])) {
2916 my_setenv("PERL5DB_THREADED", "1");
2919 /* The following permits -d:Mod to accepts arguments following an =
2920 in the fashion that -MSome::Mod does. */
2921 if (*s == ':' || *s == '=') {
2924 sv = newSVpv("use Devel::", 0);
2926 /* We now allow -d:Module=Foo,Bar */
2927 while(isALNUM(*s) || *s==':') ++s;
2929 sv_catpv(sv, start);
2931 sv_catpvn(sv, start, s-start);
2932 sv_catpv(sv, " split(/,/,q{");
2937 my_setenv("PERL5DB", SvPV(sv, PL_na));
2940 PL_perldb = PERLDB_ALL;
2949 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
2950 #else /* !DEBUGGING */
2951 if (ckWARN_d(WARN_DEBUGGING))
2952 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2953 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
2954 for (s++; isALNUM(*s); s++) ;
2959 usage(PL_origargv[0]);
2963 Safefree(PL_inplace);
2964 #if defined(__CYGWIN__) /* do backup extension automagically */
2965 if (*(s+1) == '\0') {
2966 PL_inplace = savepv(".bak");
2969 #endif /* __CYGWIN__ */
2970 PL_inplace = savepv(s+1);
2971 for (s = PL_inplace; *s && !isSPACE(*s); s++)
2975 if (*s == '-') /* Additional switches on #! line. */
2979 case 'I': /* -I handled both here and in parse_body() */
2982 while (*s && isSPACE(*s))
2987 /* ignore trailing spaces (possibly followed by other switches) */
2989 for (e = p; *e && !isSPACE(*e); e++) ;
2993 } while (*p && *p != '-');
2994 e = savepvn(s, e-s);
2995 incpush(e, TRUE, TRUE, FALSE, FALSE);
3002 Perl_croak(aTHX_ "No directory specified for -I");
3008 SvREFCNT_dec(PL_ors_sv);
3014 PL_ors_sv = newSVpvn("\n",1);
3015 numlen = 3 + (*s == '0');
3016 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3020 if (RsPARA(PL_rs)) {
3021 PL_ors_sv = newSVpvn("\n\n",2);
3024 PL_ors_sv = newSVsv(PL_rs);
3031 PL_preambleav = newAV();
3035 SV *sv = newSVpv("use assertions::activate", 24);
3036 while(isALNUM(*s) || *s == ':') ++s;
3038 sv_catpvn(sv, "::", 2);
3039 sv_catpvn(sv, start, s-start);
3042 sv_catpvn(sv, " split(/,/,q\0", 13);
3044 sv_catpvn(sv, "\0)", 2);
3047 else if (*s != '\0') {
3048 Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start);
3050 av_push(PL_preambleav, sv);
3054 forbid_setid("-M"); /* XXX ? */
3057 forbid_setid("-m"); /* XXX ? */
3061 const char *use = "use ";
3062 /* -M-foo == 'no foo' */
3063 /* Leading space on " no " is deliberate, to make both
3064 possibilities the same length. */
3065 if (*s == '-') { use = " no "; ++s; }
3066 sv = newSVpvn(use,4);
3068 /* We allow -M'Module qw(Foo Bar)' */
3069 while(isALNUM(*s) || *s==':') ++s;
3071 sv_catpv(sv, start);
3072 if (*(start-1) == 'm') {
3074 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3075 sv_catpv( sv, " ()");
3079 Perl_croak(aTHX_ "Module name required with -%c option",
3081 sv_catpvn(sv, start, s-start);
3082 sv_catpv(sv, " split(/,/,q");
3083 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
3085 sv_catpvn(sv, "\0)", 2);
3089 PL_preambleav = newAV();
3090 av_push(PL_preambleav, sv);
3093 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
3105 PL_doswitches = TRUE;
3119 #ifdef MACOS_TRADITIONAL
3120 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
3122 PL_do_undump = TRUE;
3130 if (!sv_derived_from(PL_patchlevel, "version"))
3131 (void *)upg_version(PL_patchlevel);
3133 PerlIO_printf(PerlIO_stdout(),
3134 Perl_form(aTHX_ "\nThis is perl, %"SVf" built for %s",
3135 vstringify(PL_patchlevel),
3138 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
3139 PerlIO_printf(PerlIO_stdout(),
3140 Perl_form(aTHX_ "\nThis is perl, %"SVf"\n",
3141 vstringify(PL_patchlevel)));
3142 PerlIO_printf(PerlIO_stdout(),
3143 Perl_form(aTHX_ " built under %s at %s %s\n",
3144 OSNAME, __DATE__, __TIME__));
3145 PerlIO_printf(PerlIO_stdout(),
3146 Perl_form(aTHX_ " OS Specific Release: %s\n",
3150 #if defined(LOCAL_PATCH_COUNT)
3151 if (LOCAL_PATCH_COUNT > 0)
3152 PerlIO_printf(PerlIO_stdout(),
3153 "\n(with %d registered patch%s, "
3154 "see perl -V for more detail)",
3155 (int)LOCAL_PATCH_COUNT,
3156 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3159 PerlIO_printf(PerlIO_stdout(),
3160 "\n\nCopyright 1987-2005, Larry Wall\n");
3161 #ifdef MACOS_TRADITIONAL
3162 PerlIO_printf(PerlIO_stdout(),
3163 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
3164 "maintained by Chris Nandor\n");
3167 PerlIO_printf(PerlIO_stdout(),
3168 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3171 PerlIO_printf(PerlIO_stdout(),
3172 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3173 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3176 PerlIO_printf(PerlIO_stdout(),
3177 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3178 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3181 PerlIO_printf(PerlIO_stdout(),
3182 "atariST series port, ++jrb bammi@cadence.com\n");
3185 PerlIO_printf(PerlIO_stdout(),
3186 "BeOS port Copyright Tom Spindler, 1997-1999\n");
3189 PerlIO_printf(PerlIO_stdout(),
3190 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
3193 PerlIO_printf(PerlIO_stdout(),
3194 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3197 PerlIO_printf(PerlIO_stdout(),
3198 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
3201 PerlIO_printf(PerlIO_stdout(),
3202 "VM/ESA port by Neale Ferguson, 1998-1999\n");
3205 PerlIO_printf(PerlIO_stdout(),
3206 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3209 PerlIO_printf(PerlIO_stdout(),
3210 "MiNT port by Guido Flohr, 1997-1999\n");
3213 PerlIO_printf(PerlIO_stdout(),
3214 "EPOC port by Olaf Flebbe, 1999-2002\n");
3217 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
3218 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
3222 PerlIO_printf(PerlIO_stdout(),
3223 "Symbian port by Nokia, 2004-2005\n");
3225 #ifdef BINARY_BUILD_NOTICE
3226 BINARY_BUILD_NOTICE;
3228 PerlIO_printf(PerlIO_stdout(),
3230 Perl may be copied only under the terms of either the Artistic License or the\n\
3231 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3232 Complete documentation for Perl, including FAQ lists, should be found on\n\
3233 this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
3234 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3237 if (! (PL_dowarn & G_WARN_ALL_MASK))
3238 PL_dowarn |= G_WARN_ON;
3242 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3243 if (!specialWARN(PL_compiling.cop_warnings))
3244 SvREFCNT_dec(PL_compiling.cop_warnings);
3245 PL_compiling.cop_warnings = pWARN_ALL ;
3249 PL_dowarn = G_WARN_ALL_OFF;
3250 if (!specialWARN(PL_compiling.cop_warnings))
3251 SvREFCNT_dec(PL_compiling.cop_warnings);
3252 PL_compiling.cop_warnings = pWARN_NONE ;
3257 if (s[1] == '-') /* Additional switches on #! line. */
3262 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3268 #ifdef ALTERNATE_SHEBANG
3269 case 'S': /* OS/2 needs -S on "extproc" line. */
3277 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3282 /* compliments of Tom Christiansen */
3284 /* unexec() can be found in the Gnu emacs distribution */
3285 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3288 Perl_my_unexec(pTHX)
3296 prog = newSVpv(BIN_EXP, 0);
3297 sv_catpv(prog, "/perl");
3298 file = newSVpv(PL_origfilename, 0);
3299 sv_catpv(file, ".perldump");
3301 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3302 /* unexec prints msg to stderr in case of failure */
3303 PerlProc_exit(status);
3306 # include <lib$routines.h>
3307 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
3309 ABORT(); /* for use with undump */
3314 /* initialize curinterp */
3320 # define PERLVAR(var,type)
3321 # define PERLVARA(var,n,type)
3322 # if defined(PERL_IMPLICIT_CONTEXT)
3323 # if defined(USE_5005THREADS)
3324 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3325 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3326 # else /* !USE_5005THREADS */
3327 # define PERLVARI(var,type,init) aTHX->var = init;
3328 # define PERLVARIC(var,type,init) aTHX->var = init;
3329 # endif /* USE_5005THREADS */
3331 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
3332 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
3334 # include "intrpvar.h"
3335 # ifndef USE_5005THREADS
3336 # include "thrdvar.h"
3343 # define PERLVAR(var,type)
3344 # define PERLVARA(var,n,type)
3345 # define PERLVARI(var,type,init) PL_##var = init;
3346 # define PERLVARIC(var,type,init) PL_##var = init;
3347 # include "intrpvar.h"
3348 # ifndef USE_5005THREADS
3349 # include "thrdvar.h"
3360 S_init_main_stash(pTHX)
3364 PL_curstash = PL_defstash = newHV();
3365 PL_curstname = newSVpvn("main",4);
3366 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
3367 SvREFCNT_dec(GvHV(gv));
3368 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
3370 Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0);
3371 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
3372 GvMULTI_on(PL_incgv);
3373 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
3374 GvMULTI_on(PL_hintgv);
3375 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
3376 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
3377 GvMULTI_on(PL_errgv);
3378 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
3379 GvMULTI_on(PL_replgv);
3380 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
3381 #ifdef PERL_DONT_CREATE_GVSV
3384 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3385 sv_setpvn(ERRSV, "", 0);
3386 PL_curstash = PL_defstash;
3387 CopSTASH_set(&PL_compiling, PL_defstash);
3388 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3389 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
3390 /* We must init $/ before switches are processed. */
3391 sv_setpvn(get_sv("/", TRUE), "\n", 1);
3394 /* PSz 18 Nov 03 fdscript now global but do not change prototype */
3396 S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
3401 const char *cpp_discard_flag;
3410 PL_origfilename = savepvn("-e", 2);
3413 /* if find_script() returns, it returns a malloc()-ed value */
3414 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3416 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3417 const char *s = scriptname + 8;
3418 PL_fdscript = atoi(s);
3423 * Tell apart "normal" usage of fdscript, e.g.
3424 * with bash on FreeBSD:
3425 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3426 * from usage in suidperl.
3427 * Does any "normal" usage leave garbage after the number???
3428 * Is it a mistake to use a similar /dev/fd/ construct for
3433 * Be supersafe and do some sanity-checks.
3434 * Still, can we be sure we got the right thing?
3437 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3440 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3442 scriptname = savepv(s + 1);
3443 Safefree(PL_origfilename);
3444 PL_origfilename = (char *)scriptname;
3449 CopFILE_free(PL_curcop);
3450 CopFILE_set(PL_curcop, PL_origfilename);
3451 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3452 scriptname = (char *)"";
3453 if (PL_fdscript >= 0) {
3454 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
3455 # if defined(HAS_FCNTL) && defined(F_SETFD)
3457 /* ensure close-on-exec */
3458 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3463 Perl_croak(aTHX_ "sperl needs fd script\n"
3464 "You should not call sperl directly; do you need to "
3465 "change a #! line\nfrom sperl to perl?\n");
3468 * Do not open (or do other fancy stuff) while setuid.
3469 * Perl does the open, and hands script to suidperl on a fd;
3470 * suidperl only does some checks, sets up UIDs and re-execs
3471 * perl with that fd as it has always done.
3474 if (PL_suidscript != 1) {
3475 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3478 else if (PL_preprocess) {
3479 const char *cpp_cfg = CPPSTDIN;
3480 SV *cpp = newSVpvn("",0);
3481 SV *cmd = NEWSV(0,0);
3483 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3484 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
3485 if (strEQ(cpp_cfg, "cppstdin"))
3486 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
3487 sv_catpv(cpp, cpp_cfg);
3490 sv_catpvn(sv, "-I", 2);
3491 sv_catpv(sv,PRIVLIB_EXP);
3494 DEBUG_P(PerlIO_printf(Perl_debug_log,
3495 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3496 scriptname, SvPVX_const (cpp), SvPVX_const (sv),
3499 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
3506 cpp_discard_flag = "";
3508 cpp_discard_flag = "-C";
3512 perl = os2_execname(aTHX);
3514 perl = PL_origargv[0];
3518 /* This strips off Perl comments which might interfere with
3519 the C pre-processor, including #!. #line directives are
3520 deliberately stripped to avoid confusion with Perl's version
3521 of #line. FWP played some golf with it so it will fit
3522 into VMS's 255 character buffer.
3525 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3527 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3529 Perl_sv_setpvf(aTHX_ cmd, "\
3530 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
3531 perl, quote, code, quote, scriptname, cpp,
3532 cpp_discard_flag, sv, CPPMINUS);
3534 PL_doextract = FALSE;
3536 DEBUG_P(PerlIO_printf(Perl_debug_log,
3537 "PL_preprocess: cmd=\"%s\"\n",
3540 PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
3544 else if (!*scriptname) {
3545 forbid_setid("program input from stdin");
3546 PL_rsfp = PerlIO_stdin();
3549 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3550 # if defined(HAS_FCNTL) && defined(F_SETFD)
3552 /* ensure close-on-exec */
3553 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3556 #endif /* IAMSUID */
3558 /* PSz 16 Sep 03 Keep neat error message */
3559 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3560 CopFILE(PL_curcop), Strerror(errno));
3565 * I_SYSSTATVFS HAS_FSTATVFS
3567 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3568 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3569 * here so that metaconfig picks them up. */
3573 S_fd_on_nosuid_fs(pTHX_ int fd)
3576 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3577 * but is needed also on machines without setreuid.
3578 * Seems safe enough to run as root.
3580 int check_okay = 0; /* able to do all the required sys/libcalls */
3581 int on_nosuid = 0; /* the fd is on a nosuid fs */
3583 * Need to check noexec also: nosuid might not be set, the average
3584 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3586 int on_noexec = 0; /* the fd is on a noexec fs */
3589 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3590 * fstatvfs() is UNIX98.
3591 * fstatfs() is 4.3 BSD.
3592 * ustat()+getmnt() is pre-4.3 BSD.
3593 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3594 * an irrelevant filesystem while trying to reach the right one.
3597 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3599 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3600 defined(HAS_FSTATVFS)
3601 # define FD_ON_NOSUID_CHECK_OKAY
3602 struct statvfs stfs;
3604 check_okay = fstatvfs(fd, &stfs) == 0;
3605 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
3607 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3608 on platforms where it is present. */
3609 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3611 # endif /* fstatvfs */
3613 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3614 defined(PERL_MOUNT_NOSUID) && \
3615 defined(PERL_MOUNT_NOEXEC) && \
3616 defined(HAS_FSTATFS) && \
3617 defined(HAS_STRUCT_STATFS) && \
3618 defined(HAS_STRUCT_STATFS_F_FLAGS)
3619 # define FD_ON_NOSUID_CHECK_OKAY
3622 check_okay = fstatfs(fd, &stfs) == 0;
3623 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3624 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
3625 # endif /* fstatfs */
3627 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3628 defined(PERL_MOUNT_NOSUID) && \
3629 defined(PERL_MOUNT_NOEXEC) && \
3630 defined(HAS_FSTAT) && \
3631 defined(HAS_USTAT) && \
3632 defined(HAS_GETMNT) && \
3633 defined(HAS_STRUCT_FS_DATA) && \
3635 # define FD_ON_NOSUID_CHECK_OKAY
3638 if (fstat(fd, &fdst) == 0) {
3640 if (ustat(fdst.st_dev, &us) == 0) {
3642 /* NOSTAT_ONE here because we're not examining fields which
3643 * vary between that case and STAT_ONE. */
3644 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3645 size_t cmplen = sizeof(us.f_fname);
3646 if (sizeof(fsd.fd_req.path) < cmplen)
3647 cmplen = sizeof(fsd.fd_req.path);
3648 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3649 fdst.st_dev == fsd.fd_req.dev) {
3651 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3652 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
3658 # endif /* fstat+ustat+getmnt */
3660 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3661 defined(HAS_GETMNTENT) && \
3662 defined(HAS_HASMNTOPT) && \
3663 defined(MNTOPT_NOSUID) && \
3664 defined(MNTOPT_NOEXEC)
3665 # define FD_ON_NOSUID_CHECK_OKAY
3666 FILE *mtab = fopen("/etc/mtab", "r");
3667 struct mntent *entry;
3670 if (mtab && (fstat(fd, &stb) == 0)) {
3671 while (entry = getmntent(mtab)) {
3672 if (stat(entry->mnt_dir, &fsb) == 0
3673 && fsb.st_dev == stb.st_dev)
3675 /* found the filesystem */
3677 if (hasmntopt(entry, MNTOPT_NOSUID))
3679 if (hasmntopt(entry, MNTOPT_NOEXEC))
3682 } /* A single fs may well fail its stat(). */
3687 # endif /* getmntent+hasmntopt */
3690 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3692 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3694 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3695 return ((!check_okay) || on_nosuid || on_noexec);
3697 #endif /* IAMSUID */
3700 S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
3705 #endif /* IAMSUID */
3707 /* do we need to emulate setuid on scripts? */
3709 /* This code is for those BSD systems that have setuid #! scripts disabled
3710 * in the kernel because of a security problem. Merely defining DOSUID
3711 * in perl will not fix that problem, but if you have disabled setuid
3712 * scripts in the kernel, this will attempt to emulate setuid and setgid
3713 * on scripts that have those now-otherwise-useless bits set. The setuid
3714 * root version must be called suidperl or sperlN.NNN. If regular perl
3715 * discovers that it has opened a setuid script, it calls suidperl with
3716 * the same argv that it had. If suidperl finds that the script it has
3717 * just opened is NOT setuid root, it sets the effective uid back to the
3718 * uid. We don't just make perl setuid root because that loses the
3719 * effective uid we had before invoking perl, if it was different from the
3722 * Description/comments above do not match current workings:
3723 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3724 * suidperl called with script open and name changed to /dev/fd/N/X;
3725 * suidperl croaks if script is not setuid;
3726 * making perl setuid would be a huge security risk (and yes, that
3727 * would lose any euid we might have had).
3729 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3730 * be defined in suidperl only. suidperl must be setuid root. The
3731 * Configure script will set this up for you if you want it.
3737 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3738 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3739 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3741 const char *linestr;
3744 if (PL_fdscript < 0 || PL_suidscript != 1)
3745 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3747 * Since the script is opened by perl, not suidperl, some of these
3748 * checks are superfluous. Leaving them in probably does not lower
3752 * Do checks even for systems with no HAS_SETREUID.
3753 * We used to swap, then re-swap UIDs with
3755 if (setreuid(PL_euid,PL_uid) < 0
3756 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3757 Perl_croak(aTHX_ "Can't swap uid and euid");
3760 if (setreuid(PL_uid,PL_euid) < 0
3761 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3762 Perl_croak(aTHX_ "Can't reswap uid and euid");
3766 /* On this access check to make sure the directories are readable,
3767 * there is actually a small window that the user could use to make
3768 * filename point to an accessible directory. So there is a faint
3769 * chance that someone could execute a setuid script down in a
3770 * non-accessible directory. I don't know what to do about that.
3771 * But I don't think it's too important. The manual lies when
3772 * it says access() is useful in setuid programs.
3774 * So, access() is pretty useless... but not harmful... do anyway.
3776 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
3777 Perl_croak(aTHX_ "Can't access() script\n");
3780 /* If we can swap euid and uid, then we can determine access rights
3781 * with a simple stat of the file, and then compare device and
3782 * inode to make sure we did stat() on the same file we opened.
3783 * Then we just have to make sure he or she can execute it.
3786 * As the script is opened by perl, not suidperl, we do not need to
3787 * care much about access rights.
3789 * The 'script changed' check is needed, or we can get lied to
3790 * about $0 with e.g.
3791 * suidperl /dev/fd/4//bin/x 4<setuidscript
3792 * Without HAS_SETREUID, is it safe to stat() as root?
3794 * Are there any operating systems that pass /dev/fd/xxx for setuid
3795 * scripts, as suggested/described in perlsec(1)? Surely they do not
3796 * pass the script name as we do, so the "script changed" test would
3797 * fail for them... but we never get here with
3798 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3800 * This is one place where we must "lie" about return status: not
3801 * say if the stat() failed. We are doing this as root, and could
3802 * be tricked into reporting existence or not of files that the
3803 * "plain" user cannot even see.
3807 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3808 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3809 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3810 Perl_croak(aTHX_ "Setuid script changed\n");
3814 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3815 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3818 * We used to do this check as the "plain" user (after swapping
3819 * UIDs). But the check for nosuid and noexec filesystem is needed,
3820 * and should be done even without HAS_SETREUID. (Maybe those
3821 * operating systems do not have such mount options anyway...)
3822 * Seems safe enough to do as root.
3824 #if !defined(NO_NOSUID_CHECK)
3825 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3826 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3829 #endif /* IAMSUID */
3831 if (!S_ISREG(PL_statbuf.st_mode)) {
3832 Perl_croak(aTHX_ "Setuid script not plain file\n");
3834 if (PL_statbuf.st_mode & S_IWOTH)
3835 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3836 PL_doswitches = FALSE; /* -s is insecure in suid */
3837 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
3838 CopLINE_inc(PL_curcop);
3839 linestr = SvPV_nolen_const(PL_linestr);
3840 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3841 strnNE(linestr,"#!",2) ) /* required even on Sys V */
3842 Perl_croak(aTHX_ "No #! line");
3846 /* Sanity check on line length */
3847 if (strlen(s) < 1 || strlen(s) > 4000)
3848 Perl_croak(aTHX_ "Very long #! line");
3849 /* Allow more than a single space after #! */
3850 while (isSPACE(*s)) s++;
3851 /* Sanity check on buffer end */
3852 while ((*s) && !isSPACE(*s)) s++;
3853 for (s2 = s; (s2 > linestr &&
3854 (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
3855 || s2[-1] == '-')); s2--) ;
3856 /* Sanity check on buffer start */
3857 if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
3858 (s-9 < linestr || strnNE(s-9,"perl",4)) )
3859 Perl_croak(aTHX_ "Not a perl script");
3860 while (*s == ' ' || *s == '\t') s++;
3862 * #! arg must be what we saw above. They can invoke it by
3863 * mentioning suidperl explicitly, but they may not add any strange
3864 * arguments beyond what #! says if they do invoke suidperl that way.
3867 * The way validarg was set up, we rely on the kernel to start
3868 * scripts with argv[1] set to contain all #! line switches (the
3872 * Check that we got all the arguments listed in the #! line (not
3873 * just that there are no extraneous arguments). Might not matter
3874 * much, as switches from #! line seem to be acted upon (also), and
3875 * so may be checked and trapped in perl. But, security checks must
3876 * be done in suidperl and not deferred to perl. Note that suidperl
3877 * does not get around to parsing (and checking) the switches on
3878 * the #! line (but execs perl sooner).
3879 * Allow (require) a trailing newline (which may be of two
3880 * characters on some architectures?) (but no other trailing
3883 len = strlen(validarg);
3884 if (strEQ(validarg," PHOOEY ") ||
3885 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3886 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
3887 Perl_croak(aTHX_ "Args must match #! line");
3890 if (PL_fdscript < 0 &&
3891 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3892 PL_euid == PL_statbuf.st_uid)
3894 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3895 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
3896 #endif /* IAMSUID */
3898 if (PL_fdscript < 0 &&
3899 PL_euid) { /* oops, we're not the setuid root perl */
3901 * When root runs a setuid script, we do not go through the same
3902 * steps of execing sperl and then perl with fd scripts, but
3903 * simply set up UIDs within the same perl invocation; so do
3904 * not have the same checks (on options, whatever) that we have
3905 * for plain users. No problem really: would have to be a script
3906 * that does not actually work for plain users; and if root is
3907 * foolish and can be persuaded to run such an unsafe script, he
3908 * might run also non-setuid ones, and deserves what he gets.
3910 * Or, we might drop the PL_euid check above (and rely just on
3911 * PL_fdscript to avoid loops), and do the execs
3917 * Pass fd script to suidperl.
3918 * Exec suidperl, substituting fd script for scriptname.
3919 * Pass script name as "subdir" of fd, which perl will grok;
3920 * in fact will use that to distinguish this from "normal"
3921 * usage, see comments above.
3923 PerlIO_rewind(PL_rsfp);
3924 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3925 /* PSz 27 Feb 04 Sanity checks on scriptname */
3926 if ((!scriptname) || (!*scriptname) ) {
3927 Perl_croak(aTHX_ "No setuid script name\n");
3929 if (*scriptname == '-') {
3930 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3931 /* Or we might confuse it with an option when replacing
3932 * name in argument list, below (though we do pointer, not
3933 * string, comparisons).
3936 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3937 if (!PL_origargv[which]) {
3938 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3940 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3941 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3942 #if defined(HAS_FCNTL) && defined(F_SETFD)
3943 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3946 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3947 (int)PERL_REVISION, (int)PERL_VERSION,
3948 (int)PERL_SUBVERSION), PL_origargv);
3950 #endif /* IAMSUID */
3951 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
3954 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3956 * This seems back to front: we try HAS_SETEGID first; if not available
3957 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3958 * in the sense that we only want to set EGID; but are there any machines
3959 * with either of the latter, but not the former? Same with UID, later.
3962 (void)setegid(PL_statbuf.st_gid);
3965 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3967 #ifdef HAS_SETRESGID
3968 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3970 PerlProc_setgid(PL_statbuf.st_gid);
3974 if (PerlProc_getegid() != PL_statbuf.st_gid)
3975 Perl_croak(aTHX_ "Can't do setegid!\n");
3977 if (PL_statbuf.st_mode & S_ISUID) {
3978 if (PL_statbuf.st_uid != PL_euid)
3980 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3983 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3985 #ifdef HAS_SETRESUID
3986 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3988 PerlProc_setuid(PL_statbuf.st_uid);
3992 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3993 Perl_croak(aTHX_ "Can't do seteuid!\n");
3995 else if (PL_uid) { /* oops, mustn't run as root */
3997 (void)seteuid((Uid_t)PL_uid);
4000 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
4002 #ifdef HAS_SETRESUID
4003 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
4005 PerlProc_setuid((Uid_t)PL_uid);
4009 if (PerlProc_geteuid() != PL_uid)
4010 Perl_croak(aTHX_ "Can't do seteuid!\n");
4013 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
4014 Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
4017 else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
4018 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
4019 else if (PL_fdscript < 0 || PL_suidscript != 1)
4020 /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
4021 Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
4023 /* PSz 16 Sep 03 Keep neat error message */
4024 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
4027 /* We absolutely must clear out any saved ids here, so we */
4028 /* exec the real perl, substituting fd script for scriptname. */
4029 /* (We pass script name as "subdir" of fd, which perl will grok.) */
4031 * It might be thought that using setresgid and/or setresuid (changed to
4032 * set the saved IDs) above might obviate the need to exec, and we could
4033 * go on to "do the perl thing".
4035 * Is there such a thing as "saved GID", and is that set for setuid (but
4036 * not setgid) execution like suidperl? Without exec, it would not be
4037 * cleared for setuid (but not setgid) scripts (or might need a dummy
4040 * We need suidperl to do the exact same argument checking that perl
4041 * does. Thus it cannot be very small; while it could be significantly
4042 * smaller, it is safer (simpler?) to make it essentially the same
4043 * binary as perl (but they are not identical). - Maybe could defer that
4044 * check to the invoked perl, and suidperl be a tiny wrapper instead;
4045 * but prefer to do thorough checks in suidperl itself. Such deferral
4046 * would make suidperl security rely on perl, a design no-no.
4048 * Setuid things should be short and simple, thus easy to understand and
4049 * verify. They should do their "own thing", without influence by
4050 * attackers. It may help if their internal execution flow is fixed,
4051 * regardless of platform: it may be best to exec anyway.
4053 * Suidperl should at least be conceptually simple: a wrapper only,
4054 * never to do any real perl. Maybe we should put
4056 * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
4058 * into the perly bits.
4060 PerlIO_rewind(PL_rsfp);
4061 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
4063 * Keep original arguments: suidperl already has fd script.
4065 /* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
4066 /* if (!PL_origargv[which]) { */
4067 /* errno = EPERM; */
4068 /* Perl_croak(aTHX_ "Permission denied\n"); */
4070 /* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */
4071 /* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
4072 #if defined(HAS_FCNTL) && defined(F_SETFD)
4073 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
4076 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
4077 (int)PERL_REVISION, (int)PERL_VERSION,
4078 (int)PERL_SUBVERSION), PL_origargv);/* try again */
4080 Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
4081 #endif /* IAMSUID */
4083 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
4084 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
4085 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
4086 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
4088 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
4091 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
4092 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
4093 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4094 /* not set-id, must be wrapped */
4102 S_find_beginning(pTHX)
4105 register const char *s2;
4106 #ifdef MACOS_TRADITIONAL
4110 /* skip forward in input to the real script? */
4113 #ifdef MACOS_TRADITIONAL
4114 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
4116 while (PL_doextract || gMacPerl_AlwaysExtract) {
4117 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
4118 if (!gMacPerl_AlwaysExtract)
4119 Perl_croak(aTHX_ "No Perl script found in input\n");
4121 if (PL_doextract) /* require explicit override ? */
4122 if (!OverrideExtract(PL_origfilename))
4123 Perl_croak(aTHX_ "User aborted script\n");
4125 PL_doextract = FALSE;
4127 /* Pater peccavi, file does not have #! */
4128 PerlIO_rewind(PL_rsfp);
4133 while (PL_doextract) {
4134 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
4135 Perl_croak(aTHX_ "No Perl script found in input\n");
4138 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
4139 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
4140 PL_doextract = FALSE;
4141 while (*s && !(isSPACE (*s) || *s == '#')) s++;
4143 while (*s == ' ' || *s == '\t') s++;
4145 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
4146 || s2[-1] == '_') s2--;
4147 if (strnEQ(s2-4,"perl",4))
4148 while ((s = moreswitches(s)))
4151 #ifdef MACOS_TRADITIONAL
4152 /* We are always searching for the #!perl line in MacPerl,
4153 * so if we find it, still keep the line count correct
4154 * by counting lines we already skipped over
4156 for (; maclines > 0 ; maclines--)
4157 PerlIO_ungetc(PL_rsfp, '\n');
4161 /* gMacPerl_AlwaysExtract is false in MPW tool */
4162 } else if (gMacPerl_AlwaysExtract) {
4173 PL_uid = PerlProc_getuid();
4174 PL_euid = PerlProc_geteuid();
4175 PL_gid = PerlProc_getgid();
4176 PL_egid = PerlProc_getegid();
4178 PL_uid |= PL_gid << 16;
4179 PL_euid |= PL_egid << 16;
4181 /* Should not happen: */
4182 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4183 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
4186 * Should go by suidscript, not uid!=euid: why disallow
4187 * system("ls") in scripts run from setuid things?
4188 * Or, is this run before we check arguments and set suidscript?
4189 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
4190 * (We never have suidscript, can we be sure to have fdscript?)
4191 * Or must then go by UID checks? See comments in forbid_setid also.
4195 /* This is used very early in the lifetime of the program,
4196 * before even the options are parsed, so PL_tainting has
4197 * not been initialized properly. */
4199 Perl_doing_taint(int argc, char *argv[], char *envp[])
4201 #ifndef PERL_IMPLICIT_SYS
4202 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
4203 * before we have an interpreter-- and the whole point of this
4204 * function is to be called at such an early stage. If you are on
4205 * a system with PERL_IMPLICIT_SYS but you do have a concept of
4206 * "tainted because running with altered effective ids', you'll
4207 * have to add your own checks somewhere in here. The two most
4208 * known samples of 'implicitness' are Win32 and NetWare, neither
4209 * of which has much of concept of 'uids'. */
4210 int uid = PerlProc_getuid();
4211 int euid = PerlProc_geteuid();
4212 int gid = PerlProc_getgid();
4213 int egid = PerlProc_getegid();
4220 if (uid && (euid != uid || egid != gid))
4222 #endif /* !PERL_IMPLICIT_SYS */
4223 /* This is a really primitive check; environment gets ignored only
4224 * if -T are the first chars together; otherwise one gets
4225 * "Too late" message. */
4226 if ( argc > 1 && argv[1][0] == '-'
4227 && (argv[1][1] == 't' || argv[1][1] == 'T') )
4233 S_forbid_setid(pTHX_ const char *s)
4235 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
4236 if (PL_euid != PL_uid)
4237 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
4238 if (PL_egid != PL_gid)
4239 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
4240 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
4242 * Checks for UID/GID above "wrong": why disallow
4243 * perl -e 'print "Hello\n"'
4244 * from within setuid things?? Simply drop them: replaced by
4245 * fdscript/suidscript and #ifdef IAMSUID checks below.
4247 * This may be too late for command-line switches. Will catch those on
4248 * the #! line, after finding the script name and setting up
4249 * fdscript/suidscript. Note that suidperl does not get around to
4250 * parsing (and checking) the switches on the #! line, but checks that
4251 * the two sets are identical.
4253 * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
4254 * instead, or would that be "too late"? (We never have suidscript, can
4255 * we be sure to have fdscript?)
4257 * Catch things with suidscript (in descendant of suidperl), even with
4258 * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
4259 * below; but I am paranoid.
4261 * Also see comments about root running a setuid script, elsewhere.
4263 if (PL_suidscript >= 0)
4264 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
4266 /* PSz 11 Nov 03 Catch it in suidperl, always! */
4267 Perl_croak(aTHX_ "No %s allowed in suidperl", s);
4268 #endif /* IAMSUID */
4272 Perl_init_debugger(pTHX)
4274 HV *ostash = PL_curstash;
4276 PL_curstash = PL_debstash;
4277 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
4278 AvREAL_off(PL_dbargs);
4279 PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
4280 PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4281 PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
4282 PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
4283 sv_setiv(PL_DBsingle, 0);
4284 PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
4285 sv_setiv(PL_DBtrace, 0);
4286 PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
4287 sv_setiv(PL_DBsignal, 0);
4288 PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
4289 sv_setiv(PL_DBassertion, 0);
4290 PL_curstash = ostash;
4293 #ifndef STRESS_REALLOC
4294 #define REASONABLE(size) (size)
4296 #define REASONABLE(size) (1) /* unreasonable */
4300 Perl_init_stacks(pTHX)
4302 /* start with 128-item stack and 8K cxstack */
4303 PL_curstackinfo = new_stackinfo(REASONABLE(128),
4304 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4305 PL_curstackinfo->si_type = PERLSI_MAIN;
4306 PL_curstack = PL_curstackinfo->si_stack;
4307 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
4309 PL_stack_base = AvARRAY(PL_curstack);
4310 PL_stack_sp = PL_stack_base;
4311 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4313 New(50,PL_tmps_stack,REASONABLE(128),SV*);
4316 PL_tmps_max = REASONABLE(128);
4318 New(54,PL_markstack,REASONABLE(32),I32);
4319 PL_markstack_ptr = PL_markstack;
4320 PL_markstack_max = PL_markstack + REASONABLE(32);
4324 New(54,PL_scopestack,REASONABLE(32),I32);
4325 PL_scopestack_ix = 0;
4326 PL_scopestack_max = REASONABLE(32);
4328 New(54,PL_savestack,REASONABLE(128),ANY);
4329 PL_savestack_ix = 0;
4330 PL_savestack_max = REASONABLE(128);
4338 while (PL_curstackinfo->si_next)
4339 PL_curstackinfo = PL_curstackinfo->si_next;
4340 while (PL_curstackinfo) {
4341 PERL_SI *p = PL_curstackinfo->si_prev;
4342 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4343 Safefree(PL_curstackinfo->si_cxstack);
4344 Safefree(PL_curstackinfo);
4345 PL_curstackinfo = p;
4347 Safefree(PL_tmps_stack);
4348 Safefree(PL_markstack);
4349 Safefree(PL_scopestack);
4350 Safefree(PL_savestack);
4359 lex_start(PL_linestr);
4361 PL_subname = newSVpvn("main",4);
4365 S_init_predump_symbols(pTHX)
4370 sv_setpvn(get_sv("\"", TRUE), " ", 1);
4371 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
4372 GvMULTI_on(PL_stdingv);
4373 io = GvIOp(PL_stdingv);
4374 IoTYPE(io) = IoTYPE_RDONLY;
4375 IoIFP(io) = PerlIO_stdin();
4376 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
4378 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4380 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
4383 IoTYPE(io) = IoTYPE_WRONLY;
4384 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4386 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
4388 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4390 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
4391 GvMULTI_on(PL_stderrgv);
4392 io = GvIOp(PL_stderrgv);
4393 IoTYPE(io) = IoTYPE_WRONLY;
4394 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4395 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
4397 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
4399 PL_statname = NEWSV(66,0); /* last filename we did stat on */
4402 Safefree(PL_osname);
4403 PL_osname = savepv(OSNAME);
4407 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
4410 argc--,argv++; /* skip name of script */
4411 if (PL_doswitches) {
4412 for (; argc > 0 && **argv == '-'; argc--,argv++) {
4415 if (argv[0][1] == '-' && !argv[0][2]) {
4419 if ((s = strchr(argv[0], '='))) {
4421 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
4424 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
4427 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
4428 GvMULTI_on(PL_argvgv);
4429 (void)gv_AVadd(PL_argvgv);
4430 av_clear(GvAVn(PL_argvgv));
4431 for (; argc > 0; argc--,argv++) {
4432 SV *sv = newSVpv(argv[0],0);
4433 av_push(GvAVn(PL_argvgv),sv);
4434 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4435 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4438 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4439 (void)sv_utf8_decode(sv);
4445 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
4450 PL_toptarget = NEWSV(0,0);
4451 sv_upgrade(PL_toptarget, SVt_PVFM);
4452 sv_setpvn(PL_toptarget, "", 0);
4453 PL_bodytarget = NEWSV(0,0);
4454 sv_upgrade(PL_bodytarget, SVt_PVFM);
4455 sv_setpvn(PL_bodytarget, "", 0);
4456 PL_formtarget = PL_bodytarget;
4460 init_argv_symbols(argc,argv);
4462 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
4463 #ifdef MACOS_TRADITIONAL
4464 /* $0 is not majick on a Mac */
4465 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4467 sv_setpv(GvSV(tmpgv),PL_origfilename);
4468 magicname("0", "0", 1);
4471 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
4473 GvMULTI_on(PL_envgv);
4474 hv = GvHVn(PL_envgv);
4475 hv_magic(hv, Nullgv, PERL_MAGIC_env);
4477 #ifdef USE_ENVIRON_ARRAY
4478 /* Note that if the supplied env parameter is actually a copy
4479 of the global environ then it may now point to free'd memory
4480 if the environment has been modified since. To avoid this
4481 problem we treat env==NULL as meaning 'use the default'
4486 # ifdef USE_ITHREADS
4487 && PL_curinterp == aTHX
4491 environ[0] = Nullch;
4494 char** origenv = environ;
4497 for (; *env; env++) {
4498 if (!(s = strchr(*env,'=')) || s == *env)
4500 #if defined(MSDOS) && !defined(DJGPP)
4505 sv = newSVpv(s+1, 0);
4506 (void)hv_store(hv, *env, s - *env, sv, 0);
4509 if (origenv != environ) {
4510 /* realloc has shifted us */
4511 env = (env - origenv) + environ;
4516 #endif /* USE_ENVIRON_ARRAY */
4517 #endif /* !PERL_MICRO */
4520 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4521 SvREADONLY_off(GvSV(tmpgv));
4522 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4523 SvREADONLY_on(GvSV(tmpgv));
4525 #ifdef THREADS_HAVE_PIDS
4526 PL_ppid = (IV)getppid();
4529 /* touch @F array to prevent spurious warnings 20020415 MJD */
4531 (void) get_av("main::F", TRUE | GV_ADDMULTI);
4533 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4534 (void) get_av("main::-", TRUE | GV_ADDMULTI);
4535 (void) get_av("main::+", TRUE | GV_ADDMULTI);
4539 S_init_perllib(pTHX)
4544 s = PerlEnv_getenv("PERL5LIB");
4546 incpush(s, TRUE, TRUE, TRUE, FALSE);
4548 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
4550 /* Treat PERL5?LIB as a possible search list logical name -- the
4551 * "natural" VMS idiom for a Unix path string. We allow each
4552 * element to be a set of |-separated directories for compatibility.
4556 if (my_trnlnm("PERL5LIB",buf,0))
4557 do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
4559 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
4563 /* Use the ~-expanded versions of APPLLIB (undocumented),
4564 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
4567 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
4571 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4573 #ifdef MACOS_TRADITIONAL
4576 SV * privdir = NEWSV(55, 0);
4577 char * macperl = PerlEnv_getenv("MACPERL");
4582 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4583 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4584 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4585 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4586 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
4587 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
4589 SvREFCNT_dec(privdir);
4592 incpush(":", FALSE, FALSE, TRUE, FALSE);
4595 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4598 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
4600 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4604 /* sitearch is always relative to sitelib on Windows for
4605 * DLL-based path intuition to work correctly */
4606 # if !defined(WIN32)
4607 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4613 /* this picks up sitearch as well */
4614 incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
4616 incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
4620 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
4621 incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
4624 #ifdef PERL_VENDORARCH_EXP
4625 /* vendorarch is always relative to vendorlib on Windows for
4626 * DLL-based path intuition to work correctly */
4627 # if !defined(WIN32)
4628 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
4632 #ifdef PERL_VENDORLIB_EXP
4634 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE); /* this picks up vendorarch as well */
4636 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
4640 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
4641 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
4644 #ifdef PERL_OTHERLIBDIRS
4645 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
4649 incpush(".", FALSE, FALSE, TRUE, FALSE);
4650 #endif /* MACOS_TRADITIONAL */
4653 #if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
4654 # define PERLLIB_SEP ';'
4657 # define PERLLIB_SEP '|'
4659 # if defined(MACOS_TRADITIONAL)
4660 # define PERLLIB_SEP ','
4662 # define PERLLIB_SEP ':'
4666 #ifndef PERLLIB_MANGLE
4667 # define PERLLIB_MANGLE(s,n) (s)
4670 /* Push a directory onto @INC if it exists.
4671 Generate a new SV if we do this, to save needing to copy the SV we push
4674 S_incpush_if_exists(pTHX_ SV *dir)
4677 if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4678 S_ISDIR(tmpstatbuf.st_mode)) {
4679 av_push(GvAVn(PL_incgv), dir);
4686 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
4689 SV *subdir = Nullsv;
4690 const char *p = dir;
4695 if (addsubdirs || addoldvers) {
4696 subdir = NEWSV(0,0);
4699 /* Break at all separators */
4701 SV *libdir = NEWSV(55,0);
4704 /* skip any consecutive separators */
4706 while ( *p == PERLLIB_SEP ) {
4707 /* Uncomment the next line for PATH semantics */
4708 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4713 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
4714 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4719 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4720 p = Nullch; /* break out */
4722 #ifdef MACOS_TRADITIONAL
4723 if (!strchr(SvPVX(libdir), ':')) {
4726 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4728 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4729 sv_catpv(libdir, ":");
4732 /* Do the if() outside the #ifdef to avoid warnings about an unused
4735 #ifdef PERL_RELOCATABLE_INC
4737 * Relocatable include entries are marked with a leading .../
4740 * 0: Remove that leading ".../"
4741 * 1: Remove trailing executable name (anything after the last '/')
4742 * from the perl path to give a perl prefix
4744 * While the @INC element starts "../" and the prefix ends with a real
4745 * directory (ie not . or ..) chop that real directory off the prefix
4746 * and the leading "../" from the @INC element. ie a logical "../"
4748 * Finally concatenate the prefix and the remainder of the @INC element
4749 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4750 * generates /usr/local/lib/perl5
4752 char *libpath = SvPVX(libdir);
4753 STRLEN libpath_len = SvCUR(libdir);
4754 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4756 SV *caret_X = get_sv("\030", 0);
4757 /* Going to use the SV just as a scratch buffer holding a C
4763 /* $^X is *the* source of taint if tainting is on, hence
4764 SvPOK() won't be true. */
4766 assert(SvPOKp(caret_X));
4767 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
4768 /* Firstly take off the leading .../
4769 If all else fail we'll do the paths relative to the current
4771 sv_chop(libdir, libpath + 4);
4772 /* Don't use SvPV as we're intentionally bypassing taining,
4773 mortal copies that the mg_get of tainting creates, and
4774 corruption that seems to come via the save stack.
4775 I guess that the save stack isn't correctly set up yet. */
4776 libpath = SvPVX(libdir);
4777 libpath_len = SvCUR(libdir);
4779 /* This would work more efficiently with memrchr, but as it's
4780 only a GNU extension we'd need to probe for it and
4781 implement our own. Not hard, but maybe not worth it? */
4783 prefix = SvPVX(prefix_sv);
4784 lastslash = strrchr(prefix, '/');
4786 /* First time in with the *lastslash = '\0' we just wipe off
4787 the trailing /perl from (say) /usr/foo/bin/perl
4791 while ((*lastslash = '\0'), /* Do that, come what may. */
4792 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4793 && (lastslash = strrchr(prefix, '/')))) {
4794 if (lastslash[1] == '\0'
4795 || (lastslash[1] == '.'
4796 && (lastslash[2] == '/' /* ends "/." */
4797 || (lastslash[2] == '/'
4798 && lastslash[3] == '/' /* or "/.." */
4800 /* Prefix ends "/" or "/." or "/..", any of which
4801 are fishy, so don't do any more logical cleanup.
4805 /* Remove leading "../" from path */
4808 /* Next iteration round the loop removes the last
4809 directory name from prefix by writing a '\0' in
4810 the while clause. */
4812 /* prefix has been terminated with a '\0' to the correct
4813 length. libpath points somewhere into the libdir SV.
4814 We need to join the 2 with '/' and drop the result into
4816 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4817 SvREFCNT_dec(libdir);
4818 /* And this is the new libdir. */
4821 (PL_uid != PL_euid || PL_gid != PL_egid)) {
4822 /* Need to taint reloccated paths if running set ID */
4823 SvTAINTED_on(libdir);
4826 SvREFCNT_dec(prefix_sv);
4831 * BEFORE pushing libdir onto @INC we may first push version- and
4832 * archname-specific sub-directories.
4834 if (addsubdirs || addoldvers) {
4835 #ifdef PERL_INC_VERSION_LIST
4836 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4837 const char *incverlist[] = { PERL_INC_VERSION_LIST };
4838 const char **incver;
4844 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
4846 while (unix[len-1] == '/') len--; /* Cosmetic */
4847 sv_usepvn(libdir,unix,len);
4850 PerlIO_printf(Perl_error_log,
4851 "Failed to unixify @INC element \"%s\"\n",
4855 #ifdef MACOS_TRADITIONAL
4856 #define PERL_AV_SUFFIX_FMT ""
4857 #define PERL_ARCH_FMT "%s:"
4858 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
4860 #define PERL_AV_SUFFIX_FMT "/"
4861 #define PERL_ARCH_FMT "/%s"
4862 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
4864 /* .../version/archname if -d .../version/archname */
4865 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
4867 (int)PERL_REVISION, (int)PERL_VERSION,
4868 (int)PERL_SUBVERSION, ARCHNAME);
4869 subdir = S_incpush_if_exists(aTHX_ subdir);
4871 /* .../version if -d .../version */
4872 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
4873 (int)PERL_REVISION, (int)PERL_VERSION,
4874 (int)PERL_SUBVERSION);
4875 subdir = S_incpush_if_exists(aTHX_ subdir);
4877 /* .../archname if -d .../archname */
4878 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
4879 subdir = S_incpush_if_exists(aTHX_ subdir);
4883 #ifdef PERL_INC_VERSION_LIST
4885 for (incver = incverlist; *incver; incver++) {
4886 /* .../xxx if -d .../xxx */
4887 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
4888 subdir = S_incpush_if_exists(aTHX_ subdir);
4894 /* finally push this lib directory on the end of @INC */
4895 av_push(GvAVn(PL_incgv), libdir);
4898 assert (SvREFCNT(subdir) == 1);
4899 SvREFCNT_dec(subdir);
4903 #ifdef USE_5005THREADS
4904 STATIC struct perl_thread *
4905 S_init_main_thread(pTHX)
4907 #if !defined(PERL_IMPLICIT_CONTEXT)
4908 struct perl_thread *thr;
4912 Newz(53, thr, 1, struct perl_thread);
4913 PL_curcop = &PL_compiling;
4914 thr->interp = PERL_GET_INTERP;
4915 thr->cvcache = newHV();
4916 thr->threadsv = newAV();
4917 /* thr->threadsvp is set when find_threadsv is called */
4918 thr->specific = newAV();
4919 thr->flags = THRf_R_JOINABLE;
4920 MUTEX_INIT(&thr->mutex);
4921 /* Handcraft thrsv similarly to mess_sv */
4922 New(53, PL_thrsv, 1, SV);
4923 Newz(53, xpv, 1, XPV);
4924 SvFLAGS(PL_thrsv) = SVt_PV;
4925 SvANY(PL_thrsv) = (void*)xpv;
4926 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
4927 SvPV_set(PL_thrsvr, (char*)thr);
4928 SvCUR_set(PL_thrsv, sizeof(thr));
4929 SvLEN_set(PL_thrsv, sizeof(thr));
4930 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
4931 thr->oursv = PL_thrsv;
4932 PL_chopset = " \n-";
4935 MUTEX_LOCK(&PL_threads_mutex);
4941 MUTEX_UNLOCK(&PL_threads_mutex);
4943 #ifdef HAVE_THREAD_INTERN
4944 Perl_init_thread_intern(thr);
4947 #ifdef SET_THREAD_SELF
4948 SET_THREAD_SELF(thr);
4950 thr->self = pthread_self();
4951 #endif /* SET_THREAD_SELF */
4955 * These must come after the thread self setting
4956 * because sv_setpvn does SvTAINT and the taint
4957 * fields thread selfness being set.
4959 PL_toptarget = NEWSV(0,0);
4960 sv_upgrade(PL_toptarget, SVt_PVFM);
4961 sv_setpvn(PL_toptarget, "", 0);
4962 PL_bodytarget = NEWSV(0,0);
4963 sv_upgrade(PL_bodytarget, SVt_PVFM);
4964 sv_setpvn(PL_bodytarget, "", 0);
4965 PL_formtarget = PL_bodytarget;
4966 thr->errsv = newSVpvn("", 0);
4967 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
4970 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
4971 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4972 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4973 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4974 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4975 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
4977 PL_reginterp_cnt = 0;
4981 #endif /* USE_5005THREADS */
4984 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4988 const line_t oldline = CopLINE(PL_curcop);
4994 while (av_len(paramList) >= 0) {
4995 cv = (CV*)av_shift(paramList);
4997 if (paramList == PL_beginav) {
4998 /* save PL_beginav for compiler */
4999 if (! PL_beginav_save)
5000 PL_beginav_save = newAV();
5001 av_push(PL_beginav_save, (SV*)cv);
5003 else if (paramList == PL_checkav) {
5004 /* save PL_checkav for compiler */
5005 if (! PL_checkav_save)
5006 PL_checkav_save = newAV();
5007 av_push(PL_checkav_save, (SV*)cv);
5017 (void)SvPV_const(atsv, len);
5019 PL_curcop = &PL_compiling;
5020 CopLINE_set(PL_curcop, oldline);
5021 if (paramList == PL_beginav)
5022 sv_catpv(atsv, "BEGIN failed--compilation aborted");
5024 Perl_sv_catpvf(aTHX_ atsv,
5025 "%s failed--call queue aborted",
5026 paramList == PL_checkav ? "CHECK"
5027 : paramList == PL_initav ? "INIT"
5029 while (PL_scopestack_ix > oldscope)
5032 Perl_croak(aTHX_ "%"SVf"", atsv);
5039 /* my_exit() was called */
5040 while (PL_scopestack_ix > oldscope)
5043 PL_curstash = PL_defstash;
5044 PL_curcop = &PL_compiling;
5045 CopLINE_set(PL_curcop, oldline);
5047 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
5048 if (paramList == PL_beginav)
5049 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
5051 Perl_croak(aTHX_ "%s failed--call queue aborted",
5052 paramList == PL_checkav ? "CHECK"
5053 : paramList == PL_initav ? "INIT"
5060 PL_curcop = &PL_compiling;
5061 CopLINE_set(PL_curcop, oldline);
5064 PerlIO_printf(Perl_error_log, "panic: restartop\n");
5073 S_call_list_body(pTHX_ CV *cv)
5075 PUSHMARK(PL_stack_sp);
5076 call_sv((SV*)cv, G_EVAL|G_DISCARD);
5081 Perl_my_exit(pTHX_ U32 status)
5083 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
5084 thr, (unsigned long) status));
5093 STATUS_NATIVE_SET(status);
5100 Perl_my_failure_exit(pTHX)
5103 if (vaxc$errno & 1) {
5104 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
5105 STATUS_NATIVE_SET(44);
5108 if (!vaxc$errno) /* unlikely */
5109 STATUS_NATIVE_SET(44);
5111 STATUS_NATIVE_SET(vaxc$errno);
5116 STATUS_UNIX_SET(errno);
5118 exitstatus = STATUS_UNIX >> 8;
5119 if (exitstatus & 255)
5120 STATUS_UNIX_SET(exitstatus);
5122 STATUS_UNIX_SET(255);
5129 S_my_exit_jump(pTHX)
5132 register PERL_CONTEXT *cx;
5137 SvREFCNT_dec(PL_e_script);
5138 PL_e_script = Nullsv;
5141 POPSTACK_TO(PL_mainstack);
5142 if (cxstack_ix >= 0) {
5145 POPBLOCK(cx,PL_curpm);
5150 PERL_UNUSED_VAR(gimme);
5151 PERL_UNUSED_VAR(newsp);
5155 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
5157 const char * const p = SvPVX_const(PL_e_script);
5158 const char *nl = strchr(p, '\n');
5160 PERL_UNUSED_ARG(idx);
5161 PERL_UNUSED_ARG(maxlen);
5163 nl = (nl) ? nl+1 : SvEND(PL_e_script);
5165 filter_del(read_e_script);
5168 sv_catpvn(buf_sv, p, nl-p);
5169 sv_chop(PL_e_script, nl);
5175 * c-indentation-style: bsd
5177 * indent-tabs-mode: t
5180 * ex: set ts=8 sts=4 sw=4 noet: