File Coverage

perl.c
Criterion Covered Total %
statement 1161 1517 76.5
branch 261 1076 24.3
condition n/a
subroutine n/a
total 1422 2593 54.8


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