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