This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don't bother prettifying win32/perldll.def
[perl5.git] / util.c
CommitLineData
a0d0e21e 1/* util.c
a687059c 2 *
1129b882
NC
3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
a687059c 5 *
d48672a2
LW
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8d063cd8 8 *
8d063cd8 9 */
a0d0e21e
LW
10
11/*
4ac71550
TC
12 * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content.' --Gandalf to Pippin
14 *
cdad3b53 15 * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
a0d0e21e 16 */
8d063cd8 17
166f8a29
DM
18/* This file contains assorted utility routines.
19 * Which is a polite way of saying any stuff that people couldn't think of
20 * a better place for. Amongst other things, it includes the warning and
21 * dieing stuff, plus wrappers for malloc code.
22 */
23
8d063cd8 24#include "EXTERN.h"
864dbfa3 25#define PERL_IN_UTIL_C
8d063cd8 26#include "perl.h"
7dc86639 27#include "reentr.h"
62b28dd9 28
97cb92d6 29#if defined(USE_PERLIO)
2e0cfa16 30#include "perliol.h" /* For PerlIOUnix_refcnt */
6f408c34 31#endif
2e0cfa16 32
64ca3a65 33#ifndef PERL_MICRO
a687059c 34#include <signal.h>
36477c24
PP
35#ifndef SIG_ERR
36# define SIG_ERR ((Sighandler_t) -1)
37#endif
64ca3a65 38#endif
36477c24 39
3be8f094
TC
40#include <math.h>
41#include <stdlib.h>
42
172d2248
OS
43#ifdef __Lynx__
44/* Missing protos on LynxOS */
45int putenv(char *);
46#endif
47
868439a2
JH
48#ifdef HAS_SELECT
49# ifdef I_SYS_SELECT
50# include <sys/select.h>
51# endif
52#endif
53
470dd224 54#ifdef USE_C_BACKTRACE
0762e42f
JH
55# ifdef I_BFD
56# define USE_BFD
57# ifdef PERL_DARWIN
58# undef USE_BFD /* BFD is useless in OS X. */
59# endif
60# ifdef USE_BFD
61# include <bfd.h>
62# endif
63# endif
470dd224
JH
64# ifdef I_DLFCN
65# include <dlfcn.h>
66# endif
67# ifdef I_EXECINFO
68# include <execinfo.h>
69# endif
70#endif
71
b001a0d1
FC
72#ifdef PERL_DEBUG_READONLY_COW
73# include <sys/mman.h>
74#endif
75
8d063cd8 76#define FLUSH
8d063cd8 77
a687059c
LW
78/* NOTE: Do not call the next three routines directly. Use the macros
79 * in handy.h, so that we can easily redefine everything to do tracking of
80 * allocated hunks back to the original New to track down any memory leaks.
20cec16a 81 * XXX This advice seems to be widely ignored :-( --AD August 1996.
a687059c
LW
82 */
83
79a92154 84#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
1f4d2d4e
NC
85# define ALWAYS_NEED_THX
86#endif
87
b001a0d1
FC
88#if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
89static void
90S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
91{
92 if (header->readonly
93 && mprotect(header, header->size, PROT_READ|PROT_WRITE))
94 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
95 header, header->size, errno);
96}
97
98static void
99S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
100{
101 if (header->readonly
102 && mprotect(header, header->size, PROT_READ))
103 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
104 header, header->size, errno);
105}
106# define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
107# define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
108#else
109# define maybe_protect_rw(foo) NOOP
110# define maybe_protect_ro(foo) NOOP
111#endif
112
3f07c2bc
FC
113#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
114 /* Use memory_debug_header */
115# define USE_MDH
116# if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
117 || defined(PERL_DEBUG_READONLY_COW)
118# define MDH_HAS_SIZE
119# endif
120#endif
121
26fa51c3
AMS
122/* paranoid version of system's malloc() */
123
bd4080b3 124Malloc_t
4f63d024 125Perl_safesysmalloc(MEM_SIZE size)
8d063cd8 126{
1f4d2d4e 127#ifdef ALWAYS_NEED_THX
54aff467 128 dTHX;
0cb20dae 129#endif
bd4080b3 130 Malloc_t ptr;
a78adc84 131 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
34de22dd 132#ifdef DEBUGGING
03c5309f 133 if ((SSize_t)size < 0)
5637ef5b 134 Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
34de22dd 135#endif
b001a0d1
FC
136 if (!size) size = 1; /* malloc(0) is NASTY on our system */
137#ifdef PERL_DEBUG_READONLY_COW
138 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
139 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
140 perror("mmap failed");
141 abort();
142 }
143#else
144 ptr = (Malloc_t)PerlMem_malloc(size?size:1);
145#endif
da927450 146 PERL_ALLOC_CHECK(ptr);
bd61b366 147 if (ptr != NULL) {
3f07c2bc 148#ifdef USE_MDH
7cb608b5
NC
149 struct perl_memory_debug_header *const header
150 = (struct perl_memory_debug_header *)ptr;
9a083ecf
NC
151#endif
152
153#ifdef PERL_POISON
7e337ee0 154 PoisonNew(((char *)ptr), size, char);
9a083ecf 155#endif
7cb608b5 156
9a083ecf 157#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC
158 header->interpreter = aTHX;
159 /* Link us into the list. */
160 header->prev = &PL_memory_debug_header;
161 header->next = PL_memory_debug_header.next;
162 PL_memory_debug_header.next = header;
b001a0d1 163 maybe_protect_rw(header->next);
7cb608b5 164 header->next->prev = header;
b001a0d1
FC
165 maybe_protect_ro(header->next);
166# ifdef PERL_DEBUG_READONLY_COW
167 header->readonly = 0;
cd1541b2 168# endif
e8dda941 169#endif
3f07c2bc 170#ifdef MDH_HAS_SIZE
b001a0d1
FC
171 header->size = size;
172#endif
b033d668 173 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
5dfff8f3 174 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
b033d668
DD
175
176 }
8d063cd8 177 else {
1f4d2d4e 178#ifndef ALWAYS_NEED_THX
0cb20dae
NC
179 dTHX;
180#endif
c62df97f 181 if (PL_nomemok)
b033d668
DD
182 ptr = NULL;
183 else
4cbe3a7d 184 croak_no_mem();
8d063cd8 185 }
b033d668 186 return ptr;
8d063cd8
LW
187}
188
f2517201 189/* paranoid version of system's realloc() */
8d063cd8 190
bd4080b3 191Malloc_t
4f63d024 192Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
8d063cd8 193{
1f4d2d4e 194#ifdef ALWAYS_NEED_THX
54aff467 195 dTHX;
0cb20dae 196#endif
bd4080b3 197 Malloc_t ptr;
b001a0d1
FC
198#ifdef PERL_DEBUG_READONLY_COW
199 const MEM_SIZE oldsize = where
a78adc84 200 ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
b001a0d1
FC
201 : 0;
202#endif
9a34ef1d 203#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
6ad3d225 204 Malloc_t PerlMem_realloc();
ecfc5424 205#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
8d063cd8 206
7614df0c 207 if (!size) {
f2517201 208 safesysfree(where);
b033d668 209 ptr = NULL;
7614df0c 210 }
b033d668
DD
211 else if (!where) {
212 ptr = safesysmalloc(size);
213 }
214 else {
3f07c2bc 215#ifdef USE_MDH
b033d668
DD
216 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
217 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
218 {
219 struct perl_memory_debug_header *const header
220 = (struct perl_memory_debug_header *)where;
7cb608b5 221
b001a0d1 222# ifdef PERL_TRACK_MEMPOOL
b033d668
DD
223 if (header->interpreter != aTHX) {
224 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
225 header->interpreter, aTHX);
226 }
227 assert(header->next->prev == header);
228 assert(header->prev->next == header);
cd1541b2 229# ifdef PERL_POISON
b033d668
DD
230 if (header->size > size) {
231 const MEM_SIZE freed_up = header->size - size;
232 char *start_of_freed = ((char *)where) + size;
233 PoisonFree(start_of_freed, freed_up, char);
234 }
cd1541b2 235# endif
b001a0d1 236# endif
3f07c2bc 237# ifdef MDH_HAS_SIZE
b033d668 238 header->size = size;
b001a0d1 239# endif
b033d668 240 }
e8dda941 241#endif
34de22dd 242#ifdef DEBUGGING
b033d668
DD
243 if ((SSize_t)size < 0)
244 Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
34de22dd 245#endif
b001a0d1 246#ifdef PERL_DEBUG_READONLY_COW
b033d668
DD
247 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
248 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
249 perror("mmap failed");
250 abort();
251 }
252 Copy(where,ptr,oldsize < size ? oldsize : size,char);
253 if (munmap(where, oldsize)) {
254 perror("munmap failed");
255 abort();
256 }
b001a0d1 257#else
b033d668 258 ptr = (Malloc_t)PerlMem_realloc(where,size);
b001a0d1 259#endif
b033d668 260 PERL_ALLOC_CHECK(ptr);
a1d180c4 261
4fd0a9b8
NC
262 /* MUST do this fixup first, before doing ANYTHING else, as anything else
263 might allocate memory/free/move memory, and until we do the fixup, it
264 may well be chasing (and writing to) free memory. */
b033d668 265 if (ptr != NULL) {
b001a0d1 266#ifdef PERL_TRACK_MEMPOOL
b033d668
DD
267 struct perl_memory_debug_header *const header
268 = (struct perl_memory_debug_header *)ptr;
7cb608b5 269
9a083ecf 270# ifdef PERL_POISON
b033d668
DD
271 if (header->size < size) {
272 const MEM_SIZE fresh = size - header->size;
273 char *start_of_fresh = ((char *)ptr) + size;
274 PoisonNew(start_of_fresh, fresh, char);
275 }
9a083ecf
NC
276# endif
277
b033d668
DD
278 maybe_protect_rw(header->next);
279 header->next->prev = header;
280 maybe_protect_ro(header->next);
281 maybe_protect_rw(header->prev);
282 header->prev->next = header;
283 maybe_protect_ro(header->prev);
b001a0d1 284#endif
b033d668
DD
285 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
286 }
4fd0a9b8
NC
287
288 /* In particular, must do that fixup above before logging anything via
289 *printf(), as it can reallocate memory, which can cause SEGVs. */
290
b033d668
DD
291 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
292 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
4fd0a9b8 293
b033d668 294 if (ptr == NULL) {
1f4d2d4e 295#ifndef ALWAYS_NEED_THX
b033d668 296 dTHX;
0cb20dae 297#endif
b033d668
DD
298 if (PL_nomemok)
299 ptr = NULL;
300 else
301 croak_no_mem();
0cb20dae 302 }
8d063cd8 303 }
b033d668 304 return ptr;
8d063cd8
LW
305}
306
f2517201 307/* safe version of system's free() */
8d063cd8 308
54310121 309Free_t
4f63d024 310Perl_safesysfree(Malloc_t where)
8d063cd8 311{
79a92154 312#ifdef ALWAYS_NEED_THX
54aff467 313 dTHX;
155aba94 314#endif
97835f67 315 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
378cc40b 316 if (where) {
3f07c2bc 317#ifdef USE_MDH
6edcbed6 318 Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
cd1541b2 319 {
7cb608b5 320 struct perl_memory_debug_header *const header
6edcbed6 321 = (struct perl_memory_debug_header *)where_intrn;
7cb608b5 322
3f07c2bc 323# ifdef MDH_HAS_SIZE
b001a0d1
FC
324 const MEM_SIZE size = header->size;
325# endif
326# ifdef PERL_TRACK_MEMPOOL
7cb608b5 327 if (header->interpreter != aTHX) {
5637ef5b
NC
328 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
329 header->interpreter, aTHX);
7cb608b5
NC
330 }
331 if (!header->prev) {
cd1541b2
NC
332 Perl_croak_nocontext("panic: duplicate free");
333 }
5637ef5b
NC
334 if (!(header->next))
335 Perl_croak_nocontext("panic: bad free, header->next==NULL");
336 if (header->next->prev != header || header->prev->next != header) {
337 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
338 "header=%p, ->prev->next=%p",
339 header->next->prev, header,
340 header->prev->next);
cd1541b2 341 }
7cb608b5 342 /* Unlink us from the chain. */
b001a0d1 343 maybe_protect_rw(header->next);
7cb608b5 344 header->next->prev = header->prev;
b001a0d1
FC
345 maybe_protect_ro(header->next);
346 maybe_protect_rw(header->prev);
7cb608b5 347 header->prev->next = header->next;
b001a0d1
FC
348 maybe_protect_ro(header->prev);
349 maybe_protect_rw(header);
7cb608b5 350# ifdef PERL_POISON
6edcbed6 351 PoisonNew(where_intrn, size, char);
cd1541b2 352# endif
7cb608b5
NC
353 /* Trigger the duplicate free warning. */
354 header->next = NULL;
b001a0d1
FC
355# endif
356# ifdef PERL_DEBUG_READONLY_COW
6edcbed6 357 if (munmap(where_intrn, size)) {
b001a0d1
FC
358 perror("munmap failed");
359 abort();
360 }
361# endif
7cb608b5 362 }
6edcbed6
DD
363#else
364 Malloc_t where_intrn = where;
365#endif /* USE_MDH */
b001a0d1 366#ifndef PERL_DEBUG_READONLY_COW
6edcbed6 367 PerlMem_free(where_intrn);
b001a0d1 368#endif
378cc40b 369 }
8d063cd8
LW
370}
371
f2517201 372/* safe version of system's calloc() */
1050c9ca 373
bd4080b3 374Malloc_t
4f63d024 375Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
1050c9ca 376{
1f4d2d4e 377#ifdef ALWAYS_NEED_THX
54aff467 378 dTHX;
0cb20dae 379#endif
bd4080b3 380 Malloc_t ptr;
3f07c2bc 381#if defined(USE_MDH) || defined(DEBUGGING)
ad7244db 382 MEM_SIZE total_size = 0;
4b1123b9 383#endif
1050c9ca 384
ad7244db 385 /* Even though calloc() for zero bytes is strange, be robust. */
4b1123b9 386 if (size && (count <= MEM_SIZE_MAX / size)) {
3f07c2bc 387#if defined(USE_MDH) || defined(DEBUGGING)
ad7244db 388 total_size = size * count;
4b1123b9
NC
389#endif
390 }
ad7244db 391 else
d1decf2b 392 croak_memory_wrap();
3f07c2bc 393#ifdef USE_MDH
a78adc84
DM
394 if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
395 total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
ad7244db 396 else
d1decf2b 397 croak_memory_wrap();
ad7244db 398#endif
1050c9ca 399#ifdef DEBUGGING
03c5309f 400 if ((SSize_t)size < 0 || (SSize_t)count < 0)
5637ef5b
NC
401 Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
402 (UV)size, (UV)count);
1050c9ca 403#endif
b001a0d1
FC
404#ifdef PERL_DEBUG_READONLY_COW
405 if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
406 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
407 perror("mmap failed");
408 abort();
409 }
410#elif defined(PERL_TRACK_MEMPOOL)
e1a95402
NC
411 /* Have to use malloc() because we've added some space for our tracking
412 header. */
ad7244db
JH
413 /* malloc(0) is non-portable. */
414 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
e1a95402
NC
415#else
416 /* Use calloc() because it might save a memset() if the memory is fresh
417 and clean from the OS. */
ad7244db
JH
418 if (count && size)
419 ptr = (Malloc_t)PerlMem_calloc(count, size);
420 else /* calloc(0) is non-portable. */
421 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
e8dda941 422#endif
da927450 423 PERL_ALLOC_CHECK(ptr);
e1a95402 424 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
bd61b366 425 if (ptr != NULL) {
3f07c2bc 426#ifdef USE_MDH
7cb608b5
NC
427 {
428 struct perl_memory_debug_header *const header
429 = (struct perl_memory_debug_header *)ptr;
430
b001a0d1 431# ifndef PERL_DEBUG_READONLY_COW
e1a95402 432 memset((void*)ptr, 0, total_size);
b001a0d1
FC
433# endif
434# ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC
435 header->interpreter = aTHX;
436 /* Link us into the list. */
437 header->prev = &PL_memory_debug_header;
438 header->next = PL_memory_debug_header.next;
439 PL_memory_debug_header.next = header;
b001a0d1 440 maybe_protect_rw(header->next);
7cb608b5 441 header->next->prev = header;
b001a0d1
FC
442 maybe_protect_ro(header->next);
443# ifdef PERL_DEBUG_READONLY_COW
444 header->readonly = 0;
445# endif
446# endif
3f07c2bc 447# ifdef MDH_HAS_SIZE
e1a95402 448 header->size = total_size;
cd1541b2 449# endif
a78adc84 450 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
7cb608b5 451 }
e8dda941 452#endif
1050c9ca
PP
453 return ptr;
454 }
0cb20dae 455 else {
1f4d2d4e 456#ifndef ALWAYS_NEED_THX
0cb20dae
NC
457 dTHX;
458#endif
459 if (PL_nomemok)
460 return NULL;
4cbe3a7d 461 croak_no_mem();
0cb20dae 462 }
1050c9ca
PP
463}
464
cae6d0e5
GS
465/* These must be defined when not using Perl's malloc for binary
466 * compatibility */
467
468#ifndef MYMALLOC
469
470Malloc_t Perl_malloc (MEM_SIZE nbytes)
471{
20b7effb
JH
472#ifdef PERL_IMPLICIT_SYS
473 dTHX;
474#endif
077a72a9 475 return (Malloc_t)PerlMem_malloc(nbytes);
cae6d0e5
GS
476}
477
478Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
479{
20b7effb
JH
480#ifdef PERL_IMPLICIT_SYS
481 dTHX;
482#endif
077a72a9 483 return (Malloc_t)PerlMem_calloc(elements, size);
cae6d0e5
GS
484}
485
486Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
487{
20b7effb
JH
488#ifdef PERL_IMPLICIT_SYS
489 dTHX;
490#endif
077a72a9 491 return (Malloc_t)PerlMem_realloc(where, nbytes);
cae6d0e5
GS
492}
493
494Free_t Perl_mfree (Malloc_t where)
495{
20b7effb
JH
496#ifdef PERL_IMPLICIT_SYS
497 dTHX;
498#endif
cae6d0e5
GS
499 PerlMem_free(where);
500}
501
502#endif
503
8d063cd8
LW
504/* copy a string up to some (non-backslashed) delimiter, if any */
505
506char *
5aaab254 507Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
8d063cd8 508{
eb578fdb 509 I32 tolen;
35da51f7 510
7918f24d
NC
511 PERL_ARGS_ASSERT_DELIMCPY;
512
fc36a67e 513 for (tolen = 0; from < fromend; from++, tolen++) {
378cc40b 514 if (*from == '\\') {
35da51f7 515 if (from[1] != delim) {
fc36a67e
PP
516 if (to < toend)
517 *to++ = *from;
518 tolen++;
fc36a67e 519 }
35da51f7 520 from++;
378cc40b 521 }
bedebaa5 522 else if (*from == delim)
8d063cd8 523 break;
fc36a67e
PP
524 if (to < toend)
525 *to++ = *from;
8d063cd8 526 }
bedebaa5
CS
527 if (to < toend)
528 *to = '\0';
fc36a67e 529 *retlen = tolen;
73d840c0 530 return (char *)from;
8d063cd8
LW
531}
532
533/* return ptr to little string in big string, NULL if not found */
378cc40b 534/* This routine was donated by Corey Satten. */
8d063cd8
LW
535
536char *
5aaab254 537Perl_instr(const char *big, const char *little)
378cc40b 538{
378cc40b 539
7918f24d
NC
540 PERL_ARGS_ASSERT_INSTR;
541
9c4b6232
KW
542 /* libc prior to 4.6.27 (late 1994) did not work properly on a NULL
543 * 'little' */
a687059c 544 if (!little)
08105a92 545 return (char*)big;
5d1d68e2 546 return strstr((char*)big, (char*)little);
378cc40b 547}
8d063cd8 548
e057d092
KW
549/* same as instr but allow embedded nulls. The end pointers point to 1 beyond
550 * the final character desired to be checked */
a687059c
LW
551
552char *
04c9e624 553Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
8d063cd8 554{
7918f24d 555 PERL_ARGS_ASSERT_NINSTR;
4c8626be
GA
556 if (little >= lend)
557 return (char*)big;
558 {
8ba22ff4 559 const char first = *little;
4c8626be 560 const char *s, *x;
8ba22ff4 561 bigend -= lend - little++;
4c8626be
GA
562 OUTER:
563 while (big <= bigend) {
b0ca24ee
JH
564 if (*big++ == first) {
565 for (x=big,s=little; s < lend; x++,s++) {
566 if (*s != *x)
567 goto OUTER;
568 }
569 return (char*)(big-1);
4c8626be 570 }
4c8626be 571 }
378cc40b 572 }
bd61b366 573 return NULL;
a687059c
LW
574}
575
576/* reverse of the above--find last substring */
577
578char *
5aaab254 579Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
a687059c 580{
eb578fdb
KW
581 const char *bigbeg;
582 const I32 first = *little;
583 const char * const littleend = lend;
a687059c 584
7918f24d
NC
585 PERL_ARGS_ASSERT_RNINSTR;
586
260d78c9 587 if (little >= littleend)
08105a92 588 return (char*)bigend;
a687059c
LW
589 bigbeg = big;
590 big = bigend - (littleend - little++);
591 while (big >= bigbeg) {
eb578fdb 592 const char *s, *x;
a687059c
LW
593 if (*big-- != first)
594 continue;
595 for (x=big+2,s=little; s < littleend; /**/ ) {
4fc877ac 596 if (*s != *x)
a687059c 597 break;
4fc877ac
AL
598 else {
599 x++;
600 s++;
a687059c
LW
601 }
602 }
603 if (s >= littleend)
08105a92 604 return (char*)(big+1);
378cc40b 605 }
bd61b366 606 return NULL;
378cc40b 607}
a687059c 608
cf93c79d
IZ
609/* As a space optimization, we do not compile tables for strings of length
610 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
611 special-cased in fbm_instr().
612
613 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
614
954c1994 615/*
ccfc67b7
JH
616=head1 Miscellaneous Functions
617
954c1994
GS
618=for apidoc fbm_compile
619
620Analyses the string in order to make fast searches on it using fbm_instr()
621-- the Boyer-Moore algorithm.
622
623=cut
624*/
625
378cc40b 626void
7506f9c3 627Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
378cc40b 628{
eb578fdb 629 const U8 *s;
ea725ce6 630 STRLEN i;
0b71040e 631 STRLEN len;
79072805 632 U32 frequency = 256;
2bda37ba 633 MAGIC *mg;
00cccd05 634 PERL_DEB( STRLEN rarest = 0 );
79072805 635
7918f24d
NC
636 PERL_ARGS_ASSERT_FBM_COMPILE;
637
948d2370 638 if (isGV_with_GP(sv) || SvROK(sv))
4265b45d
NC
639 return;
640
9402563a
NC
641 if (SvVALID(sv))
642 return;
643
c517dc2b 644 if (flags & FBMcf_TAIL) {
890ce7af 645 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
396482e1 646 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
c517dc2b
JH
647 if (mg && mg->mg_len >= 0)
648 mg->mg_len++;
649 }
11609d9c 650 if (!SvPOK(sv) || SvNIOKp(sv))
66379c06
FC
651 s = (U8*)SvPV_force_mutable(sv, len);
652 else s = (U8 *)SvPV_mutable(sv, len);
d1be9408 653 if (len == 0) /* TAIL might be on a zero-length string. */
cf93c79d 654 return;
c13a5c80 655 SvUPGRADE(sv, SVt_PVMG);
78d0cf80 656 SvIOK_off(sv);
8eeaf79a
NC
657 SvNOK_off(sv);
658 SvVALID_on(sv);
2bda37ba
NC
659
660 /* "deep magic", the comment used to add. The use of MAGIC itself isn't
661 really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
662 to call SvVALID_off() if the scalar was assigned to.
663
664 The comment itself (and "deeper magic" below) date back to
665 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
666 str->str_pok |= 2;
667 where the magic (presumably) was that the scalar had a BM table hidden
668 inside itself.
669
670 As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
671 the table instead of the previous (somewhat hacky) approach of co-opting
672 the string buffer and storing it after the string. */
673
674 assert(!mg_find(sv, PERL_MAGIC_bm));
675 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
676 assert(mg);
677
02128f11 678 if (len > 2) {
21aeb718
NC
679 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
680 the BM table. */
66a1b24b 681 const U8 mlen = (len>255) ? 255 : (U8)len;
2bda37ba 682 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
eb578fdb 683 U8 *table;
cf93c79d 684
2bda37ba 685 Newx(table, 256, U8);
7506f9c3 686 memset((void*)table, mlen, 256);
2bda37ba
NC
687 mg->mg_ptr = (char *)table;
688 mg->mg_len = 256;
689
690 s += len - 1; /* last char */
02128f11 691 i = 0;
cf93c79d
IZ
692 while (s >= sb) {
693 if (table[*s] == mlen)
7506f9c3 694 table[*s] = (U8)i;
cf93c79d
IZ
695 s--, i++;
696 }
378cc40b 697 }
378cc40b 698
9cbe880b 699 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
bbce6d69 700 for (i = 0; i < len; i++) {
22c35a8c 701 if (PL_freq[s[i]] < frequency) {
00cccd05 702 PERL_DEB( rarest = i );
22c35a8c 703 frequency = PL_freq[s[i]];
378cc40b
LW
704 }
705 }
cf93c79d
IZ
706 BmUSEFUL(sv) = 100; /* Initial value */
707 if (flags & FBMcf_TAIL)
708 SvTAIL_on(sv);
ea725ce6 709 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
d80cf470 710 s[rarest], (UV)rarest));
378cc40b
LW
711}
712
cf93c79d
IZ
713/* If SvTAIL(littlestr), it has a fake '\n' at end. */
714/* If SvTAIL is actually due to \Z or \z, this gives false positives
715 if multiline */
716
954c1994
GS
717/*
718=for apidoc fbm_instr
719
3f4963df
FC
720Returns the location of the SV in the string delimited by C<big> and
721C<bigend>. It returns C<NULL> if the string can't be found. The C<sv>
954c1994
GS
722does not have to be fbm_compiled, but the search will not be as fast
723then.
724
725=cut
726*/
727
378cc40b 728char *
5aaab254 729Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
378cc40b 730{
eb578fdb 731 unsigned char *s;
cf93c79d 732 STRLEN l;
eb578fdb
KW
733 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
734 STRLEN littlelen = l;
735 const I32 multiline = flags & FBMrf_MULTILINE;
cf93c79d 736
7918f24d
NC
737 PERL_ARGS_ASSERT_FBM_INSTR;
738
eb160463 739 if ((STRLEN)(bigend - big) < littlelen) {
a1d180c4 740 if ( SvTAIL(littlestr)
eb160463 741 && ((STRLEN)(bigend - big) == littlelen - 1)
a1d180c4 742 && (littlelen == 1
12ae5dfc 743 || (*big == *little &&
27da23d5 744 memEQ((char *)big, (char *)little, littlelen - 1))))
cf93c79d 745 return (char*)big;
bd61b366 746 return NULL;
cf93c79d 747 }
378cc40b 748
21aeb718
NC
749 switch (littlelen) { /* Special cases for 0, 1 and 2 */
750 case 0:
751 return (char*)big; /* Cannot be SvTAIL! */
752 case 1:
cf93c79d
IZ
753 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
754 /* Know that bigend != big. */
755 if (bigend[-1] == '\n')
756 return (char *)(bigend - 1);
757 return (char *) bigend;
758 }
759 s = big;
760 while (s < bigend) {
761 if (*s == *little)
762 return (char *)s;
763 s++;
764 }
765 if (SvTAIL(littlestr))
766 return (char *) bigend;
bd61b366 767 return NULL;
21aeb718 768 case 2:
cf93c79d
IZ
769 if (SvTAIL(littlestr) && !multiline) {
770 if (bigend[-1] == '\n' && bigend[-2] == *little)
771 return (char*)bigend - 2;
772 if (bigend[-1] == *little)
773 return (char*)bigend - 1;
bd61b366 774 return NULL;
cf93c79d
IZ
775 }
776 {
777 /* This should be better than FBM if c1 == c2, and almost
778 as good otherwise: maybe better since we do less indirection.
779 And we save a lot of memory by caching no table. */
66a1b24b
AL
780 const unsigned char c1 = little[0];
781 const unsigned char c2 = little[1];
cf93c79d
IZ
782
783 s = big + 1;
784 bigend--;
785 if (c1 != c2) {
786 while (s <= bigend) {
787 if (s[0] == c2) {
788 if (s[-1] == c1)
789 return (char*)s - 1;
790 s += 2;
791 continue;
3fe6f2dc 792 }
cf93c79d
IZ
793 next_chars:
794 if (s[0] == c1) {
795 if (s == bigend)
796 goto check_1char_anchor;
797 if (s[1] == c2)
798 return (char*)s;
799 else {
800 s++;
801 goto next_chars;
802 }
803 }
804 else
805 s += 2;
806 }
807 goto check_1char_anchor;
808 }
809 /* Now c1 == c2 */
810 while (s <= bigend) {
811 if (s[0] == c1) {
812 if (s[-1] == c1)
813 return (char*)s - 1;
814 if (s == bigend)
815 goto check_1char_anchor;
816 if (s[1] == c1)
817 return (char*)s;
818 s += 3;
02128f11 819 }
c277df42 820 else
cf93c79d 821 s += 2;
c277df42 822 }
c277df42 823 }
cf93c79d
IZ
824 check_1char_anchor: /* One char and anchor! */
825 if (SvTAIL(littlestr) && (*bigend == *little))
826 return (char *)bigend; /* bigend is already decremented. */
bd61b366 827 return NULL;
21aeb718
NC
828 default:
829 break; /* Only lengths 0 1 and 2 have special-case code. */
d48672a2 830 }
21aeb718 831
cf93c79d 832 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
bbce6d69 833 s = bigend - littlelen;
a1d180c4 834 if (s >= big && bigend[-1] == '\n' && *s == *little
cf93c79d
IZ
835 /* Automatically of length > 2 */
836 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
7506f9c3 837 {
bbce6d69 838 return (char*)s; /* how sweet it is */
7506f9c3
GS
839 }
840 if (s[1] == *little
841 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
842 {
cf93c79d 843 return (char*)s + 1; /* how sweet it is */
7506f9c3 844 }
bd61b366 845 return NULL;
02128f11 846 }
cecf5685 847 if (!SvVALID(littlestr)) {
c4420975 848 char * const b = ninstr((char*)big,(char*)bigend,
cf93c79d
IZ
849 (char*)little, (char*)little + littlelen);
850
851 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
852 /* Chop \n from littlestr: */
853 s = bigend - littlelen + 1;
7506f9c3
GS
854 if (*s == *little
855 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
856 {
3fe6f2dc 857 return (char*)s;
7506f9c3 858 }
bd61b366 859 return NULL;
a687059c 860 }
cf93c79d 861 return b;
a687059c 862 }
a1d180c4 863
3566a07d
NC
864 /* Do actual FBM. */
865 if (littlelen > (STRLEN)(bigend - big))
866 return NULL;
867
868 {
2bda37ba 869 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
eb578fdb 870 const unsigned char *oldlittle;
cf93c79d 871
316ebaf2
JH
872 assert(mg);
873
cf93c79d
IZ
874 --littlelen; /* Last char found by table lookup */
875
876 s = big + littlelen;
877 little += littlelen; /* last char */
878 oldlittle = little;
879 if (s < bigend) {
316ebaf2 880 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
eb578fdb 881 I32 tmp;
cf93c79d
IZ
882
883 top2:
7506f9c3 884 if ((tmp = table[*s])) {
cf93c79d 885 if ((s += tmp) < bigend)
62b28dd9 886 goto top2;
cf93c79d
IZ
887 goto check_end;
888 }
889 else { /* less expensive than calling strncmp() */
eb578fdb 890 unsigned char * const olds = s;
cf93c79d
IZ
891
892 tmp = littlelen;
893
894 while (tmp--) {
895 if (*--s == *--little)
896 continue;
cf93c79d
IZ
897 s = olds + 1; /* here we pay the price for failure */
898 little = oldlittle;
899 if (s < bigend) /* fake up continue to outer loop */
900 goto top2;
901 goto check_end;
902 }
903 return (char *)s;
a687059c 904 }
378cc40b 905 }
cf93c79d 906 check_end:
c8029a41 907 if ( s == bigend
cffe132d 908 && SvTAIL(littlestr)
12ae5dfc
JH
909 && memEQ((char *)(bigend - littlelen),
910 (char *)(oldlittle - littlelen), littlelen) )
cf93c79d 911 return (char*)bigend - littlelen;
bd61b366 912 return NULL;
378cc40b 913 }
378cc40b
LW
914}
915
e6226b18
KW
916/*
917=for apidoc foldEQ
918
919Returns true if the leading len bytes of the strings s1 and s2 are the same
920case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
921match themselves and their opposite case counterparts. Non-cased and non-ASCII
922range bytes match only themselves.
923
924=cut
925*/
926
927
79072805 928I32
5aaab254 929Perl_foldEQ(const char *s1, const char *s2, I32 len)
79072805 930{
eb578fdb
KW
931 const U8 *a = (const U8 *)s1;
932 const U8 *b = (const U8 *)s2;
96a5add6 933
e6226b18 934 PERL_ARGS_ASSERT_FOLDEQ;
7918f24d 935
223f01db
KW
936 assert(len >= 0);
937
79072805 938 while (len--) {
22c35a8c 939 if (*a != *b && *a != PL_fold[*b])
e6226b18 940 return 0;
bbce6d69
PP
941 a++,b++;
942 }
e6226b18 943 return 1;
bbce6d69 944}
1b9f127b 945I32
5aaab254 946Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1b9f127b
KW
947{
948 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
949 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
950 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
951 * does it check that the strings each have at least 'len' characters */
952
eb578fdb
KW
953 const U8 *a = (const U8 *)s1;
954 const U8 *b = (const U8 *)s2;
1b9f127b
KW
955
956 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
957
223f01db
KW
958 assert(len >= 0);
959
1b9f127b
KW
960 while (len--) {
961 if (*a != *b && *a != PL_fold_latin1[*b]) {
962 return 0;
963 }
964 a++, b++;
965 }
966 return 1;
967}
bbce6d69 968
e6226b18
KW
969/*
970=for apidoc foldEQ_locale
971
972Returns true if the leading len bytes of the strings s1 and s2 are the same
973case-insensitively in the current locale; false otherwise.
974
975=cut
976*/
977
bbce6d69 978I32
5aaab254 979Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
bbce6d69 980{
27da23d5 981 dVAR;
eb578fdb
KW
982 const U8 *a = (const U8 *)s1;
983 const U8 *b = (const U8 *)s2;
96a5add6 984
e6226b18 985 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
7918f24d 986
223f01db
KW
987 assert(len >= 0);
988
bbce6d69 989 while (len--) {
22c35a8c 990 if (*a != *b && *a != PL_fold_locale[*b])
e6226b18 991 return 0;
bbce6d69 992 a++,b++;
79072805 993 }
e6226b18 994 return 1;
79072805
LW
995}
996
8d063cd8
LW
997/* copy a string to a safe spot */
998
954c1994 999/*
ccfc67b7
JH
1000=head1 Memory Management
1001
954c1994
GS
1002=for apidoc savepv
1003
72d33970
FC
1004Perl's version of C<strdup()>. Returns a pointer to a newly allocated
1005string which is a duplicate of C<pv>. The size of the string is
30a15352
KW
1006determined by C<strlen()>, which means it may not contain embedded C<NUL>
1007characters and must have a trailing C<NUL>. The memory allocated for the new
1008string can be freed with the C<Safefree()> function.
954c1994 1009
0358c255
KW
1010On some platforms, Windows for example, all allocated memory owned by a thread
1011is deallocated when that thread ends. So if you need that not to happen, you
1012need to use the shared memory functions, such as C<L</savesharedpv>>.
1013
954c1994
GS
1014=cut
1015*/
1016
8d063cd8 1017char *
efdfce31 1018Perl_savepv(pTHX_ const char *pv)
8d063cd8 1019{
96a5add6 1020 PERL_UNUSED_CONTEXT;
e90e2364 1021 if (!pv)
bd61b366 1022 return NULL;
66a1b24b
AL
1023 else {
1024 char *newaddr;
1025 const STRLEN pvlen = strlen(pv)+1;
10edeb5d
JH
1026 Newx(newaddr, pvlen, char);
1027 return (char*)memcpy(newaddr, pv, pvlen);
66a1b24b 1028 }
8d063cd8
LW
1029}
1030
a687059c
LW
1031/* same thing but with a known length */
1032
954c1994
GS
1033/*
1034=for apidoc savepvn
1035
72d33970 1036Perl's version of what C<strndup()> would be if it existed. Returns a
61a925ed 1037pointer to a newly allocated string which is a duplicate of the first
72d33970 1038C<len> bytes from C<pv>, plus a trailing
6602b933 1039C<NUL> byte. The memory allocated for
cbf82dd0 1040the new string can be freed with the C<Safefree()> function.
954c1994 1041
0358c255
KW
1042On some platforms, Windows for example, all allocated memory owned by a thread
1043is deallocated when that thread ends. So if you need that not to happen, you
1044need to use the shared memory functions, such as C<L</savesharedpvn>>.
1045
954c1994
GS
1046=cut
1047*/
1048
a687059c 1049char *
5aaab254 1050Perl_savepvn(pTHX_ const char *pv, I32 len)
a687059c 1051{
eb578fdb 1052 char *newaddr;
96a5add6 1053 PERL_UNUSED_CONTEXT;
a687059c 1054
223f01db
KW
1055 assert(len >= 0);
1056
a02a5408 1057 Newx(newaddr,len+1,char);
92110913 1058 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
efdfce31 1059 if (pv) {
e90e2364
NC
1060 /* might not be null terminated */
1061 newaddr[len] = '\0';
07409e01 1062 return (char *) CopyD(pv,newaddr,len,char);
92110913
NIS
1063 }
1064 else {
07409e01 1065 return (char *) ZeroD(newaddr,len+1,char);
92110913 1066 }
a687059c
LW
1067}
1068
05ec9bb3
NIS
1069/*
1070=for apidoc savesharedpv
1071
61a925ed
AMS
1072A version of C<savepv()> which allocates the duplicate string in memory
1073which is shared between threads.
05ec9bb3
NIS
1074
1075=cut
1076*/
1077char *
efdfce31 1078Perl_savesharedpv(pTHX_ const char *pv)
05ec9bb3 1079{
eb578fdb 1080 char *newaddr;
490a0e98 1081 STRLEN pvlen;
dc3bf405
BF
1082
1083 PERL_UNUSED_CONTEXT;
1084
e90e2364 1085 if (!pv)
bd61b366 1086 return NULL;
e90e2364 1087
490a0e98
NC
1088 pvlen = strlen(pv)+1;
1089 newaddr = (char*)PerlMemShared_malloc(pvlen);
e90e2364 1090 if (!newaddr) {
4cbe3a7d 1091 croak_no_mem();
05ec9bb3 1092 }
10edeb5d 1093 return (char*)memcpy(newaddr, pv, pvlen);
05ec9bb3
NIS
1094}
1095
2e0de35c 1096/*
d9095cec
NC
1097=for apidoc savesharedpvn
1098
1099A version of C<savepvn()> which allocates the duplicate string in memory
72d33970 1100which is shared between threads. (With the specific difference that a NULL
d9095cec
NC
1101pointer is not acceptable)
1102
1103=cut
1104*/
1105char *
1106Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1107{
1108 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
7918f24d 1109
dc3bf405 1110 PERL_UNUSED_CONTEXT;
6379d4a9 1111 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
7918f24d 1112
d9095cec 1113 if (!newaddr) {
4cbe3a7d 1114 croak_no_mem();
d9095cec
NC
1115 }
1116 newaddr[len] = '\0';
1117 return (char*)memcpy(newaddr, pv, len);
1118}
1119
1120/*
2e0de35c
NC
1121=for apidoc savesvpv
1122
6832267f 1123A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
2e0de35c
NC
1124the passed in SV using C<SvPV()>
1125
0358c255
KW
1126On some platforms, Windows for example, all allocated memory owned by a thread
1127is deallocated when that thread ends. So if you need that not to happen, you
1128need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1129
2e0de35c
NC
1130=cut
1131*/
1132
1133char *
1134Perl_savesvpv(pTHX_ SV *sv)
1135{
1136 STRLEN len;
7452cf6a 1137 const char * const pv = SvPV_const(sv, len);
eb578fdb 1138 char *newaddr;
2e0de35c 1139
7918f24d
NC
1140 PERL_ARGS_ASSERT_SAVESVPV;
1141
26866f99 1142 ++len;
a02a5408 1143 Newx(newaddr,len,char);
07409e01 1144 return (char *) CopyD(pv,newaddr,len,char);
2e0de35c 1145}
05ec9bb3 1146
9dcc53ea
Z
1147/*
1148=for apidoc savesharedsvpv
1149
1150A version of C<savesharedpv()> which allocates the duplicate string in
1151memory which is shared between threads.
1152
1153=cut
1154*/
1155
1156char *
1157Perl_savesharedsvpv(pTHX_ SV *sv)
1158{
1159 STRLEN len;
1160 const char * const pv = SvPV_const(sv, len);
1161
1162 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1163
1164 return savesharedpvn(pv, len);
1165}
05ec9bb3 1166
cea2e8a9 1167/* the SV for Perl_form() and mess() is not kept in an arena */
fc36a67e 1168
76e3520e 1169STATIC SV *
cea2e8a9 1170S_mess_alloc(pTHX)
fc36a67e
PP
1171{
1172 SV *sv;
1173 XPVMG *any;
1174
627364f1 1175 if (PL_phase != PERL_PHASE_DESTRUCT)
84bafc02 1176 return newSVpvs_flags("", SVs_TEMP);
e72dc28c 1177
0372dbb6
GS
1178 if (PL_mess_sv)
1179 return PL_mess_sv;
1180
fc36a67e 1181 /* Create as PVMG now, to avoid any upgrading later */
a02a5408
JC
1182 Newx(sv, 1, SV);
1183 Newxz(any, 1, XPVMG);
fc36a67e
PP
1184 SvFLAGS(sv) = SVt_PVMG;
1185 SvANY(sv) = (void*)any;
6136c704 1186 SvPV_set(sv, NULL);
fc36a67e 1187 SvREFCNT(sv) = 1 << 30; /* practically infinite */
e72dc28c 1188 PL_mess_sv = sv;
fc36a67e
PP
1189 return sv;
1190}
1191
c5be433b 1192#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1193char *
1194Perl_form_nocontext(const char* pat, ...)
1195{
1196 dTHX;
c5be433b 1197 char *retval;
cea2e8a9 1198 va_list args;
7918f24d 1199 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
cea2e8a9 1200 va_start(args, pat);
c5be433b 1201 retval = vform(pat, &args);
cea2e8a9 1202 va_end(args);
c5be433b 1203 return retval;
cea2e8a9 1204}
c5be433b 1205#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1206
7c9e965c 1207/*
ccfc67b7 1208=head1 Miscellaneous Functions
7c9e965c
JP
1209=for apidoc form
1210
1211Takes a sprintf-style format pattern and conventional
1212(non-SV) arguments and returns the formatted string.
1213
1214 (char *) Perl_form(pTHX_ const char* pat, ...)
1215
1216can be used any place a string (char *) is required:
1217
1218 char * s = Perl_form("%d.%d",major,minor);
1219
1220Uses a single private buffer so if you want to format several strings you
1221must explicitly copy the earlier strings away (and free the copies when you
1222are done).
1223
1224=cut
1225*/
1226
8990e307 1227char *
864dbfa3 1228Perl_form(pTHX_ const char* pat, ...)
8990e307 1229{
c5be433b 1230 char *retval;
46fc3d4c 1231 va_list args;
7918f24d 1232 PERL_ARGS_ASSERT_FORM;
46fc3d4c 1233 va_start(args, pat);
c5be433b 1234 retval = vform(pat, &args);
46fc3d4c 1235 va_end(args);
c5be433b
GS
1236 return retval;
1237}
1238
1239char *
1240Perl_vform(pTHX_ const char *pat, va_list *args)
1241{
2d03de9c 1242 SV * const sv = mess_alloc();
7918f24d 1243 PERL_ARGS_ASSERT_VFORM;
4608196e 1244 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
e72dc28c 1245 return SvPVX(sv);
46fc3d4c 1246}
a687059c 1247
c5df3096
Z
1248/*
1249=for apidoc Am|SV *|mess|const char *pat|...
1250
1251Take a sprintf-style format pattern and argument list. These are used to
1252generate a string message. If the message does not end with a newline,
1253then it will be extended with some indication of the current location
1254in the code, as described for L</mess_sv>.
1255
1256Normally, the resulting message is returned in a new mortal SV.
1257During global destruction a single SV may be shared between uses of
1258this function.
1259
1260=cut
1261*/
1262
5a844595
GS
1263#if defined(PERL_IMPLICIT_CONTEXT)
1264SV *
1265Perl_mess_nocontext(const char *pat, ...)
1266{
1267 dTHX;
1268 SV *retval;
1269 va_list args;
7918f24d 1270 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
5a844595
GS
1271 va_start(args, pat);
1272 retval = vmess(pat, &args);
1273 va_end(args);
1274 return retval;
1275}
1276#endif /* PERL_IMPLICIT_CONTEXT */
1277
06bf62c7 1278SV *
5a844595
GS
1279Perl_mess(pTHX_ const char *pat, ...)
1280{
1281 SV *retval;
1282 va_list args;
7918f24d 1283 PERL_ARGS_ASSERT_MESS;
5a844595
GS
1284 va_start(args, pat);
1285 retval = vmess(pat, &args);
1286 va_end(args);
1287 return retval;
1288}
1289
25502127
FC
1290const COP*
1291Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1292 bool opnext)
ae7d165c 1293{
25502127
FC
1294 /* Look for curop starting from o. cop is the last COP we've seen. */
1295 /* opnext means that curop is actually the ->op_next of the op we are
1296 seeking. */
ae7d165c 1297
7918f24d
NC
1298 PERL_ARGS_ASSERT_CLOSEST_COP;
1299
25502127
FC
1300 if (!o || !curop || (
1301 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1302 ))
fabdb6c0 1303 return cop;
ae7d165c
PJ
1304
1305 if (o->op_flags & OPf_KIDS) {
5f66b61c 1306 const OP *kid;
e6dae479 1307 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
5f66b61c 1308 const COP *new_cop;
ae7d165c
PJ
1309
1310 /* If the OP_NEXTSTATE has been optimised away we can still use it
1311 * the get the file and line number. */
1312
1313 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
5f66b61c 1314 cop = (const COP *)kid;
ae7d165c
PJ
1315
1316 /* Keep searching, and return when we've found something. */
1317
25502127 1318 new_cop = closest_cop(cop, kid, curop, opnext);
fabdb6c0
AL
1319 if (new_cop)
1320 return new_cop;
ae7d165c
PJ
1321 }
1322 }
1323
1324 /* Nothing found. */
1325
5f66b61c 1326 return NULL;
ae7d165c
PJ
1327}
1328
c5df3096
Z
1329/*
1330=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1331
1332Expands a message, intended for the user, to include an indication of
1333the current location in the code, if the message does not already appear
1334to be complete.
1335
1336C<basemsg> is the initial message or object. If it is a reference, it
1337will be used as-is and will be the result of this function. Otherwise it
1338is used as a string, and if it already ends with a newline, it is taken
1339to be complete, and the result of this function will be the same string.
1340If the message does not end with a newline, then a segment such as C<at
1341foo.pl line 37> will be appended, and possibly other clauses indicating
1342the current state of execution. The resulting message will end with a
1343dot and a newline.
1344
1345Normally, the resulting message is returned in a new mortal SV.
1346During global destruction a single SV may be shared between uses of this
1347function. If C<consume> is true, then the function is permitted (but not
1348required) to modify and return C<basemsg> instead of allocating a new SV.
1349
1350=cut
1351*/
1352
5a844595 1353SV *
c5df3096 1354Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
46fc3d4c 1355{
c5df3096 1356 SV *sv;
46fc3d4c 1357
0762e42f 1358#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
470dd224
JH
1359 {
1360 char *ws;
1361 int wi;
1362 /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
0762e42f 1363 if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR")) &&
96e440d2 1364 (wi = grok_atou(ws, NULL)) > 0) {
470dd224
JH
1365 Perl_dump_c_backtrace(aTHX_ Perl_debug_log, wi, 1);
1366 }
1367 }
1368#endif
1369
c5df3096
Z
1370 PERL_ARGS_ASSERT_MESS_SV;
1371
1372 if (SvROK(basemsg)) {
1373 if (consume) {
1374 sv = basemsg;
1375 }
1376 else {
1377 sv = mess_alloc();
1378 sv_setsv(sv, basemsg);
1379 }
1380 return sv;
1381 }
1382
1383 if (SvPOK(basemsg) && consume) {
1384 sv = basemsg;
1385 }
1386 else {
1387 sv = mess_alloc();
1388 sv_copypv(sv, basemsg);
1389 }
7918f24d 1390
46fc3d4c 1391 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
ae7d165c
PJ
1392 /*
1393 * Try and find the file and line for PL_op. This will usually be
1394 * PL_curcop, but it might be a cop that has been optimised away. We
1395 * can try to find such a cop by searching through the optree starting
1396 * from the sibling of PL_curcop.
1397 */
1398
25502127 1399 const COP *cop =
e6dae479 1400 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
5f66b61c
AL
1401 if (!cop)
1402 cop = PL_curcop;
ae7d165c
PJ
1403
1404 if (CopLINE(cop))
ed094faf 1405 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
3aed30dc 1406 OutCopFILE(cop), (IV)CopLINE(cop));
191f87d5
DH
1407 /* Seems that GvIO() can be untrustworthy during global destruction. */
1408 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1409 && IoLINES(GvIOp(PL_last_in_gv)))
1410 {
2748e602 1411 STRLEN l;
e1ec3a88 1412 const bool line_mode = (RsSIMPLE(PL_rs) &&
2748e602 1413 *SvPV_const(PL_rs,l) == '\n' && l == 1);
3b46b707
BF
1414 Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1415 SVfARG(PL_last_in_gv == PL_argvgv
1416 ? &PL_sv_no
1417 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
edc2eac3
JH
1418 line_mode ? "line" : "chunk",
1419 (IV)IoLINES(GvIOp(PL_last_in_gv)));
a687059c 1420 }
627364f1 1421 if (PL_phase == PERL_PHASE_DESTRUCT)
5f66b61c
AL
1422 sv_catpvs(sv, " during global destruction");
1423 sv_catpvs(sv, ".\n");
a687059c 1424 }
06bf62c7 1425 return sv;
a687059c
LW
1426}
1427
c5df3096
Z
1428/*
1429=for apidoc Am|SV *|vmess|const char *pat|va_list *args
1430
1431C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1432argument list. These are used to generate a string message. If the
1433message does not end with a newline, then it will be extended with
1434some indication of the current location in the code, as described for
1435L</mess_sv>.
1436
1437Normally, the resulting message is returned in a new mortal SV.
1438During global destruction a single SV may be shared between uses of
1439this function.
1440
1441=cut
1442*/
1443
1444SV *
1445Perl_vmess(pTHX_ const char *pat, va_list *args)
1446{
c5df3096
Z
1447 SV * const sv = mess_alloc();
1448
1449 PERL_ARGS_ASSERT_VMESS;
1450
1451 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1452 return mess_sv(sv, 1);
1453}
1454
7ff03255 1455void
7d0994e0 1456Perl_write_to_stderr(pTHX_ SV* msv)
7ff03255
SG
1457{
1458 IO *io;
1459 MAGIC *mg;
1460
7918f24d
NC
1461 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1462
7ff03255
SG
1463 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1464 && (io = GvIO(PL_stderrgv))
daba3364 1465 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
36925d9e 1466 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
d1d7a15d 1467 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
7ff03255 1468 else {
53c1dcc0 1469 PerlIO * const serr = Perl_error_log;
7ff03255 1470
83c55556 1471 do_print(msv, serr);
7ff03255 1472 (void)PerlIO_flush(serr);
7ff03255
SG
1473 }
1474}
1475
c5df3096
Z
1476/*
1477=head1 Warning and Dieing
1478*/
1479
1480/* Common code used in dieing and warning */
1481
1482STATIC SV *
1483S_with_queued_errors(pTHX_ SV *ex)
1484{
1485 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1486 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1487 sv_catsv(PL_errors, ex);
1488 ex = sv_mortalcopy(PL_errors);
1489 SvCUR_set(PL_errors, 0);
1490 }
1491 return ex;
1492}
3ab1ac99 1493
46d9c920 1494STATIC bool
c5df3096 1495S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
63315e18
NC
1496{
1497 HV *stash;
1498 GV *gv;
1499 CV *cv;
46d9c920
NC
1500 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1501 /* sv_2cv might call Perl_croak() or Perl_warner() */
1502 SV * const oldhook = *hook;
1503
c5df3096
Z
1504 if (!oldhook)
1505 return FALSE;
63315e18 1506
63315e18 1507 ENTER;
46d9c920
NC
1508 SAVESPTR(*hook);
1509 *hook = NULL;
1510 cv = sv_2cv(oldhook, &stash, &gv, 0);
63315e18
NC
1511 LEAVE;
1512 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1513 dSP;
c5df3096 1514 SV *exarg;
63315e18
NC
1515
1516 ENTER;
46d9c920
NC
1517 if (warn) {
1518 SAVESPTR(*hook);
1519 *hook = NULL;
1520 }
c5df3096
Z
1521 exarg = newSVsv(ex);
1522 SvREADONLY_on(exarg);
1523 SAVEFREESV(exarg);
63315e18 1524
46d9c920 1525 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
63315e18 1526 PUSHMARK(SP);
c5df3096 1527 XPUSHs(exarg);
63315e18 1528 PUTBACK;
daba3364 1529 call_sv(MUTABLE_SV(cv), G_DISCARD);
63315e18
NC
1530 POPSTACK;
1531 LEAVE;
46d9c920 1532 return TRUE;
63315e18 1533 }
46d9c920 1534 return FALSE;
63315e18
NC
1535}
1536
c5df3096
Z
1537/*
1538=for apidoc Am|OP *|die_sv|SV *baseex
e07360fa 1539
c5df3096
Z
1540Behaves the same as L</croak_sv>, except for the return type.
1541It should be used only where the C<OP *> return type is required.
1542The function never actually returns.
e07360fa 1543
c5df3096
Z
1544=cut
1545*/
e07360fa 1546
f8d5a522
DD
1547#ifdef _MSC_VER
1548# pragma warning( push )
1549# pragma warning( disable : 4646 ) /* warning C4646: function declared with
1550 __declspec(noreturn) has non-void return type */
1551# pragma warning( disable : 4645 ) /* warning C4645: function declared with
1552__declspec(noreturn) has a return statement */
1553#endif
c5df3096
Z
1554OP *
1555Perl_die_sv(pTHX_ SV *baseex)
36477c24 1556{
c5df3096
Z
1557 PERL_ARGS_ASSERT_DIE_SV;
1558 croak_sv(baseex);
e5964223 1559 /* NOTREACHED */
117af67d 1560 NORETURN_FUNCTION_END;
36477c24 1561}
f8d5a522
DD
1562#ifdef _MSC_VER
1563# pragma warning( pop )
1564#endif
36477c24 1565
c5df3096
Z
1566/*
1567=for apidoc Am|OP *|die|const char *pat|...
1568
1569Behaves the same as L</croak>, except for the return type.
1570It should be used only where the C<OP *> return type is required.
1571The function never actually returns.
1572
1573=cut
1574*/
1575
c5be433b 1576#if defined(PERL_IMPLICIT_CONTEXT)
f8d5a522
DD
1577#ifdef _MSC_VER
1578# pragma warning( push )
1579# pragma warning( disable : 4646 ) /* warning C4646: function declared with
1580 __declspec(noreturn) has non-void return type */
1581# pragma warning( disable : 4645 ) /* warning C4645: function declared with
1582__declspec(noreturn) has a return statement */
1583#endif
cea2e8a9
GS
1584OP *
1585Perl_die_nocontext(const char* pat, ...)
a687059c 1586{
cea2e8a9 1587 dTHX;
a687059c 1588 va_list args;
cea2e8a9 1589 va_start(args, pat);
c5df3096 1590 vcroak(pat, &args);
e5964223 1591 NOT_REACHED; /* NOTREACHED */
cea2e8a9 1592 va_end(args);
117af67d 1593 NORETURN_FUNCTION_END;
cea2e8a9 1594}
f8d5a522
DD
1595#ifdef _MSC_VER
1596# pragma warning( pop )
1597#endif
c5be433b 1598#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1599
f8d5a522
DD
1600#ifdef _MSC_VER
1601# pragma warning( push )
1602# pragma warning( disable : 4646 ) /* warning C4646: function declared with
1603 __declspec(noreturn) has non-void return type */
1604# pragma warning( disable : 4645 ) /* warning C4645: function declared with
1605__declspec(noreturn) has a return statement */
1606#endif
cea2e8a9
GS
1607OP *
1608Perl_die(pTHX_ const char* pat, ...)
1609{
cea2e8a9
GS
1610 va_list args;
1611 va_start(args, pat);
c5df3096 1612 vcroak(pat, &args);
e5964223 1613 NOT_REACHED; /* NOTREACHED */
cea2e8a9 1614 va_end(args);
117af67d 1615 NORETURN_FUNCTION_END;
cea2e8a9 1616}
f8d5a522
DD
1617#ifdef _MSC_VER
1618# pragma warning( pop )
1619#endif
cea2e8a9 1620
c5df3096
Z
1621/*
1622=for apidoc Am|void|croak_sv|SV *baseex
1623
1624This is an XS interface to Perl's C<die> function.
1625
1626C<baseex> is the error message or object. If it is a reference, it
1627will be used as-is. Otherwise it is used as a string, and if it does
1628not end with a newline then it will be extended with some indication of
1629the current location in the code, as described for L</mess_sv>.
1630
1631The error message or object will be used as an exception, by default
1632returning control to the nearest enclosing C<eval>, but subject to
1633modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1634function never returns normally.
1635
1636To die with a simple string message, the L</croak> function may be
1637more convenient.
1638
1639=cut
1640*/
1641
c5be433b 1642void
c5df3096 1643Perl_croak_sv(pTHX_ SV *baseex)
cea2e8a9 1644{
c5df3096
Z
1645 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1646 PERL_ARGS_ASSERT_CROAK_SV;
1647 invoke_exception_hook(ex, FALSE);
1648 die_unwind(ex);
1649}
1650
1651/*
1652=for apidoc Am|void|vcroak|const char *pat|va_list *args
1653
1654This is an XS interface to Perl's C<die> function.
1655
1656C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1657argument list. These are used to generate a string message. If the
1658message does not end with a newline, then it will be extended with
1659some indication of the current location in the code, as described for
1660L</mess_sv>.
1661
1662The error message will be used as an exception, by default
1663returning control to the nearest enclosing C<eval>, but subject to
1664modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1665function never returns normally.
a687059c 1666
c5df3096
Z
1667For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1668(C<$@>) will be used as an error message or object instead of building an
1669error message from arguments. If you want to throw a non-string object,
1670or build an error message in an SV yourself, it is preferable to use
1671the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
5a844595 1672
c5df3096
Z
1673=cut
1674*/
1675
1676void
1677Perl_vcroak(pTHX_ const char* pat, va_list *args)
1678{
1679 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1680 invoke_exception_hook(ex, FALSE);
1681 die_unwind(ex);
a687059c
LW
1682}
1683
c5df3096
Z
1684/*
1685=for apidoc Am|void|croak|const char *pat|...
1686
1687This is an XS interface to Perl's C<die> function.
1688
1689Take a sprintf-style format pattern and argument list. These are used to
1690generate a string message. If the message does not end with a newline,
1691then it will be extended with some indication of the current location
1692in the code, as described for L</mess_sv>.
1693
1694The error message will be used as an exception, by default
1695returning control to the nearest enclosing C<eval>, but subject to
1696modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1697function never returns normally.
1698
1699For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1700(C<$@>) will be used as an error message or object instead of building an
1701error message from arguments. If you want to throw a non-string object,
1702or build an error message in an SV yourself, it is preferable to use
1703the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1704
1705=cut
1706*/
1707
c5be433b 1708#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1709void
cea2e8a9 1710Perl_croak_nocontext(const char *pat, ...)
a687059c 1711{
cea2e8a9 1712 dTHX;
a687059c 1713 va_list args;
cea2e8a9 1714 va_start(args, pat);
c5be433b 1715 vcroak(pat, &args);
e5964223 1716 NOT_REACHED; /* NOTREACHED */
cea2e8a9
GS
1717 va_end(args);
1718}
1719#endif /* PERL_IMPLICIT_CONTEXT */
1720
c5df3096
Z
1721void
1722Perl_croak(pTHX_ const char *pat, ...)
1723{
1724 va_list args;
1725 va_start(args, pat);
1726 vcroak(pat, &args);
e5964223 1727 NOT_REACHED; /* NOTREACHED */
c5df3096
Z
1728 va_end(args);
1729}
1730
954c1994 1731/*
6ad8f254
NC
1732=for apidoc Am|void|croak_no_modify
1733
1734Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
72d33970 1735terser object code than using C<Perl_croak>. Less code used on exception code
6ad8f254
NC
1736paths reduces CPU cache pressure.
1737
d8e47b5c 1738=cut
6ad8f254
NC
1739*/
1740
1741void
88772978 1742Perl_croak_no_modify(void)
6ad8f254 1743{
cb077ed2 1744 Perl_croak_nocontext( "%s", PL_no_modify);
6ad8f254
NC
1745}
1746
4cbe3a7d
DD
1747/* does not return, used in util.c perlio.c and win32.c
1748 This is typically called when malloc returns NULL.
1749*/
1750void
88772978 1751Perl_croak_no_mem(void)
4cbe3a7d
DD
1752{
1753 dTHX;
77c1c05b 1754
375ed12a
JH
1755 int fd = PerlIO_fileno(Perl_error_log);
1756 if (fd < 0)
1757 SETERRNO(EBADF,RMS_IFI);
1758 else {
1759 /* Can't use PerlIO to write as it allocates memory */
b469f1e0 1760 PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
375ed12a 1761 }
4cbe3a7d
DD
1762 my_exit(1);
1763}
1764
3d04513d
DD
1765/* does not return, used only in POPSTACK */
1766void
1767Perl_croak_popstack(void)
1768{
1769 dTHX;
1770 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1771 my_exit(1);
1772}
1773
6ad8f254 1774/*
c5df3096 1775=for apidoc Am|void|warn_sv|SV *baseex
ccfc67b7 1776
c5df3096 1777This is an XS interface to Perl's C<warn> function.
954c1994 1778
c5df3096
Z
1779C<baseex> is the error message or object. If it is a reference, it
1780will be used as-is. Otherwise it is used as a string, and if it does
1781not end with a newline then it will be extended with some indication of
1782the current location in the code, as described for L</mess_sv>.
9983fa3c 1783
c5df3096
Z
1784The error message or object will by default be written to standard error,
1785but this is subject to modification by a C<$SIG{__WARN__}> handler.
9983fa3c 1786
c5df3096
Z
1787To warn with a simple string message, the L</warn> function may be
1788more convenient.
954c1994
GS
1789
1790=cut
1791*/
1792
cea2e8a9 1793void
c5df3096 1794Perl_warn_sv(pTHX_ SV *baseex)
cea2e8a9 1795{
c5df3096
Z
1796 SV *ex = mess_sv(baseex, 0);
1797 PERL_ARGS_ASSERT_WARN_SV;
1798 if (!invoke_exception_hook(ex, TRUE))
1799 write_to_stderr(ex);
cea2e8a9
GS
1800}
1801
c5df3096
Z
1802/*
1803=for apidoc Am|void|vwarn|const char *pat|va_list *args
1804
1805This is an XS interface to Perl's C<warn> function.
1806
1807C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1808argument list. These are used to generate a string message. If the
1809message does not end with a newline, then it will be extended with
1810some indication of the current location in the code, as described for
1811L</mess_sv>.
1812
1813The error message or object will by default be written to standard error,
1814but this is subject to modification by a C<$SIG{__WARN__}> handler.
1815
1816Unlike with L</vcroak>, C<pat> is not permitted to be null.
1817
1818=cut
1819*/
1820
c5be433b
GS
1821void
1822Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1823{
c5df3096 1824 SV *ex = vmess(pat, args);
7918f24d 1825 PERL_ARGS_ASSERT_VWARN;
c5df3096
Z
1826 if (!invoke_exception_hook(ex, TRUE))
1827 write_to_stderr(ex);
1828}
7918f24d 1829
c5df3096
Z
1830/*
1831=for apidoc Am|void|warn|const char *pat|...
87582a92 1832
c5df3096
Z
1833This is an XS interface to Perl's C<warn> function.
1834
1835Take a sprintf-style format pattern and argument list. These are used to
1836generate a string message. If the message does not end with a newline,
1837then it will be extended with some indication of the current location
1838in the code, as described for L</mess_sv>.
1839
1840The error message or object will by default be written to standard error,
1841but this is subject to modification by a C<$SIG{__WARN__}> handler.
1842
1843Unlike with L</croak>, C<pat> is not permitted to be null.
1844
1845=cut
1846*/
8d063cd8 1847
c5be433b 1848#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1849void
1850Perl_warn_nocontext(const char *pat, ...)
1851{
1852 dTHX;
1853 va_list args;
7918f24d 1854 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
cea2e8a9 1855 va_start(args, pat);
c5be433b 1856 vwarn(pat, &args);
cea2e8a9
GS
1857 va_end(args);
1858}
1859#endif /* PERL_IMPLICIT_CONTEXT */
1860
1861void
1862Perl_warn(pTHX_ const char *pat, ...)
1863{
1864 va_list args;
7918f24d 1865 PERL_ARGS_ASSERT_WARN;
cea2e8a9 1866 va_start(args, pat);
c5be433b 1867 vwarn(pat, &args);
cea2e8a9
GS
1868 va_end(args);
1869}
1870
c5be433b
GS
1871#if defined(PERL_IMPLICIT_CONTEXT)
1872void
1873Perl_warner_nocontext(U32 err, const char *pat, ...)
1874{
27da23d5 1875 dTHX;
c5be433b 1876 va_list args;
7918f24d 1877 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
c5be433b
GS
1878 va_start(args, pat);
1879 vwarner(err, pat, &args);
1880 va_end(args);
1881}
1882#endif /* PERL_IMPLICIT_CONTEXT */
1883
599cee73 1884void
9b387841
NC
1885Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1886{
1887 PERL_ARGS_ASSERT_CK_WARNER_D;
1888
1889 if (Perl_ckwarn_d(aTHX_ err)) {
1890 va_list args;
1891 va_start(args, pat);
1892 vwarner(err, pat, &args);
1893 va_end(args);
1894 }
1895}
1896
1897void
a2a5de95
NC
1898Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1899{
1900 PERL_ARGS_ASSERT_CK_WARNER;
1901
1902 if (Perl_ckwarn(aTHX_ err)) {
1903 va_list args;
1904 va_start(args, pat);
1905 vwarner(err, pat, &args);
1906 va_end(args);
1907 }
1908}
1909
1910void
864dbfa3 1911Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM
1912{
1913 va_list args;
7918f24d 1914 PERL_ARGS_ASSERT_WARNER;
c5be433b
GS
1915 va_start(args, pat);
1916 vwarner(err, pat, &args);
1917 va_end(args);
1918}
1919
1920void
1921Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1922{
27da23d5 1923 dVAR;
7918f24d 1924 PERL_ARGS_ASSERT_VWARNER;
5f2d9966 1925 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
a3b680e6 1926 SV * const msv = vmess(pat, args);
599cee73 1927
594b6fac
LM
1928 if (PL_parser && PL_parser->error_count) {
1929 qerror(msv);
1930 }
1931 else {
1932 invoke_exception_hook(msv, FALSE);
1933 die_unwind(msv);
1934 }
599cee73
PM
1935 }
1936 else {
d13b0d77 1937 Perl_vwarn(aTHX_ pat, args);
599cee73
PM
1938 }
1939}
1940
f54ba1c2
DM
1941/* implements the ckWARN? macros */
1942
1943bool
1944Perl_ckwarn(pTHX_ U32 w)
1945{
ad287e37 1946 /* If lexical warnings have not been set, use $^W. */
ea5519d6
AB
1947 if (isLEXWARN_off) {
1948 /* TODO: Hardcoding this here sucks, see the commit that added this */
1949 if (w == WARN_VOID_UNUSUAL)
1950 return FALSE;
1951 else
1952 return PL_dowarn & G_WARN_ON;
1953 }
ad287e37 1954
26c7b074 1955 return ckwarn_common(w);
f54ba1c2
DM
1956}
1957
1958/* implements the ckWARN?_d macro */
1959
1960bool
1961Perl_ckwarn_d(pTHX_ U32 w)
1962{
ad287e37 1963 /* If lexical warnings have not been set then default classes warn. */
ea5519d6
AB
1964 if (isLEXWARN_off) {
1965 /* TODO: Hardcoding this here sucks, see the commit that added this */
1966 if (w == WARN_VOID_UNUSUAL)
1967 return FALSE;
1968 else
1969 return TRUE;
1970 }
ad287e37 1971
26c7b074
NC
1972 return ckwarn_common(w);
1973}
1974
1975static bool
1976S_ckwarn_common(pTHX_ U32 w)
1977{
ea5519d6
AB
1978 if (PL_curcop->cop_warnings == pWARN_ALL) {
1979 /* TODO: Hardcoding this here sucks, see the commit that added this */
1980 if (w == WARN_VOID_UNUSUAL)
1981 return FALSE;
1982 else
1983 return TRUE;
1984 }
ad287e37
NC
1985
1986 if (PL_curcop->cop_warnings == pWARN_NONE)
1987 return FALSE;
1988
98fe6610
NC
1989 /* Check the assumption that at least the first slot is non-zero. */
1990 assert(unpackWARN1(w));
1991
1992 /* Check the assumption that it is valid to stop as soon as a zero slot is
1993 seen. */
1994 if (!unpackWARN2(w)) {
1995 assert(!unpackWARN3(w));
1996 assert(!unpackWARN4(w));
1997 } else if (!unpackWARN3(w)) {
1998 assert(!unpackWARN4(w));
1999 }
2000
26c7b074
NC
2001 /* Right, dealt with all the special cases, which are implemented as non-
2002 pointers, so there is a pointer to a real warnings mask. */
98fe6610
NC
2003 do {
2004 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2005 return TRUE;
2006 } while (w >>= WARNshift);
2007
2008 return FALSE;
f54ba1c2
DM
2009}
2010
72dc9ed5
NC
2011/* Set buffer=NULL to get a new one. */
2012STRLEN *
8ee4cf24 2013Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
72dc9ed5 2014 STRLEN size) {
5af88345
FC
2015 const MEM_SIZE len_wanted =
2016 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
35da51f7 2017 PERL_UNUSED_CONTEXT;
7918f24d 2018 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
72dc9ed5 2019
10edeb5d
JH
2020 buffer = (STRLEN*)
2021 (specialWARN(buffer) ?
2022 PerlMemShared_malloc(len_wanted) :
2023 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC
2024 buffer[0] = size;
2025 Copy(bits, (buffer + 1), size, char);
5af88345
FC
2026 if (size < WARNsize)
2027 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
72dc9ed5
NC
2028 return buffer;
2029}
f54ba1c2 2030
e6587932
DM
2031/* since we've already done strlen() for both nam and val
2032 * we can use that info to make things faster than
2033 * sprintf(s, "%s=%s", nam, val)
2034 */
2035#define my_setenv_format(s, nam, nlen, val, vlen) \
2036 Copy(nam, s, nlen, char); \
2037 *(s+nlen) = '='; \
2038 Copy(val, s+(nlen+1), vlen, char); \
2039 *(s+(nlen+1+vlen)) = '\0'
2040
c5d12488
JH
2041#ifdef USE_ENVIRON_ARRAY
2042 /* VMS' my_setenv() is in vms.c */
2043#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 2044void
e1ec3a88 2045Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 2046{
27da23d5 2047 dVAR;
4efc5df6
GS
2048#ifdef USE_ITHREADS
2049 /* only parent thread can modify process environment */
2050 if (PL_curinterp == aTHX)
2051#endif
2052 {
f2517201 2053#ifndef PERL_USE_SAFE_PUTENV
50acdf95 2054 if (!PL_use_safe_putenv) {
b7d87861
JH
2055 /* most putenv()s leak, so we manipulate environ directly */
2056 I32 i;
2057 const I32 len = strlen(nam);
2058 int nlen, vlen;
2059
2060 /* where does it go? */
2061 for (i = 0; environ[i]; i++) {
2062 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2063 break;
2064 }
c5d12488 2065
b7d87861
JH
2066 if (environ == PL_origenviron) { /* need we copy environment? */
2067 I32 j;
2068 I32 max;
2069 char **tmpenv;
2070
2071 max = i;
2072 while (environ[max])
2073 max++;
2074 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2075 for (j=0; j<max; j++) { /* copy environment */
2076 const int len = strlen(environ[j]);
2077 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2078 Copy(environ[j], tmpenv[j], len+1, char);
2079 }
2080 tmpenv[max] = NULL;
2081 environ = tmpenv; /* tell exec where it is now */
2082 }
2083 if (!val) {
2084 safesysfree(environ[i]);
2085 while (environ[i]) {
2086 environ[i] = environ[i+1];
2087 i++;
2088 }
2089 return;
2090 }
2091 if (!environ[i]) { /* does not exist yet */
2092 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2093 environ[i+1] = NULL; /* make sure it's null terminated */
2094 }
2095 else
2096 safesysfree(environ[i]);
2097 nlen = strlen(nam);
2098 vlen = strlen(val);
2099
2100 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2101 /* all that work just for this */
2102 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95 2103 } else {
c5d12488 2104# endif
235c1d5f
AD
2105 /* This next branch should only be called #if defined(HAS_SETENV), but
2106 Configure doesn't test for that yet. For Solaris, setenv() and unsetenv()
2107 were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
2108 */
2109# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV))
88f5bc07
AB
2110# if defined(HAS_UNSETENV)
2111 if (val == NULL) {
2112 (void)unsetenv(nam);
2113 } else {
2114 (void)setenv(nam, val, 1);
2115 }
2116# else /* ! HAS_UNSETENV */
2117 (void)setenv(nam, val, 1);
2118# endif /* HAS_UNSETENV */
47dafe4d 2119# else
88f5bc07
AB
2120# if defined(HAS_UNSETENV)
2121 if (val == NULL) {
ba88ff58
MJ
2122 if (environ) /* old glibc can crash with null environ */
2123 (void)unsetenv(nam);
88f5bc07 2124 } else {
c4420975
AL
2125 const int nlen = strlen(nam);
2126 const int vlen = strlen(val);
2127 char * const new_env =
88f5bc07
AB
2128 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2129 my_setenv_format(new_env, nam, nlen, val, vlen);
2130 (void)putenv(new_env);
2131 }
2132# else /* ! HAS_UNSETENV */
2133 char *new_env;
c4420975
AL
2134 const int nlen = strlen(nam);
2135 int vlen;
88f5bc07
AB
2136 if (!val) {
2137 val = "";
2138 }
2139 vlen = strlen(val);
2140 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2141 /* all that work just for this */
2142 my_setenv_format(new_env, nam, nlen, val, vlen);
2143 (void)putenv(new_env);
2144# endif /* HAS_UNSETENV */
47dafe4d 2145# endif /* __CYGWIN__ */
50acdf95
MS
2146#ifndef PERL_USE_SAFE_PUTENV
2147 }
2148#endif
4efc5df6 2149 }
8d063cd8
LW
2150}
2151
c5d12488 2152#else /* WIN32 || NETWARE */
68dc0745
PP
2153
2154void
72229eff 2155Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 2156{
27da23d5 2157 dVAR;
eb578fdb 2158 char *envstr;
c5d12488
JH
2159 const int nlen = strlen(nam);
2160 int vlen;
e6587932 2161
c5d12488
JH
2162 if (!val) {
2163 val = "";
ac5c734f 2164 }
c5d12488
JH
2165 vlen = strlen(val);
2166 Newx(envstr, nlen+vlen+2, char);
2167 my_setenv_format(envstr, nam, nlen, val, vlen);
2168 (void)PerlEnv_putenv(envstr);
2169 Safefree(envstr);
3e3baf6d
TB
2170}
2171
c5d12488 2172#endif /* WIN32 || NETWARE */
3e3baf6d 2173
739a0b84 2174#endif /* !VMS */
378cc40b 2175
16d20bd9 2176#ifdef UNLINK_ALL_VERSIONS
79072805 2177I32
6e732051 2178Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 2179{
35da51f7 2180 I32 retries = 0;
378cc40b 2181
7918f24d
NC
2182 PERL_ARGS_ASSERT_UNLNK;
2183
35da51f7
AL
2184 while (PerlLIO_unlink(f) >= 0)
2185 retries++;
2186 return retries ? 0 : -1;
378cc40b
LW
2187}
2188#endif
2189
7a3f2258 2190/* this is a drop-in replacement for bcopy() */
2253333f 2191#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 2192char *
5aaab254 2193Perl_my_bcopy(const char *from, char *to, I32 len)
378cc40b 2194{
2d03de9c 2195 char * const retval = to;
378cc40b 2196
7918f24d
NC
2197 PERL_ARGS_ASSERT_MY_BCOPY;
2198
223f01db
KW
2199 assert(len >= 0);
2200
7c0587c8
LW
2201 if (from - to >= 0) {
2202 while (len--)
2203 *to++ = *from++;
2204 }
2205 else {
2206 to += len;
2207 from += len;
2208 while (len--)
faf8582f 2209 *(--to) = *(--from);
7c0587c8 2210 }
378cc40b
LW
2211 return retval;
2212}
ffed7fef 2213#endif
378cc40b 2214
7a3f2258 2215/* this is a drop-in replacement for memset() */
fc36a67e
PP
2216#ifndef HAS_MEMSET
2217void *
5aaab254 2218Perl_my_memset(char *loc, I32 ch, I32 len)
fc36a67e 2219{
2d03de9c 2220 char * const retval = loc;
fc36a67e 2221
7918f24d
NC
2222 PERL_ARGS_ASSERT_MY_MEMSET;
2223
223f01db
KW
2224 assert(len >= 0);
2225
fc36a67e
PP
2226 while (len--)
2227 *loc++ = ch;
2228 return retval;
2229}
2230#endif
2231
7a3f2258 2232/* this is a drop-in replacement for bzero() */
7c0587c8 2233#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 2234char *
5aaab254 2235Perl_my_bzero(char *loc, I32 len)
378cc40b 2236{
2d03de9c 2237 char * const retval = loc;
378cc40b 2238
7918f24d
NC
2239 PERL_ARGS_ASSERT_MY_BZERO;
2240
223f01db
KW
2241 assert(len >= 0);
2242
378cc40b
LW
2243 while (len--)
2244 *loc++ = 0;
2245 return retval;
2246}
2247#endif
7c0587c8 2248
7a3f2258 2249/* this is a drop-in replacement for memcmp() */
36477c24 2250#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 2251I32
5aaab254 2252Perl_my_memcmp(const char *s1, const char *s2, I32 len)
7c0587c8 2253{
eb578fdb
KW
2254 const U8 *a = (const U8 *)s1;
2255 const U8 *b = (const U8 *)s2;
2256 I32 tmp;
7c0587c8 2257
7918f24d
NC
2258 PERL_ARGS_ASSERT_MY_MEMCMP;
2259
223f01db
KW
2260 assert(len >= 0);
2261
7c0587c8 2262 while (len--) {
27da23d5 2263 if ((tmp = *a++ - *b++))
7c0587c8
LW
2264 return tmp;
2265 }
2266 return 0;
2267}
36477c24 2268#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 2269
fe14fcc3 2270#ifndef HAS_VPRINTF
d05d9be5
AD
2271/* This vsprintf replacement should generally never get used, since
2272 vsprintf was available in both System V and BSD 2.11. (There may
2273 be some cross-compilation or embedded set-ups where it is needed,
2274 however.)
2275
2276 If you encounter a problem in this function, it's probably a symptom
2277 that Configure failed to detect your system's vprintf() function.
2278 See the section on "item vsprintf" in the INSTALL file.
2279
2280 This version may compile on systems with BSD-ish <stdio.h>,
2281 but probably won't on others.
2282*/
a687059c 2283
85e6fe83 2284#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2285char *
2286#else
2287int
2288#endif
d05d9be5 2289vsprintf(char *dest, const char *pat, void *args)
a687059c
LW
2290{
2291 FILE fakebuf;
2292
d05d9be5
AD
2293#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2294 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2295 FILE_cnt(&fakebuf) = 32767;
2296#else
2297 /* These probably won't compile -- If you really need
2298 this, you'll have to figure out some other method. */
a687059c
LW
2299 fakebuf._ptr = dest;
2300 fakebuf._cnt = 32767;
d05d9be5 2301#endif
35c8bce7
LW
2302#ifndef _IOSTRG
2303#define _IOSTRG 0
2304#endif
a687059c
LW
2305 fakebuf._flag = _IOWRT|_IOSTRG;
2306 _doprnt(pat, args, &fakebuf); /* what a kludge */
d05d9be5
AD
2307#if defined(STDIO_PTR_LVALUE)
2308 *(FILE_ptr(&fakebuf)++) = '\0';
2309#else
2310 /* PerlIO has probably #defined away fputc, but we want it here. */
2311# ifdef fputc
2312# undef fputc /* XXX Should really restore it later */
2313# endif
2314 (void)fputc('\0', &fakebuf);
2315#endif
85e6fe83 2316#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2317 return(dest);
2318#else
2319 return 0; /* perl doesn't use return value */
2320#endif
2321}
2322
fe14fcc3 2323#endif /* HAS_VPRINTF */
a687059c 2324
4a7d1889 2325PerlIO *
c9289b7b 2326Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
4a7d1889 2327{
739a0b84 2328#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
1f852d0d 2329 int p[2];
eb578fdb
KW
2330 I32 This, that;
2331 Pid_t pid;
1f852d0d
NIS
2332 SV *sv;
2333 I32 did_pipes = 0;
2334 int pp[2];
2335
7918f24d
NC
2336 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2337
1f852d0d
NIS
2338 PERL_FLUSHALL_FOR_CHILD;
2339 This = (*mode == 'w');
2340 that = !This;
284167a5 2341 if (TAINTING_get) {
1f852d0d
NIS
2342 taint_env();
2343 taint_proper("Insecure %s%s", "EXEC");
2344 }
2345 if (PerlProc_pipe(p) < 0)
4608196e 2346 return NULL;
1f852d0d
NIS
2347 /* Try for another pipe pair for error return */
2348 if (PerlProc_pipe(pp) >= 0)
2349 did_pipes = 1;
52e18b1f 2350 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS
2351 if (errno != EAGAIN) {
2352 PerlLIO_close(p[This]);
4e6dfe71 2353 PerlLIO_close(p[that]);
1f852d0d
NIS
2354 if (did_pipes) {
2355 PerlLIO_close(pp[0]);
2356 PerlLIO_close(pp[1]);
2357 }
4608196e 2358 return NULL;
1f852d0d 2359 }
a2a5de95 2360 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
1f852d0d
NIS
2361 sleep(5);
2362 }
2363 if (pid == 0) {
2364 /* Child */
1f852d0d
NIS
2365#undef THIS
2366#undef THAT
2367#define THIS that
2368#define THAT This
1f852d0d
NIS
2369 /* Close parent's end of error status pipe (if any) */
2370 if (did_pipes) {
2371 PerlLIO_close(pp[0]);
2372#if defined(HAS_FCNTL) && defined(F_SETFD)
2373 /* Close error pipe automatically if exec works */
375ed12a
JH
2374 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2375 return NULL;
1f852d0d
NIS
2376#endif
2377 }
2378 /* Now dup our end of _the_ pipe to right position */
2379 if (p[THIS] != (*mode == 'r')) {
2380 PerlLIO_dup2(p[THIS], *mode == 'r');
2381 PerlLIO_close(p[THIS]);
4e6dfe71
GS
2382 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2383 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2384 }
4e6dfe71
GS
2385 else
2386 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS
2387#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2388 /* No automatic close - do it by hand */
b7953727
JH
2389# ifndef NOFILE
2390# define NOFILE 20
2391# endif
a080fe3d
NIS
2392 {
2393 int fd;
2394
2395 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2396 if (fd != pp[1])
a080fe3d
NIS
2397 PerlLIO_close(fd);
2398 }
1f852d0d
NIS
2399 }
2400#endif
a0714e2c 2401 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS
2402 PerlProc__exit(1);
2403#undef THIS
2404#undef THAT
2405 }
2406 /* Parent */
52e18b1f 2407 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS
2408 if (did_pipes)
2409 PerlLIO_close(pp[1]);
2410 /* Keep the lower of the two fd numbers */
2411 if (p[that] < p[This]) {
2412 PerlLIO_dup2(p[This], p[that]);
2413 PerlLIO_close(p[This]);
2414 p[This] = p[that];
2415 }
4e6dfe71
GS
2416 else
2417 PerlLIO_close(p[that]); /* close child's end of pipe */
2418
1f852d0d 2419 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2420 SvUPGRADE(sv,SVt_IV);
45977657 2421 SvIV_set(sv, pid);
1f852d0d
NIS
2422 PL_forkprocess = pid;
2423 /* If we managed to get status pipe check for exec fail */
2424 if (did_pipes && pid > 0) {
2425 int errkid;
bb7a0f54
MHM
2426 unsigned n = 0;
2427 SSize_t n1;
1f852d0d
NIS
2428
2429 while (n < sizeof(int)) {
2430 n1 = PerlLIO_read(pp[0],
2431 (void*)(((char*)&errkid)+n),
2432 (sizeof(int)) - n);
2433 if (n1 <= 0)
2434 break;
2435 n += n1;
2436 }
2437 PerlLIO_close(pp[0]);
2438 did_pipes = 0;
2439 if (n) { /* Error */
2440 int pid2, status;
8c51524e 2441 PerlLIO_close(p[This]);
1f852d0d 2442 if (n != sizeof(int))
5637ef5b 2443 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
1f852d0d
NIS
2444 do {
2445 pid2 = wait4pid(pid, &status, 0);
2446 } while (pid2 == -1 && errno == EINTR);
2447 errno = errkid; /* Propagate errno from kid */
4608196e 2448 return NULL;
1f852d0d
NIS
2449 }
2450 }
2451 if (did_pipes)
2452 PerlLIO_close(pp[0]);
2453 return PerlIO_fdopen(p[This], mode);
2454#else
8492b23f 2455# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
4e205ed6 2456 return my_syspopen4(aTHX_ NULL, mode, n, args);
8492b23f
TC
2457# elif defined(WIN32)
2458 return win32_popenlist(mode, n, args);
9d419b5f 2459# else
4a7d1889
NIS
2460 Perl_croak(aTHX_ "List form of piped open not implemented");
2461 return (PerlIO *) NULL;
9d419b5f 2462# endif
1f852d0d 2463#endif
4a7d1889
NIS
2464}
2465
5f05dabc 2466 /* VMS' my_popen() is in VMS.c, same with OS/2. */
739a0b84 2467#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
760ac839 2468PerlIO *
3dd43144 2469Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c
LW
2470{
2471 int p[2];
eb578fdb
KW
2472 I32 This, that;
2473 Pid_t pid;
79072805 2474 SV *sv;
bfce84ec 2475 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ
2476 I32 did_pipes = 0;
2477 int pp[2];
a687059c 2478
7918f24d
NC
2479 PERL_ARGS_ASSERT_MY_POPEN;
2480
45bc9206 2481 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ
2482#ifdef OS2
2483 if (doexec) {
23da6c43 2484 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2485 }
a1d180c4 2486#endif
8ac85365
NIS
2487 This = (*mode == 'w');
2488 that = !This;
284167a5 2489 if (doexec && TAINTING_get) {
bbce6d69
PP
2490 taint_env();
2491 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2492 }
c2267164 2493 if (PerlProc_pipe(p) < 0)
4608196e 2494 return NULL;
e446cec8
IZ
2495 if (doexec && PerlProc_pipe(pp) >= 0)
2496 did_pipes = 1;
52e18b1f 2497 while ((pid = PerlProc_fork()) < 0) {
a687059c 2498 if (errno != EAGAIN) {
6ad3d225 2499 PerlLIO_close(p[This]);
b5ac89c3 2500 PerlLIO_close(p[that]);
e446cec8
IZ
2501 if (did_pipes) {
2502 PerlLIO_close(pp[0]);
2503 PerlLIO_close(pp[1]);
2504 }
a687059c 2505 if (!doexec)
b3647a36 2506 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2507 return NULL;
a687059c 2508 }
a2a5de95 2509 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW
2510 sleep(5);
2511 }
2512 if (pid == 0) {
79072805 2513
30ac6d9b
GS
2514#undef THIS
2515#undef THAT
a687059c 2516#define THIS that
8ac85365 2517#define THAT This
e446cec8
IZ
2518 if (did_pipes) {
2519 PerlLIO_close(pp[0]);
2520#if defined(HAS_FCNTL) && defined(F_SETFD)
375ed12a
JH
2521 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2522 return NULL;
e446cec8
IZ
2523#endif
2524 }
a687059c 2525 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS
2526 PerlLIO_dup2(p[THIS], *mode == 'r');
2527 PerlLIO_close(p[THIS]);
b5ac89c3
NIS
2528 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2529 PerlLIO_close(p[THAT]);
a687059c 2530 }
b5ac89c3
NIS
2531 else
2532 PerlLIO_close(p[THAT]);
4435c477 2533#ifndef OS2
a687059c 2534 if (doexec) {
a0d0e21e 2535#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
2536#ifndef NOFILE
2537#define NOFILE 20
2538#endif
a080fe3d 2539 {
3aed30dc 2540 int fd;
a080fe3d
NIS
2541
2542 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2543 if (fd != pp[1])
3aed30dc 2544 PerlLIO_close(fd);
a080fe3d 2545 }
ae986130 2546#endif
a080fe3d
NIS
2547 /* may or may not use the shell */
2548 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2549 PerlProc__exit(1);
a687059c 2550 }
4435c477 2551#endif /* defined OS2 */
713cef20
IZ
2552
2553#ifdef PERLIO_USING_CRLF
2554 /* Since we circumvent IO layers when we manipulate low-level
2555 filedescriptors directly, need to manually switch to the
2556 default, binary, low-level mode; see PerlIOBuf_open(). */
2557 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2558#endif
3280af22 2559 PL_forkprocess = 0;
ca0c25f6 2560#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2561 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2562#endif
4608196e 2563 return NULL;
a687059c
LW
2564#undef THIS
2565#undef THAT
2566 }
b5ac89c3 2567 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ
2568 if (did_pipes)
2569 PerlLIO_close(pp[1]);
8ac85365 2570 if (p[that] < p[This]) {
6ad3d225
GS
2571 PerlLIO_dup2(p[This], p[that]);
2572 PerlLIO_close(p[This]);
8ac85365 2573 p[This] = p[that];
62b28dd9 2574 }
b5ac89c3
NIS
2575 else
2576 PerlLIO_close(p[that]);
2577
3280af22 2578 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2579 SvUPGRADE(sv,SVt_IV);
45977657 2580 SvIV_set(sv, pid);
3280af22 2581 PL_forkprocess = pid;
e446cec8
IZ
2582 if (did_pipes && pid > 0) {
2583 int errkid;
bb7a0f54
MHM
2584 unsigned n = 0;
2585 SSize_t n1;
e446cec8
IZ
2586
2587 while (n < sizeof(int)) {
2588 n1 = PerlLIO_read(pp[0],
2589 (void*)(((char*)&errkid)+n),
2590 (sizeof(int)) - n);
2591 if (n1 <= 0)
2592 break;
2593 n += n1;
2594 }
2f96c702
IZ
2595 PerlLIO_close(pp[0]);
2596 did_pipes = 0;
e446cec8 2597 if (n) { /* Error */
faa466a7 2598 int pid2, status;
8c51524e 2599 PerlLIO_close(p[This]);
e446cec8 2600 if (n != sizeof(int))
5637ef5b 2601 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
faa466a7
RG
2602 do {
2603 pid2 = wait4pid(pid, &status, 0);
2604 } while (pid2 == -1 && errno == EINTR);
e446cec8 2605 errno = errkid; /* Propagate errno from kid */
4608196e 2606 return NULL;
e446cec8
IZ
2607 }
2608 }
2609 if (did_pipes)
2610 PerlLIO_close(pp[0]);
8ac85365 2611 return PerlIO_fdopen(p[This], mode);
a687059c 2612}
7c0587c8 2613#else
2b96b0a5
JH
2614#if defined(DJGPP)
2615FILE *djgpp_popen();
2616PerlIO *
cef6ea9d 2617Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH
2618{
2619 PERL_FLUSHALL_FOR_CHILD;
2620 /* Call system's popen() to get a FILE *, then import it.
2621 used 0 for 2nd parameter to PerlIO_importFILE;
2622 apparently not used
2623 */
2624 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2625}
9c12f1e5
RGS
2626#else
2627#if defined(__LIBCATAMOUNT__)
2628PerlIO *
2629Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2630{
2631 return NULL;
2632}
2633#endif
2b96b0a5 2634#endif
7c0587c8
LW
2635
2636#endif /* !DOSISH */
a687059c 2637
52e18b1f
GS
2638/* this is called in parent before the fork() */
2639void
2640Perl_atfork_lock(void)
2641{
3db8f154 2642#if defined(USE_ITHREADS)
20b7effb 2643 dVAR;
52e18b1f 2644 /* locks must be held in locking order (if any) */
4da80956
P
2645# ifdef USE_PERLIO
2646 MUTEX_LOCK(&PL_perlio_mutex);
2647# endif
52e18b1f
GS
2648# ifdef MYMALLOC
2649 MUTEX_LOCK(&PL_malloc_mutex);
2650# endif
2651 OP_REFCNT_LOCK;
2652#endif
2653}
2654
2655/* this is called in both parent and child after the fork() */
2656void
2657Perl_atfork_unlock(void)
2658{
3db8f154 2659#if defined(USE_ITHREADS)
20b7effb 2660 dVAR;
52e18b1f 2661 /* locks must be released in same order as in atfork_lock() */
4da80956
P
2662# ifdef USE_PERLIO
2663 MUTEX_UNLOCK(&PL_perlio_mutex);
2664# endif
52e18b1f
GS
2665# ifdef MYMALLOC
2666 MUTEX_UNLOCK(&PL_malloc_mutex);
2667# endif
2668 OP_REFCNT_UNLOCK;
2669#endif
2670}
2671
2672Pid_t
2673Perl_my_fork(void)
2674{
2675#if defined(HAS_FORK)
2676 Pid_t pid;
3db8f154 2677#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS
2678 atfork_lock();
2679 pid = fork();
2680 atfork_unlock();
2681#else
2682 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2683 * handlers elsewhere in the code */
2684 pid = fork();
2685#endif
2686 return pid;
2687#else
2688 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2689 Perl_croak_nocontext("fork() not available");
b961a566 2690 return 0;
52e18b1f
GS
2691#endif /* HAS_FORK */
2692}
2693
fe14fcc3 2694#ifndef HAS_DUP2
fec02dd3 2695int
ba106d47 2696dup2(int oldfd, int newfd)
a687059c 2697{
a0d0e21e 2698#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
2699 if (oldfd == newfd)
2700 return oldfd;
6ad3d225 2701 PerlLIO_close(newfd);
fec02dd3 2702 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2703#else
fc36a67e
PP
2704#define DUP2_MAX_FDS 256
2705 int fdtmp[DUP2_MAX_FDS];
79072805 2706 I32 fdx = 0;
ae986130
LW
2707 int fd;
2708
fe14fcc3 2709 if (oldfd == newfd)
fec02dd3 2710 return oldfd;
6ad3d225 2711 PerlLIO_close(newfd);
fc36a67e 2712 /* good enough for low fd's... */
6ad3d225 2713 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2714 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2715 PerlLIO_close(fd);
fc36a67e
PP
2716 fd = -1;
2717 break;
2718 }
ae986130 2719 fdtmp[fdx++] = fd;
fc36a67e 2720 }
ae986130 2721 while (fdx > 0)
6ad3d225 2722 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2723 return fd;
62b28dd9 2724#endif
a687059c
LW
2725}
2726#endif
2727
64ca3a65 2728#ifndef PERL_MICRO
ff68c719
PP
2729#ifdef HAS_SIGACTION
2730
2731Sighandler_t
864dbfa3 2732Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719
PP
2733{
2734 struct sigaction act, oact;
2735
a10b1e10 2736#ifdef USE_ITHREADS
20b7effb 2737 dVAR;
a10b1e10
JH
2738 /* only "parent" interpreter can diddle signals */
2739 if (PL_curinterp != aTHX)
8aad04aa 2740 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2741#endif
2742
8aad04aa 2743 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2744 sigemptyset(&act.sa_mask);
2745 act.sa_flags = 0;
2746#ifdef SA_RESTART
4ffa73a3
JH
2747 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2748 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2749#endif
358837b8 2750#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2751 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2752 act.sa_flags |= SA_NOCLDWAIT;
2753#endif
ff68c719 2754 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2755 return (Sighandler_t) SIG_ERR;
ff68c719 2756 else
8aad04aa 2757 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2758}
2759
2760Sighandler_t
864dbfa3 2761Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
2762{
2763 struct sigaction oact;
96a5add6 2764 PERL_UNUSED_CONTEXT;
ff68c719
PP
2765
2766 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2767 return (Sighandler_t) SIG_ERR;
ff68c719 2768 else
8aad04aa 2769 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2770}
2771
2772int
864dbfa3 2773Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2774{
20b7effb 2775#ifdef USE_ITHREADS
27da23d5 2776 dVAR;
20b7effb 2777#endif
ff68c719
PP
2778 struct sigaction act;
2779
7918f24d
NC
2780 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2781
a10b1e10
JH
2782#ifdef USE_ITHREADS
2783 /* only "parent" interpreter can diddle signals */
2784 if (PL_curinterp != aTHX)
2785 return -1;
2786#endif
2787
8aad04aa 2788 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2789 sigemptyset(&act.sa_mask);
2790 act.sa_flags = 0;
2791#ifdef SA_RESTART
4ffa73a3
JH
2792 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2793 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2794#endif
36b5d377 2795#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2796 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2797 act.sa_flags |= SA_NOCLDWAIT;
2798#endif
ff68c719
PP
2799 return sigaction(signo, &act, save);
2800}
2801
2802int
864dbfa3 2803Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2804{
20b7effb 2805#ifdef USE_ITHREADS
27da23d5 2806 dVAR;
20b7effb
JH
2807#endif
2808 PERL_UNUSED_CONTEXT;
a10b1e10
JH
2809#ifdef USE_ITHREADS
2810 /* only "parent" interpreter can diddle signals */
2811 if (PL_curinterp != aTHX)
2812 return -1;
2813#endif
2814
ff68c719
PP
2815 return sigaction(signo, save, (struct sigaction *)NULL);
2816}
2817
2818#else /* !HAS_SIGACTION */
2819
2820Sighandler_t
864dbfa3 2821Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2822{
39f1703b 2823#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2824 /* only "parent" interpreter can diddle signals */
2825 if (PL_curinterp != aTHX)
8aad04aa 2826 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2827#endif
2828
6ad3d225 2829 return PerlProc_signal(signo, handler);
ff68c719
PP
2830}
2831
fabdb6c0 2832static Signal_t
4e35701f 2833sig_trap(int signo)
ff68c719 2834{
27da23d5
JH
2835 dVAR;
2836 PL_sig_trapped++;
ff68c719
PP
2837}
2838
2839Sighandler_t
864dbfa3 2840Perl_rsignal_state(pTHX_ int signo)
ff68c719 2841{
27da23d5 2842 dVAR;
ff68c719
PP
2843 Sighandler_t oldsig;
2844
39f1703b 2845#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2846 /* only "parent" interpreter can diddle signals */
2847 if (PL_curinterp != aTHX)
8aad04aa 2848 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2849#endif
2850
27da23d5 2851 PL_sig_trapped = 0;
6ad3d225
GS
2852 oldsig = PerlProc_signal(signo, sig_trap);
2853 PerlProc_signal(signo, oldsig);
27da23d5 2854 if (PL_sig_trapped)
3aed30dc 2855 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719
PP
2856 return oldsig;
2857}
2858
2859int
864dbfa3 2860Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2861{
39f1703b 2862#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2863 /* only "parent" interpreter can diddle signals */
2864 if (PL_curinterp != aTHX)
2865 return -1;
2866#endif
6ad3d225 2867 *save = PerlProc_signal(signo, handler);
8aad04aa 2868 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
2869}
2870
2871int
864dbfa3 2872Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2873{
39f1703b 2874#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2875 /* only "parent" interpreter can diddle signals */
2876 if (PL_curinterp != aTHX)
2877 return -1;
2878#endif
8aad04aa 2879 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
2880}
2881
2882#endif /* !HAS_SIGACTION */
64ca3a65 2883#endif /* !PERL_MICRO */
ff68c719 2884
5f05dabc 2885 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
739a0b84 2886#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
79072805 2887I32
864dbfa3 2888Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2889{
a687059c 2890 int status;
a0d0e21e 2891 SV **svp;
d8a83dd3 2892 Pid_t pid;
2e0cfa16 2893 Pid_t pid2 = 0;
03136e13 2894 bool close_failed;
4ee39169 2895 dSAVEDERRNO;
2e0cfa16 2896 const int fd = PerlIO_fileno(ptr);
e9d373c4
TC
2897 bool should_wait;
2898
2899 svp = av_fetch(PL_fdpid,fd,TRUE);
2900 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2901 SvREFCNT_dec(*svp);
2902 *svp = NULL;
2e0cfa16 2903
97cb92d6 2904#if defined(USE_PERLIO)
2e0cfa16
FC
2905 /* Find out whether the refcount is low enough for us to wait for the
2906 child proc without blocking. */
e9d373c4 2907 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
b6ae43b7 2908#else
e9d373c4 2909 should_wait = pid > 0;
b6ae43b7 2910#endif
a687059c 2911
ddcf38b7
IZ
2912#ifdef OS2
2913 if (pid == -1) { /* Opened by popen. */
2914 return my_syspclose(ptr);
2915 }
a1d180c4 2916#endif
f1618b10
CS
2917 close_failed = (PerlIO_close(ptr) == EOF);
2918 SAVE_ERRNO;
2e0cfa16 2919 if (should_wait) do {
1d3434b8
GS
2920 pid2 = wait4pid(pid, &status, 0);
2921 } while (pid2 == -1 && errno == EINTR);
03136e13 2922 if (close_failed) {
4ee39169 2923 RESTORE_ERRNO;
03136e13
CS
2924 return -1;
2925 }
2e0cfa16
FC
2926 return(
2927 should_wait
2928 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2929 : 0
2930 );
20188a90 2931}
9c12f1e5
RGS
2932#else
2933#if defined(__LIBCATAMOUNT__)
2934I32
2935Perl_my_pclose(pTHX_ PerlIO *ptr)
2936{
2937 return -1;
2938}
2939#endif
4633a7c4
LW
2940#endif /* !DOSISH */
2941
e37778c2 2942#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 2943I32
d8a83dd3 2944Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2945{
27da23d5 2946 I32 result = 0;
7918f24d 2947 PERL_ARGS_ASSERT_WAIT4PID;
ca0c25f6 2948#ifdef PERL_USES_PL_PIDSTATUS
d4c02743
TC
2949 if (!pid) {
2950 /* PERL_USES_PL_PIDSTATUS is only defined when neither
2951 waitpid() nor wait4() is available, or on OS/2, which
2952 doesn't appear to support waiting for a progress group
2953 member, so we can only treat a 0 pid as an unknown child.
2954 */
2955 errno = ECHILD;
2956 return -1;
2957 }
b7953727 2958 {
3aed30dc 2959 if (pid > 0) {
12072db5
NC
2960 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2961 pid, rather than a string form. */
c4420975 2962 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS
2963 if (svp && *svp != &PL_sv_undef) {
2964 *statusp = SvIVX(*svp);
12072db5
NC
2965 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2966 G_DISCARD);
3aed30dc
HS
2967 return pid;
2968 }
2969 }
2970 else {
2971 HE *entry;
2972
2973 hv_iterinit(PL_pidstatus);
2974 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 2975 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 2976 I32 len;
0bcc34c2 2977 const char * const spid = hv_iterkey(entry,&len);
27da23d5 2978
12072db5
NC
2979 assert (len == sizeof(Pid_t));
2980 memcpy((char *)&pid, spid, len);
3aed30dc 2981 *statusp = SvIVX(sv);
7b9a3241
NC
2982 /* The hash iterator is currently on this entry, so simply
2983 calling hv_delete would trigger the lazy delete, which on
2984 aggregate does more work, beacuse next call to hv_iterinit()
2985 would spot the flag, and have to call the delete routine,
2986 while in the meantime any new entries can't re-use that
2987 memory. */
2988 hv_iterinit(PL_pidstatus);
7ea75b61 2989 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS
2990 return pid;
2991 }
20188a90
LW
2992 }
2993 }
68a29c53 2994#endif
79072805 2995#ifdef HAS_WAITPID
367f3c24
IZ
2996# ifdef HAS_WAITPID_RUNTIME
2997 if (!HAS_WAITPID_RUNTIME)
2998 goto hard_way;
2999# endif
cddd4526 3000 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 3001 goto finish;
367f3c24
IZ
3002#endif
3003#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
d4c02743 3004 result = wait4(pid,statusp,flags,NULL);
dfcfdb64 3005 goto finish;
367f3c24 3006#endif
ca0c25f6 3007#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 3008#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 3009 hard_way:
27da23d5 3010#endif
a0d0e21e 3011 {
a0d0e21e 3012 if (flags)
cea2e8a9 3013 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 3014 else {
76e3520e 3015 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW
3016 pidgone(result,*statusp);
3017 if (result < 0)
3018 *statusp = -1;
3019 }
a687059c
LW
3020 }
3021#endif
27da23d5 3022#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 3023 finish:
27da23d5 3024#endif
cddd4526
NIS
3025 if (result < 0 && errno == EINTR) {
3026 PERL_ASYNC_CHECK();
48dbb59e 3027 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS
3028 }
3029 return result;
a687059c 3030}
2986a63f 3031#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 3032
ca0c25f6 3033#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 3034void
ed4173ef 3035S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 3036{
eb578fdb 3037 SV *sv;
a687059c 3038
12072db5 3039 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 3040 SvUPGRADE(sv,SVt_IV);
45977657 3041 SvIV_set(sv, status);
20188a90 3042 return;
a687059c 3043}
ca0c25f6 3044#endif
a687059c 3045
739a0b84 3046#if defined(OS2)
7c0587c8 3047int pclose();
ddcf38b7
IZ
3048#ifdef HAS_FORK
3049int /* Cannot prototype with I32
3050 in os2ish.h. */
ba106d47 3051my_syspclose(PerlIO *ptr)
ddcf38b7 3052#else
79072805 3053I32
864dbfa3 3054Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 3055#endif
a687059c 3056{
760ac839 3057 /* Needs work for PerlIO ! */
c4420975 3058 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 3059 const I32 result = pclose(f);
2b96b0a5
JH
3060 PerlIO_releaseFILE(ptr,f);
3061 return result;
3062}
3063#endif
3064
933fea7f 3065#if defined(DJGPP)
2b96b0a5
JH
3066int djgpp_pclose();
3067I32
3068Perl_my_pclose(pTHX_ PerlIO *ptr)
3069{
3070 /* Needs work for PerlIO ! */
c4420975 3071 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 3072 I32 result = djgpp_pclose(f);
933fea7f 3073 result = (result << 8) & 0xff00;
760ac839
LW
3074 PerlIO_releaseFILE(ptr,f);
3075 return result;
a687059c 3076}
7c0587c8 3077#endif
9f68db38 3078
16fa5c11 3079#define PERL_REPEATCPY_LINEAR 4
9f68db38 3080void
5aaab254 3081Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
9f68db38 3082{
7918f24d
NC
3083 PERL_ARGS_ASSERT_REPEATCPY;
3084
223f01db
KW
3085 assert(len >= 0);
3086
2709980d 3087 if (count < 0)
d1decf2b 3088 croak_memory_wrap();
2709980d 3089
16fa5c11
VP
3090 if (len == 1)
3091 memset(to, *from, count);
3092 else if (count) {
eb578fdb 3093 char *p = to;
26e1303d 3094 IV items, linear, half;
16fa5c11
VP
3095
3096 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3097 for (items = 0; items < linear; ++items) {
eb578fdb 3098 const char *q = from;
26e1303d 3099 IV todo;
16fa5c11
VP
3100 for (todo = len; todo > 0; todo--)
3101 *p++ = *q++;
3102 }
3103
3104 half = count / 2;
3105 while (items <= half) {
26e1303d 3106 IV size = items * len;
16fa5c11
VP
3107 memcpy(p, to, size);
3108 p += size;
3109 items *= 2;
9f68db38 3110 }
16fa5c11
VP
3111
3112 if (count > items)
3113 memcpy(p, to, (count - items) * len);
9f68db38
LW
3114 }
3115}
0f85fab0 3116
fe14fcc3 3117#ifndef HAS_RENAME
79072805 3118I32
4373e329 3119Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3120{
93a17b20
LW
3121 char *fa = strrchr(a,'/');
3122 char *fb = strrchr(b,'/');
c623ac67
GS
3123 Stat_t tmpstatbuf1;
3124 Stat_t tmpstatbuf2;
c4420975 3125 SV * const tmpsv = sv_newmortal();
62b28dd9 3126
7918f24d
NC
3127 PERL_ARGS_ASSERT_SAME_DIRENT;
3128
62b28dd9
LW
3129 if (fa)
3130 fa++;
3131 else
3132 fa = a;
3133 if (fb)
3134 fb++;
3135 else
3136 fb = b;
3137 if (strNE(a,b))
3138 return FALSE;
3139 if (fa == a)
76f68e9b 3140 sv_setpvs(tmpsv, ".");
62b28dd9 3141 else
46fc3d4c 3142 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3143 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
3144 return FALSE;
3145 if (fb == b)
76f68e9b 3146 sv_setpvs(tmpsv, ".");
62b28dd9 3147 else
46fc3d4c 3148 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3149 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
3150 return FALSE;
3151 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3152 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3153}
fe14fcc3
LW
3154#endif /* !HAS_RENAME */
3155
491527d0 3156char*
7f315aed
NC
3157Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3158 const char *const *const search_ext, I32 flags)
491527d0 3159{
bd61b366
SS
3160 const char *xfound = NULL;
3161 char *xfailed = NULL;
0f31cffe 3162 char tmpbuf[MAXPATHLEN];
eb578fdb 3163 char *s;
5f74f29c 3164 I32 len = 0;
491527d0 3165 int retval;
39a02377 3166 char *bufend;
7c458fae 3167#if defined(DOSISH) && !defined(OS2)
491527d0
GS
3168# define SEARCH_EXTS ".bat", ".cmd", NULL
3169# define MAX_EXT_LEN 4
3170#endif
3171#ifdef OS2
3172# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3173# define MAX_EXT_LEN 4
3174#endif
3175#ifdef VMS
3176# define SEARCH_EXTS ".pl", ".com", NULL
3177# define MAX_EXT_LEN 4
3178#endif
3179 /* additional extensions to try in each dir if scriptname not found */
3180#ifdef SEARCH_EXTS
0bcc34c2 3181 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3182 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3183 int extidx = 0, i = 0;
bd61b366 3184 const char *curext = NULL;
491527d0 3185#else
53c1dcc0 3186 PERL_UNUSED_ARG(search_ext);
491527d0
GS
3187# define MAX_EXT_LEN 0
3188#endif
3189
7918f24d
NC
3190 PERL_ARGS_ASSERT_FIND_SCRIPT;
3191
491527d0
GS
3192 /*
3193 * If dosearch is true and if scriptname does not contain path
3194 * delimiters, search the PATH for scriptname.
3195 *
3196 * If SEARCH_EXTS is also defined, will look for each
3197 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3198 * while searching the PATH.
3199 *
3200 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3201 * proceeds as follows:
3202 * If DOSISH or VMSISH:
3203 * + look for ./scriptname{,.foo,.bar}
3204 * + search the PATH for scriptname{,.foo,.bar}
3205 *
3206 * If !DOSISH:
3207 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3208 * this will not look in '.' if it's not in the PATH)
3209 */
84486fc6 3210 tmpbuf[0] = '\0';
491527d0
GS
3211
3212#ifdef VMS
3213# ifdef ALWAYS_DEFTYPES
3214 len = strlen(scriptname);
3215 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3216 int idx = 0, deftypes = 1;
491527d0
GS
3217 bool seen_dot = 1;
3218
bd61b366 3219 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3220# else
3221 if (dosearch) {
c4420975 3222 int idx = 0, deftypes = 1;
491527d0
GS
3223 bool seen_dot = 1;
3224
bd61b366 3225 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3226# endif
3227 /* The first time through, just add SEARCH_EXTS to whatever we
3228 * already have, so we can check for default file types. */
3229 while (deftypes ||
84486fc6 3230 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS
3231 {
3232 if (deftypes) {
3233 deftypes = 0;
84486fc6 3234 *tmpbuf = '\0';
491527d0 3235 }
84486fc6
GS
3236 if ((strlen(tmpbuf) + strlen(scriptname)
3237 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3238 continue; /* don't search dir with too-long name */
6fca0082 3239 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS
3240#else /* !VMS */
3241
3242#ifdef DOSISH
3243 if (strEQ(scriptname, "-"))
3244 dosearch = 0;
3245 if (dosearch) { /* Look in '.' first. */
fe2774ed 3246 const char *cur = scriptname;
491527d0
GS
3247#ifdef SEARCH_EXTS
3248 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3249 while (ext[i])
3250 if (strEQ(ext[i++],curext)) {
3251 extidx = -1; /* already has an ext */
3252 break;
3253 }
3254 do {
3255#endif
3256 DEBUG_p(PerlIO_printf(Perl_debug_log,
3257 "Looking for %s\n",cur));
017f25f1
IZ
3258 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3259 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS
3260 dosearch = 0;
3261 scriptname = cur;
3262#ifdef SEARCH_EXTS
3263 break;
3264#endif
3265 }
3266#ifdef SEARCH_EXTS
3267 if (cur == scriptname) {
3268 len = strlen(scriptname);
84486fc6 3269 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3270 break;
9e4425f7
SH
3271 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3272 cur = tmpbuf;
491527d0
GS
3273 }
3274 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3275 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS
3276#endif
3277 }
3278#endif
3279
3280 if (dosearch && !strchr(scriptname, '/')
3281#ifdef DOSISH
3282 && !strchr(scriptname, '\\')
3283#endif
cd39f2b6 3284 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3285 {
491527d0 3286 bool seen_dot = 0;
92f0c265 3287
39a02377
DM
3288 bufend = s + strlen(s);
3289 while (s < bufend) {
7c458fae 3290# ifdef DOSISH
491527d0 3291 for (len = 0; *s
491527d0 3292 && *s != ';'; len++, s++) {
84486fc6
GS
3293 if (len < sizeof tmpbuf)
3294 tmpbuf[len] = *s;
491527d0 3295 }
84486fc6
GS
3296 if (len < sizeof tmpbuf)
3297 tmpbuf[len] = '\0';
7c458fae 3298# else
39a02377 3299 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS
3300 ':',
3301 &len);
7c458fae 3302# endif
39a02377 3303 if (s < bufend)
491527d0 3304 s++;
84486fc6 3305 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS
3306 continue; /* don't search dir with too-long name */
3307 if (len
7c458fae 3308# ifdef DOSISH
84486fc6
GS
3309 && tmpbuf[len - 1] != '/'
3310 && tmpbuf[len - 1] != '\\'
490a0e98 3311# endif
491527d0 3312 )
84486fc6
GS
3313 tmpbuf[len++] = '/';
3314 if (len == 2 && tmpbuf[0] == '.')
491527d0 3315 seen_dot = 1;
28f0d0ec 3316 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS
3317#endif /* !VMS */
3318
3319#ifdef SEARCH_EXTS
84486fc6 3320 len = strlen(tmpbuf);
491527d0
GS
3321 if (extidx > 0) /* reset after previous loop */
3322 extidx = 0;
3323 do {
3324#endif
84486fc6 3325 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3326 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ
3327 if (S_ISDIR(PL_statbuf.st_mode)) {
3328 retval = -1;
3329 }
491527d0
GS
3330#ifdef SEARCH_EXTS
3331 } while ( retval < 0 /* not there */
3332 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3333 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS
3334 );
3335#endif
3336 if (retval < 0)
3337 continue;
3280af22
NIS
3338 if (S_ISREG(PL_statbuf.st_mode)
3339 && cando(S_IRUSR,TRUE,&PL_statbuf)
e37778c2 3340#if !defined(DOSISH)
3280af22 3341 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS
3342#endif
3343 )
3344 {
3aed30dc 3345 xfound = tmpbuf; /* bingo! */
491527d0
GS
3346 break;
3347 }
3348 if (!xfailed)
84486fc6 3349 xfailed = savepv(tmpbuf);
491527d0
GS
3350 }
3351#ifndef DOSISH
017f25f1 3352 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3353 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3354 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS
3355#endif
3356 seen_dot = 1; /* Disable message. */
9ccb31f9
GS
3357 if (!xfound) {
3358 if (flags & 1) { /* do or die? */
6ad282c7 3359 /* diag_listed_as: Can't execute %s */
3aed30dc 3360 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS
3361 (xfailed ? "execute" : "find"),
3362 (xfailed ? xfailed : scriptname),
3363 (xfailed ? "" : " on PATH"),
3364 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3365 }
bd61b366 3366 scriptname = NULL;
9ccb31f9 3367 }
43c5f42d 3368 Safefree(xfailed);
491527d0
GS
3369 scriptname = xfound;
3370 }
bd61b366 3371 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS
3372}
3373
ba869deb
GS
3374#ifndef PERL_GET_CONTEXT_DEFINED
3375
3376void *
3377Perl_get_context(void)
3378{
3db8f154 3379#if defined(USE_ITHREADS)
20b7effb 3380 dVAR;
ba869deb
GS
3381# ifdef OLD_PTHREADS_API
3382 pthread_addr_t t;
5637ef5b
NC
3383 int error = pthread_getspecific(PL_thr_key, &t)
3384 if (error)
3385 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
ba869deb
GS
3386 return (void*)t;
3387# else
bce813aa 3388# ifdef I_MACH_CTHREADS
8b8b35ab 3389 return (void*)cthread_data(cthread_self());
bce813aa 3390# else
8b8b35ab
JH
3391 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3392# endif
c44d3fdb 3393# endif
ba869deb
GS
3394#else
3395 return (void*)NULL;
3396#endif
3397}
3398
3399void
3400Perl_set_context(void *t)
3401{
20b7effb 3402#if defined(USE_ITHREADS)
8772537c 3403 dVAR;
20b7effb 3404#endif
7918f24d 3405 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3406#if defined(USE_ITHREADS)
c44d3fdb
GS
3407# ifdef I_MACH_CTHREADS
3408 cthread_set_data(cthread_self(), t);
3409# else
5637ef5b
NC
3410 {
3411 const int error = pthread_setspecific(PL_thr_key, t);
3412 if (error)
3413 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3414 }
c44d3fdb 3415# endif
b464bac0 3416#else
8772537c 3417 PERL_UNUSED_ARG(t);
ba869deb
GS
3418#endif
3419}
3420
3421#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3422
27da23d5 3423#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3424struct perl_vars *
864dbfa3 3425Perl_GetVars(pTHX)
22239a37 3426{
23491f1d
JH
3427 PERL_UNUSED_CONTEXT;
3428 return &PL_Vars;
22239a37 3429}
31fb1209
NIS
3430#endif
3431
1cb0ed9b 3432char **
864dbfa3 3433Perl_get_op_names(pTHX)
31fb1209 3434{
96a5add6
AL
3435 PERL_UNUSED_CONTEXT;
3436 return (char **)PL_op_name;
31fb1209
NIS
3437}
3438
1cb0ed9b 3439char **
864dbfa3 3440Perl_get_op_descs(pTHX)
31fb1209 3441{
96a5add6
AL
3442 PERL_UNUSED_CONTEXT;
3443 return (char **)PL_op_desc;
31fb1209 3444}
9e6b2b00 3445
e1ec3a88 3446const char *
864dbfa3 3447Perl_get_no_modify(pTHX)
9e6b2b00 3448{
96a5add6
AL
3449 PERL_UNUSED_CONTEXT;
3450 return PL_no_modify;
9e6b2b00
GS
3451}
3452
3453U32 *
864dbfa3 3454Perl_get_opargs(pTHX)
9e6b2b00 3455{
96a5add6
AL
3456 PERL_UNUSED_CONTEXT;
3457 return (U32 *)PL_opargs;
9e6b2b00 3458}
51aa15f3 3459
0cb96387
GS
3460PPADDR_t*
3461Perl_get_ppaddr(pTHX)
3462{
96a5add6
AL
3463 dVAR;
3464 PERL_UNUSED_CONTEXT;
3465 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS
3466}
3467
a6c40364
GS
3468#ifndef HAS_GETENV_LEN
3469char *
bf4acbe4 3470Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3471{
8772537c 3472 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3473 PERL_UNUSED_CONTEXT;
7918f24d 3474 PERL_ARGS_ASSERT_GETENV_LEN;
a6c40364
GS
3475 if (env_trans)
3476 *len = strlen(env_trans);
3477 return env_trans;
f675dbe5
CB
3478}
3479#endif
3480
dc9e4912
GS
3481
3482MGVTBL*
864dbfa3 3483Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3484{
96a5add6 3485 PERL_UNUSED_CONTEXT;
dc9e4912 3486
c7fdacb9 3487 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
31114fe9 3488 ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
dc9e4912
GS
3489}
3490
767df6a1 3491I32
864dbfa3 3492Perl_my_fflush_all(pTHX)
767df6a1 3493{
97cb92d6 3494#if defined(USE_PERLIO) || defined(FFLUSH_NULL)
ce720889 3495 return PerlIO_flush(NULL);
767df6a1 3496#else
8fbdfb7c 3497# if defined(HAS__FWALK)
f13a2bc0 3498 extern int fflush(FILE *);
74cac757
JH
3499 /* undocumented, unprototyped, but very useful BSDism */
3500 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3501 _fwalk(&fflush);
74cac757 3502 return 0;
8fa7f367 3503# else
8fbdfb7c 3504# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3505 long open_max = -1;
8fbdfb7c 3506# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3507 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3508# else
8fa7f367 3509# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3510 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH
3511# else
3512# ifdef FOPEN_MAX
74cac757 3513 open_max = FOPEN_MAX;
8fa7f367
JH
3514# else
3515# ifdef OPEN_MAX
74cac757 3516 open_max = OPEN_MAX;
8fa7f367
JH
3517# else
3518# ifdef _NFILE
d2201af2 3519 open_max = _NFILE;
8fa7f367
JH
3520# endif
3521# endif
74cac757 3522# endif
767df6a1
JH
3523# endif
3524# endif
767df6a1
JH
3525 if (open_max > 0) {
3526 long i;
3527 for (i = 0; i < open_max; i++)
d2201af2
AD
3528 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3529 STDIO_STREAM_ARRAY[i]._file < open_max &&
3530 STDIO_STREAM_ARRAY[i]._flag)
3531 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH
3532 return 0;
3533 }
8fbdfb7c 3534# endif
93189314 3535 SETERRNO(EBADF,RMS_IFI);
767df6a1 3536 return EOF;
74cac757 3537# endif
767df6a1
JH
3538#endif
3539}
097ee67d 3540
69282e91 3541void
45219de6 3542Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
a5390457
NC
3543{
3544 if (ckWARN(WARN_IO)) {
0223a801 3545 HEK * const name
c6e4ff34 3546 = gv && (isGV_with_GP(gv))
0223a801 3547 ? GvENAME_HEK((gv))
3b46b707 3548 : NULL;
a5390457
NC
3549 const char * const direction = have == '>' ? "out" : "in";
3550
b3c81598 3551 if (name && HEK_LEN(name))
a5390457 3552 Perl_warner(aTHX_ packWARN(WARN_IO),
0223a801 3553 "Filehandle %"HEKf" opened only for %sput",
10bafe90 3554 HEKfARG(name), direction);
a5390457
NC
3555 else
3556 Perl_warner(aTHX_ packWARN(WARN_IO),
3557 "Filehandle opened only for %sput", direction);
3558 }
3559}
3560
3561void