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