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