This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
SV_CONST(name) and PL_sv_consts
[perl5.git] / perl.c
1 #line 2 "perl.c"
2 /*    perl.c
3  *
4  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
5  *    2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
6  *     by Larry Wall and others
7  *
8  *    You may distribute under the terms of either the GNU General Public
9  *    License or the Artistic License, as specified in the README file.
10  *
11  */
12
13 /*
14  *      A ship then new they built for him
15  *      of mithril and of elven-glass
16  *              --from Bilbo's song of EƤrendil
17  *
18  *     [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
19  */
20
21 /* This file contains the top-level functions that are used to create, use
22  * and destroy a perl interpreter, plus the functions used by XS code to
23  * call back into perl. Note that it does not contain the actual main()
24  * function of the interpreter; that can be found in perlmain.c
25  */
26
27 #if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
28 #  define USE_SITECUSTOMIZE
29 #endif
30
31 #include "EXTERN.h"
32 #define PERL_IN_PERL_C
33 #include "perl.h"
34 #include "patchlevel.h"                 /* for local_patches */
35 #include "XSUB.h"
36
37 #ifdef NETWARE
38 #include "nwutil.h"     
39 #endif
40
41 #ifdef USE_KERN_PROC_PATHNAME
42 #  include <sys/sysctl.h>
43 #endif
44
45 #ifdef USE_NSGETEXECUTABLEPATH
46 #  include <mach-o/dyld.h>
47 #endif
48
49 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
50 #  ifdef I_SYSUIO
51 #    include <sys/uio.h>
52 #  endif
53
54 union control_un {
55   struct cmsghdr cm;
56   char control[CMSG_SPACE(sizeof(int))];
57 };
58
59 #endif
60
61 #ifndef HZ
62 #  ifdef CLK_TCK
63 #    define HZ CLK_TCK
64 #  else
65 #    define HZ 60
66 #  endif
67 #endif
68
69 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
70 char *getenv (char *); /* Usually in <stdlib.h> */
71 #endif
72
73 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
74
75 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
76 #  define validate_suid(rsfp) NOOP
77 #else
78 #  define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp)
79 #endif
80
81 #define CALL_BODY_SUB(myop) \
82     if (PL_op == (myop)) \
83         PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
84     if (PL_op) \
85         CALLRUNOPS(aTHX);
86
87 #define CALL_LIST_BODY(cv) \
88     PUSHMARK(PL_stack_sp); \
89     call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID);
90
91 static void
92 S_init_tls_and_interp(PerlInterpreter *my_perl)
93 {
94     dVAR;
95     if (!PL_curinterp) {                        
96         PERL_SET_INTERP(my_perl);
97 #if defined(USE_ITHREADS)
98         INIT_THREADS;
99         ALLOC_THREAD_KEY;
100         PERL_SET_THX(my_perl);
101         OP_REFCNT_INIT;
102         OP_CHECK_MUTEX_INIT;
103         HINTS_REFCNT_INIT;
104         MUTEX_INIT(&PL_dollarzero_mutex);
105         MUTEX_INIT(&PL_my_ctx_mutex);
106 #  endif
107     }
108 #if defined(USE_ITHREADS)
109     else
110 #else
111     /* This always happens for non-ithreads  */
112 #endif
113     {
114         PERL_SET_THX(my_perl);
115     }
116 }
117
118
119 /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */
120
121 void
122 Perl_sys_init(int* argc, char*** argv)
123 {
124     dVAR;
125
126     PERL_ARGS_ASSERT_SYS_INIT;
127
128     PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
129     PERL_UNUSED_ARG(argv);
130     PERL_SYS_INIT_BODY(argc, argv);
131 }
132
133 void
134 Perl_sys_init3(int* argc, char*** argv, char*** env)
135 {
136     dVAR;
137
138     PERL_ARGS_ASSERT_SYS_INIT3;
139
140     PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */
141     PERL_UNUSED_ARG(argv);
142     PERL_UNUSED_ARG(env);
143     PERL_SYS_INIT3_BODY(argc, argv, env);
144 }
145
146 void
147 Perl_sys_term()
148 {
149     dVAR;
150     if (!PL_veto_cleanup) {
151         PERL_SYS_TERM_BODY();
152     }
153 }
154
155
156 #ifdef PERL_IMPLICIT_SYS
157 PerlInterpreter *
158 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
159                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
160                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
161                  struct IPerlDir* ipD, struct IPerlSock* ipS,
162                  struct IPerlProc* ipP)
163 {
164     PerlInterpreter *my_perl;
165
166     PERL_ARGS_ASSERT_PERL_ALLOC_USING;
167
168     /* Newx() needs interpreter, so call malloc() instead */
169     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
170     S_init_tls_and_interp(my_perl);
171     Zero(my_perl, 1, PerlInterpreter);
172     PL_Mem = ipM;
173     PL_MemShared = ipMS;
174     PL_MemParse = ipMP;
175     PL_Env = ipE;
176     PL_StdIO = ipStd;
177     PL_LIO = ipLIO;
178     PL_Dir = ipD;
179     PL_Sock = ipS;
180     PL_Proc = ipP;
181     INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
182
183     return my_perl;
184 }
185 #else
186
187 /*
188 =head1 Embedding Functions
189
190 =for apidoc perl_alloc
191
192 Allocates a new Perl interpreter.  See L<perlembed>.
193
194 =cut
195 */
196
197 PerlInterpreter *
198 perl_alloc(void)
199 {
200     PerlInterpreter *my_perl;
201
202     /* Newx() needs interpreter, so call malloc() instead */
203     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
204
205     S_init_tls_and_interp(my_perl);
206 #ifndef PERL_TRACK_MEMPOOL
207     return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
208 #else
209     Zero(my_perl, 1, PerlInterpreter);
210     INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
211     return my_perl;
212 #endif
213 }
214 #endif /* PERL_IMPLICIT_SYS */
215
216 /*
217 =for apidoc perl_construct
218
219 Initializes a new Perl interpreter.  See L<perlembed>.
220
221 =cut
222 */
223
224 void
225 perl_construct(pTHXx)
226 {
227     dVAR;
228
229     PERL_ARGS_ASSERT_PERL_CONSTRUCT;
230
231 #ifdef MULTIPLICITY
232     init_interp();
233     PL_perl_destruct_level = 1;
234 #else
235     PERL_UNUSED_ARG(my_perl);
236    if (PL_perl_destruct_level > 0)
237        init_interp();
238 #endif
239     PL_curcop = &PL_compiling;  /* needed by ckWARN, right away */
240
241     init_constants();
242
243     SvREADONLY_on(&PL_sv_placeholder);
244     SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL;
245
246     PL_sighandlerp = (Sighandler_t) Perl_sighandler;
247 #ifdef PERL_USES_PL_PIDSTATUS
248     PL_pidstatus = newHV();
249 #endif
250
251     PL_rs = newSVpvs("\n");
252
253     init_stacks();
254
255     init_ids();
256
257     JMPENV_BOOTSTRAP;
258     STATUS_ALL_SUCCESS;
259
260     init_i18nl10n(1);
261     SET_NUMERIC_STANDARD();
262
263 #if defined(LOCAL_PATCH_COUNT)
264     PL_localpatches = local_patches;    /* For possible -v */
265 #endif
266
267 #ifdef HAVE_INTERP_INTERN
268     sys_intern_init();
269 #endif
270
271     PerlIO_init(aTHX);                  /* Hook to IO system */
272
273     PL_fdpid = newAV();                 /* for remembering popen pids by fd */
274     PL_modglobal = newHV();             /* pointers to per-interpreter module globals */
275     PL_errors = newSVpvs("");
276     sv_setpvs(PERL_DEBUG_PAD(0), "");   /* For regex debugging. */
277     sv_setpvs(PERL_DEBUG_PAD(1), "");   /* ext/re needs these */
278     sv_setpvs(PERL_DEBUG_PAD(2), "");   /* even without DEBUGGING. */
279 #ifdef USE_ITHREADS
280     /* First entry is a list of empty elements. It needs to be initialised
281        else all hell breaks loose in S_find_uninit_var().  */
282     Perl_av_create_and_push(aTHX_ &PL_regex_padav, newSVpvs(""));
283     PL_regex_pad = AvARRAY(PL_regex_padav);
284     Newxz(PL_stashpad, PL_stashpadmax, HV *);
285 #endif
286 #ifdef USE_REENTRANT_API
287     Perl_reentrant_init(aTHX);
288 #endif
289 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
290         /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
291          * This MUST be done before any hash stores or fetches take place.
292          * If you set PL_hash_seed (and presumably also PL_hash_seed_set)
293          * yourself, it is your responsibility to provide a good random seed!
294          * You can also define PERL_HASH_SEED in compile time, see hv.h.
295          *
296          * XXX: fix this comment */
297     if (PL_hash_seed_set == FALSE) {
298         Perl_get_hash_seed(aTHX_ PL_hash_seed);
299         PL_hash_seed_set= TRUE;
300     }
301 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
302
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() */
306     PL_strtab = newHV();
307
308     HvSHAREKEYS_off(PL_strtab);                 /* mandatory */
309     hv_ksplit(PL_strtab, 512);
310
311     Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
312
313 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
314     _dyld_lookup_and_bind
315         ("__environ", (unsigned long *) &environ_pointer, NULL);
316 #endif /* environ */
317
318 #ifndef PERL_MICRO
319 #   ifdef  USE_ENVIRON_ARRAY
320     PL_origenviron = environ;
321 #   endif
322 #endif
323
324     /* Use sysconf(_SC_CLK_TCK) if available, if not
325      * available or if the sysconf() fails, use the HZ.
326      * The HZ if not originally defined has been by now
327      * been defined as CLK_TCK, if available. */
328 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
329     PL_clocktick = sysconf(_SC_CLK_TCK);
330     if (PL_clocktick <= 0)
331 #endif
332          PL_clocktick = HZ;
333
334     PL_stashcache = newHV();
335
336     PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
337     PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING);
338
339 #ifdef HAS_MMAP
340     if (!PL_mmap_page_size) {
341 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
342       {
343         SETERRNO(0, SS_NORMAL);
344 #   ifdef _SC_PAGESIZE
345         PL_mmap_page_size = sysconf(_SC_PAGESIZE);
346 #   else
347         PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
348 #   endif
349         if ((long) PL_mmap_page_size < 0) {
350           if (errno) {
351             SV * const error = ERRSV;
352             SvUPGRADE(error, SVt_PV);
353             Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
354           }
355           else
356             Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
357         }
358       }
359 #else
360 #   ifdef HAS_GETPAGESIZE
361       PL_mmap_page_size = getpagesize();
362 #   else
363 #       if defined(I_SYS_PARAM) && defined(PAGESIZE)
364       PL_mmap_page_size = PAGESIZE;       /* compiletime, bad */
365 #       endif
366 #   endif
367 #endif
368       if (PL_mmap_page_size <= 0)
369         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
370                    (IV) PL_mmap_page_size);
371     }
372 #endif /* HAS_MMAP */
373
374 #if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
375     PL_timesbase.tms_utime  = 0;
376     PL_timesbase.tms_stime  = 0;
377     PL_timesbase.tms_cutime = 0;
378     PL_timesbase.tms_cstime = 0;
379 #endif
380
381     PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME));
382
383     PL_registered_mros = newHV();
384     /* Start with 1 bucket, for DFS.  It's unlikely we'll need more.  */
385     HvMAX(PL_registered_mros) = 0;
386
387     ENTER;
388 }
389
390 /*
391 =for apidoc nothreadhook
392
393 Stub that provides thread hook for perl_destruct when there are
394 no threads.
395
396 =cut
397 */
398
399 int
400 Perl_nothreadhook(pTHX)
401 {
402     PERL_UNUSED_CONTEXT;
403     return 0;
404 }
405
406 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
407 void
408 Perl_dump_sv_child(pTHX_ SV *sv)
409 {
410     ssize_t got;
411     const int sock = PL_dumper_fd;
412     const int debug_fd = PerlIO_fileno(Perl_debug_log);
413     union control_un control;
414     struct msghdr msg;
415     struct iovec vec[2];
416     struct cmsghdr *cmptr;
417     int returned_errno;
418     unsigned char buffer[256];
419
420     PERL_ARGS_ASSERT_DUMP_SV_CHILD;
421
422     if(sock == -1 || debug_fd == -1)
423         return;
424
425     PerlIO_flush(Perl_debug_log);
426
427     /* All these shenanigans are to pass a file descriptor over to our child for
428        it to dump out to.  We can't let it hold open the file descriptor when it
429        forks, as the file descriptor it will dump to can turn out to be one end
430        of pipe that some other process will wait on for EOF. (So as it would
431        be open, the wait would be forever.)  */
432
433     msg.msg_control = control.control;
434     msg.msg_controllen = sizeof(control.control);
435     /* We're a connected socket so we don't need a destination  */
436     msg.msg_name = NULL;
437     msg.msg_namelen = 0;
438     msg.msg_iov = vec;
439     msg.msg_iovlen = 1;
440
441     cmptr = CMSG_FIRSTHDR(&msg);
442     cmptr->cmsg_len = CMSG_LEN(sizeof(int));
443     cmptr->cmsg_level = SOL_SOCKET;
444     cmptr->cmsg_type = SCM_RIGHTS;
445     *((int *)CMSG_DATA(cmptr)) = 1;
446
447     vec[0].iov_base = (void*)&sv;
448     vec[0].iov_len = sizeof(sv);
449     got = sendmsg(sock, &msg, 0);
450
451     if(got < 0) {
452         perror("Debug leaking scalars parent sendmsg failed");
453         abort();
454     }
455     if(got < sizeof(sv)) {
456         perror("Debug leaking scalars parent short sendmsg");
457         abort();
458     }
459
460     /* Return protocol is
461        int:             errno value
462        unsigned char:   length of location string (0 for empty)
463        unsigned char*:  string (not terminated)
464     */
465     vec[0].iov_base = (void*)&returned_errno;
466     vec[0].iov_len = sizeof(returned_errno);
467     vec[1].iov_base = buffer;
468     vec[1].iov_len = 1;
469
470     got = readv(sock, vec, 2);
471
472     if(got < 0) {
473         perror("Debug leaking scalars parent read failed");
474         PerlIO_flush(PerlIO_stderr());
475         abort();
476     }
477     if(got < sizeof(returned_errno) + 1) {
478         perror("Debug leaking scalars parent short read");
479         PerlIO_flush(PerlIO_stderr());
480         abort();
481     }
482
483     if (*buffer) {
484         got = read(sock, buffer + 1, *buffer);
485         if(got < 0) {
486             perror("Debug leaking scalars parent read 2 failed");
487             PerlIO_flush(PerlIO_stderr());
488             abort();
489         }
490
491         if(got < *buffer) {
492             perror("Debug leaking scalars parent short read 2");
493             PerlIO_flush(PerlIO_stderr());
494             abort();
495         }
496     }
497
498     if (returned_errno || *buffer) {
499         Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
500                   " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
501                   returned_errno, strerror(returned_errno));
502     }
503 }
504 #endif
505
506 /*
507 =for apidoc perl_destruct
508
509 Shuts down a Perl interpreter.  See L<perlembed>.
510
511 =cut
512 */
513
514 int
515 perl_destruct(pTHXx)
516 {
517     dVAR;
518     VOL signed char destruct_level;  /* see possible values in intrpvar.h */
519     HV *hv;
520 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
521     pid_t child;
522 #endif
523     int i;
524
525     PERL_ARGS_ASSERT_PERL_DESTRUCT;
526 #ifndef MULTIPLICITY
527     PERL_UNUSED_ARG(my_perl);
528 #endif
529
530     assert(PL_scopestack_ix == 1);
531
532     /* wait for all pseudo-forked children to finish */
533     PERL_WAIT_FOR_CHILDREN;
534
535     destruct_level = PL_perl_destruct_level;
536 #if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL)
537     {
538         const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
539         if (s) {
540         const int i = atoi(s);
541 #ifdef DEBUGGING
542             if (destruct_level < i) destruct_level = i;
543 #endif
544 #ifdef PERL_TRACK_MEMPOOL
545         /* RT #114496, for perl_free */
546         PL_perl_destruct_level = i;
547 #endif
548         }
549     }
550 #endif
551
552     if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
553         dJMPENV;
554         int x = 0;
555
556         JMPENV_PUSH(x);
557         PERL_UNUSED_VAR(x);
558         if (PL_endav && !PL_minus_c) {
559             PERL_SET_PHASE(PERL_PHASE_END);
560             call_list(PL_scopestack_ix, PL_endav);
561         }
562         JMPENV_POP;
563     }
564     LEAVE;
565     FREETMPS;
566     assert(PL_scopestack_ix == 0);
567
568     /* Need to flush since END blocks can produce output */
569     my_fflush_all();
570
571     if (PL_threadhook(aTHX)) {
572         /* Threads hook has vetoed further cleanup */
573         PL_veto_cleanup = TRUE;
574         return STATUS_EXIT;
575     }
576
577 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
578     if (destruct_level != 0) {
579         /* Fork here to create a child. Our child's job is to preserve the
580            state of scalars prior to destruction, so that we can instruct it
581            to dump any scalars that we later find have leaked.
582            There's no subtlety in this code - it assumes POSIX, and it doesn't
583            fail gracefully  */
584         int fd[2];
585
586         if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
587             perror("Debug leaking scalars socketpair failed");
588             abort();
589         }
590
591         child = fork();
592         if(child == -1) {
593             perror("Debug leaking scalars fork failed");
594             abort();
595         }
596         if (!child) {
597             /* We are the child */
598             const int sock = fd[1];
599             const int debug_fd = PerlIO_fileno(Perl_debug_log);
600             int f;
601             const char *where;
602             /* Our success message is an integer 0, and a char 0  */
603             static const char success[sizeof(int) + 1] = {0};
604
605             close(fd[0]);
606
607             /* We need to close all other file descriptors otherwise we end up
608                with interesting hangs, where the parent closes its end of a
609                pipe, and sits waiting for (another) child to terminate. Only
610                that child never terminates, because it never gets EOF, because
611                we also have the far end of the pipe open.  We even need to
612                close the debugging fd, because sometimes it happens to be one
613                end of a pipe, and a process is waiting on the other end for
614                EOF. Normally it would be closed at some point earlier in
615                destruction, but if we happen to cause the pipe to remain open,
616                EOF never occurs, and we get an infinite hang. Hence all the
617                games to pass in a file descriptor if it's actually needed.  */
618
619             f = sysconf(_SC_OPEN_MAX);
620             if(f < 0) {
621                 where = "sysconf failed";
622                 goto abort;
623             }
624             while (f--) {
625                 if (f == sock)
626                     continue;
627                 close(f);
628             }
629
630             while (1) {
631                 SV *target;
632                 union control_un control;
633                 struct msghdr msg;
634                 struct iovec vec[1];
635                 struct cmsghdr *cmptr;
636                 ssize_t got;
637                 int got_fd;
638
639                 msg.msg_control = control.control;
640                 msg.msg_controllen = sizeof(control.control);
641                 /* We're a connected socket so we don't need a source  */
642                 msg.msg_name = NULL;
643                 msg.msg_namelen = 0;
644                 msg.msg_iov = vec;
645                 msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
646
647                 vec[0].iov_base = (void*)&target;
648                 vec[0].iov_len = sizeof(target);
649       
650                 got = recvmsg(sock, &msg, 0);
651
652                 if(got == 0)
653                     break;
654                 if(got < 0) {
655                     where = "recv failed";
656                     goto abort;
657                 }
658                 if(got < sizeof(target)) {
659                     where = "short recv";
660                     goto abort;
661                 }
662
663                 if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
664                     where = "no cmsg";
665                     goto abort;
666                 }
667                 if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
668                     where = "wrong cmsg_len";
669                     goto abort;
670                 }
671                 if(cmptr->cmsg_level != SOL_SOCKET) {
672                     where = "wrong cmsg_level";
673                     goto abort;
674                 }
675                 if(cmptr->cmsg_type != SCM_RIGHTS) {
676                     where = "wrong cmsg_type";
677                     goto abort;
678                 }
679
680                 got_fd = *(int*)CMSG_DATA(cmptr);
681                 /* For our last little bit of trickery, put the file descriptor
682                    back into Perl_debug_log, as if we never actually closed it
683                 */
684                 if(got_fd != debug_fd) {
685                     if (dup2(got_fd, debug_fd) == -1) {
686                         where = "dup2";
687                         goto abort;
688                     }
689                 }
690                 sv_dump(target);
691
692                 PerlIO_flush(Perl_debug_log);
693
694                 got = write(sock, &success, sizeof(success));
695
696                 if(got < 0) {
697                     where = "write failed";
698                     goto abort;
699                 }
700                 if(got < sizeof(success)) {
701                     where = "short write";
702                     goto abort;
703                 }
704             }
705             _exit(0);
706         abort:
707             {
708                 int send_errno = errno;
709                 unsigned char length = (unsigned char) strlen(where);
710                 struct iovec failure[3] = {
711                     {(void*)&send_errno, sizeof(send_errno)},
712                     {&length, 1},
713                     {(void*)where, length}
714                 };
715                 int got = writev(sock, failure, 3);
716                 /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
717                    in the parent if we try to read from the socketpair after the
718                    child has exited, even if there was data to read.
719                    So sleep a bit to give the parent a fighting chance of
720                    reading the data.  */
721                 sleep(2);
722                 _exit((got == -1) ? errno : 0);
723             }
724             /* End of child.  */
725         }
726         PL_dumper_fd = fd[0];
727         close(fd[1]);
728     }
729 #endif
730     
731     /* We must account for everything.  */
732
733     /* Destroy the main CV and syntax tree */
734     /* Set PL_curcop now, because destroying ops can cause new SVs
735        to be generated in Perl_pad_swipe, and when running with
736       -DDEBUG_LEAKING_SCALARS they expect PL_curcop to point to a valid
737        op from which the filename structure member is copied.  */
738     PL_curcop = &PL_compiling;
739     if (PL_main_root) {
740         /* ensure comppad/curpad to refer to main's pad */
741         if (CvPADLIST(PL_main_cv)) {
742             PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
743         }
744         op_free(PL_main_root);
745         PL_main_root = NULL;
746     }
747     PL_main_start = NULL;
748     /* note that  PL_main_cv isn't usually actually freed at this point,
749      * due to the CvOUTSIDE refs from subs compiled within it. It will
750      * get freed once all the subs are freed in sv_clean_all(), for
751      * destruct_level > 0 */
752     SvREFCNT_dec(PL_main_cv);
753     PL_main_cv = NULL;
754     PERL_SET_PHASE(PERL_PHASE_DESTRUCT);
755
756     /* Tell PerlIO we are about to tear things apart in case
757        we have layers which are using resources that should
758        be cleaned up now.
759      */
760
761     PerlIO_destruct(aTHX);
762
763     /*
764      * Try to destruct global references.  We do this first so that the
765      * destructors and destructees still exist.  Some sv's might remain.
766      * Non-referenced objects are on their own.
767      */
768     sv_clean_objs();
769
770     /* unhook hooks which will soon be, or use, destroyed data */
771     SvREFCNT_dec(PL_warnhook);
772     PL_warnhook = NULL;
773     SvREFCNT_dec(PL_diehook);
774     PL_diehook = NULL;
775
776     /* call exit list functions */
777     while (PL_exitlistlen-- > 0)
778         PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
779
780     Safefree(PL_exitlist);
781
782     PL_exitlist = NULL;
783     PL_exitlistlen = 0;
784
785     SvREFCNT_dec(PL_registered_mros);
786
787     /* jettison our possibly duplicated environment */
788     /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
789      * so we certainly shouldn't free it here
790      */
791 #ifndef PERL_MICRO
792 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
793     if (environ != PL_origenviron && !PL_use_safe_putenv
794 #ifdef USE_ITHREADS
795         /* only main thread can free environ[0] contents */
796         && PL_curinterp == aTHX
797 #endif
798         )
799     {
800         I32 i;
801
802         for (i = 0; environ[i]; i++)
803             safesysfree(environ[i]);
804
805         /* Must use safesysfree() when working with environ. */
806         safesysfree(environ);           
807
808         environ = PL_origenviron;
809     }
810 #endif
811 #endif /* !PERL_MICRO */
812
813     if (destruct_level == 0) {
814
815         DEBUG_P(debprofdump());
816
817 #if defined(PERLIO_LAYERS)
818         /* No more IO - including error messages ! */
819         PerlIO_cleanup(aTHX);
820 #endif
821
822         CopFILE_free(&PL_compiling);
823
824         /* The exit() function will do everything that needs doing. */
825         return STATUS_EXIT;
826     }
827
828 #ifdef USE_ITHREADS
829     /* the syntax tree is shared between clones
830      * so op_free(PL_main_root) only ReREFCNT_dec's
831      * REGEXPs in the parent interpreter
832      * we need to manually ReREFCNT_dec for the clones
833      */
834     {
835         I32 i = AvFILLp(PL_regex_padav);
836         SV **ary = AvARRAY(PL_regex_padav);
837
838         for (; i; i--) {
839             SvREFCNT_dec(ary[i]);
840             ary[i] = &PL_sv_undef;
841         }
842     }
843 #endif
844
845
846     SvREFCNT_dec(MUTABLE_SV(PL_stashcache));
847     PL_stashcache = NULL;
848
849     /* loosen bonds of global variables */
850
851     /* XXX can PL_parser still be non-null here? */
852     if(PL_parser && PL_parser->rsfp) {
853         (void)PerlIO_close(PL_parser->rsfp);
854         PL_parser->rsfp = NULL;
855     }
856
857     if (PL_minus_F) {
858         Safefree(PL_splitstr);
859         PL_splitstr = NULL;
860     }
861
862     /* switches */
863     PL_minus_n      = FALSE;
864     PL_minus_p      = FALSE;
865     PL_minus_l      = FALSE;
866     PL_minus_a      = FALSE;
867     PL_minus_F      = FALSE;
868     PL_doswitches   = FALSE;
869     PL_dowarn       = G_WARN_OFF;
870 #ifdef PERL_SAWAMPERSAND
871     PL_sawampersand = 0;        /* must save all match strings */
872 #endif
873     PL_unsafe       = FALSE;
874
875     Safefree(PL_inplace);
876     PL_inplace = NULL;
877     SvREFCNT_dec(PL_patchlevel);
878     SvREFCNT_dec(PL_apiversion);
879
880     if (PL_e_script) {
881         SvREFCNT_dec(PL_e_script);
882         PL_e_script = NULL;
883     }
884
885     PL_perldb = 0;
886
887     /* magical thingies */
888
889     SvREFCNT_dec(PL_ofsgv);     /* *, */
890     PL_ofsgv = NULL;
891
892     SvREFCNT_dec(PL_ors_sv);    /* $\ */
893     PL_ors_sv = NULL;
894
895     SvREFCNT_dec(PL_rs);        /* $/ */
896     PL_rs = NULL;
897
898     Safefree(PL_osname);        /* $^O */
899     PL_osname = NULL;
900
901     SvREFCNT_dec(PL_statname);
902     PL_statname = NULL;
903     PL_statgv = NULL;
904
905     /* defgv, aka *_ should be taken care of elsewhere */
906
907     /* float buffer */
908     Safefree(PL_efloatbuf);
909     PL_efloatbuf = NULL;
910     PL_efloatsize = 0;
911
912     /* startup and shutdown function lists */
913     SvREFCNT_dec(PL_beginav);
914     SvREFCNT_dec(PL_beginav_save);
915     SvREFCNT_dec(PL_endav);
916     SvREFCNT_dec(PL_checkav);
917     SvREFCNT_dec(PL_checkav_save);
918     SvREFCNT_dec(PL_unitcheckav);
919     SvREFCNT_dec(PL_unitcheckav_save);
920     SvREFCNT_dec(PL_initav);
921     PL_beginav = NULL;
922     PL_beginav_save = NULL;
923     PL_endav = NULL;
924     PL_checkav = NULL;
925     PL_checkav_save = NULL;
926     PL_unitcheckav = NULL;
927     PL_unitcheckav_save = NULL;
928     PL_initav = NULL;
929
930     /* shortcuts just get cleared */
931     PL_envgv = NULL;
932     PL_incgv = NULL;
933     PL_hintgv = NULL;
934     PL_errgv = NULL;
935     PL_argvgv = NULL;
936     PL_argvoutgv = NULL;
937     PL_stdingv = NULL;
938     PL_stderrgv = NULL;
939     PL_last_in_gv = NULL;
940     PL_replgv = NULL;
941     PL_DBgv = NULL;
942     PL_DBline = NULL;
943     PL_DBsub = NULL;
944     PL_DBsingle = NULL;
945     PL_DBtrace = NULL;
946     PL_DBsignal = NULL;
947     PL_DBcv = NULL;
948     PL_dbargs = NULL;
949     PL_debstash = NULL;
950
951     SvREFCNT_dec(PL_argvout_stack);
952     PL_argvout_stack = NULL;
953
954     SvREFCNT_dec(PL_modglobal);
955     PL_modglobal = NULL;
956     SvREFCNT_dec(PL_preambleav);
957     PL_preambleav = NULL;
958     SvREFCNT_dec(PL_subname);
959     PL_subname = NULL;
960 #ifdef PERL_USES_PL_PIDSTATUS
961     SvREFCNT_dec(PL_pidstatus);
962     PL_pidstatus = NULL;
963 #endif
964     SvREFCNT_dec(PL_toptarget);
965     PL_toptarget = NULL;
966     SvREFCNT_dec(PL_bodytarget);
967     PL_bodytarget = NULL;
968     PL_formtarget = NULL;
969
970     /* free locale stuff */
971 #ifdef USE_LOCALE_COLLATE
972     Safefree(PL_collation_name);
973     PL_collation_name = NULL;
974 #endif
975
976 #ifdef USE_LOCALE_NUMERIC
977     Safefree(PL_numeric_name);
978     PL_numeric_name = NULL;
979     SvREFCNT_dec(PL_numeric_radix_sv);
980     PL_numeric_radix_sv = NULL;
981 #endif
982
983     /* clear character classes  */
984     for (i = 0; i < POSIX_SWASH_COUNT; i++) {
985         SvREFCNT_dec(PL_utf8_swash_ptrs[i]);
986         PL_utf8_swash_ptrs[i] = NULL;
987     }
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     SvREFCNT_dec(PL_utf8_foldclosures);
996     PL_utf8_mark        = NULL;
997     PL_utf8_toupper     = NULL;
998     PL_utf8_totitle     = NULL;
999     PL_utf8_tolower     = NULL;
1000     PL_utf8_tofold      = NULL;
1001     PL_utf8_idstart     = NULL;
1002     PL_utf8_idcont      = NULL;
1003     PL_utf8_foldclosures = NULL;
1004     for (i = 0; i < POSIX_CC_COUNT; i++) {
1005         SvREFCNT_dec(PL_Posix_ptrs[i]);
1006         PL_Posix_ptrs[i] = NULL;
1007
1008         SvREFCNT_dec(PL_L1Posix_ptrs[i]);
1009         PL_L1Posix_ptrs[i] = NULL;
1010
1011         SvREFCNT_dec(PL_XPosix_ptrs[i]);
1012         PL_XPosix_ptrs[i] = NULL;
1013     }
1014
1015     if (!specialWARN(PL_compiling.cop_warnings))
1016         PerlMemShared_free(PL_compiling.cop_warnings);
1017     PL_compiling.cop_warnings = NULL;
1018     cophh_free(CopHINTHASH_get(&PL_compiling));
1019     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
1020     CopFILE_free(&PL_compiling);
1021
1022     /* Prepare to destruct main symbol table.  */
1023
1024     hv = PL_defstash;
1025     /* break ref loop  *:: <=> %:: */
1026     (void)hv_delete(hv, "main::", 6, G_DISCARD);
1027     PL_defstash = 0;
1028     SvREFCNT_dec(hv);
1029     SvREFCNT_dec(PL_curstname);
1030     PL_curstname = NULL;
1031
1032     /* clear queued errors */
1033     SvREFCNT_dec(PL_errors);
1034     PL_errors = NULL;
1035
1036     SvREFCNT_dec(PL_isarev);
1037
1038     FREETMPS;
1039     if (destruct_level >= 2) {
1040         if (PL_scopestack_ix != 0)
1041             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1042                              "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
1043                              (long)PL_scopestack_ix);
1044         if (PL_savestack_ix != 0)
1045             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1046                              "Unbalanced saves: %ld more saves than restores\n",
1047                              (long)PL_savestack_ix);
1048         if (PL_tmps_floor != -1)
1049             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
1050                              (long)PL_tmps_floor + 1);
1051         if (cxstack_ix != -1)
1052             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
1053                              (long)cxstack_ix + 1);
1054     }
1055
1056 #ifdef USE_ITHREADS
1057     SvREFCNT_dec(PL_regex_padav);
1058     PL_regex_padav = NULL;
1059     PL_regex_pad = NULL;
1060 #endif
1061
1062 #ifdef PERL_IMPLICIT_CONTEXT
1063     /* the entries in this list are allocated via SV PVX's, so get freed
1064      * in sv_clean_all */
1065     Safefree(PL_my_cxt_list);
1066 #endif
1067
1068     /* Now absolutely destruct everything, somehow or other, loops or no. */
1069
1070     /* the 2 is for PL_fdpid and PL_strtab */
1071     while (sv_clean_all() > 2)
1072         ;
1073
1074 #ifdef USE_ITHREADS
1075     Safefree(PL_stashpad); /* must come after sv_clean_all */
1076 #endif
1077
1078     AvREAL_off(PL_fdpid);               /* no surviving entries */
1079     SvREFCNT_dec(PL_fdpid);             /* needed in io_close() */
1080     PL_fdpid = NULL;
1081
1082 #ifdef HAVE_INTERP_INTERN
1083     sys_intern_clear();
1084 #endif
1085
1086     /* constant strings */
1087     for (i = 0; i < SV_CONSTS_COUNT; i++) {
1088         SvREFCNT_dec(PL_sv_consts[i]);
1089         PL_sv_consts[i] = NULL;
1090     }
1091
1092     /* Destruct the global string table. */
1093     {
1094         /* Yell and reset the HeVAL() slots that are still holding refcounts,
1095          * so that sv_free() won't fail on them.
1096          * Now that the global string table is using a single hunk of memory
1097          * for both HE and HEK, we either need to explicitly unshare it the
1098          * correct way, or actually free things here.
1099          */
1100         I32 riter = 0;
1101         const I32 max = HvMAX(PL_strtab);
1102         HE * const * const array = HvARRAY(PL_strtab);
1103         HE *hent = array[0];
1104
1105         for (;;) {
1106             if (hent && ckWARN_d(WARN_INTERNAL)) {
1107                 HE * const next = HeNEXT(hent);
1108                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1109                      "Unbalanced string table refcount: (%ld) for \"%s\"",
1110                      (long)hent->he_valu.hent_refcount, HeKEY(hent));
1111                 Safefree(hent);
1112                 hent = next;
1113             }
1114             if (!hent) {
1115                 if (++riter > max)
1116                     break;
1117                 hent = array[riter];
1118             }
1119         }
1120
1121         Safefree(array);
1122         HvARRAY(PL_strtab) = 0;
1123         HvTOTALKEYS(PL_strtab) = 0;
1124     }
1125     SvREFCNT_dec(PL_strtab);
1126
1127 #ifdef USE_ITHREADS
1128     /* free the pointer tables used for cloning */
1129     ptr_table_free(PL_ptr_table);
1130     PL_ptr_table = (PTR_TBL_t*)NULL;
1131 #endif
1132
1133     /* free special SVs */
1134
1135     SvREFCNT(&PL_sv_yes) = 0;
1136     sv_clear(&PL_sv_yes);
1137     SvANY(&PL_sv_yes) = NULL;
1138     SvFLAGS(&PL_sv_yes) = 0;
1139
1140     SvREFCNT(&PL_sv_no) = 0;
1141     sv_clear(&PL_sv_no);
1142     SvANY(&PL_sv_no) = NULL;
1143     SvFLAGS(&PL_sv_no) = 0;
1144
1145     {
1146         int i;
1147         for (i=0; i<=2; i++) {
1148             SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
1149             sv_clear(PERL_DEBUG_PAD(i));
1150             SvANY(PERL_DEBUG_PAD(i)) = NULL;
1151             SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
1152         }
1153     }
1154
1155     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
1156         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
1157
1158 #ifdef DEBUG_LEAKING_SCALARS
1159     if (PL_sv_count != 0) {
1160         SV* sva;
1161         SV* sv;
1162         SV* svend;
1163
1164         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
1165             svend = &sva[SvREFCNT(sva)];
1166             for (sv = sva + 1; sv < svend; ++sv) {
1167                 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
1168                     PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
1169                         " flags=0x%"UVxf
1170                         " refcnt=%"UVuf pTHX__FORMAT "\n"
1171                         "\tallocated at %s:%d %s %s (parent 0x%"UVxf");"
1172                         "serial %"UVuf"\n",
1173                         (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt
1174                         pTHX__VALUE,
1175                         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1176                         sv->sv_debug_line,
1177                         sv->sv_debug_inpad ? "for" : "by",
1178                         sv->sv_debug_optype ?
1179                             PL_op_name[sv->sv_debug_optype]: "(none)",
1180                         PTR2UV(sv->sv_debug_parent),
1181                         sv->sv_debug_serial
1182                     );
1183 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1184                     Perl_dump_sv_child(aTHX_ sv);
1185 #endif
1186                 }
1187             }
1188         }
1189     }
1190 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
1191     {
1192         int status;
1193         fd_set rset;
1194         /* Wait for up to 4 seconds for child to terminate.
1195            This seems to be the least effort way of timing out on reaping
1196            its exit status.  */
1197         struct timeval waitfor = {4, 0};
1198         int sock = PL_dumper_fd;
1199
1200         shutdown(sock, 1);
1201         FD_ZERO(&rset);
1202         FD_SET(sock, &rset);
1203         select(sock + 1, &rset, NULL, NULL, &waitfor);
1204         waitpid(child, &status, WNOHANG);
1205         close(sock);
1206     }
1207 #endif
1208 #endif
1209 #ifdef DEBUG_LEAKING_SCALARS_ABORT
1210     if (PL_sv_count)
1211         abort();
1212 #endif
1213     PL_sv_count = 0;
1214
1215 #if defined(PERLIO_LAYERS)
1216     /* No more IO - including error messages ! */
1217     PerlIO_cleanup(aTHX);
1218 #endif
1219
1220     /* sv_undef needs to stay immortal until after PerlIO_cleanup
1221        as currently layers use it rather than NULL as a marker
1222        for no arg - and will try and SvREFCNT_dec it.
1223      */
1224     SvREFCNT(&PL_sv_undef) = 0;
1225     SvREADONLY_off(&PL_sv_undef);
1226
1227     Safefree(PL_origfilename);
1228     PL_origfilename = NULL;
1229     Safefree(PL_reg_curpm);
1230     free_tied_hv_pool();
1231     Safefree(PL_op_mask);
1232     Safefree(PL_psig_name);
1233     PL_psig_name = (SV**)NULL;
1234     PL_psig_ptr = (SV**)NULL;
1235     {
1236         /* We need to NULL PL_psig_pend first, so that
1237            signal handlers know not to use it */
1238         int *psig_save = PL_psig_pend;
1239         PL_psig_pend = (int*)NULL;
1240         Safefree(psig_save);
1241     }
1242     nuke_stacks();
1243     TAINTING_set(FALSE);
1244     TAINT_WARN_set(FALSE);
1245     PL_hints = 0;               /* Reset hints. Should hints be per-interpreter ? */
1246     PL_debug = 0;
1247
1248     DEBUG_P(debprofdump());
1249
1250 #ifdef USE_REENTRANT_API
1251     Perl_reentrant_free(aTHX);
1252 #endif
1253
1254     sv_free_arenas();
1255
1256     while (PL_regmatch_slab) {
1257         regmatch_slab  *s = PL_regmatch_slab;
1258         PL_regmatch_slab = PL_regmatch_slab->next;
1259         Safefree(s);
1260     }
1261
1262     /* As the absolutely last thing, free the non-arena SV for mess() */
1263
1264     if (PL_mess_sv) {
1265         /* we know that type == SVt_PVMG */
1266
1267         /* it could have accumulated taint magic */
1268         MAGIC* mg;
1269         MAGIC* moremagic;
1270         for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
1271             moremagic = mg->mg_moremagic;
1272             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
1273                 && mg->mg_len >= 0)
1274                 Safefree(mg->mg_ptr);
1275             Safefree(mg);
1276         }
1277
1278         /* we know that type >= SVt_PV */
1279         SvPV_free(PL_mess_sv);
1280         Safefree(SvANY(PL_mess_sv));
1281         Safefree(PL_mess_sv);
1282         PL_mess_sv = NULL;
1283     }
1284     return STATUS_EXIT;
1285 }
1286
1287 /*
1288 =for apidoc perl_free
1289
1290 Releases a Perl interpreter.  See L<perlembed>.
1291
1292 =cut
1293 */
1294
1295 void
1296 perl_free(pTHXx)
1297 {
1298     dVAR;
1299
1300     PERL_ARGS_ASSERT_PERL_FREE;
1301
1302     if (PL_veto_cleanup)
1303         return;
1304
1305 #ifdef PERL_TRACK_MEMPOOL
1306     {
1307         /*
1308          * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero
1309          * value as we're probably hunting memory leaks then
1310          */
1311         if (PL_perl_destruct_level == 0) {
1312             const U32 old_debug = PL_debug;
1313             /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
1314                thread at thread exit.  */
1315             if (DEBUG_m_TEST) {
1316                 PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
1317                             "free this thread's memory\n");
1318                 PL_debug &= ~ DEBUG_m_FLAG;
1319             }
1320             while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
1321                 safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
1322             PL_debug = old_debug;
1323         }
1324     }
1325 #endif
1326
1327 #if defined(WIN32) || defined(NETWARE)
1328 #  if defined(PERL_IMPLICIT_SYS)
1329     {
1330 #    ifdef NETWARE
1331         void *host = nw_internal_host;
1332 #    else
1333         void *host = w32_internal_host;
1334 #    endif
1335         PerlMem_free(aTHXx);
1336 #    ifdef NETWARE
1337         nw_delete_internal_host(host);
1338 #    else
1339         win32_delete_internal_host(host);
1340 #    endif
1341     }
1342 #  else
1343     PerlMem_free(aTHXx);
1344 #  endif
1345 #else
1346     PerlMem_free(aTHXx);
1347 #endif
1348 }
1349
1350 #if defined(USE_ITHREADS)
1351 /* provide destructors to clean up the thread key when libperl is unloaded */
1352 #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
1353
1354 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
1355 #pragma fini "perl_fini"
1356 #elif defined(__sun) && !defined(__GNUC__)
1357 #pragma fini (perl_fini)
1358 #endif
1359
1360 static void
1361 #if defined(__GNUC__)
1362 __attribute__((destructor))
1363 #endif
1364 perl_fini(void)
1365 {
1366     dVAR;
1367     if (PL_curinterp  && !PL_veto_cleanup)
1368         FREE_THREAD_KEY;
1369 }
1370
1371 #endif /* WIN32 */
1372 #endif /* THREADS */
1373
1374 void
1375 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
1376 {
1377     dVAR;
1378     Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
1379     PL_exitlist[PL_exitlistlen].fn = fn;
1380     PL_exitlist[PL_exitlistlen].ptr = ptr;
1381     ++PL_exitlistlen;
1382 }
1383
1384 STATIC void
1385 S_set_caret_X(pTHX) {
1386     dVAR;
1387     GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
1388     if (tmpgv) {
1389         SV *const caret_x = GvSV(tmpgv);
1390 #if defined(OS2)
1391         sv_setpv(caret_x, os2_execname(aTHX));
1392 #else
1393 #  ifdef USE_KERN_PROC_PATHNAME
1394         size_t size = 0;
1395         int mib[4];
1396         mib[0] = CTL_KERN;
1397         mib[1] = KERN_PROC;
1398         mib[2] = KERN_PROC_PATHNAME;
1399         mib[3] = -1;
1400
1401         if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
1402             && size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
1403             sv_grow(caret_x, size);
1404
1405             if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
1406                 && size > 2) {
1407                 SvPOK_only(caret_x);
1408                 SvCUR_set(caret_x, size - 1);
1409                 SvTAINT(caret_x);
1410                 return;
1411             }
1412         }
1413 #  elif defined(USE_NSGETEXECUTABLEPATH)
1414         char buf[1];
1415         uint32_t size = sizeof(buf);
1416
1417         _NSGetExecutablePath(buf, &size);
1418         if (size < MAXPATHLEN * MAXPATHLEN) {
1419             sv_grow(caret_x, size);
1420             if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
1421                 char *const tidied = realpath(SvPVX(caret_x), NULL);
1422                 if (tidied) {
1423                     sv_setpv(caret_x, tidied);
1424                     free(tidied);
1425                 } else {
1426                     SvPOK_only(caret_x);
1427                     SvCUR_set(caret_x, size);
1428                 }
1429                 return;
1430             }
1431         }
1432 #  elif defined(HAS_PROCSELFEXE)
1433         char buf[MAXPATHLEN];
1434         int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
1435
1436         /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
1437            includes a spurious NUL which will cause $^X to fail in system
1438            or backticks (this will prevent extensions from being built and
1439            many tests from working). readlink is not meant to add a NUL.
1440            Normal readlink works fine.
1441         */
1442         if (len > 0 && buf[len-1] == '\0') {
1443             len--;
1444         }
1445
1446         /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1447            returning the text "unknown" from the readlink rather than the path
1448            to the executable (or returning an error from the readlink). Any
1449            valid path has a '/' in it somewhere, so use that to validate the
1450            result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1451         */
1452         if (len > 0 && memchr(buf, '/', len)) {
1453             sv_setpvn(caret_x, buf, len);
1454             return;
1455         }
1456 #  endif
1457         /* Fallback to this:  */
1458         sv_setpv(caret_x, PL_origargv[0]);
1459 #endif
1460     }
1461 }
1462
1463 /*
1464 =for apidoc perl_parse
1465
1466 Tells a Perl interpreter to parse a Perl script.  See L<perlembed>.
1467
1468 =cut
1469 */
1470
1471 #define SET_CURSTASH(newstash)                       \
1472         if (PL_curstash != newstash) {                \
1473             SvREFCNT_dec(PL_curstash);                 \
1474             PL_curstash = (HV *)SvREFCNT_inc(newstash); \
1475         }
1476
1477 int
1478 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
1479 {
1480     dVAR;
1481     I32 oldscope;
1482     int ret;
1483     dJMPENV;
1484
1485     PERL_ARGS_ASSERT_PERL_PARSE;
1486 #ifndef MULTIPLICITY
1487     PERL_UNUSED_ARG(my_perl);
1488 #endif
1489 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) || defined(USE_HASH_SEED_DEBUG)
1490     {
1491         const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1492
1493         if (s && (atoi(s) == 1)) {
1494             unsigned char *seed= PERL_HASH_SEED;
1495             unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
1496             PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
1497             while (seed < seed_end) {
1498                 PerlIO_printf(Perl_debug_log, "%02x", *seed++);
1499             }
1500 #ifdef PERL_HASH_RANDOMIZE_KEYS
1501             PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
1502                     PL_HASH_RAND_BITS_ENABLED,
1503                     PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC");
1504 #endif
1505             PerlIO_printf(Perl_debug_log, "\n");
1506         }
1507     }
1508 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1509     PL_origargc = argc;
1510     PL_origargv = argv;
1511
1512     if (PL_origalen != 0) {
1513         PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */
1514     }
1515     else {
1516         /* Set PL_origalen be the sum of the contiguous argv[]
1517          * elements plus the size of the env in case that it is
1518          * contiguous with the argv[].  This is used in mg.c:Perl_magic_set()
1519          * as the maximum modifiable length of $0.  In the worst case
1520          * the area we are able to modify is limited to the size of
1521          * the original argv[0].  (See below for 'contiguous', though.)
1522          * --jhi */
1523          const char *s = NULL;
1524          int i;
1525          const UV mask =
1526            ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
1527          /* Do the mask check only if the args seem like aligned. */
1528          const UV aligned =
1529            (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1530
1531          /* See if all the arguments are contiguous in memory.  Note
1532           * that 'contiguous' is a loose term because some platforms
1533           * align the argv[] and the envp[].  If the arguments look
1534           * like non-aligned, assume that they are 'strictly' or
1535           * 'traditionally' contiguous.  If the arguments look like
1536           * aligned, we just check that they are within aligned
1537           * PTRSIZE bytes.  As long as no system has something bizarre
1538           * like the argv[] interleaved with some other data, we are
1539           * fine.  (Did I just evoke Murphy's Law?)  --jhi */
1540          if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1541               while (*s) s++;
1542               for (i = 1; i < PL_origargc; i++) {
1543                    if ((PL_origargv[i] == s + 1
1544 #ifdef OS2
1545                         || PL_origargv[i] == s + 2
1546 #endif 
1547                             )
1548                        ||
1549                        (aligned &&
1550                         (PL_origargv[i] >  s &&
1551                          PL_origargv[i] <=
1552                          INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1553                         )
1554                    {
1555                         s = PL_origargv[i];
1556                         while (*s) s++;
1557                    }
1558                    else
1559                         break;
1560               }
1561          }
1562
1563 #ifndef PERL_USE_SAFE_PUTENV
1564          /* Can we grab env area too to be used as the area for $0? */
1565          if (s && PL_origenviron && !PL_use_safe_putenv) {
1566               if ((PL_origenviron[0] == s + 1)
1567                   ||
1568                   (aligned &&
1569                    (PL_origenviron[0] >  s &&
1570                     PL_origenviron[0] <=
1571                     INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1572                  )
1573               {
1574 #ifndef OS2             /* ENVIRON is read by the kernel too. */
1575                    s = PL_origenviron[0];
1576                    while (*s) s++;
1577 #endif
1578                    my_setenv("NoNe  SuCh", NULL);
1579                    /* Force copy of environment. */
1580                    for (i = 1; PL_origenviron[i]; i++) {
1581                         if (PL_origenviron[i] == s + 1
1582                             ||
1583                             (aligned &&
1584                              (PL_origenviron[i] >  s &&
1585                               PL_origenviron[i] <=
1586                               INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1587                            )
1588                         {
1589                              s = PL_origenviron[i];
1590                              while (*s) s++;
1591                         }
1592                         else
1593                              break;
1594                    }
1595               }
1596          }
1597 #endif /* !defined(PERL_USE_SAFE_PUTENV) */
1598
1599          PL_origalen = s ? s - PL_origargv[0] + 1 : 0;
1600     }
1601
1602     if (PL_do_undump) {
1603
1604         /* Come here if running an undumped a.out. */
1605
1606         PL_origfilename = savepv(argv[0]);
1607         PL_do_undump = FALSE;
1608         cxstack_ix = -1;                /* start label stack again */
1609         init_ids();
1610         assert (!TAINT_get);
1611         TAINT;
1612         S_set_caret_X(aTHX);
1613         TAINT_NOT;
1614         init_postdump_symbols(argc,argv,env);
1615         return 0;
1616     }
1617
1618     if (PL_main_root) {
1619         op_free(PL_main_root);
1620         PL_main_root = NULL;
1621     }
1622     PL_main_start = NULL;
1623     SvREFCNT_dec(PL_main_cv);
1624     PL_main_cv = NULL;
1625
1626     time(&PL_basetime);
1627     oldscope = PL_scopestack_ix;
1628     PL_dowarn = G_WARN_OFF;
1629
1630     JMPENV_PUSH(ret);
1631     switch (ret) {
1632     case 0:
1633         parse_body(env,xsinit);
1634         if (PL_unitcheckav) {
1635             call_list(oldscope, PL_unitcheckav);
1636         }
1637         if (PL_checkav) {
1638             PERL_SET_PHASE(PERL_PHASE_CHECK);
1639             call_list(oldscope, PL_checkav);
1640         }
1641         ret = 0;
1642         break;
1643     case 1:
1644         STATUS_ALL_FAILURE;
1645         /* FALL THROUGH */
1646     case 2:
1647         /* my_exit() was called */
1648         while (PL_scopestack_ix > oldscope)
1649             LEAVE;
1650         FREETMPS;
1651         SET_CURSTASH(PL_defstash);
1652         if (PL_unitcheckav) {
1653             call_list(oldscope, PL_unitcheckav);
1654         }
1655         if (PL_checkav) {
1656             PERL_SET_PHASE(PERL_PHASE_CHECK);
1657             call_list(oldscope, PL_checkav);
1658         }
1659         ret = STATUS_EXIT;
1660         break;
1661     case 3:
1662         PerlIO_printf(Perl_error_log, "panic: top_env\n");
1663         ret = 1;
1664         break;
1665     }
1666     JMPENV_POP;
1667     return ret;
1668 }
1669
1670 /* This needs to stay in perl.c, as perl.c is compiled with different flags for
1671    miniperl, and we need to see those flags reflected in the values here.  */
1672
1673 /* What this returns is subject to change.  Use the public interface in Config.
1674  */
1675 static void
1676 S_Internals_V(pTHX_ CV *cv)
1677 {
1678     dXSARGS;
1679 #ifdef LOCAL_PATCH_COUNT
1680     const int local_patch_count = LOCAL_PATCH_COUNT;
1681 #else
1682     const int local_patch_count = 0;
1683 #endif
1684     const int entries = 3 + local_patch_count;
1685     int i;
1686     static const char non_bincompat_options[] = 
1687 #  ifdef DEBUGGING
1688                              " DEBUGGING"
1689 #  endif
1690 #  ifdef NO_MATHOMS
1691                              " NO_MATHOMS"
1692 #  endif
1693 #  ifdef NO_HASH_SEED
1694                              " NO_HASH_SEED"
1695 #  endif
1696 #  ifdef NO_TAINT_SUPPORT
1697                              " NO_TAINT_SUPPORT"
1698 #  endif
1699 #  ifdef PERL_DISABLE_PMC
1700                              " PERL_DISABLE_PMC"
1701 #  endif
1702 #  ifdef PERL_DONT_CREATE_GVSV
1703                              " PERL_DONT_CREATE_GVSV"
1704 #  endif
1705 #  ifdef PERL_EXTERNAL_GLOB
1706                              " PERL_EXTERNAL_GLOB"
1707 #  endif
1708 #  ifdef PERL_HASH_FUNC_SIPHASH
1709                              " PERL_HASH_FUNC_SIPHASH"
1710 #  endif
1711 #  ifdef PERL_HASH_FUNC_SDBM
1712                              " PERL_HASH_FUNC_SDBM"
1713 #  endif
1714 #  ifdef PERL_HASH_FUNC_DJB2
1715                              " PERL_HASH_FUNC_DJB2"
1716 #  endif
1717 #  ifdef PERL_HASH_FUNC_SUPERFAST
1718                              " PERL_HASH_FUNC_SUPERFAST"
1719 #  endif
1720 #  ifdef PERL_HASH_FUNC_MURMUR3
1721                              " PERL_HASH_FUNC_MURMUR3"
1722 #  endif
1723 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME
1724                              " PERL_HASH_FUNC_ONE_AT_A_TIME"
1725 #  endif
1726 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
1727                              " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD"
1728 #  endif
1729 #  ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
1730                              " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD"
1731 #  endif
1732 #  ifdef PERL_IS_MINIPERL
1733                              " PERL_IS_MINIPERL"
1734 #  endif
1735 #  ifdef PERL_MALLOC_WRAP
1736                              " PERL_MALLOC_WRAP"
1737 #  endif
1738 #  ifdef PERL_MEM_LOG
1739                              " PERL_MEM_LOG"
1740 #  endif
1741 #  ifdef PERL_MEM_LOG_NOIMPL
1742                              " PERL_MEM_LOG_NOIMPL"
1743 #  endif
1744 #  ifdef PERL_NEW_COPY_ON_WRITE
1745                              " PERL_NEW_COPY_ON_WRITE"
1746 #  endif
1747 #  ifdef PERL_PERTURB_KEYS_DETERMINISTIC
1748                              " PERL_PERTURB_KEYS_DETERMINISTIC"
1749 #  endif
1750 #  ifdef PERL_PERTURB_KEYS_DISABLED
1751                              " PERL_PERTURB_KEYS_DISABLED"
1752 #  endif
1753 #  ifdef PERL_PERTURB_KEYS_RANDOM
1754                              " PERL_PERTURB_KEYS_RANDOM"
1755 #  endif
1756 #  ifdef PERL_PRESERVE_IVUV
1757                              " PERL_PRESERVE_IVUV"
1758 #  endif
1759 #  ifdef PERL_RELOCATABLE_INCPUSH
1760                              " PERL_RELOCATABLE_INCPUSH"
1761 #  endif
1762 #  ifdef PERL_USE_DEVEL
1763                              " PERL_USE_DEVEL"
1764 #  endif
1765 #  ifdef PERL_USE_SAFE_PUTENV
1766                              " PERL_USE_SAFE_PUTENV"
1767 #  endif
1768 #  ifdef UNLINK_ALL_VERSIONS
1769                              " UNLINK_ALL_VERSIONS"
1770 #  endif
1771 #  ifdef USE_ATTRIBUTES_FOR_PERLIO
1772                              " USE_ATTRIBUTES_FOR_PERLIO"
1773 #  endif
1774 #  ifdef USE_FAST_STDIO
1775                              " USE_FAST_STDIO"
1776 #  endif               
1777 #  ifdef USE_HASH_SEED_EXPLICIT
1778                              " USE_HASH_SEED_EXPLICIT"
1779 #  endif
1780 #  ifdef USE_LOCALE
1781                              " USE_LOCALE"
1782 #  endif
1783 #  ifdef USE_LOCALE_CTYPE
1784                              " USE_LOCALE_CTYPE"
1785 #  endif
1786 #  ifdef USE_PERL_ATOF
1787                              " USE_PERL_ATOF"
1788 #  endif               
1789 #  ifdef USE_SITECUSTOMIZE
1790                              " USE_SITECUSTOMIZE"
1791 #  endif               
1792         ;
1793     PERL_UNUSED_ARG(cv);
1794     PERL_UNUSED_ARG(items);
1795
1796     EXTEND(SP, entries);
1797
1798     PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
1799     PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
1800                               sizeof(non_bincompat_options) - 1, SVs_TEMP));
1801
1802 #ifdef __DATE__
1803 #  ifdef __TIME__
1804     PUSHs(Perl_newSVpvn_flags(aTHX_
1805                               STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__),
1806                               SVs_TEMP));
1807 #  else
1808     PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
1809                               SVs_TEMP));
1810 #  endif
1811 #else
1812     PUSHs(&PL_sv_undef);
1813 #endif
1814
1815     for (i = 1; i <= local_patch_count; i++) {
1816         /* This will be an undef, if PL_localpatches[i] is NULL.  */
1817         PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
1818     }
1819
1820     XSRETURN(entries);
1821 }
1822
1823 #define INCPUSH_UNSHIFT                 0x01
1824 #define INCPUSH_ADD_OLD_VERS            0x02
1825 #define INCPUSH_ADD_VERSIONED_SUB_DIRS  0x04
1826 #define INCPUSH_ADD_ARCHONLY_SUB_DIRS   0x08
1827 #define INCPUSH_NOT_BASEDIR             0x10
1828 #define INCPUSH_CAN_RELOCATE            0x20
1829 #define INCPUSH_ADD_SUB_DIRS    \
1830     (INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_ADD_ARCHONLY_SUB_DIRS)
1831
1832 STATIC void *
1833 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1834 {
1835     dVAR;
1836     PerlIO *rsfp;
1837     int argc = PL_origargc;
1838     char **argv = PL_origargv;
1839     const char *scriptname = NULL;
1840     VOL bool dosearch = FALSE;
1841     char c;
1842     bool doextract = FALSE;
1843     const char *cddir = NULL;
1844 #ifdef USE_SITECUSTOMIZE
1845     bool minus_f = FALSE;
1846 #endif
1847     SV *linestr_sv = NULL;
1848     bool add_read_e_script = FALSE;
1849     U32 lex_start_flags = 0;
1850
1851     PERL_SET_PHASE(PERL_PHASE_START);
1852
1853     init_main_stash();
1854
1855     {
1856         const char *s;
1857     for (argc--,argv++; argc > 0; argc--,argv++) {
1858         if (argv[0][0] != '-' || !argv[0][1])
1859             break;
1860         s = argv[0]+1;
1861       reswitch:
1862         switch ((c = *s)) {
1863         case 'C':
1864 #ifndef PERL_STRICT_CR
1865         case '\r':
1866 #endif
1867         case ' ':
1868         case '0':
1869         case 'F':
1870         case 'a':
1871         case 'c':
1872         case 'd':
1873         case 'D':
1874         case 'h':
1875         case 'i':
1876         case 'l':
1877         case 'M':
1878         case 'm':
1879         case 'n':
1880         case 'p':
1881         case 's':
1882         case 'u':
1883         case 'U':
1884         case 'v':
1885         case 'W':
1886         case 'X':
1887         case 'w':
1888             if ((s = moreswitches(s)))
1889                 goto reswitch;
1890             break;
1891
1892         case 't':
1893 #if SILENT_NO_TAINT_SUPPORT
1894             /* silently ignore */
1895 #elif NO_TAINT_SUPPORT
1896             Perl_croak_nocontext("This perl was compiled without taint support. "
1897                        "Cowardly refusing to run with -t or -T flags");
1898 #else
1899             CHECK_MALLOC_TOO_LATE_FOR('t');
1900             if( !TAINTING_get ) {
1901                  TAINT_WARN_set(TRUE);
1902                  TAINTING_set(TRUE);
1903             }
1904 #endif
1905             s++;
1906             goto reswitch;
1907         case 'T':
1908 #if SILENT_NO_TAINT_SUPPORT
1909             /* silently ignore */
1910 #elif NO_TAINT_SUPPORT
1911             Perl_croak_nocontext("This perl was compiled without taint support. "
1912                        "Cowardly refusing to run with -t or -T flags");
1913 #else
1914             CHECK_MALLOC_TOO_LATE_FOR('T');
1915             TAINTING_set(TRUE);
1916             TAINT_WARN_set(FALSE);
1917 #endif
1918             s++;
1919             goto reswitch;
1920
1921         case 'E':
1922             PL_minus_E = TRUE;
1923             /* FALL THROUGH */
1924         case 'e':
1925             forbid_setid('e', FALSE);
1926             if (!PL_e_script) {
1927                 PL_e_script = newSVpvs("");
1928                 add_read_e_script = TRUE;
1929             }
1930             if (*++s)
1931                 sv_catpv(PL_e_script, s);
1932             else if (argv[1]) {
1933                 sv_catpv(PL_e_script, argv[1]);
1934                 argc--,argv++;
1935             }
1936             else
1937                 Perl_croak(aTHX_ "No code specified for -%c", c);
1938             sv_catpvs(PL_e_script, "\n");
1939             break;
1940
1941         case 'f':
1942 #ifdef USE_SITECUSTOMIZE
1943             minus_f = TRUE;
1944 #endif
1945             s++;
1946             goto reswitch;
1947
1948         case 'I':       /* -I handled both here and in moreswitches() */
1949             forbid_setid('I', FALSE);
1950             if (!*++s && (s=argv[1]) != NULL) {
1951                 argc--,argv++;
1952             }
1953             if (s && *s) {
1954                 STRLEN len = strlen(s);
1955                 incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
1956             }
1957             else
1958                 Perl_croak(aTHX_ "No directory specified for -I");
1959             break;
1960         case 'S':
1961             forbid_setid('S', FALSE);
1962             dosearch = TRUE;
1963             s++;
1964             goto reswitch;
1965         case 'V':
1966             {
1967                 SV *opts_prog;
1968
1969                 if (*++s != ':')  {
1970                     opts_prog = newSVpvs("use Config; Config::_V()");
1971                 }
1972                 else {
1973                     ++s;
1974                     opts_prog = Perl_newSVpvf(aTHX_
1975                                               "use Config; Config::config_vars(qw%c%s%c)",
1976                                               0, s, 0);
1977                     s += strlen(s);
1978                 }
1979                 Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
1980                 /* don't look for script or read stdin */
1981                 scriptname = BIT_BUCKET;
1982                 goto reswitch;
1983             }
1984         case 'x':
1985             doextract = TRUE;
1986             s++;
1987             if (*s)
1988                 cddir = s;
1989             break;
1990         case 0:
1991             break;
1992         case '-':
1993             if (!*++s || isSPACE(*s)) {
1994                 argc--,argv++;
1995                 goto switch_end;
1996             }
1997             /* catch use of gnu style long options.
1998                Both of these exit immediately.  */
1999             if (strEQ(s, "version"))
2000                 minus_v();
2001             if (strEQ(s, "help"))
2002                 usage();
2003             s--;
2004             /* FALL THROUGH */
2005         default:
2006             Perl_croak(aTHX_ "Unrecognized switch: -%s  (-h will show valid options)",s);
2007         }
2008     }
2009     }
2010
2011   switch_end:
2012
2013     {
2014         char *s;
2015
2016     if (
2017 #ifndef SECURE_INTERNAL_GETENV
2018         !TAINTING_get &&
2019 #endif
2020         (s = PerlEnv_getenv("PERL5OPT")))
2021     {
2022         while (isSPACE(*s))
2023             s++;
2024         if (*s == '-' && *(s+1) == 'T') {
2025 #if SILENT_NO_TAINT_SUPPORT
2026             /* silently ignore */
2027 #elif NO_TAINT_SUPPORT
2028             Perl_croak_nocontext("This perl was compiled without taint support. "
2029                        "Cowardly refusing to run with -t or -T flags");
2030 #else
2031             CHECK_MALLOC_TOO_LATE_FOR('T');
2032             TAINTING_set(TRUE);
2033             TAINT_WARN_set(FALSE);
2034 #endif
2035         }
2036         else {
2037             char *popt_copy = NULL;
2038             while (s && *s) {
2039                 const char *d;
2040                 while (isSPACE(*s))
2041                     s++;
2042                 if (*s == '-') {
2043                     s++;
2044                     if (isSPACE(*s))
2045                         continue;
2046                 }
2047                 d = s;
2048                 if (!*s)
2049                     break;
2050                 if (!strchr("CDIMUdmtwW", *s))
2051                     Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
2052                 while (++s && *s) {
2053                     if (isSPACE(*s)) {
2054                         if (!popt_copy) {
2055                             popt_copy = SvPVX(sv_2mortal(newSVpv(d,0)));
2056                             s = popt_copy + (s - d);
2057                             d = popt_copy;
2058                         }
2059                         *s++ = '\0';
2060                         break;
2061                     }
2062                 }
2063                 if (*d == 't') {
2064 #if SILENT_NO_TAINT_SUPPORT
2065             /* silently ignore */
2066 #elif NO_TAINT_SUPPORT
2067                     Perl_croak_nocontext("This perl was compiled without taint support. "
2068                                "Cowardly refusing to run with -t or -T flags");
2069 #else
2070                     if( !TAINTING_get) {
2071                         TAINT_WARN_set(TRUE);
2072                         TAINTING_set(TRUE);
2073                     }
2074 #endif
2075                 } else {
2076                     moreswitches(d);
2077                 }
2078             }
2079         }
2080     }
2081     }
2082
2083     /* Set $^X early so that it can be used for relocatable paths in @INC  */
2084     /* and for SITELIB_EXP in USE_SITECUSTOMIZE                            */
2085     assert (!TAINT_get);
2086     TAINT;
2087     S_set_caret_X(aTHX);
2088     TAINT_NOT;
2089
2090 #if defined(USE_SITECUSTOMIZE)
2091     if (!minus_f) {
2092         /* The games with local $! are to avoid setting errno if there is no
2093            sitecustomize script.  "q%c...%c", 0, ..., 0 becomes "q\0...\0",
2094            ie a q() operator with a NUL byte as a the delimiter. This avoids
2095            problems with pathnames containing (say) '  */
2096 #  ifdef PERL_IS_MINIPERL
2097         AV *const inc = GvAV(PL_incgv);
2098         SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL;
2099
2100         if (inc0) {
2101             /* if lib/buildcustomize.pl exists, it should not fail. If it does,
2102                it should be reported immediately as a build failure.  */
2103             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2104                                                  Perl_newSVpvf(aTHX_
2105         "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }",
2106                                                                0, *inc0, 0,
2107                                                                0, *inc0, 0));
2108         }
2109 #  else
2110         /* SITELIB_EXP is a function call on Win32.  */
2111         const char *const raw_sitelib = SITELIB_EXP;
2112         if (raw_sitelib) {
2113             /* process .../.. if PERL_RELOCATABLE_INC is defined */
2114             SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib),
2115                                            INCPUSH_CAN_RELOCATE);
2116             const char *const sitelib = SvPVX(sitelib_sv);
2117             (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
2118                                                  Perl_newSVpvf(aTHX_
2119                                                                "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }",
2120                                                                0, sitelib, 0,
2121                                                                0, sitelib, 0));
2122             assert (SvREFCNT(sitelib_sv) == 1);
2123             SvREFCNT_dec(sitelib_sv);
2124         }
2125 #  endif
2126     }
2127 #endif
2128
2129     if (!scriptname)
2130         scriptname = argv[0];
2131     if (PL_e_script) {
2132         argc++,argv--;
2133         scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
2134     }
2135     else if (scriptname == NULL) {
2136 #ifdef MSDOS
2137         if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
2138             moreswitches("h");
2139 #endif
2140         scriptname = "-";
2141     }
2142
2143     assert (!TAINT_get);
2144     init_perllib();
2145
2146     {
2147         bool suidscript = FALSE;
2148
2149         rsfp = open_script(scriptname, dosearch, &suidscript);
2150         if (!rsfp) {
2151             rsfp = PerlIO_stdin();
2152             lex_start_flags = LEX_DONT_CLOSE_RSFP;
2153         }
2154
2155         validate_suid(rsfp);
2156
2157 #ifndef PERL_MICRO
2158 #  if defined(SIGCHLD) || defined(SIGCLD)
2159         {
2160 #  ifndef SIGCHLD
2161 #    define SIGCHLD SIGCLD
2162 #  endif
2163             Sighandler_t sigstate = rsignal_state(SIGCHLD);
2164             if (sigstate == (Sighandler_t) SIG_IGN) {
2165                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
2166                                "Can't ignore signal CHLD, forcing to default");
2167                 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
2168             }
2169         }
2170 #  endif
2171 #endif
2172
2173         if (doextract) {
2174
2175             /* This will croak if suidscript is true, as -x cannot be used with
2176                setuid scripts.  */
2177             forbid_setid('x', suidscript);
2178             /* Hence you can't get here if suidscript is true */
2179
2180             linestr_sv = newSV_type(SVt_PV);
2181             lex_start_flags |= LEX_START_COPIED;
2182             find_beginning(linestr_sv, rsfp);
2183             if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
2184                 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
2185         }
2186     }
2187
2188     PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2189     CvUNIQUE_on(PL_compcv);
2190
2191     CvPADLIST(PL_compcv) = pad_new(0);
2192
2193     PL_isarev = newHV();
2194
2195     boot_core_PerlIO();
2196     boot_core_UNIVERSAL();
2197     boot_core_mro();
2198     newXS("Internals::V", S_Internals_V, __FILE__);
2199
2200     if (xsinit)
2201         (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
2202 #ifndef PERL_MICRO
2203 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN)
2204     init_os_extras();
2205 #endif
2206 #endif
2207
2208 #ifdef USE_SOCKS
2209 #   ifdef HAS_SOCKS5_INIT
2210     socks5_init(argv[0]);
2211 #   else
2212     SOCKSinit(argv[0]);
2213 #   endif
2214 #endif
2215
2216     init_predump_symbols();
2217     /* init_postdump_symbols not currently designed to be called */
2218     /* more than once (ENV isn't cleared first, for example)     */
2219     /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
2220     if (!PL_do_undump)
2221         init_postdump_symbols(argc,argv,env);
2222
2223     /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
2224      * or explicitly in some platforms.
2225      * locale.c:Perl_init_i18nl10n() if the environment
2226      * look like the user wants to use UTF-8. */
2227 #if defined(__SYMBIAN32__)
2228     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
2229 #endif
2230 #  ifndef PERL_IS_MINIPERL
2231     if (PL_unicode) {
2232          /* Requires init_predump_symbols(). */
2233          if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
2234               IO* io;
2235               PerlIO* fp;
2236               SV* sv;
2237
2238               /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
2239                * and the default open disciplines. */
2240               if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
2241                   PL_stdingv  && (io = GvIO(PL_stdingv)) &&
2242                   (fp = IoIFP(io)))
2243                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2244               if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
2245                   PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
2246                   (fp = IoOFP(io)))
2247                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2248               if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
2249                   PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
2250                   (fp = IoOFP(io)))
2251                    PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
2252               if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
2253                   (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL,
2254                                          SVt_PV)))) {
2255                    U32 in  = PL_unicode & PERL_UNICODE_IN_FLAG;
2256                    U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
2257                    if (in) {
2258                         if (out)
2259                              sv_setpvs(sv, ":utf8\0:utf8");
2260                         else
2261                              sv_setpvs(sv, ":utf8\0");
2262                    }
2263                    else if (out)
2264                         sv_setpvs(sv, "\0:utf8");
2265                    SvSETMAGIC(sv);
2266               }
2267          }
2268     }
2269 #endif
2270
2271     {
2272         const char *s;
2273     if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
2274          if (strEQ(s, "unsafe"))
2275               PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
2276          else if (strEQ(s, "safe"))
2277               PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
2278          else
2279               Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
2280     }
2281     }
2282
2283 #ifdef PERL_MAD
2284     {
2285         const char *s;
2286     if (!TAINTING_get &&
2287         (s = PerlEnv_getenv("PERL_XMLDUMP"))) {
2288         PL_madskills = 1;
2289         PL_minus_c = 1;
2290         if (!s || !s[0])
2291             PL_xmlfp = PerlIO_stdout();
2292         else {
2293             PL_xmlfp = PerlIO_open(s, "w");
2294             if (!PL_xmlfp)
2295                 Perl_croak(aTHX_ "Can't open %s", s);
2296         }
2297         my_setenv("PERL_XMLDUMP", NULL);        /* hide from subprocs */
2298     }
2299     }
2300
2301     {
2302         const char *s;
2303     if ((s = PerlEnv_getenv("PERL_MADSKILLS"))) {
2304         PL_madskills = atoi(s);
2305         my_setenv("PERL_MADSKILLS", NULL);      /* hide from subprocs */
2306     }
2307     }
2308 #endif
2309
2310     lex_start(linestr_sv, rsfp, lex_start_flags);
2311     SvREFCNT_dec(linestr_sv);
2312
2313     PL_subname = newSVpvs("main");
2314
2315     if (add_read_e_script)
2316         filter_add(read_e_script, NULL);
2317
2318     /* now parse the script */
2319
2320     SETERRNO(0,SS_NORMAL);
2321     if (yyparse(GRAMPROG) || PL_parser->error_count) {
2322         if (PL_minus_c)
2323             Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
2324         else {
2325             Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
2326                        PL_origfilename);
2327         }
2328     }
2329     CopLINE_set(PL_curcop, 0);
2330     SET_CURSTASH(PL_defstash);
2331     if (PL_e_script) {
2332         SvREFCNT_dec(PL_e_script);
2333         PL_e_script = NULL;
2334     }
2335
2336     if (PL_do_undump)
2337         my_unexec();
2338
2339     if (isWARN_ONCE) {
2340         SAVECOPFILE(PL_curcop);
2341         SAVECOPLINE(PL_curcop);
2342         gv_check(PL_defstash);
2343     }
2344
2345     LEAVE;
2346     FREETMPS;
2347
2348 #ifdef MYMALLOC
2349     {
2350         const char *s;
2351     if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
2352         dump_mstats("after compilation:");
2353     }
2354 #endif
2355
2356     ENTER;
2357     PL_restartjmpenv = NULL;
2358     PL_restartop = 0;
2359     return NULL;
2360 }
2361
2362 /*
2363 =for apidoc perl_run
2364
2365 Tells a Perl interpreter to run.  See L<perlembed>.
2366
2367 =cut
2368 */
2369
2370 int
2371 perl_run(pTHXx)
2372 {
2373     dVAR;
2374     I32 oldscope;
2375     int ret = 0;
2376     dJMPENV;
2377
2378     PERL_ARGS_ASSERT_PERL_RUN;
2379 #ifndef MULTIPLICITY
2380     PERL_UNUSED_ARG(my_perl);
2381 #endif
2382
2383     oldscope = PL_scopestack_ix;
2384 #ifdef VMS
2385     VMSISH_HUSHED = 0;
2386 #endif
2387
2388     JMPENV_PUSH(ret);
2389     switch (ret) {
2390     case 1:
2391         cxstack_ix = -1;                /* start context stack again */
2392         goto redo_body;
2393     case 0:                             /* normal completion */
2394  redo_body:
2395         run_body(oldscope);
2396         /* FALL THROUGH */
2397     case 2:                             /* my_exit() */
2398         while (PL_scopestack_ix > oldscope)
2399             LEAVE;
2400         FREETMPS;
2401         SET_CURSTASH(PL_defstash);
2402         if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
2403             PL_endav && !PL_minus_c) {
2404             PERL_SET_PHASE(PERL_PHASE_END);
2405             call_list(oldscope, PL_endav);
2406         }
2407 #ifdef MYMALLOC
2408         if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
2409             dump_mstats("after execution:  ");
2410 #endif
2411         ret = STATUS_EXIT;
2412         break;
2413     case 3:
2414         if (PL_restartop) {
2415             POPSTACK_TO(PL_mainstack);
2416             goto redo_body;
2417         }
2418         PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
2419         FREETMPS;
2420         ret = 1;
2421         break;
2422     }
2423
2424     JMPENV_POP;
2425     return ret;
2426 }
2427
2428 STATIC void
2429 S_run_body(pTHX_ I32 oldscope)
2430 {
2431     dVAR;
2432     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n",
2433                     PL_sawampersand ? "Enabling" : "Omitting",
2434                     (unsigned int)(PL_sawampersand)));
2435
2436     if (!PL_restartop) {
2437 #ifdef PERL_MAD
2438         if (PL_xmlfp) {
2439             xmldump_all();
2440             exit(0);    /* less likely to core dump than my_exit(0) */
2441         }
2442 #endif
2443 #ifdef DEBUGGING
2444         if (DEBUG_x_TEST || DEBUG_B_TEST)
2445             dump_all_perl(!DEBUG_B_TEST);
2446         if (!DEBUG_q_TEST)
2447           PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
2448 #endif
2449
2450         if (PL_minus_c) {
2451             PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
2452             my_exit(0);
2453         }
2454         if (PERLDB_SINGLE && PL_DBsingle)
2455             sv_setiv(PL_DBsingle, 1);
2456         if (PL_initav) {
2457             PERL_SET_PHASE(PERL_PHASE_INIT);
2458             call_list(oldscope, PL_initav);
2459         }
2460 #ifdef PERL_DEBUG_READONLY_OPS
2461         if (PL_main_root && PL_main_root->op_slabbed)
2462             Slab_to_ro(OpSLAB(PL_main_root));
2463 #endif
2464     }
2465
2466     /* do it */
2467
2468     PERL_SET_PHASE(PERL_PHASE_RUN);
2469
2470     if (PL_restartop) {
2471         PL_restartjmpenv = NULL;
2472         PL_op = PL_restartop;
2473         PL_restartop = 0;
2474         CALLRUNOPS(aTHX);
2475     }
2476     else if (PL_main_start) {
2477         CvDEPTH(PL_main_cv) = 1;
2478         PL_op = PL_main_start;
2479         CALLRUNOPS(aTHX);
2480     }
2481     my_exit(0);
2482     assert(0); /* NOTREACHED */
2483 }
2484
2485 /*
2486 =head1 SV Manipulation Functions
2487
2488 =for apidoc p||get_sv
2489
2490 Returns the SV of the specified Perl scalar.  C<flags> are passed to
2491 C<gv_fetchpv>. If C<GV_ADD> is set and the
2492 Perl variable does not exist then it will be created.  If C<flags> is zero
2493 and the variable does not exist then NULL is returned.
2494
2495 =cut
2496 */
2497
2498 SV*
2499 Perl_get_sv(pTHX_ const char *name, I32 flags)
2500 {
2501     GV *gv;
2502
2503     PERL_ARGS_ASSERT_GET_SV;
2504
2505     gv = gv_fetchpv(name, flags, SVt_PV);
2506     if (gv)
2507         return GvSV(gv);
2508     return NULL;
2509 }
2510
2511 /*
2512 =head1 Array Manipulation Functions
2513
2514 =for apidoc p||get_av
2515
2516 Returns the AV of the specified Perl global or package array with the given
2517 name (so it won't work on lexical variables).  C<flags> are passed 
2518 to C<gv_fetchpv>. If C<GV_ADD> is set and the
2519 Perl variable does not exist then it will be created.  If C<flags> is zero
2520 and the variable does not exist then NULL is returned.
2521
2522 Perl equivalent: C<@{"$name"}>.
2523
2524 =cut
2525 */
2526
2527 AV*
2528 Perl_get_av(pTHX_ const char *name, I32 flags)
2529 {
2530     GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
2531
2532     PERL_ARGS_ASSERT_GET_AV;
2533
2534     if (flags)
2535         return GvAVn(gv);
2536     if (gv)
2537         return GvAV(gv);
2538     return NULL;
2539 }
2540
2541 /*
2542 =head1 Hash Manipulation Functions
2543
2544 =for apidoc p||get_hv
2545
2546 Returns the HV of the specified Perl hash.  C<flags> are passed to
2547 C<gv_fetchpv>. If C<GV_ADD> is set and the
2548 Perl variable does not exist then it will be created.  If C<flags> is zero
2549 and the variable does not exist then NULL is returned.
2550
2551 =cut
2552 */
2553
2554 HV*
2555 Perl_get_hv(pTHX_ const char *name, I32 flags)
2556 {
2557     GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
2558
2559     PERL_ARGS_ASSERT_GET_HV;
2560
2561     if (flags)
2562         return GvHVn(gv);
2563     if (gv)
2564         return GvHV(gv);
2565     return NULL;
2566 }
2567
2568 /*
2569 =head1 CV Manipulation Functions
2570
2571 =for apidoc p||get_cvn_flags
2572
2573 Returns the CV of the specified Perl subroutine.  C<flags> are passed to
2574 C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
2575 exist then it will be declared (which has the same effect as saying
2576 C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
2577 then NULL is returned.
2578
2579 =for apidoc p||get_cv
2580
2581 Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
2582
2583 =cut
2584 */
2585
2586 CV*
2587 Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
2588 {
2589     GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
2590
2591     PERL_ARGS_ASSERT_GET_CVN_FLAGS;
2592
2593     /* XXX this is probably not what they think they're getting.
2594      * It has the same effect as "sub name;", i.e. just a forward
2595      * declaration! */
2596     if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
2597         return newSTUB(gv,0);
2598     }
2599     if (gv)
2600         return GvCVu(gv);
2601     return NULL;
2602 }
2603
2604 /* Nothing in core calls this now, but we can't replace it with a macro and
2605    move it to mathoms.c as a macro would evaluate name twice.  */
2606 CV*
2607 Perl_get_cv(pTHX_ const char *name, I32 flags)
2608 {
2609     PERL_ARGS_ASSERT_GET_CV;
2610
2611     return get_cvn_flags(name, strlen(name), flags);
2612 }
2613
2614 /* Be sure to refetch the stack pointer after calling these routines. */
2615
2616 /*
2617
2618 =head1 Callback Functions
2619
2620 =for apidoc p||call_argv
2621
2622 Performs a callback to the specified named and package-scoped Perl subroutine 
2623 with C<argv> (a NULL-terminated array of strings) as arguments. See L<perlcall>.
2624
2625 Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>.
2626
2627 =cut
2628 */
2629
2630 I32
2631 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
2632
2633                         /* See G_* flags in cop.h */
2634                         /* null terminated arg list */
2635 {
2636     dVAR;
2637     dSP;
2638
2639     PERL_ARGS_ASSERT_CALL_ARGV;
2640
2641     PUSHMARK(SP);
2642     if (argv) {
2643         while (*argv) {
2644             mXPUSHs(newSVpv(*argv,0));
2645             argv++;
2646         }
2647         PUTBACK;
2648     }
2649     return call_pv(sub_name, flags);
2650 }
2651
2652 /*
2653 =for apidoc p||call_pv
2654
2655 Performs a callback to the specified Perl sub.  See L<perlcall>.
2656
2657 =cut
2658 */
2659
2660 I32
2661 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
2662                         /* name of the subroutine */
2663                         /* See G_* flags in cop.h */
2664 {
2665     PERL_ARGS_ASSERT_CALL_PV;
2666
2667     return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
2668 }
2669
2670 /*
2671 =for apidoc p||call_method
2672
2673 Performs a callback to the specified Perl method.  The blessed object must
2674 be on the stack.  See L<perlcall>.
2675
2676 =cut
2677 */
2678
2679 I32
2680 Perl_call_method(pTHX_ const char *methname, I32 flags)
2681                         /* name of the subroutine */
2682                         /* See G_* flags in cop.h */
2683 {
2684     STRLEN len;
2685     SV* sv;
2686     PERL_ARGS_ASSERT_CALL_METHOD;
2687
2688     len = strlen(methname);
2689     sv = flags & G_METHOD_NAMED
2690         ? sv_2mortal(newSVpvn_share(methname, len,0))
2691         : newSVpvn_flags(methname, len, SVs_TEMP);
2692
2693     return call_sv(sv, flags | G_METHOD);
2694 }
2695
2696 /* May be called with any of a CV, a GV, or an SV containing the name. */
2697 /*
2698 =for apidoc p||call_sv
2699
2700 Performs a callback to the Perl sub whose name is in the SV.  See
2701 L<perlcall>.
2702
2703 =cut
2704 */
2705
2706 I32
2707 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
2708                         /* See G_* flags in cop.h */
2709 {
2710     dVAR; dSP;
2711     LOGOP myop;         /* fake syntax tree node */
2712     OP* method;
2713     UNOP method_unop;
2714     SVOP method_svop;
2715     I32 oldmark;
2716     VOL I32 retval = 0;
2717     I32 oldscope;
2718     bool oldcatch = CATCH_GET;
2719     int ret;
2720     OP* const oldop = PL_op;
2721     dJMPENV;
2722
2723     PERL_ARGS_ASSERT_CALL_SV;
2724
2725     if (flags & G_DISCARD) {
2726         ENTER;
2727         SAVETMPS;
2728     }
2729     if (!(flags & G_WANT)) {
2730         /* Backwards compatibility - as G_SCALAR was 0, it could be omitted.
2731          */
2732         flags |= G_SCALAR;
2733     }
2734
2735     Zero(&myop, 1, LOGOP);
2736     if (!(flags & G_NOARGS))
2737         myop.op_flags |= OPf_STACKED;
2738     myop.op_flags |= OP_GIMME_REVERSE(flags);
2739     SAVEOP();
2740     PL_op = (OP*)&myop;
2741
2742     EXTEND(PL_stack_sp, 1);
2743     if (!(flags & G_METHOD_NAMED))
2744         *++PL_stack_sp = sv;
2745     oldmark = TOPMARK;
2746     oldscope = PL_scopestack_ix;
2747
2748     if (PERLDB_SUB && PL_curstash != PL_debstash
2749            /* Handle first BEGIN of -d. */
2750           && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
2751            /* Try harder, since this may have been a sighandler, thus
2752             * curstash may be meaningless. */
2753           && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash)
2754           && !(flags & G_NODEBUG))
2755         myop.op_private |= OPpENTERSUB_DB;
2756
2757     if (flags & (G_METHOD|G_METHOD_NAMED)) {
2758         if ( flags & G_METHOD_NAMED ) {
2759             Zero(&method_svop, 1, SVOP);
2760             method_svop.op_next = (OP*)&myop;
2761             method_svop.op_ppaddr = PL_ppaddr[OP_METHOD_NAMED];
2762             method_svop.op_type = OP_METHOD_NAMED;
2763             method_svop.op_sv = sv;
2764             PL_op = (OP*)&method_svop;
2765         } else {
2766             Zero(&method_unop, 1, UNOP);
2767             method_unop.op_next = (OP*)&myop;
2768             method_unop.op_ppaddr = PL_ppaddr[OP_METHOD];
2769             method_unop.op_type = OP_METHOD;
2770             PL_op = (OP*)&method_unop;
2771         }
2772         myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
2773         myop.op_type = OP_ENTERSUB;
2774
2775     }
2776
2777     if (!(flags & G_EVAL)) {
2778         CATCH_SET(TRUE);
2779         CALL_BODY_SUB((OP*)&myop);
2780         retval = PL_stack_sp - (PL_stack_base + oldmark);
2781         CATCH_SET(oldcatch);
2782     }
2783     else {
2784         myop.op_other = (OP*)&myop;
2785         PL_markstack_ptr--;
2786         create_eval_scope(flags|G_FAKINGEVAL);
2787         PL_markstack_ptr++;
2788
2789         JMPENV_PUSH(ret);
2790
2791         switch (ret) {
2792         case 0:
2793  redo_body:
2794             CALL_BODY_SUB((OP*)&myop);
2795             retval = PL_stack_sp - (PL_stack_base + oldmark);
2796             if (!(flags & G_KEEPERR)) {
2797                 CLEAR_ERRSV();
2798             }
2799             break;
2800         case 1:
2801             STATUS_ALL_FAILURE;
2802             /* FALL THROUGH */
2803         case 2:
2804             /* my_exit() was called */
2805             SET_CURSTASH(PL_defstash);
2806             FREETMPS;
2807             JMPENV_POP;
2808             my_exit_jump();
2809             assert(0); /* NOTREACHED */
2810         case 3:
2811             if (PL_restartop) {
2812                 PL_restartjmpenv = NULL;
2813                 PL_op = PL_restartop;
2814                 PL_restartop = 0;
2815                 goto redo_body;
2816             }
2817             PL_stack_sp = PL_stack_base + oldmark;
2818             if ((flags & G_WANT) == G_ARRAY)
2819                 retval = 0;
2820             else {
2821                 retval = 1;
2822                 *++PL_stack_sp = &PL_sv_undef;
2823             }
2824             break;
2825         }
2826
2827         if (PL_scopestack_ix > oldscope)
2828             delete_eval_scope();
2829         JMPENV_POP;
2830     }
2831
2832     if (flags & G_DISCARD) {
2833         PL_stack_sp = PL_stack_base + oldmark;
2834         retval = 0;
2835         FREETMPS;
2836         LEAVE;
2837     }
2838     PL_op = oldop;
2839     return retval;
2840 }
2841
2842 /* Eval a string. The G_EVAL flag is always assumed. */
2843
2844 /*
2845 =for apidoc p||eval_sv
2846
2847 Tells Perl to C<eval> the string in the SV. It supports the same flags
2848 as C<call_sv>, with the obvious exception of G_EVAL. See L<perlcall>.
2849
2850 =cut
2851 */
2852
2853 I32
2854 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2855
2856                         /* See G_* flags in cop.h */
2857 {
2858     dVAR;
2859     dSP;
2860     UNOP myop;          /* fake syntax tree node */
2861     VOL I32 oldmark = SP - PL_stack_base;
2862     VOL I32 retval = 0;
2863     int ret;
2864     OP* const oldop = PL_op;
2865     dJMPENV;
2866
2867     PERL_ARGS_ASSERT_EVAL_SV;
2868
2869     if (flags & G_DISCARD) {
2870         ENTER;
2871         SAVETMPS;
2872     }
2873
2874     SAVEOP();
2875     PL_op = (OP*)&myop;
2876     Zero(&myop, 1, UNOP);
2877     EXTEND(PL_stack_sp, 1);
2878     *++PL_stack_sp = sv;
2879
2880     if (!(flags & G_NOARGS))
2881         myop.op_flags = OPf_STACKED;
2882     myop.op_type = OP_ENTEREVAL;
2883     myop.op_flags |= OP_GIMME_REVERSE(flags);
2884     if (flags & G_KEEPERR)
2885         myop.op_flags |= OPf_SPECIAL;
2886
2887     if (flags & G_RE_REPARSING)
2888         myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING);
2889
2890     /* fail now; otherwise we could fail after the JMPENV_PUSH but
2891      * before a PUSHEVAL, which corrupts the stack after a croak */
2892     TAINT_PROPER("eval_sv()");
2893
2894     JMPENV_PUSH(ret);
2895     switch (ret) {
2896     case 0:
2897  redo_body:
2898         if (PL_op == (OP*)(&myop)) {
2899             PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX);
2900             if (!PL_op)
2901                 goto fail; /* failed in compilation */
2902         }
2903         CALLRUNOPS(aTHX);
2904         retval = PL_stack_sp - (PL_stack_base + oldmark);
2905         if (!(flags & G_KEEPERR)) {
2906             CLEAR_ERRSV();
2907         }
2908         break;
2909     case 1:
2910         STATUS_ALL_FAILURE;
2911         /* FALL THROUGH */
2912     case 2:
2913         /* my_exit() was called */
2914         SET_CURSTASH(PL_defstash);
2915         FREETMPS;
2916         JMPENV_POP;
2917         my_exit_jump();
2918         assert(0); /* NOTREACHED */
2919     case 3:
2920         if (PL_restartop) {
2921             PL_restartjmpenv = NULL;
2922             PL_op = PL_restartop;
2923             PL_restartop = 0;
2924             goto redo_body;
2925         }
2926       fail:
2927         PL_stack_sp = PL_stack_base + oldmark;
2928         if ((flags & G_WANT) == G_ARRAY)
2929             retval = 0;
2930         else {
2931             retval = 1;
2932             *++PL_stack_sp = &PL_sv_undef;
2933         }
2934         break;
2935     }
2936
2937     JMPENV_POP;
2938     if (flags & G_DISCARD) {
2939         PL_stack_sp = PL_stack_base + oldmark;
2940         retval = 0;
2941         FREETMPS;
2942         LEAVE;
2943     }
2944     PL_op = oldop;
2945     return retval;
2946 }
2947
2948 /*
2949 =for apidoc p||eval_pv
2950
2951 Tells Perl to C<eval> the given string and return an SV* result.
2952
2953 =cut
2954 */
2955
2956 SV*
2957 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2958 {
2959     dVAR;
2960     SV* sv = newSVpv(p, 0);
2961
2962     PERL_ARGS_ASSERT_EVAL_PV;
2963
2964     eval_sv(sv, G_SCALAR);
2965     SvREFCNT_dec(sv);
2966
2967     {
2968         dSP;
2969         sv = POPs;
2970         PUTBACK;
2971     }
2972
2973     /* just check empty string or undef? */
2974     if (croak_on_error) {
2975         SV * const errsv = ERRSV;
2976         if(SvTRUE_NN(errsv))
2977             /* replace with croak_sv? */
2978             Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
2979     }
2980
2981     return sv;
2982 }
2983
2984 /* Require a module. */
2985
2986 /*
2987 =head1 Embedding Functions
2988
2989 =for apidoc p||require_pv
2990
2991 Tells Perl to C<require> the file named by the string argument.  It is
2992 analogous to the Perl code C<eval "require '$file'">.  It's even
2993 implemented that way; consider using load_module instead.
2994
2995 =cut */
2996
2997 void
2998 Perl_require_pv(pTHX_ const char *pv)
2999 {
3000     dVAR;
3001     dSP;
3002     SV* sv;
3003
3004     PERL_ARGS_ASSERT_REQUIRE_PV;
3005
3006     PUSHSTACKi(PERLSI_REQUIRE);
3007     PUTBACK;
3008     sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
3009     eval_sv(sv_2mortal(sv), G_DISCARD);
3010     SPAGAIN;
3011     POPSTACK;
3012 }
3013
3014 STATIC void
3015 S_usage(pTHX)           /* XXX move this out into a module ? */
3016 {
3017     /* This message really ought to be max 23 lines.
3018      * Removed -h because the user already knows that option. Others? */
3019
3020     /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89
3021        minimum of 509 character string literals.  */
3022     static const char * const usage_msg[] = {
3023 "  -0[octal]         specify record separator (\\0, if no argument)\n"
3024 "  -a                autosplit mode with -n or -p (splits $_ into @F)\n"
3025 "  -C[number/list]   enables the listed Unicode features\n"
3026 "  -c                check syntax only (runs BEGIN and CHECK blocks)\n"
3027 "  -d[:debugger]     run program under debugger\n"
3028 "  -D[number/list]   set debugging flags (argument is a bit mask or alphabets)\n",
3029 "  -e program        one line of program (several -e's allowed, omit programfile)\n"
3030 "  -E program        like -e, but enables all optional features\n"
3031 "  -f                don't do $sitelib/sitecustomize.pl at startup\n"
3032 "  -F/pattern/       split() pattern for -a switch (//'s are optional)\n"
3033 "  -i[extension]     edit <> files in place (makes backup if extension supplied)\n"
3034 "  -Idirectory       specify @INC/#include directory (several -I's allowed)\n",
3035 "  -l[octal]         enable line ending processing, specifies line terminator\n"
3036 "  -[mM][-]module    execute \"use/no module...\" before executing program\n"
3037 "  -n                assume \"while (<>) { ... }\" loop around program\n"
3038 "  -p                assume loop like -n but print line also, like sed\n"
3039 "  -s                enable rudimentary parsing for switches after programfile\n"
3040 "  -S                look for programfile using PATH environment variable\n",
3041 "  -t                enable tainting warnings\n"
3042 "  -T                enable tainting checks\n"
3043 "  -u                dump core after parsing program\n"
3044 "  -U                allow unsafe operations\n"
3045 "  -v                print version, patchlevel and license\n"
3046 "  -V[:variable]     print configuration summary (or a single Config.pm variable)\n",
3047 "  -w                enable many useful warnings\n"
3048 "  -W                enable all warnings\n"
3049 "  -x[directory]     ignore text before #!perl line (optionally cd to directory)\n"
3050 "  -X                disable all warnings\n"
3051 "  \n"
3052 "Run 'perldoc perl' for more help with Perl.\n\n",
3053 NULL
3054 };
3055     const char * const *p = usage_msg;
3056     PerlIO *out = PerlIO_stdout();
3057
3058     PerlIO_printf(out,
3059                   "\nUsage: %s [switches] [--] [programfile] [arguments]\n",
3060                   PL_origargv[0]);
3061     while (*p)
3062         PerlIO_puts(out, *p++);
3063     my_exit(0);
3064 }
3065
3066 /* convert a string of -D options (or digits) into an int.
3067  * sets *s to point to the char after the options */
3068
3069 #ifdef DEBUGGING
3070 int
3071 Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
3072 {
3073     static const char * const usage_msgd[] = {
3074       " Debugging flag values: (see also -d)\n"
3075       "  p  Tokenizing and parsing (with v, displays parse stack)\n"
3076       "  s  Stack snapshots (with v, displays all stacks)\n"
3077       "  l  Context (loop) stack processing\n"
3078       "  t  Trace execution\n"
3079       "  o  Method and overloading resolution\n",
3080       "  c  String/numeric conversions\n"
3081       "  P  Print profiling info, source file input state\n"
3082       "  m  Memory and SV allocation\n"
3083       "  f  Format processing\n"
3084       "  r  Regular expression parsing and execution\n"
3085       "  x  Syntax tree dump\n",
3086       "  u  Tainting checks\n"
3087       "  H  Hash dump -- usurps values()\n"
3088       "  X  Scratchpad allocation\n"
3089       "  D  Cleaning up\n"
3090       "  S  Op slab allocation\n"
3091       "  T  Tokenising\n"
3092       "  R  Include reference counts of dumped variables (eg when using -Ds)\n",
3093       "  J  Do not s,t,P-debug (Jump over) opcodes within package DB\n"
3094       "  v  Verbose: use in conjunction with other flags\n"
3095       "  C  Copy On Write\n"
3096       "  A  Consistency checks on internal structures\n"
3097       "  q  quiet - currently only suppresses the 'EXECUTING' message\n"
3098       "  M  trace smart match resolution\n"
3099       "  B  dump suBroutine definitions, including special Blocks like BEGIN\n",
3100       NULL
3101     };
3102     int i = 0;
3103
3104     PERL_ARGS_ASSERT_GET_DEBUG_OPTS;
3105
3106     if (isALPHA(**s)) {
3107         /* if adding extra options, remember to update DEBUG_MASK */
3108         static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
3109
3110         for (; isWORDCHAR(**s); (*s)++) {
3111             const char * const d = strchr(debopts,**s);
3112             if (d)
3113                 i |= 1 << (d - debopts);
3114             else if (ckWARN_d(WARN_DEBUGGING))
3115                 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3116                     "invalid option -D%c, use -D'' to see choices\n", **s);
3117         }
3118     }
3119     else if (isDIGIT(**s)) {
3120         i = atoi(*s);
3121         for (; isWORDCHAR(**s); (*s)++) ;
3122     }
3123     else if (givehelp) {
3124       const char *const *p = usage_msgd;
3125       while (*p) PerlIO_puts(PerlIO_stdout(), *p++);
3126     }
3127 #  ifdef EBCDIC
3128     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
3129         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3130                 "-Dp not implemented on this platform\n");
3131 #  endif
3132     return i;
3133 }
3134 #endif
3135
3136 /* This routine handles any switches that can be given during run */
3137
3138 const char *
3139 Perl_moreswitches(pTHX_ const char *s)
3140 {
3141     dVAR;
3142     UV rschar;
3143     const char option = *s; /* used to remember option in -m/-M code */
3144
3145     PERL_ARGS_ASSERT_MORESWITCHES;
3146
3147     switch (*s) {
3148     case '0':
3149     {
3150          I32 flags = 0;
3151          STRLEN numlen;
3152
3153          SvREFCNT_dec(PL_rs);
3154          if (s[1] == 'x' && s[2]) {
3155               const char *e = s+=2;
3156               U8 *tmps;
3157
3158               while (*e)
3159                 e++;
3160               numlen = e - s;
3161               flags = PERL_SCAN_SILENT_ILLDIGIT;
3162               rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
3163               if (s + numlen < e) {
3164                    rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
3165                    numlen = 0;
3166                    s--;
3167               }
3168               PL_rs = newSVpvs("");
3169               SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
3170               tmps = (U8*)SvPVX(PL_rs);
3171               uvchr_to_utf8(tmps, rschar);
3172               SvCUR_set(PL_rs, UNISKIP(rschar));
3173               SvUTF8_on(PL_rs);
3174          }
3175          else {
3176               numlen = 4;
3177               rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
3178               if (rschar & ~((U8)~0))
3179                    PL_rs = &PL_sv_undef;
3180               else if (!rschar && numlen >= 2)
3181                    PL_rs = newSVpvs("");
3182               else {
3183                    char ch = (char)rschar;
3184                    PL_rs = newSVpvn(&ch, 1);
3185               }
3186          }
3187          sv_setsv(get_sv("/", GV_ADD), PL_rs);
3188          return s + numlen;
3189     }
3190     case 'C':
3191         s++;
3192         PL_unicode = parse_unicode_opts( (const char **)&s );
3193         if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
3194             PL_utf8cache = -1;
3195         return s;
3196     case 'F':
3197         PL_minus_F = TRUE;
3198         PL_splitstr = ++s;
3199         while (*s && !isSPACE(*s)) ++s;
3200         PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
3201         return s;
3202     case 'a':
3203         PL_minus_a = TRUE;
3204         s++;
3205         return s;
3206     case 'c':
3207         PL_minus_c = TRUE;
3208         s++;
3209         return s;
3210     case 'd':
3211         forbid_setid('d', FALSE);
3212         s++;
3213
3214         /* -dt indicates to the debugger that threads will be used */
3215         if (*s == 't' && !isWORDCHAR(s[1])) {
3216             ++s;
3217             my_setenv("PERL5DB_THREADED", "1");
3218         }
3219
3220         /* The following permits -d:Mod to accepts arguments following an =
3221            in the fashion that -MSome::Mod does. */
3222         if (*s == ':' || *s == '=') {
3223             const char *start;
3224             const char *end;
3225             SV *sv;
3226
3227             if (*++s == '-') {
3228                 ++s;
3229                 sv = newSVpvs("no Devel::");
3230             } else {
3231                 sv = newSVpvs("use Devel::");
3232             }
3233
3234             start = s;
3235             end = s + strlen(s);
3236
3237             /* We now allow -d:Module=Foo,Bar and -d:-Module */
3238             while(isWORDCHAR(*s) || *s==':') ++s;
3239             if (*s != '=')
3240                 sv_catpvn(sv, start, end - start);
3241             else {
3242                 sv_catpvn(sv, start, s-start);
3243                 /* Don't use NUL as q// delimiter here, this string goes in the
3244                  * environment. */
3245                 Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s);
3246             }
3247             s = end;
3248             my_setenv("PERL5DB", SvPV_nolen_const(sv));
3249             SvREFCNT_dec(sv);
3250         }
3251         if (!PL_perldb) {
3252             PL_perldb = PERLDB_ALL;
3253             init_debugger();
3254         }
3255         return s;
3256     case 'D':
3257     {   
3258 #ifdef DEBUGGING
3259         forbid_setid('D', FALSE);
3260         s++;
3261         PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
3262 #else /* !DEBUGGING */
3263         if (ckWARN_d(WARN_DEBUGGING))
3264             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
3265                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
3266         for (s++; isWORDCHAR(*s); s++) ;
3267 #endif
3268         return s;
3269     }   
3270     case 'h':
3271         usage();
3272     case 'i':
3273         Safefree(PL_inplace);
3274 #if defined(__CYGWIN__) /* do backup extension automagically */
3275         if (*(s+1) == '\0') {
3276         PL_inplace = savepvs(".bak");
3277         return s+1;
3278         }
3279 #endif /* __CYGWIN__ */
3280         {
3281             const char * const start = ++s;
3282             while (*s && !isSPACE(*s))
3283                 ++s;
3284
3285             PL_inplace = savepvn(start, s - start);
3286         }
3287         if (*s) {
3288             ++s;
3289             if (*s == '-')      /* Additional switches on #! line. */
3290                 s++;
3291         }
3292         return s;
3293     case 'I':   /* -I handled both here and in parse_body() */
3294         forbid_setid('I', FALSE);
3295         ++s;
3296         while (*s && isSPACE(*s))
3297             ++s;
3298         if (*s) {
3299             const char *e, *p;
3300             p = s;
3301             /* ignore trailing spaces (possibly followed by other switches) */
3302             do {
3303                 for (e = p; *e && !isSPACE(*e); e++) ;
3304                 p = e;
3305                 while (isSPACE(*p))
3306                     p++;
3307             } while (*p && *p != '-');
3308             incpush(s, e-s,
3309                     INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);
3310             s = p;
3311             if (*s == '-')
3312                 s++;
3313         }
3314         else
3315             Perl_croak(aTHX_ "No directory specified for -I");
3316         return s;
3317     case 'l':
3318         PL_minus_l = TRUE;
3319         s++;
3320         if (PL_ors_sv) {
3321             SvREFCNT_dec(PL_ors_sv);
3322             PL_ors_sv = NULL;
3323         }
3324         if (isDIGIT(*s)) {
3325             I32 flags = 0;
3326             STRLEN numlen;
3327             PL_ors_sv = newSVpvs("\n");
3328             numlen = 3 + (*s == '0');
3329             *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
3330             s += numlen;
3331         }
3332         else {
3333             if (RsPARA(PL_rs)) {
3334                 PL_ors_sv = newSVpvs("\n\n");
3335             }
3336             else {
3337                 PL_ors_sv = newSVsv(PL_rs);
3338             }
3339         }
3340         return s;
3341     case 'M':
3342         forbid_setid('M', FALSE);       /* XXX ? */
3343         /* FALL THROUGH */
3344     case 'm':
3345         forbid_setid('m', FALSE);       /* XXX ? */
3346         if (*++s) {
3347             const char *start;
3348             const char *end;
3349             SV *sv;
3350             const char *use = "use ";
3351             bool colon = FALSE;
3352             /* -M-foo == 'no foo'       */
3353             /* Leading space on " no " is deliberate, to make both
3354                possibilities the same length.  */
3355             if (*s == '-') { use = " no "; ++s; }
3356             sv = newSVpvn(use,4);
3357             start = s;
3358             /* We allow -M'Module qw(Foo Bar)'  */
3359             while(isWORDCHAR(*s) || *s==':') {
3360                 if( *s++ == ':' ) {
3361                     if( *s == ':' ) 
3362                         s++;
3363                     else
3364                         colon = TRUE;
3365                 }
3366             }
3367             if (s == start)
3368                 Perl_croak(aTHX_ "Module name required with -%c option",
3369                                     option);
3370             if (colon) 
3371                 Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
3372                                     "contains single ':'",
3373                                     (int)(s - start), start, option);
3374             end = s + strlen(s);
3375             if (*s != '=') {
3376                 sv_catpvn(sv, start, end - start);
3377                 if (option == 'm') {
3378                     if (*s != '\0')
3379                         Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
3380                     sv_catpvs( sv, " ()");
3381                 }
3382             } else {
3383                 sv_catpvn(sv, start, s-start);
3384                 /* Use NUL as q''-delimiter.  */
3385                 sv_catpvs(sv, " split(/,/,q\0");
3386                 ++s;
3387                 sv_catpvn(sv, s, end - s);
3388                 sv_catpvs(sv,  "\0)");
3389             }
3390             s = end;
3391             Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
3392         }
3393         else
3394             Perl_croak(aTHX_ "Missing argument to -%c", option);
3395         return s;
3396     case 'n':
3397         PL_minus_n = TRUE;
3398         s++;
3399         return s;
3400     case 'p':
3401         PL_minus_p = TRUE;
3402         s++;
3403         return s;
3404     case 's':
3405         forbid_setid('s', FALSE);
3406         PL_doswitches = TRUE;
3407         s++;
3408         return s;
3409     case 't':
3410     case 'T':
3411 #if SILENT_NO_TAINT_SUPPORT
3412             /* silently ignore */
3413 #elif NO_TAINT_SUPPORT
3414         Perl_croak_nocontext("This perl was compiled without taint support. "
3415                    "Cowardly refusing to run with -t or -T flags");
3416 #else
3417         if (!TAINTING_get)
3418             TOO_LATE_FOR(*s);
3419 #endif
3420         s++;
3421         return s;
3422     case 'u':
3423         PL_do_undump = TRUE;
3424         s++;
3425         return s;
3426     case 'U':
3427         PL_unsafe = TRUE;
3428         s++;
3429         return s;
3430     case 'v':
3431         minus_v();
3432     case 'w':
3433         if (! (PL_dowarn & G_WARN_ALL_MASK)) {
3434             PL_dowarn |= G_WARN_ON;
3435         }
3436         s++;
3437         return s;
3438     case 'W':
3439         PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
3440         if (!specialWARN(PL_compiling.cop_warnings))
3441             PerlMemShared_free(PL_compiling.cop_warnings);
3442         PL_compiling.cop_warnings = pWARN_ALL ;
3443         s++;
3444         return s;
3445     case 'X':
3446         PL_dowarn = G_WARN_ALL_OFF;
3447         if (!specialWARN(PL_compiling.cop_warnings))
3448             PerlMemShared_free(PL_compiling.cop_warnings);
3449         PL_compiling.cop_warnings = pWARN_NONE ;
3450         s++;
3451         return s;
3452     case '*':
3453     case ' ':
3454         while( *s == ' ' )
3455           ++s;
3456         if (s[0] == '-')        /* Additional switches on #! line. */
3457             return s+1;
3458         break;
3459     case '-':
3460     case 0:
3461 #if defined(WIN32) || !defined(PERL_STRICT_CR)
3462     case '\r':
3463 #endif
3464     case '\n':
3465     case '\t':
3466         break;
3467 #ifdef ALTERNATE_SHEBANG
3468     case 'S':                   /* OS/2 needs -S on "extproc" line. */
3469         break;
3470 #endif
3471     case 'e': case 'f': case 'x': case 'E':
3472 #ifndef ALTERNATE_SHEBANG
3473     case 'S':
3474 #endif
3475     case 'V':
3476         Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
3477     default:
3478         Perl_croak(aTHX_
3479             "Unrecognized switch: -%.1s  (-h will show valid options)",s
3480         );
3481     }
3482     return NULL;
3483 }
3484
3485
3486 STATIC void
3487 S_minus_v(pTHX)
3488 {
3489         PerlIO * PIO_stdout;
3490         if (!sv_derived_from(PL_patchlevel, "version"))
3491             upg_version(PL_patchlevel, TRUE);
3492         {
3493             SV* level= vstringify(PL_patchlevel);
3494 #ifdef PERL_PATCHNUM
3495 #  ifdef PERL_GIT_UNCOMMITTED_CHANGES
3496             SV *num = newSVpvs(PERL_PATCHNUM "*");
3497 #  else
3498             SV *num = newSVpvs(PERL_PATCHNUM);
3499 #  endif
3500             {
3501                 STRLEN level_len, num_len;
3502                 char * level_str, * num_str;
3503                 num_str = SvPV(num, num_len);
3504                 level_str = SvPV(level, level_len);
3505                 if (num_len>=level_len && strnEQ(num_str,level_str,level_len)) {
3506                     SvREFCNT_dec(level);
3507                     level= num;
3508                 } else {
3509                     Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
3510                     SvREFCNT_dec(num);
3511                 }
3512             }
3513  #endif
3514         PIO_stdout =  PerlIO_stdout();
3515             PerlIO_printf(PIO_stdout,
3516                 "\nThis is perl "       STRINGIFY(PERL_REVISION)
3517                 ", version "            STRINGIFY(PERL_VERSION)
3518                 ", subversion "         STRINGIFY(PERL_SUBVERSION)
3519                 " (%"SVf") built for "  ARCHNAME, level
3520                 );
3521             SvREFCNT_dec(level);
3522         }
3523 #if defined(LOCAL_PATCH_COUNT)
3524         if (LOCAL_PATCH_COUNT > 0)
3525             PerlIO_printf(PIO_stdout,
3526                           "\n(with %d registered patch%s, "
3527                           "see perl -V for more detail)",
3528                           LOCAL_PATCH_COUNT,
3529                           (LOCAL_PATCH_COUNT!=1) ? "es" : "");
3530 #endif
3531
3532         PerlIO_printf(PIO_stdout,
3533                       "\n\nCopyright 1987-2013, Larry Wall\n");
3534 #ifdef MSDOS
3535         PerlIO_printf(PIO_stdout,
3536                       "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
3537 #endif
3538 #ifdef DJGPP
3539         PerlIO_printf(PIO_stdout,
3540                       "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
3541                       "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
3542 #endif
3543 #ifdef OS2
3544         PerlIO_printf(PIO_stdout,
3545                       "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
3546                       "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
3547 #endif
3548 #ifdef OEMVS
3549         PerlIO_printf(PIO_stdout,
3550                       "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
3551 #endif
3552 #ifdef __VOS__
3553         PerlIO_printf(PIO_stdout,
3554                       "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n");
3555 #endif
3556 #ifdef POSIX_BC
3557         PerlIO_printf(PIO_stdout,
3558                       "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
3559 #endif
3560 #ifdef UNDER_CE
3561         PerlIO_printf(PIO_stdout,
3562                         "WINCE port by Rainer Keuchel, 2001-2002\n"
3563                         "Built on " __DATE__ " " __TIME__ "\n\n");
3564         wce_hitreturn();
3565 #endif
3566 #ifdef __SYMBIAN32__
3567         PerlIO_printf(PIO_stdout,
3568                       "Symbian port by Nokia, 2004-2005\n");
3569 #endif
3570 #ifdef BINARY_BUILD_NOTICE
3571         BINARY_BUILD_NOTICE;
3572 #endif
3573         PerlIO_printf(PIO_stdout,
3574                       "\n\
3575 Perl may be copied only under the terms of either the Artistic License or the\n\
3576 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
3577 Complete documentation for Perl, including FAQ lists, should be found on\n\
3578 this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n\
3579 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
3580         my_exit(0);
3581 }
3582
3583 /* compliments of Tom Christiansen */
3584
3585 /* unexec() can be found in the Gnu emacs distribution */
3586 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
3587
3588 #ifdef VMS
3589 #include <lib$routines.h>
3590 #endif
3591
3592 void
3593 Perl_my_unexec(pTHX)
3594 {
3595     PERL_UNUSED_CONTEXT;
3596 #ifdef UNEXEC
3597     SV *    prog = newSVpv(BIN_EXP, 0);
3598     SV *    file = newSVpv(PL_origfilename, 0);
3599     int    status = 1;
3600     extern int etext;
3601
3602     sv_catpvs(prog, "/perl");
3603     sv_catpvs(file, ".perldump");
3604
3605     unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
3606     /* unexec prints msg to stderr in case of failure */
3607     PerlProc_exit(status);
3608 #else
3609 #  ifdef VMS
3610      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
3611 #  elif defined(WIN32) || defined(__CYGWIN__)
3612     Perl_croak(aTHX_ "dump is not supported");
3613 #  else
3614     ABORT();            /* for use with undump */
3615 #  endif
3616 #endif
3617 }
3618
3619 /* initialize curinterp */
3620 STATIC void
3621 S_init_interp(pTHX)
3622 {
3623     dVAR;
3624 #ifdef MULTIPLICITY
3625 #  define PERLVAR(prefix,var,type)
3626 #  define PERLVARA(prefix,var,n,type)
3627 #  if defined(PERL_IMPLICIT_CONTEXT)
3628 #    define PERLVARI(prefix,var,type,init)      aTHX->prefix##var = init;
3629 #    define PERLVARIC(prefix,var,type,init)     aTHX->prefix##var = init;
3630 #  else
3631 #    define PERLVARI(prefix,var,type,init)      PERL_GET_INTERP->var = init;
3632 #    define PERLVARIC(prefix,var,type,init)     PERL_GET_INTERP->var = init;
3633 #  endif
3634 #  include "intrpvar.h"
3635 #  undef PERLVAR
3636 #  undef PERLVARA
3637 #  undef PERLVARI
3638 #  undef PERLVARIC
3639 #else
3640 #  define PERLVAR(prefix,var,type)
3641 #  define PERLVARA(prefix,var,n,type)
3642 #  define PERLVARI(prefix,var,type,init)        PL_##var = init;
3643 #  define PERLVARIC(prefix,var,type,init)       PL_##var = init;
3644 #  include "intrpvar.h"
3645 #  undef PERLVAR
3646 #  undef PERLVARA
3647 #  undef PERLVARI
3648 #  undef PERLVARIC
3649 #endif
3650
3651 }
3652
3653 STATIC void
3654 S_init_main_stash(pTHX)
3655 {
3656     dVAR;
3657     GV *gv;
3658
3659     PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
3660     /* We know that the string "main" will be in the global shared string
3661        table, so it's a small saving to use it rather than allocate another
3662        8 bytes.  */
3663     PL_curstname = newSVpvs_share("main");
3664     gv = gv_fetchpvs("main::", GV_ADD|GV_NOTQUAL, SVt_PVHV);
3665     /* If we hadn't caused another reference to "main" to be in the shared
3666        string table above, then it would be worth reordering these two,
3667        because otherwise all we do is delete "main" from it as a consequence
3668        of the SvREFCNT_dec, only to add it again with hv_name_set */
3669     SvREFCNT_dec(GvHV(gv));
3670     hv_name_set(PL_defstash, "main", 4, 0);
3671     GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
3672     SvREADONLY_on(gv);
3673     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL,
3674                                              SVt_PVAV)));
3675     SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */
3676     GvMULTI_on(PL_incgv);
3677     PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
3678     GvMULTI_on(PL_hintgv);
3679     PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
3680     SvREFCNT_inc_simple_void(PL_defgv);
3681     PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
3682     SvREFCNT_inc_simple_void(PL_errgv);
3683     GvMULTI_on(PL_errgv);
3684     PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */
3685     GvMULTI_on(PL_replgv);
3686     (void)Perl_form(aTHX_ "%240s","");  /* Preallocate temp - for immediate signals. */
3687 #ifdef PERL_DONT_CREATE_GVSV
3688     gv_SVadd(PL_errgv);
3689 #endif
3690     sv_grow(ERRSV, 240);        /* Preallocate - for immediate signals. */
3691     CLEAR_ERRSV();
3692     SET_CURSTASH(PL_defstash);
3693     CopSTASH_set(&PL_compiling, PL_defstash);
3694     PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
3695     PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
3696                                       SVt_PVHV));
3697     /* We must init $/ before switches are processed. */
3698     sv_setpvs(get_sv("/", GV_ADD), "\n");
3699 }
3700
3701 STATIC PerlIO *
3702 S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
3703 {
3704     int fdscript = -1;
3705     PerlIO *rsfp = NULL;
3706     dVAR;
3707     Stat_t tmpstatbuf;
3708
3709     PERL_ARGS_ASSERT_OPEN_SCRIPT;
3710
3711     if (PL_e_script) {
3712         PL_origfilename = savepvs("-e");
3713     }
3714     else {
3715         /* if find_script() returns, it returns a malloc()-ed value */
3716         scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
3717
3718         if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
3719             const char *s = scriptname + 8;
3720             fdscript = atoi(s);
3721             while (isDIGIT(*s))
3722                 s++;
3723             if (*s) {
3724                 /* PSz 18 Feb 04
3725                  * Tell apart "normal" usage of fdscript, e.g.
3726                  * with bash on FreeBSD:
3727                  *   perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3728                  * from usage in suidperl.
3729                  * Does any "normal" usage leave garbage after the number???
3730                  * Is it a mistake to use a similar /dev/fd/ construct for
3731                  * suidperl?
3732                  */
3733                 *suidscript = TRUE;
3734                 /* PSz 20 Feb 04  
3735                  * Be supersafe and do some sanity-checks.
3736                  * Still, can we be sure we got the right thing?
3737                  */
3738                 if (*s != '/') {
3739                     Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3740                 }
3741                 if (! *(s+1)) {
3742                     Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3743                 }
3744                 scriptname = savepv(s + 1);
3745                 Safefree(PL_origfilename);
3746                 PL_origfilename = (char *)scriptname;
3747             }
3748         }
3749     }
3750
3751     CopFILE_free(PL_curcop);
3752     CopFILE_set(PL_curcop, PL_origfilename);
3753     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
3754         scriptname = (char *)"";
3755     if (fdscript >= 0) {
3756         rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
3757     }
3758     else if (!*scriptname) {
3759         forbid_setid(0, *suidscript);
3760         return NULL;
3761     }
3762     else {
3763 #ifdef FAKE_BIT_BUCKET
3764         /* This hack allows one not to have /dev/null (or BIT_BUCKET as it
3765          * is called) and still have the "-e" work.  (Believe it or not,
3766          * a /dev/null is required for the "-e" to work because source
3767          * filter magic is used to implement it. ) This is *not* a general
3768          * replacement for a /dev/null.  What we do here is create a temp
3769          * file (an empty file), open up that as the script, and then
3770          * immediately close and unlink it.  Close enough for jazz. */ 
3771 #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
3772 #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
3773 #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
3774         char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
3775             FAKE_BIT_BUCKET_TEMPLATE
3776         };
3777         const char * const err = "Failed to create a fake bit bucket";
3778         if (strEQ(scriptname, BIT_BUCKET)) {
3779 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
3780             int tmpfd = mkstemp(tmpname);
3781             if (tmpfd > -1) {
3782                 scriptname = tmpname;
3783                 close(tmpfd);
3784             } else
3785                 Perl_croak(aTHX_ err);
3786 #else
3787 #  ifdef HAS_MKTEMP
3788             scriptname = mktemp(tmpname);
3789             if (!scriptname)
3790                 Perl_croak(aTHX_ err);
3791 #  endif
3792 #endif
3793         }
3794 #endif
3795         rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
3796 #ifdef FAKE_BIT_BUCKET
3797         if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
3798                   sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
3799             && strlen(scriptname) == sizeof(tmpname) - 1) {
3800             unlink(scriptname);
3801         }
3802         scriptname = BIT_BUCKET;
3803 #endif
3804     }
3805     if (!rsfp) {
3806         /* PSz 16 Sep 03  Keep neat error message */
3807         if (PL_e_script)
3808             Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
3809         else
3810             Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3811                     CopFILE(PL_curcop), Strerror(errno));
3812     }
3813 #if defined(HAS_FCNTL) && defined(F_SETFD)
3814     /* ensure close-on-exec */
3815     fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
3816 #endif
3817
3818     if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
3819         && S_ISDIR(tmpstatbuf.st_mode))
3820         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3821             CopFILE(PL_curcop),
3822             strerror(EISDIR));
3823
3824     return rsfp;
3825 }
3826
3827 /* Mention
3828  * I_SYSSTATVFS HAS_FSTATVFS
3829  * I_SYSMOUNT
3830  * I_STATFS     HAS_FSTATFS     HAS_GETFSSTAT
3831  * I_MNTENT     HAS_GETMNTENT   HAS_HASMNTOPT
3832  * here so that metaconfig picks them up. */
3833
3834
3835 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3836 /* Don't even need this function.  */
3837 #else
3838 STATIC void
3839 S_validate_suid(pTHX_ PerlIO *rsfp)
3840 {
3841     const Uid_t  my_uid = PerlProc_getuid();
3842     const Uid_t my_euid = PerlProc_geteuid();
3843     const Gid_t  my_gid = PerlProc_getgid();
3844     const Gid_t my_egid = PerlProc_getegid();
3845
3846     PERL_ARGS_ASSERT_VALIDATE_SUID;
3847
3848     if (my_euid != my_uid || my_egid != my_gid) {       /* (suidperl doesn't exist, in fact) */
3849         dVAR;
3850
3851         PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3852         if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3853             ||
3854             (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3855            )
3856             if (!PL_do_undump)
3857                 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3858 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3859         /* not set-id, must be wrapped */
3860     }
3861 }
3862 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3863
3864 STATIC void
3865 S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
3866 {
3867     dVAR;
3868     const char *s;
3869     const char *s2;
3870
3871     PERL_ARGS_ASSERT_FIND_BEGINNING;
3872
3873     /* skip forward in input to the real script? */
3874
3875     do {
3876         if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
3877             Perl_croak(aTHX_ "No Perl script found in input\n");
3878         s2 = s;
3879     } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))));
3880     PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
3881     while (*s && !(isSPACE (*s) || *s == '#')) s++;
3882     s2 = s;
3883     while (*s == ' ' || *s == '\t') s++;
3884     if (*s++ == '-') {
3885         while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3886                || s2[-1] == '_') s2--;
3887         if (strnEQ(s2-4,"perl",4))
3888             while ((s = moreswitches(s)))
3889                 ;
3890     }
3891 }
3892
3893
3894 STATIC void
3895 S_init_ids(pTHX)
3896 {
3897     /* no need to do anything here any more if we don't
3898      * do tainting. */
3899 #if !NO_TAINT_SUPPORT
3900     dVAR;
3901     const Uid_t my_uid = PerlProc_getuid();
3902     const Uid_t my_euid = PerlProc_geteuid();
3903     const Gid_t my_gid = PerlProc_getgid();
3904     const Gid_t my_egid = PerlProc_getegid();
3905
3906     /* Should not happen: */
3907     CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid));
3908     TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) );
3909 #endif
3910     /* BUG */
3911     /* PSz 27 Feb 04
3912      * Should go by suidscript, not uid!=euid: why disallow
3913      * system("ls") in scripts run from setuid things?
3914      * Or, is this run before we check arguments and set suidscript?
3915      * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3916      * (We never have suidscript, can we be sure to have fdscript?)
3917      * Or must then go by UID checks? See comments in forbid_setid also.
3918      */
3919 }
3920
3921 /* This is used very early in the lifetime of the program,
3922  * before even the options are parsed, so PL_tainting has
3923  * not been initialized properly.  */
3924 bool
3925 Perl_doing_taint(int argc, char *argv[], char *envp[])
3926 {
3927 #ifndef PERL_IMPLICIT_SYS
3928     /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3929      * before we have an interpreter-- and the whole point of this
3930      * function is to be called at such an early stage.  If you are on
3931      * a system with PERL_IMPLICIT_SYS but you do have a concept of
3932      * "tainted because running with altered effective ids', you'll
3933      * have to add your own checks somewhere in here.  The two most
3934      * known samples of 'implicitness' are Win32 and NetWare, neither
3935      * of which has much of concept of 'uids'. */
3936     Uid_t uid  = PerlProc_getuid();
3937     Uid_t euid = PerlProc_geteuid();
3938     Gid_t gid  = PerlProc_getgid();
3939     Gid_t egid = PerlProc_getegid();
3940     (void)envp;
3941
3942 #ifdef VMS
3943     uid  |=  gid << 16;
3944     euid |= egid << 16;
3945 #endif
3946     if (uid && (euid != uid || egid != gid))
3947         return 1;
3948 #endif /* !PERL_IMPLICIT_SYS */
3949     /* This is a really primitive check; environment gets ignored only
3950      * if -T are the first chars together; otherwise one gets
3951      *  "Too late" message. */
3952     if ( argc > 1 && argv[1][0] == '-'
3953          && (argv[1][1] == 't' || argv[1][1] == 'T') )
3954         return 1;
3955     return 0;
3956 }
3957
3958 /* Passing the flag as a single char rather than a string is a slight space
3959    optimisation.  The only message that isn't /^-.$/ is
3960    "program input from stdin", which is substituted in place of '\0', which
3961    could never be a command line flag.  */
3962 STATIC void
3963 S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */
3964 {
3965     dVAR;
3966     char string[3] = "-x";
3967     const char *message = "program input from stdin";
3968
3969     if (flag) {
3970         string[1] = flag;
3971         message = string;
3972     }
3973
3974 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3975     if (PerlProc_getuid() != PerlProc_geteuid())
3976         Perl_croak(aTHX_ "No %s allowed while running setuid", message);
3977     if (PerlProc_getgid() != PerlProc_getegid())
3978         Perl_croak(aTHX_ "No %s allowed while running setgid", message);
3979 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3980     if (suidscript)
3981         Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
3982 }
3983
3984 void
3985 Perl_init_dbargs(pTHX)
3986 {
3987     AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args",
3988                                                             GV_ADDMULTI,
3989                                                             SVt_PVAV))));
3990
3991     if (AvREAL(args)) {
3992         /* Someone has already created it.
3993            It might have entries, and if we just turn off AvREAL(), they will
3994            "leak" until global destruction.  */
3995         av_clear(args);
3996         if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
3997             Perl_croak(aTHX_ "Cannot set tied @DB::args");
3998     }
3999     AvREIFY_only(PL_dbargs);
4000 }
4001
4002 void
4003 Perl_init_debugger(pTHX)
4004 {
4005     dVAR;
4006     HV * const ostash = PL_curstash;
4007
4008     PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
4009
4010     Perl_init_dbargs(aTHX);
4011     PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV);
4012     PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV);
4013     PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV));
4014     PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV)));
4015     if (!SvIOK(PL_DBsingle))
4016         sv_setiv(PL_DBsingle, 0);
4017     PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV)));
4018     if (!SvIOK(PL_DBtrace))
4019         sv_setiv(PL_DBtrace, 0);
4020     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
4021     if (!SvIOK(PL_DBsignal))
4022         sv_setiv(PL_DBsignal, 0);
4023     SvREFCNT_dec(PL_curstash);
4024     PL_curstash = ostash;
4025 }
4026
4027 #ifndef STRESS_REALLOC
4028 #define REASONABLE(size) (size)
4029 #else
4030 #define REASONABLE(size) (1) /* unreasonable */
4031 #endif
4032
4033 void
4034 Perl_init_stacks(pTHX)
4035 {
4036     dVAR;
4037     /* start with 128-item stack and 8K cxstack */
4038     PL_curstackinfo = new_stackinfo(REASONABLE(128),
4039                                  REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
4040     PL_curstackinfo->si_type = PERLSI_MAIN;
4041     PL_curstack = PL_curstackinfo->si_stack;
4042     PL_mainstack = PL_curstack;         /* remember in case we switch stacks */
4043
4044     PL_stack_base = AvARRAY(PL_curstack);
4045     PL_stack_sp = PL_stack_base;
4046     PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
4047
4048     Newx(PL_tmps_stack,REASONABLE(128),SV*);
4049     PL_tmps_floor = -1;
4050     PL_tmps_ix = -1;
4051     PL_tmps_max = REASONABLE(128);
4052
4053     Newx(PL_markstack,REASONABLE(32),I32);
4054     PL_markstack_ptr = PL_markstack;
4055     PL_markstack_max = PL_markstack + REASONABLE(32);
4056
4057     SET_MARK_OFFSET;
4058
4059     Newx(PL_scopestack,REASONABLE(32),I32);
4060 #ifdef DEBUGGING
4061     Newx(PL_scopestack_name,REASONABLE(32),const char*);
4062 #endif
4063     PL_scopestack_ix = 0;
4064     PL_scopestack_max = REASONABLE(32);
4065
4066     Newx(PL_savestack,REASONABLE(128),ANY);
4067     PL_savestack_ix = 0;
4068     PL_savestack_max = REASONABLE(128);
4069 }
4070
4071 #undef REASONABLE
4072
4073 STATIC void
4074 S_nuke_stacks(pTHX)
4075 {
4076     dVAR;
4077     while (PL_curstackinfo->si_next)
4078         PL_curstackinfo = PL_curstackinfo->si_next;
4079     while (PL_curstackinfo) {
4080         PERL_SI *p = PL_curstackinfo->si_prev;
4081         /* curstackinfo->si_stack got nuked by sv_free_arenas() */
4082         Safefree(PL_curstackinfo->si_cxstack);
4083         Safefree(PL_curstackinfo);
4084         PL_curstackinfo = p;
4085     }
4086     Safefree(PL_tmps_stack);
4087     Safefree(PL_markstack);
4088     Safefree(PL_scopestack);
4089 #ifdef DEBUGGING
4090     Safefree(PL_scopestack_name);
4091 #endif
4092     Safefree(PL_savestack);
4093 }
4094
4095 void
4096 Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...)
4097 {
4098     GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV);
4099     AV *const isa = GvAVn(gv);
4100     va_list args;
4101
4102     PERL_ARGS_ASSERT_POPULATE_ISA;
4103
4104     if(AvFILLp(isa) != -1)
4105         return;
4106
4107     /* NOTE: No support for tied ISA */
4108
4109     va_start(args, len);
4110     do {
4111         const char *const parent = va_arg(args, const char*);
4112         size_t parent_len;
4113
4114         if (!parent)
4115             break;
4116         parent_len = va_arg(args, size_t);
4117
4118         /* Arguments are supplied with a trailing ::  */
4119         assert(parent_len > 2);
4120         assert(parent[parent_len - 1] == ':');
4121         assert(parent[parent_len - 2] == ':');
4122         av_push(isa, newSVpvn(parent, parent_len - 2));
4123         (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV);
4124     } while (1);
4125     va_end(args);
4126 }
4127
4128
4129 STATIC void
4130 S_init_predump_symbols(pTHX)
4131 {
4132     dVAR;
4133     GV *tmpgv;
4134     IO *io;
4135
4136     sv_setpvs(get_sv("\"", GV_ADD), " ");
4137     PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
4138
4139
4140     /* Historically, PVIOs were blessed into IO::Handle, unless
4141        FileHandle was loaded, in which case they were blessed into
4142        that. Action at a distance.
4143        However, if we simply bless into IO::Handle, we break code
4144        that assumes that PVIOs will have (among others) a seek
4145        method. IO::File inherits from IO::Handle and IO::Seekable,
4146        and provides the needed methods. But if we simply bless into
4147        it, then we break code that assumed that by loading
4148        IO::Handle, *it* would work.
4149        So a compromise is to set up the correct @IO::File::ISA,
4150        so that code that does C<use IO::Handle>; will still work.
4151     */
4152                    
4153     Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"),
4154                       STR_WITH_LEN("IO::Handle::"),
4155                       STR_WITH_LEN("IO::Seekable::"),
4156                       STR_WITH_LEN("Exporter::"),
4157                       NULL);
4158
4159     PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4160     GvMULTI_on(PL_stdingv);
4161     io = GvIOp(PL_stdingv);
4162     IoTYPE(io) = IoTYPE_RDONLY;
4163     IoIFP(io) = PerlIO_stdin();
4164     tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV);
4165     GvMULTI_on(tmpgv);
4166     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4167
4168     tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4169     GvMULTI_on(tmpgv);
4170     io = GvIOp(tmpgv);
4171     IoTYPE(io) = IoTYPE_WRONLY;
4172     IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4173     setdefout(tmpgv);
4174     tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV);
4175     GvMULTI_on(tmpgv);
4176     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4177
4178     PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO);
4179     GvMULTI_on(PL_stderrgv);
4180     io = GvIOp(PL_stderrgv);
4181     IoTYPE(io) = IoTYPE_WRONLY;
4182     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
4183     tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV);
4184     GvMULTI_on(tmpgv);
4185     GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io));
4186
4187     PL_statname = newSVpvs("");         /* last filename we did stat on */
4188 }
4189
4190 void
4191 Perl_init_argv_symbols(pTHX_ int argc, char **argv)
4192 {
4193     dVAR;
4194
4195     PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
4196
4197     argc--,argv++;      /* skip name of script */
4198     if (PL_doswitches) {
4199         for (; argc > 0 && **argv == '-'; argc--,argv++) {
4200             char *s;
4201             if (!argv[0][1])
4202                 break;
4203             if (argv[0][1] == '-' && !argv[0][2]) {
4204                 argc--,argv++;
4205                 break;
4206             }
4207             if ((s = strchr(argv[0], '='))) {
4208                 const char *const start_name = argv[0] + 1;
4209                 sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name,
4210                                                 TRUE, SVt_PV)), s + 1);
4211             }
4212             else
4213                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1);
4214         }
4215     }
4216     if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) {
4217         GvMULTI_on(PL_argvgv);
4218         (void)gv_AVadd(PL_argvgv);
4219         av_clear(GvAVn(PL_argvgv));
4220         for (; argc > 0; argc--,argv++) {
4221             SV * const sv = newSVpv(argv[0],0);
4222             av_push(GvAVn(PL_argvgv),sv);
4223             if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
4224                  if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
4225                       SvUTF8_on(sv);
4226             }
4227             if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
4228                  (void)sv_utf8_decode(sv);
4229         }
4230     }
4231
4232     if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1))
4233         Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
4234                          "-i used with no filenames on the command line, "
4235                          "reading from STDIN");
4236 }
4237
4238 STATIC void
4239 S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env)
4240 {
4241     dVAR;
4242     GV* tmpgv;
4243
4244     PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS;
4245
4246     PL_toptarget = newSV_type(SVt_PVIV);
4247     sv_setpvs(PL_toptarget, "");
4248     PL_bodytarget = newSV_type(SVt_PVIV);
4249     sv_setpvs(PL_bodytarget, "");
4250     PL_formtarget = PL_bodytarget;
4251
4252     TAINT;
4253
4254     init_argv_symbols(argc,argv);
4255
4256     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4257         sv_setpv(GvSV(tmpgv),PL_origfilename);
4258     }
4259     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
4260         HV *hv;
4261         bool env_is_not_environ;
4262         GvMULTI_on(PL_envgv);
4263         hv = GvHVn(PL_envgv);
4264         hv_magic(hv, NULL, PERL_MAGIC_env);
4265 #ifndef PERL_MICRO
4266 #ifdef USE_ENVIRON_ARRAY
4267         /* Note that if the supplied env parameter is actually a copy
4268            of the global environ then it may now point to free'd memory
4269            if the environment has been modified since. To avoid this
4270            problem we treat env==NULL as meaning 'use the default'
4271         */
4272         if (!env)
4273             env = environ;
4274         env_is_not_environ = env != environ;
4275         if (env_is_not_environ
4276 #  ifdef USE_ITHREADS
4277             && PL_curinterp == aTHX
4278 #  endif
4279            )
4280         {
4281             environ[0] = NULL;
4282         }
4283         if (env) {
4284           char *s, *old_var;
4285           SV *sv;
4286           for (; *env; env++) {
4287             old_var = *env;
4288
4289             if (!(s = strchr(old_var,'=')) || s == old_var)
4290                 continue;
4291
4292 #if defined(MSDOS) && !defined(DJGPP)
4293             *s = '\0';
4294             (void)strupr(old_var);
4295             *s = '=';
4296 #endif
4297             sv = newSVpv(s+1, 0);
4298             (void)hv_store(hv, old_var, s - old_var, sv, 0);
4299             if (env_is_not_environ)
4300                 mg_set(sv);
4301           }
4302       }
4303 #endif /* USE_ENVIRON_ARRAY */
4304 #endif /* !PERL_MICRO */
4305     }
4306     TAINT_NOT;
4307
4308     /* touch @F array to prevent spurious warnings 20020415 MJD */
4309     if (PL_minus_a) {
4310       (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
4311     }
4312 }
4313
4314 STATIC void
4315 S_init_perllib(pTHX)
4316 {
4317     dVAR;
4318 #ifndef VMS
4319     const char *perl5lib = NULL;
4320 #endif
4321     const char *s;
4322 #if defined(WIN32) && !defined(PERL_IS_MINIPERL)
4323     STRLEN len;
4324 #endif
4325
4326     if (!TAINTING_get) {
4327 #ifndef VMS
4328         perl5lib = PerlEnv_getenv("PERL5LIB");
4329 /*
4330  * It isn't possible to delete an environment variable with
4331  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4332  * case we treat PERL5LIB as undefined if it has a zero-length value.
4333  */
4334 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4335         if (perl5lib && *perl5lib != '\0')
4336 #else
4337         if (perl5lib)
4338 #endif
4339             incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
4340         else {
4341             s = PerlEnv_getenv("PERLLIB");
4342             if (s)
4343                 incpush_use_sep(s, 0, 0);
4344         }
4345 #else /* VMS */
4346         /* Treat PERL5?LIB as a possible search list logical name -- the
4347          * "natural" VMS idiom for a Unix path string.  We allow each
4348          * element to be a set of |-separated directories for compatibility.
4349          */
4350         char buf[256];
4351         int idx = 0;
4352         if (my_trnlnm("PERL5LIB",buf,0))
4353             do {
4354                 incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
4355             } while (my_trnlnm("PERL5LIB",buf,++idx));
4356         else {
4357             while (my_trnlnm("PERLLIB",buf,idx++))
4358                 incpush_use_sep(buf, 0, 0);
4359         }
4360 #endif /* VMS */
4361     }
4362
4363 #ifndef PERL_IS_MINIPERL
4364     /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
4365        (and not the architecture specific directories from $ENV{PERL5LIB}) */
4366
4367 /* Use the ~-expanded versions of APPLLIB (undocumented),
4368     SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB
4369 */
4370 #ifdef APPLLIB_EXP
4371     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP),
4372                       INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4373 #endif
4374
4375 #ifdef SITEARCH_EXP
4376     /* sitearch is always relative to sitelib on Windows for
4377      * DLL-based path intuition to work correctly */
4378 #  if !defined(WIN32)
4379         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP),
4380                           INCPUSH_CAN_RELOCATE);
4381 #  endif
4382 #endif
4383
4384 #ifdef SITELIB_EXP
4385 #  if defined(WIN32)
4386     /* this picks up sitearch as well */
4387         s = win32_get_sitelib(PERL_FS_VERSION, &len);
4388         if (s)
4389             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4390 #  else
4391         S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE);
4392 #  endif
4393 #endif
4394
4395 #ifdef PERL_VENDORARCH_EXP
4396     /* vendorarch is always relative to vendorlib on Windows for
4397      * DLL-based path intuition to work correctly */
4398 #  if !defined(WIN32)
4399     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP),
4400                       INCPUSH_CAN_RELOCATE);
4401 #  endif
4402 #endif
4403
4404 #ifdef PERL_VENDORLIB_EXP
4405 #  if defined(WIN32)
4406     /* this picks up vendorarch as well */
4407         s = win32_get_vendorlib(PERL_FS_VERSION, &len);
4408         if (s)
4409             incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4410 #  else
4411         S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP),
4412                           INCPUSH_CAN_RELOCATE);
4413 #  endif
4414 #endif
4415
4416 #ifdef ARCHLIB_EXP
4417     S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE);
4418 #endif
4419
4420 #ifndef PRIVLIB_EXP
4421 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
4422 #endif
4423
4424 #if defined(WIN32)
4425     s = win32_get_privlib(PERL_FS_VERSION, &len);
4426     if (s)
4427         incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE);
4428 #else
4429 #  ifdef NETWARE
4430     S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE);
4431 #  else
4432     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE);
4433 #  endif
4434 #endif
4435
4436 #ifdef PERL_OTHERLIBDIRS
4437     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4438                       INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR
4439                       |INCPUSH_CAN_RELOCATE);
4440 #endif
4441
4442     if (!TAINTING_get) {
4443 #ifndef VMS
4444 /*
4445  * It isn't possible to delete an environment variable with
4446  * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
4447  * case we treat PERL5LIB as undefined if it has a zero-length value.
4448  */
4449 #if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
4450         if (perl5lib && *perl5lib != '\0')
4451 #else
4452         if (perl5lib)
4453 #endif
4454             incpush_use_sep(perl5lib, 0,
4455                             INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4456 #else /* VMS */
4457         /* Treat PERL5?LIB as a possible search list logical name -- the
4458          * "natural" VMS idiom for a Unix path string.  We allow each
4459          * element to be a set of |-separated directories for compatibility.
4460          */
4461         char buf[256];
4462         int idx = 0;
4463         if (my_trnlnm("PERL5LIB",buf,0))
4464             do {
4465                 incpush_use_sep(buf, 0,
4466                                 INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR);
4467             } while (my_trnlnm("PERL5LIB",buf,++idx));
4468 #endif /* VMS */
4469     }
4470
4471 /* Use the ~-expanded versions of APPLLIB (undocumented),
4472     SITELIB and VENDORLIB for older versions
4473 */
4474 #ifdef APPLLIB_EXP
4475     S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS
4476                       |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE);
4477 #endif
4478
4479 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
4480     /* Search for version-specific dirs below here */
4481     S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM),
4482                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4483 #endif
4484
4485
4486 #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
4487     /* Search for version-specific dirs below here */
4488     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM),
4489                       INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE);
4490 #endif
4491
4492 #ifdef PERL_OTHERLIBDIRS
4493     S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS),
4494                       INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
4495                       |INCPUSH_CAN_RELOCATE);
4496 #endif
4497 #endif /* !PERL_IS_MINIPERL */
4498
4499     if (!TAINTING_get)
4500         S_incpush(aTHX_ STR_WITH_LEN("."), 0);
4501 }
4502
4503 #if defined(DOSISH) || defined(__SYMBIAN32__)
4504 #    define PERLLIB_SEP ';'
4505 #else
4506 #  if defined(VMS)
4507 #    define PERLLIB_SEP '|'
4508 #  else
4509 #    define PERLLIB_SEP ':'
4510 #  endif
4511 #endif
4512 #ifndef PERLLIB_MANGLE
4513 #  define PERLLIB_MANGLE(s,n) (s)
4514 #endif
4515
4516 #ifndef PERL_IS_MINIPERL
4517 /* Push a directory onto @INC if it exists.
4518    Generate a new SV if we do this, to save needing to copy the SV we push
4519    onto @INC  */
4520 STATIC SV *
4521 S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
4522 {
4523     dVAR;
4524     Stat_t tmpstatbuf;
4525
4526     PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS;
4527
4528     if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
4529         S_ISDIR(tmpstatbuf.st_mode)) {
4530         av_push(av, dir);
4531         dir = newSVsv(stem);
4532     } else {
4533         /* Truncate dir back to stem.  */
4534         SvCUR_set(dir, SvCUR(stem));
4535     }
4536     return dir;
4537 }
4538 #endif
4539
4540 STATIC SV *
4541 S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags)
4542 {
4543     const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE;
4544     SV *libdir;
4545
4546     PERL_ARGS_ASSERT_MAYBERELOCATE;
4547     assert(len > 0);
4548
4549     /* I am not convinced that this is valid when PERLLIB_MANGLE is
4550        defined to so something (in os2/os2.c), but the code has been
4551        this way, ignoring any possible changed of length, since
4552        760ac839baf413929cd31cc32ffd6dba6b781a81 (5.003_02) so I'll leave
4553        it be.  */
4554     libdir = newSVpvn(PERLLIB_MANGLE(dir, len), len);
4555
4556 #ifdef VMS
4557     {
4558         char *unix;
4559
4560         if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) {
4561             len = strlen(unix);
4562             while (unix[len-1] == '/') len--;  /* Cosmetic */
4563             sv_usepvn(libdir,unix,len);
4564         }
4565         else
4566             PerlIO_printf(Perl_error_log,
4567                           "Failed to unixify @INC element \"%s\"\n",
4568                           SvPV_nolen_const(libdir));
4569     }
4570 #endif
4571
4572         /* Do the if() outside the #ifdef to avoid warnings about an unused
4573            parameter.  */
4574         if (canrelocate) {
4575 #ifdef PERL_RELOCATABLE_INC
4576         /*
4577          * Relocatable include entries are marked with a leading .../
4578          *
4579          * The algorithm is
4580          * 0: Remove that leading ".../"
4581          * 1: Remove trailing executable name (anything after the last '/')
4582          *    from the perl path to give a perl prefix
4583          * Then
4584          * While the @INC element starts "../" and the prefix ends with a real
4585          * directory (ie not . or ..) chop that real directory off the prefix
4586          * and the leading "../" from the @INC element. ie a logical "../"
4587          * cleanup
4588          * Finally concatenate the prefix and the remainder of the @INC element
4589          * The intent is that /usr/local/bin/perl and .../../lib/perl5
4590          * generates /usr/local/lib/perl5
4591          */
4592             const char *libpath = SvPVX(libdir);
4593             STRLEN libpath_len = SvCUR(libdir);
4594             if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4595                 /* Game on!  */
4596                 SV * const caret_X = get_sv("\030", 0);
4597                 /* Going to use the SV just as a scratch buffer holding a C
4598                    string:  */
4599                 SV *prefix_sv;
4600                 char *prefix;
4601                 char *lastslash;
4602
4603                 /* $^X is *the* source of taint if tainting is on, hence
4604                    SvPOK() won't be true.  */
4605                 assert(caret_X);
4606                 assert(SvPOKp(caret_X));
4607                 prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X),
4608                                            SvUTF8(caret_X));
4609                 /* Firstly take off the leading .../
4610                    If all else fail we'll do the paths relative to the current
4611                    directory.  */
4612                 sv_chop(libdir, libpath + 4);
4613                 /* Don't use SvPV as we're intentionally bypassing taining,
4614                    mortal copies that the mg_get of tainting creates, and
4615                    corruption that seems to come via the save stack.
4616                    I guess that the save stack isn't correctly set up yet.  */
4617                 libpath = SvPVX(libdir);
4618                 libpath_len = SvCUR(libdir);
4619
4620                 /* This would work more efficiently with memrchr, but as it's
4621                    only a GNU extension we'd need to probe for it and
4622                    implement our own. Not hard, but maybe not worth it?  */
4623
4624                 prefix = SvPVX(prefix_sv);
4625                 lastslash = strrchr(prefix, '/');
4626
4627                 /* First time in with the *lastslash = '\0' we just wipe off
4628                    the trailing /perl from (say) /usr/foo/bin/perl
4629                 */
4630                 if (lastslash) {
4631                     SV *tempsv;
4632                     while ((*lastslash = '\0'), /* Do that, come what may.  */
4633                            (libpath_len >= 3 && memEQ(libpath, "../", 3)
4634                             && (lastslash = strrchr(prefix, '/')))) {
4635                         if (lastslash[1] == '\0'
4636                             || (lastslash[1] == '.'
4637                                 && (lastslash[2] == '/' /* ends "/."  */
4638                                     || (lastslash[2] == '/'
4639                                         && lastslash[3] == '/' /* or "/.."  */
4640                                         )))) {
4641                             /* Prefix ends "/" or "/." or "/..", any of which
4642                                are fishy, so don't do any more logical cleanup.
4643                             */
4644                             break;
4645                         }
4646                         /* Remove leading "../" from path  */
4647                         libpath += 3;
4648                         libpath_len -= 3;
4649                         /* Next iteration round the loop removes the last
4650                            directory name from prefix by writing a '\0' in
4651                            the while clause.  */
4652                     }
4653                     /* prefix has been terminated with a '\0' to the correct
4654                        length. libpath points somewhere into the libdir SV.
4655                        We need to join the 2 with '/' and drop the result into
4656                        libdir.  */
4657                     tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4658                     SvREFCNT_dec(libdir);
4659                     /* And this is the new libdir.  */
4660                     libdir = tempsv;
4661                     if (TAINTING_get &&
4662                         (PerlProc_getuid() != PerlProc_geteuid() ||
4663                          PerlProc_getgid() != PerlProc_getegid())) {
4664                         /* Need to taint relocated paths if running set ID  */
4665                         SvTAINTED_on(libdir);
4666                     }
4667                 }
4668                 SvREFCNT_dec(prefix_sv);
4669             }
4670 #endif
4671         }
4672     return libdir;
4673 }
4674
4675 STATIC void
4676 S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
4677 {
4678     dVAR;
4679 #ifndef PERL_IS_MINIPERL
4680     const U8 using_sub_dirs
4681         = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS
4682                        |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS);
4683     const U8 add_versioned_sub_dirs
4684         = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS;
4685     const U8 add_archonly_sub_dirs
4686         = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS;
4687 #ifdef PERL_INC_VERSION_LIST
4688     const U8 addoldvers  = (U8)flags & INCPUSH_ADD_OLD_VERS;
4689 #endif
4690 #endif
4691     const U8 unshift     = (U8)flags & INCPUSH_UNSHIFT;
4692     const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1;
4693     AV *const inc = GvAVn(PL_incgv);
4694
4695     PERL_ARGS_ASSERT_INCPUSH;
4696     assert(len > 0);
4697
4698     /* Could remove this vestigial extra block, if we don't mind a lot of
4699        re-indenting diff noise.  */
4700     {
4701         SV *const libdir = mayberelocate(dir, len, flags);
4702         /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665,
4703            arranged to unshift #! line -I onto the front of @INC. However,
4704            -I can add version and architecture specific libraries, and they
4705            need to go first. The old code assumed that it was always
4706            pushing. Hence to make it work, need to push the architecture
4707            (etc) libraries onto a temporary array, then "unshift" that onto
4708            the front of @INC.  */
4709 #ifndef PERL_IS_MINIPERL
4710         AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL;
4711
4712         /*
4713          * BEFORE pushing libdir onto @INC we may first push version- and
4714          * archname-specific sub-directories.
4715          */
4716         if (using_sub_dirs) {
4717             SV *subdir = newSVsv(libdir);
4718 #ifdef PERL_INC_VERSION_LIST
4719             /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4720             const char * const incverlist[] = { PERL_INC_VERSION_LIST };
4721             const char * const *incver;
4722 #endif
4723
4724             if (add_versioned_sub_dirs) {
4725                 /* .../version/archname if -d .../version/archname */
4726                 sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME);
4727                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4728
4729                 /* .../version if -d .../version */
4730                 sv_catpvs(subdir, "/" PERL_FS_VERSION);
4731                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4732             }
4733
4734 #ifdef PERL_INC_VERSION_LIST
4735             if (addoldvers) {
4736                 for (incver = incverlist; *incver; incver++) {
4737                     /* .../xxx if -d .../xxx */
4738                     Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver);
4739                     subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4740                 }
4741             }
4742 #endif
4743
4744             if (add_archonly_sub_dirs) {
4745                 /* .../archname if -d .../archname */
4746                 sv_catpvs(subdir, "/" ARCHNAME);
4747                 subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir);
4748
4749             }
4750
4751             assert (SvREFCNT(subdir) == 1);
4752             SvREFCNT_dec(subdir);
4753         }
4754 #endif /* !PERL_IS_MINIPERL */
4755         /* finally add this lib directory at the end of @INC */
4756         if (unshift) {
4757 #ifdef PERL_IS_MINIPERL
4758             const U32 extra = 0;
4759 #else
4760             U32 extra = av_len(av) + 1;
4761 #endif
4762             av_unshift(inc, extra + push_basedir);
4763             if (push_basedir)
4764                 av_store(inc, extra, libdir);
4765 #ifndef PERL_IS_MINIPERL
4766             while (extra--) {
4767                 /* av owns a reference, av_store() expects to be donated a
4768                    reference, and av expects to be sane when it's cleared.
4769                    If I wanted to be naughty and wrong, I could peek inside the
4770                    implementation of av_clear(), realise that it uses
4771                    SvREFCNT_dec() too, so av's array could be a run of NULLs,
4772                    and so directly steal from it (with a memcpy() to inc, and
4773                    then memset() to NULL them out. But people copy code from the
4774                    core expecting it to be best practise, so let's use the API.
4775                    Although studious readers will note that I'm not checking any
4776                    return codes.  */
4777                 av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE)));
4778             }
4779             SvREFCNT_dec(av);
4780 #endif
4781         }
4782         else if (push_basedir) {
4783             av_push(inc, libdir);
4784         }
4785
4786         if (!push_basedir) {
4787             assert (SvREFCNT(libdir) == 1);
4788             SvREFCNT_dec(libdir);
4789         }
4790     }
4791 }
4792
4793 STATIC void
4794 S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags)
4795 {
4796     const char *s;
4797     const char *end;
4798     /* This logic has been broken out from S_incpush(). It may be possible to
4799        simplify it.  */
4800
4801     PERL_ARGS_ASSERT_INCPUSH_USE_SEP;
4802
4803     /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len
4804      * argument to incpush_use_sep.  This allows creation of relocatable
4805      * Perl distributions that patch the binary at install time.  Those
4806      * distributions will have to provide their own relocation tools; this
4807      * is not a feature otherwise supported by core Perl.
4808      */
4809 #ifndef PERL_RELOCATABLE_INCPUSH
4810     if (!len)
4811 #endif
4812         len = strlen(p);
4813
4814     end = p + len;
4815
4816     /* Break at all separators */
4817     while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) {
4818         if (s == p) {
4819             /* skip any consecutive separators */
4820
4821             /* Uncomment the next line for PATH semantics */
4822             /* But you'll need to write tests */
4823             /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
4824         } else {
4825             incpush(p, (STRLEN)(s - p), flags);
4826         }
4827         p = s + 1;
4828     }
4829     if (p != end)
4830         incpush(p, (STRLEN)(end - p), flags);
4831
4832 }
4833
4834 void
4835 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4836 {
4837     dVAR;
4838     SV *atsv;
4839     volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
4840     CV *cv;
4841     STRLEN len;
4842     int ret;
4843     dJMPENV;