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