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