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