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