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