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