This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
annotate the acquire/release of PL_op_mutex
[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)
2717{
3db8f154 2718#if defined(USE_ITHREADS)
20b7effb 2719 dVAR;
52e18b1f 2720 /* locks must be held in locking order (if any) */
4da80956
P
2721# ifdef USE_PERLIO
2722 MUTEX_LOCK(&PL_perlio_mutex);
2723# endif
52e18b1f
GS
2724# ifdef MYMALLOC
2725 MUTEX_LOCK(&PL_malloc_mutex);
2726# endif
2727 OP_REFCNT_LOCK;
2728#endif
2729}
2730
2731/* this is called in both parent and child after the fork() */
2732void
2733Perl_atfork_unlock(void)
2734{
3db8f154 2735#if defined(USE_ITHREADS)
20b7effb 2736 dVAR;
52e18b1f 2737 /* locks must be released in same order as in atfork_lock() */
4da80956
P
2738# ifdef USE_PERLIO
2739 MUTEX_UNLOCK(&PL_perlio_mutex);
2740# endif
52e18b1f
GS
2741# ifdef MYMALLOC
2742 MUTEX_UNLOCK(&PL_malloc_mutex);
2743# endif
2744 OP_REFCNT_UNLOCK;
2745#endif
2746}
2747
2748Pid_t
2749Perl_my_fork(void)
2750{
2751#if defined(HAS_FORK)
2752 Pid_t pid;
3db8f154 2753#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS
2754 atfork_lock();
2755 pid = fork();
2756 atfork_unlock();
2757#else
2758 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2759 * handlers elsewhere in the code */
2760 pid = fork();
2761#endif
2762 return pid;
40262ff4
AB
2763#elif defined(__amigaos4__)
2764 return amigaos_fork();
52e18b1f
GS
2765#else
2766 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2767 Perl_croak_nocontext("fork() not available");
b961a566 2768 return 0;
52e18b1f
GS
2769#endif /* HAS_FORK */
2770}
2771
fe14fcc3 2772#ifndef HAS_DUP2
fec02dd3 2773int
ba106d47 2774dup2(int oldfd, int newfd)
a687059c 2775{
a0d0e21e 2776#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
2777 if (oldfd == newfd)
2778 return oldfd;
6ad3d225 2779 PerlLIO_close(newfd);
fec02dd3 2780 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2781#else
fc36a67e
PP
2782#define DUP2_MAX_FDS 256
2783 int fdtmp[DUP2_MAX_FDS];
79072805 2784 I32 fdx = 0;
ae986130
LW
2785 int fd;
2786
fe14fcc3 2787 if (oldfd == newfd)
fec02dd3 2788 return oldfd;
6ad3d225 2789 PerlLIO_close(newfd);
fc36a67e 2790 /* good enough for low fd's... */
6ad3d225 2791 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2792 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2793 PerlLIO_close(fd);
fc36a67e
PP
2794 fd = -1;
2795 break;
2796 }
ae986130 2797 fdtmp[fdx++] = fd;
fc36a67e 2798 }
ae986130 2799 while (fdx > 0)
6ad3d225 2800 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2801 return fd;
62b28dd9 2802#endif
a687059c
LW
2803}
2804#endif
2805
64ca3a65 2806#ifndef PERL_MICRO
ff68c719
PP
2807#ifdef HAS_SIGACTION
2808
2809Sighandler_t
864dbfa3 2810Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719
PP
2811{
2812 struct sigaction act, oact;
2813
a10b1e10 2814#ifdef USE_ITHREADS
20b7effb 2815 dVAR;
a10b1e10
JH
2816 /* only "parent" interpreter can diddle signals */
2817 if (PL_curinterp != aTHX)
8aad04aa 2818 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2819#endif
2820
8aad04aa 2821 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2822 sigemptyset(&act.sa_mask);
2823 act.sa_flags = 0;
2824#ifdef SA_RESTART
4ffa73a3
JH
2825 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2826 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2827#endif
358837b8 2828#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2829 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2830 act.sa_flags |= SA_NOCLDWAIT;
2831#endif
ff68c719 2832 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2833 return (Sighandler_t) SIG_ERR;
ff68c719 2834 else
8aad04aa 2835 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2836}
2837
2838Sighandler_t
864dbfa3 2839Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
2840{
2841 struct sigaction oact;
96a5add6 2842 PERL_UNUSED_CONTEXT;
ff68c719
PP
2843
2844 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2845 return (Sighandler_t) SIG_ERR;
ff68c719 2846 else
8aad04aa 2847 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2848}
2849
2850int
864dbfa3 2851Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2852{
20b7effb 2853#ifdef USE_ITHREADS
27da23d5 2854 dVAR;
20b7effb 2855#endif
ff68c719
PP
2856 struct sigaction act;
2857
7918f24d
NC
2858 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2859
a10b1e10
JH
2860#ifdef USE_ITHREADS
2861 /* only "parent" interpreter can diddle signals */
2862 if (PL_curinterp != aTHX)
2863 return -1;
2864#endif
2865
8aad04aa 2866 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2867 sigemptyset(&act.sa_mask);
2868 act.sa_flags = 0;
2869#ifdef SA_RESTART
4ffa73a3
JH
2870 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2871 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2872#endif
36b5d377 2873#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2874 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2875 act.sa_flags |= SA_NOCLDWAIT;
2876#endif
ff68c719
PP
2877 return sigaction(signo, &act, save);
2878}
2879
2880int
864dbfa3 2881Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2882{
20b7effb 2883#ifdef USE_ITHREADS
27da23d5 2884 dVAR;
20b7effb
JH
2885#endif
2886 PERL_UNUSED_CONTEXT;
a10b1e10
JH
2887#ifdef USE_ITHREADS
2888 /* only "parent" interpreter can diddle signals */
2889 if (PL_curinterp != aTHX)
2890 return -1;
2891#endif
2892
ff68c719
PP
2893 return sigaction(signo, save, (struct sigaction *)NULL);
2894}
2895
2896#else /* !HAS_SIGACTION */
2897
2898Sighandler_t
864dbfa3 2899Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2900{
39f1703b 2901#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2902 /* only "parent" interpreter can diddle signals */
2903 if (PL_curinterp != aTHX)
8aad04aa 2904 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2905#endif
2906
6ad3d225 2907 return PerlProc_signal(signo, handler);
ff68c719
PP
2908}
2909
fabdb6c0 2910static Signal_t
4e35701f 2911sig_trap(int signo)
ff68c719 2912{
27da23d5
JH
2913 dVAR;
2914 PL_sig_trapped++;
ff68c719
PP
2915}
2916
2917Sighandler_t
864dbfa3 2918Perl_rsignal_state(pTHX_ int signo)
ff68c719 2919{
27da23d5 2920 dVAR;
ff68c719
PP
2921 Sighandler_t oldsig;
2922
39f1703b 2923#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2924 /* only "parent" interpreter can diddle signals */
2925 if (PL_curinterp != aTHX)
8aad04aa 2926 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2927#endif
2928
27da23d5 2929 PL_sig_trapped = 0;
6ad3d225
GS
2930 oldsig = PerlProc_signal(signo, sig_trap);
2931 PerlProc_signal(signo, oldsig);
27da23d5 2932 if (PL_sig_trapped)
3aed30dc 2933 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719
PP
2934 return oldsig;
2935}
2936
2937int
864dbfa3 2938Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2939{
39f1703b 2940#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2941 /* only "parent" interpreter can diddle signals */
2942 if (PL_curinterp != aTHX)
2943 return -1;
2944#endif
6ad3d225 2945 *save = PerlProc_signal(signo, handler);
8aad04aa 2946 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
2947}
2948
2949int
864dbfa3 2950Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2951{
39f1703b 2952#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2953 /* only "parent" interpreter can diddle signals */
2954 if (PL_curinterp != aTHX)
2955 return -1;
2956#endif
8aad04aa 2957 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
2958}
2959
2960#endif /* !HAS_SIGACTION */
64ca3a65 2961#endif /* !PERL_MICRO */
ff68c719 2962
5f05dabc 2963 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
53f73940 2964#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
79072805 2965I32
864dbfa3 2966Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2967{
a687059c 2968 int status;
a0d0e21e 2969 SV **svp;
d8a83dd3 2970 Pid_t pid;
2e0cfa16 2971 Pid_t pid2 = 0;
03136e13 2972 bool close_failed;
4ee39169 2973 dSAVEDERRNO;
2e0cfa16 2974 const int fd = PerlIO_fileno(ptr);
e9d373c4
TC
2975 bool should_wait;
2976
2977 svp = av_fetch(PL_fdpid,fd,TRUE);
2978 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2979 SvREFCNT_dec(*svp);
2980 *svp = NULL;
2e0cfa16 2981
97cb92d6 2982#if defined(USE_PERLIO)
2e0cfa16
FC
2983 /* Find out whether the refcount is low enough for us to wait for the
2984 child proc without blocking. */
e9d373c4 2985 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
b6ae43b7 2986#else
e9d373c4 2987 should_wait = pid > 0;
b6ae43b7 2988#endif
a687059c 2989
ddcf38b7
IZ
2990#ifdef OS2
2991 if (pid == -1) { /* Opened by popen. */
2992 return my_syspclose(ptr);
2993 }
a1d180c4 2994#endif
f1618b10
CS
2995 close_failed = (PerlIO_close(ptr) == EOF);
2996 SAVE_ERRNO;
2e0cfa16 2997 if (should_wait) do {
1d3434b8
GS
2998 pid2 = wait4pid(pid, &status, 0);
2999 } while (pid2 == -1 && errno == EINTR);
03136e13 3000 if (close_failed) {
4ee39169 3001 RESTORE_ERRNO;
03136e13
CS
3002 return -1;
3003 }
2e0cfa16
FC
3004 return(
3005 should_wait
3006 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3007 : 0
3008 );
20188a90 3009}
9c12f1e5
RGS
3010#else
3011#if defined(__LIBCATAMOUNT__)
3012I32
3013Perl_my_pclose(pTHX_ PerlIO *ptr)
3014{
3015 return -1;
3016}
3017#endif
4633a7c4
LW
3018#endif /* !DOSISH */
3019
e37778c2 3020#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 3021I32
d8a83dd3 3022Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 3023{
27da23d5 3024 I32 result = 0;
7918f24d 3025 PERL_ARGS_ASSERT_WAIT4PID;
ca0c25f6 3026#ifdef PERL_USES_PL_PIDSTATUS
d4c02743
TC
3027 if (!pid) {
3028 /* PERL_USES_PL_PIDSTATUS is only defined when neither
3029 waitpid() nor wait4() is available, or on OS/2, which
3030 doesn't appear to support waiting for a progress group
3031 member, so we can only treat a 0 pid as an unknown child.
3032 */
3033 errno = ECHILD;
3034 return -1;
3035 }
b7953727 3036 {
3aed30dc 3037 if (pid > 0) {
12072db5
NC
3038 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3039 pid, rather than a string form. */
c4420975 3040 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS
3041 if (svp && *svp != &PL_sv_undef) {
3042 *statusp = SvIVX(*svp);
12072db5
NC
3043 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3044 G_DISCARD);
3aed30dc
HS
3045 return pid;
3046 }
3047 }
3048 else {
3049 HE *entry;
3050
3051 hv_iterinit(PL_pidstatus);
3052 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 3053 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 3054 I32 len;
0bcc34c2 3055 const char * const spid = hv_iterkey(entry,&len);
27da23d5 3056
12072db5
NC
3057 assert (len == sizeof(Pid_t));
3058 memcpy((char *)&pid, spid, len);
3aed30dc 3059 *statusp = SvIVX(sv);
7b9a3241
NC
3060 /* The hash iterator is currently on this entry, so simply
3061 calling hv_delete would trigger the lazy delete, which on
f6bab5f6 3062 aggregate does more work, because next call to hv_iterinit()
7b9a3241
NC
3063 would spot the flag, and have to call the delete routine,
3064 while in the meantime any new entries can't re-use that
3065 memory. */
3066 hv_iterinit(PL_pidstatus);
7ea75b61 3067 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS
3068 return pid;
3069 }
20188a90
LW
3070 }
3071 }
68a29c53 3072#endif
79072805 3073#ifdef HAS_WAITPID
367f3c24
IZ
3074# ifdef HAS_WAITPID_RUNTIME
3075 if (!HAS_WAITPID_RUNTIME)
3076 goto hard_way;
3077# endif
cddd4526 3078 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 3079 goto finish;
367f3c24
IZ
3080#endif
3081#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
d4c02743 3082 result = wait4(pid,statusp,flags,NULL);
dfcfdb64 3083 goto finish;
367f3c24 3084#endif
ca0c25f6 3085#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 3086#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 3087 hard_way:
27da23d5 3088#endif
a0d0e21e 3089 {
a0d0e21e 3090 if (flags)
cea2e8a9 3091 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 3092 else {
76e3520e 3093 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW
3094 pidgone(result,*statusp);
3095 if (result < 0)
3096 *statusp = -1;
3097 }
a687059c
LW
3098 }
3099#endif
27da23d5 3100#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 3101 finish:
27da23d5 3102#endif
cddd4526
NIS
3103 if (result < 0 && errno == EINTR) {
3104 PERL_ASYNC_CHECK();
48dbb59e 3105 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS
3106 }
3107 return result;
a687059c 3108}
2986a63f 3109#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 3110
ca0c25f6 3111#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 3112void
ed4173ef 3113S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 3114{
eb578fdb 3115 SV *sv;
a687059c 3116
12072db5 3117 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 3118 SvUPGRADE(sv,SVt_IV);
45977657 3119 SvIV_set(sv, status);
20188a90 3120 return;
a687059c 3121}
ca0c25f6 3122#endif
a687059c 3123
53f73940
AB
3124#if defined(OS2) || defined(__amigaos4__)
3125# if defined(__amigaos4__) && defined(pclose)
3126# undef pclose
3127# endif
7c0587c8 3128int pclose();
ddcf38b7
IZ
3129#ifdef HAS_FORK
3130int /* Cannot prototype with I32
3131 in os2ish.h. */
ba106d47 3132my_syspclose(PerlIO *ptr)
ddcf38b7 3133#else
79072805 3134I32
864dbfa3 3135Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 3136#endif
a687059c 3137{
760ac839 3138 /* Needs work for PerlIO ! */
c4420975 3139 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 3140 const I32 result = pclose(f);
2b96b0a5
JH
3141 PerlIO_releaseFILE(ptr,f);
3142 return result;
3143}
3144#endif
3145
933fea7f 3146#if defined(DJGPP)
2b96b0a5
JH
3147int djgpp_pclose();
3148I32
3149Perl_my_pclose(pTHX_ PerlIO *ptr)
3150{
3151 /* Needs work for PerlIO ! */
c4420975 3152 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 3153 I32 result = djgpp_pclose(f);
933fea7f 3154 result = (result << 8) & 0xff00;
760ac839
LW
3155 PerlIO_releaseFILE(ptr,f);
3156 return result;
a687059c 3157}
7c0587c8 3158#endif
9f68db38 3159
16fa5c11 3160#define PERL_REPEATCPY_LINEAR 4
9f68db38 3161void
5aaab254 3162Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
9f68db38 3163{
7918f24d
NC
3164 PERL_ARGS_ASSERT_REPEATCPY;
3165
223f01db
KW
3166 assert(len >= 0);
3167
2709980d 3168 if (count < 0)
d1decf2b 3169 croak_memory_wrap();
2709980d 3170
16fa5c11
VP
3171 if (len == 1)
3172 memset(to, *from, count);
3173 else if (count) {
eb578fdb 3174 char *p = to;
26e1303d 3175 IV items, linear, half;
16fa5c11
VP
3176
3177 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3178 for (items = 0; items < linear; ++items) {
eb578fdb 3179 const char *q = from;
26e1303d 3180 IV todo;
16fa5c11
VP
3181 for (todo = len; todo > 0; todo--)
3182 *p++ = *q++;
3183 }
3184
3185 half = count / 2;
3186 while (items <= half) {
26e1303d 3187 IV size = items * len;
16fa5c11
VP
3188 memcpy(p, to, size);
3189 p += size;
3190 items *= 2;
9f68db38 3191 }
16fa5c11
VP
3192
3193 if (count > items)
3194 memcpy(p, to, (count - items) * len);
9f68db38
LW
3195 }
3196}
0f85fab0 3197
fe14fcc3 3198#ifndef HAS_RENAME
79072805 3199I32
4373e329 3200Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3201{
93a17b20
LW
3202 char *fa = strrchr(a,'/');
3203 char *fb = strrchr(b,'/');
c623ac67
GS
3204 Stat_t tmpstatbuf1;
3205 Stat_t tmpstatbuf2;
c4420975 3206 SV * const tmpsv = sv_newmortal();
62b28dd9 3207
7918f24d
NC
3208 PERL_ARGS_ASSERT_SAME_DIRENT;
3209
62b28dd9
LW
3210 if (fa)
3211 fa++;
3212 else
3213 fa = a;
3214 if (fb)
3215 fb++;
3216 else
3217 fb = b;
3218 if (strNE(a,b))
3219 return FALSE;
3220 if (fa == a)
76f68e9b 3221 sv_setpvs(tmpsv, ".");
62b28dd9 3222 else
46fc3d4c 3223 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3224 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
3225 return FALSE;
3226 if (fb == b)
76f68e9b 3227 sv_setpvs(tmpsv, ".");
62b28dd9 3228 else
46fc3d4c 3229 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3230 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
3231 return FALSE;
3232 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3233 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3234}
fe14fcc3
LW
3235#endif /* !HAS_RENAME */
3236
491527d0 3237char*
7f315aed
NC
3238Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3239 const char *const *const search_ext, I32 flags)
491527d0 3240{
bd61b366
SS
3241 const char *xfound = NULL;
3242 char *xfailed = NULL;
0f31cffe 3243 char tmpbuf[MAXPATHLEN];
eb578fdb 3244 char *s;
5f74f29c 3245 I32 len = 0;
491527d0 3246 int retval;
39a02377 3247 char *bufend;
7c458fae 3248#if defined(DOSISH) && !defined(OS2)
491527d0
GS
3249# define SEARCH_EXTS ".bat", ".cmd", NULL
3250# define MAX_EXT_LEN 4
3251#endif
3252#ifdef OS2
3253# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3254# define MAX_EXT_LEN 4
3255#endif
3256#ifdef VMS
3257# define SEARCH_EXTS ".pl", ".com", NULL
3258# define MAX_EXT_LEN 4
3259#endif
3260 /* additional extensions to try in each dir if scriptname not found */
3261#ifdef SEARCH_EXTS
0bcc34c2 3262 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3263 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3264 int extidx = 0, i = 0;
bd61b366 3265 const char *curext = NULL;
491527d0 3266#else
53c1dcc0 3267 PERL_UNUSED_ARG(search_ext);
491527d0
GS
3268# define MAX_EXT_LEN 0
3269#endif
3270
7918f24d
NC
3271 PERL_ARGS_ASSERT_FIND_SCRIPT;
3272
491527d0
GS
3273 /*
3274 * If dosearch is true and if scriptname does not contain path
3275 * delimiters, search the PATH for scriptname.
3276 *
3277 * If SEARCH_EXTS is also defined, will look for each
3278 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3279 * while searching the PATH.
3280 *
3281 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3282 * proceeds as follows:
3283 * If DOSISH or VMSISH:
3284 * + look for ./scriptname{,.foo,.bar}
3285 * + search the PATH for scriptname{,.foo,.bar}
3286 *
3287 * If !DOSISH:
3288 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3289 * this will not look in '.' if it's not in the PATH)
3290 */
84486fc6 3291 tmpbuf[0] = '\0';
491527d0
GS
3292
3293#ifdef VMS
3294# ifdef ALWAYS_DEFTYPES
3295 len = strlen(scriptname);
3296 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3297 int idx = 0, deftypes = 1;
491527d0
GS
3298 bool seen_dot = 1;
3299
bd61b366 3300 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3301# else
3302 if (dosearch) {
c4420975 3303 int idx = 0, deftypes = 1;
491527d0
GS
3304 bool seen_dot = 1;
3305
bd61b366 3306 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3307# endif
3308 /* The first time through, just add SEARCH_EXTS to whatever we
3309 * already have, so we can check for default file types. */
3310 while (deftypes ||
84486fc6 3311 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0 3312 {
2aa28b86 3313 Stat_t statbuf;
491527d0
GS
3314 if (deftypes) {
3315 deftypes = 0;
84486fc6 3316 *tmpbuf = '\0';
491527d0 3317 }
84486fc6
GS
3318 if ((strlen(tmpbuf) + strlen(scriptname)
3319 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3320 continue; /* don't search dir with too-long name */
6fca0082 3321 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS
3322#else /* !VMS */
3323
3324#ifdef DOSISH
3325 if (strEQ(scriptname, "-"))
3326 dosearch = 0;
3327 if (dosearch) { /* Look in '.' first. */
fe2774ed 3328 const char *cur = scriptname;
491527d0
GS
3329#ifdef SEARCH_EXTS
3330 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3331 while (ext[i])
3332 if (strEQ(ext[i++],curext)) {
3333 extidx = -1; /* already has an ext */
3334 break;
3335 }
3336 do {
3337#endif
3338 DEBUG_p(PerlIO_printf(Perl_debug_log,
3339 "Looking for %s\n",cur));
45a23732 3340 {
0cc19a43 3341 Stat_t statbuf;
45a23732
DD
3342 if (PerlLIO_stat(cur,&statbuf) >= 0
3343 && !S_ISDIR(statbuf.st_mode)) {
3344 dosearch = 0;
3345 scriptname = cur;
491527d0 3346#ifdef SEARCH_EXTS
45a23732 3347 break;
491527d0 3348#endif
45a23732 3349 }
491527d0
GS
3350 }
3351#ifdef SEARCH_EXTS
3352 if (cur == scriptname) {
3353 len = strlen(scriptname);
84486fc6 3354 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3355 break;
9e4425f7
SH
3356 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3357 cur = tmpbuf;
491527d0
GS
3358 }
3359 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3360 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS
3361#endif
3362 }
3363#endif
3364
3365 if (dosearch && !strchr(scriptname, '/')
3366#ifdef DOSISH
3367 && !strchr(scriptname, '\\')
3368#endif
cd39f2b6 3369 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3370 {
491527d0 3371 bool seen_dot = 0;
92f0c265 3372
39a02377
DM
3373 bufend = s + strlen(s);
3374 while (s < bufend) {
45a23732 3375 Stat_t statbuf;
7c458fae 3376# ifdef DOSISH
491527d0 3377 for (len = 0; *s
491527d0 3378 && *s != ';'; len++, s++) {
84486fc6
GS
3379 if (len < sizeof tmpbuf)
3380 tmpbuf[len] = *s;
491527d0 3381 }
84486fc6
GS
3382 if (len < sizeof tmpbuf)
3383 tmpbuf[len] = '\0';
7c458fae 3384# else
39a02377 3385 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS
3386 ':',
3387 &len);
7c458fae 3388# endif
39a02377 3389 if (s < bufend)
491527d0 3390 s++;
84486fc6 3391 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS
3392 continue; /* don't search dir with too-long name */
3393 if (len
7c458fae 3394# ifdef DOSISH
84486fc6
GS
3395 && tmpbuf[len - 1] != '/'
3396 && tmpbuf[len - 1] != '\\'
490a0e98 3397# endif
491527d0 3398 )
84486fc6
GS
3399 tmpbuf[len++] = '/';
3400 if (len == 2 && tmpbuf[0] == '.')
491527d0 3401 seen_dot = 1;
28f0d0ec 3402 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS
3403#endif /* !VMS */
3404
3405#ifdef SEARCH_EXTS
84486fc6 3406 len = strlen(tmpbuf);
491527d0
GS
3407 if (extidx > 0) /* reset after previous loop */
3408 extidx = 0;
3409 do {
3410#endif
84486fc6 3411 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
45a23732
DD
3412 retval = PerlLIO_stat(tmpbuf,&statbuf);
3413 if (S_ISDIR(statbuf.st_mode)) {
017f25f1
IZ
3414 retval = -1;
3415 }
491527d0
GS
3416#ifdef SEARCH_EXTS
3417 } while ( retval < 0 /* not there */
3418 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3419 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS
3420 );
3421#endif
3422 if (retval < 0)
3423 continue;
45a23732
DD
3424 if (S_ISREG(statbuf.st_mode)
3425 && cando(S_IRUSR,TRUE,&statbuf)
e37778c2 3426#if !defined(DOSISH)
45a23732 3427 && cando(S_IXUSR,TRUE,&statbuf)
491527d0
GS
3428#endif
3429 )
3430 {
3aed30dc 3431 xfound = tmpbuf; /* bingo! */
491527d0
GS
3432 break;
3433 }
3434 if (!xfailed)
84486fc6 3435 xfailed = savepv(tmpbuf);
491527d0
GS
3436 }
3437#ifndef DOSISH
45a23732
DD
3438 {
3439 Stat_t statbuf;
3440 if (!xfound && !seen_dot && !xfailed &&
3441 (PerlLIO_stat(scriptname,&statbuf) < 0
3442 || S_ISDIR(statbuf.st_mode)))
3443#endif
3444 seen_dot = 1; /* Disable message. */
3445#ifndef DOSISH
3446 }
491527d0 3447#endif
9ccb31f9
GS
3448 if (!xfound) {
3449 if (flags & 1) { /* do or die? */
6ad282c7 3450 /* diag_listed_as: Can't execute %s */
3aed30dc 3451 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS
3452 (xfailed ? "execute" : "find"),
3453 (xfailed ? xfailed : scriptname),
3454 (xfailed ? "" : " on PATH"),
3455 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3456 }
bd61b366 3457 scriptname = NULL;
9ccb31f9 3458 }
43c5f42d 3459 Safefree(xfailed);
491527d0
GS
3460 scriptname = xfound;
3461 }
bd61b366 3462 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS
3463}
3464
ba869deb
GS
3465#ifndef PERL_GET_CONTEXT_DEFINED
3466
3467void *
3468Perl_get_context(void)
3469{
3db8f154 3470#if defined(USE_ITHREADS)
20b7effb 3471 dVAR;
ba869deb
GS
3472# ifdef OLD_PTHREADS_API
3473 pthread_addr_t t;
5637ef5b
NC
3474 int error = pthread_getspecific(PL_thr_key, &t)
3475 if (error)
3476 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
ba869deb
GS
3477 return (void*)t;
3478# else
bce813aa 3479# ifdef I_MACH_CTHREADS
8b8b35ab 3480 return (void*)cthread_data(cthread_self());
bce813aa 3481# else
8b8b35ab
JH
3482 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3483# endif
c44d3fdb 3484# endif
ba869deb
GS
3485#else
3486 return (void*)NULL;
3487#endif
3488}
3489
3490void
3491Perl_set_context(void *t)
3492{
20b7effb 3493#if defined(USE_ITHREADS)
8772537c 3494 dVAR;
20b7effb 3495#endif
7918f24d 3496 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3497#if defined(USE_ITHREADS)
c44d3fdb
GS
3498# ifdef I_MACH_CTHREADS
3499 cthread_set_data(cthread_self(), t);
3500# else
5637ef5b
NC
3501 {
3502 const int error = pthread_setspecific(PL_thr_key, t);
3503 if (error)
3504 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3505 }
c44d3fdb 3506# endif
b464bac0 3507#else
8772537c 3508 PERL_UNUSED_ARG(t);
ba869deb
GS
3509#endif
3510}
3511
3512#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3513
27da23d5 3514#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3515struct perl_vars *
864dbfa3 3516Perl_GetVars(pTHX)
22239a37 3517{
23491f1d
JH
3518 PERL_UNUSED_CONTEXT;
3519 return &PL_Vars;
22239a37 3520}
31fb1209
NIS
3521#endif
3522
1cb0ed9b 3523char **
864dbfa3 3524Perl_get_op_names(pTHX)
31fb1209 3525{
96a5add6
AL
3526 PERL_UNUSED_CONTEXT;
3527 return (char **)PL_op_name;
31fb1209
NIS
3528}
3529
1cb0ed9b 3530char **
864dbfa3 3531Perl_get_op_descs(pTHX)
31fb1209 3532{
96a5add6
AL
3533 PERL_UNUSED_CONTEXT;
3534 return (char **)PL_op_desc;
31fb1209 3535}
9e6b2b00 3536
e1ec3a88 3537const char *
864dbfa3 3538Perl_get_no_modify(pTHX)
9e6b2b00 3539{
96a5add6
AL
3540 PERL_UNUSED_CONTEXT;
3541 return PL_no_modify;
9e6b2b00
GS
3542}
3543
3544U32 *
864dbfa3 3545Perl_get_opargs(pTHX)
9e6b2b00 3546{
96a5add6
AL
3547 PERL_UNUSED_CONTEXT;
3548 return (U32 *)PL_opargs;
9e6b2b00 3549}
51aa15f3 3550
0cb96387
GS
3551PPADDR_t*
3552Perl_get_ppaddr(pTHX)
3553{
96a5add6
AL
3554 dVAR;
3555 PERL_UNUSED_CONTEXT;
3556 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS
3557}
3558
a6c40364
GS
3559#ifndef HAS_GETENV_LEN
3560char *
bf4acbe4 3561Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3562{
8772537c 3563 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3564 PERL_UNUSED_CONTEXT;
7918f24d 3565 PERL_ARGS_ASSERT_GETENV_LEN;
a6c40364
GS
3566 if (env_trans)
3567 *len = strlen(env_trans);
3568 return env_trans;
f675dbe5
CB
3569}
3570#endif
3571