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