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