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