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