This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
mg.c: Use SvTRUE instead of sv_true
[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
JP
1372=for apidoc form
1373
1374Takes a sprintf-style format pattern and conventional
1375(non-SV) arguments and returns the formatted string.
1376
1377 (char *) Perl_form(pTHX_ const char* pat, ...)
1378
1379can be used any place a string (char *) is required:
1380
1381 char * s = Perl_form("%d.%d",major,minor);
1382
1383Uses a single private buffer so if you want to format several strings you
1384must explicitly copy the earlier strings away (and free the copies when you
1385are done).
1386
3d12c238
KW
1387=for apidoc form_nocontext
1388Like C<L</form>> but does not take a thread context (C<aTHX>) parameter,
1389so is used in situations where the caller doesn't already have the thread
1390context.
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
c5df3096
Z
1421
1422Take a sprintf-style format pattern and argument list. These are used to
1423generate a string message. If the message does not end with a newline,
1424then it will be extended with some indication of the current location
1425in the code, as described for L</mess_sv>.
1426
1427Normally, the resulting message is returned in a new mortal SV.
1428During global destruction a single SV may be shared between uses of
1429this function.
1430
3d12c238
KW
1431=for apidoc mess_nocontext
1432Like C<L</mess>> but does not take a thread context (C<aTHX>) parameter,
1433so is used in situations where the caller doesn't already have the thread
1434context.
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
e07360fa 1722
c5df3096
Z
1723Behaves the same as L</croak_sv>, except for the return type.
1724It should be used only where the C<OP *> return type is required.
1725The function never actually returns.
e07360fa 1726
3d12c238
KW
1727=for apidoc die_nocontext
1728Like C<L</die>> but does not take a thread context (C<aTHX>) parameter,
1729so is used in situations where the caller doesn't already have the thread
1730context.
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
3d12c238
KW
1842=for apidoc croak_nocontext
1843Like C<L</croak>> but does not take a thread context (C<aTHX>) parameter,
1844so is used in situations where the caller doesn't already have the thread
1845context.
1846
c5df3096
Z
1847=cut
1848*/
1849
1850void
1851Perl_vcroak(pTHX_ const char* pat, va_list *args)
1852{
1853 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1854 invoke_exception_hook(ex, FALSE);
1855 die_unwind(ex);
a687059c
LW
1856}
1857
c5df3096 1858/*
44170c9a 1859=for apidoc croak
c5df3096
Z
1860
1861This is an XS interface to Perl's C<die> function.
1862
1863Take a sprintf-style format pattern and argument list. These are used to
1864generate a string message. If the message does not end with a newline,
1865then it will be extended with some indication of the current location
1866in the code, as described for L</mess_sv>.
1867
1868The error message will be used as an exception, by default
1869returning control to the nearest enclosing C<eval>, but subject to
1870modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1871function never returns normally.
1872
1873For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1874(C<$@>) will be used as an error message or object instead of building an
1875error message from arguments. If you want to throw a non-string object,
1876or build an error message in an SV yourself, it is preferable to use
1877the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1878
1879=cut
1880*/
1881
c5be433b 1882#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1883void
cea2e8a9 1884Perl_croak_nocontext(const char *pat, ...)
a687059c 1885{
cea2e8a9 1886 dTHX;
a687059c 1887 va_list args;
cea2e8a9 1888 va_start(args, pat);
c5be433b 1889 vcroak(pat, &args);
e5964223 1890 NOT_REACHED; /* NOTREACHED */
cea2e8a9
GS
1891 va_end(args);
1892}
1893#endif /* PERL_IMPLICIT_CONTEXT */
1894
d68c938a
KW
1895/* saves machine code for a common noreturn idiom typically used in Newx*() */
1896GCC_DIAG_IGNORE_DECL(-Wunused-function);
1897void
1898Perl_croak_memory_wrap(void)
1899{
1900 Perl_croak_nocontext("%s",PL_memory_wrap);
1901}
1902GCC_DIAG_RESTORE_DECL;
1903
c5df3096
Z
1904void
1905Perl_croak(pTHX_ const char *pat, ...)
1906{
1907 va_list args;
1908 va_start(args, pat);
1909 vcroak(pat, &args);
e5964223 1910 NOT_REACHED; /* NOTREACHED */
c5df3096
Z
1911 va_end(args);
1912}
1913
954c1994 1914/*
44170c9a 1915=for apidoc croak_no_modify
6ad8f254
NC
1916
1917Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
72d33970 1918terser object code than using C<Perl_croak>. Less code used on exception code
6ad8f254
NC
1919paths reduces CPU cache pressure.
1920
d8e47b5c 1921=cut
6ad8f254
NC
1922*/
1923
1924void
88772978 1925Perl_croak_no_modify(void)
6ad8f254 1926{
cb077ed2 1927 Perl_croak_nocontext( "%s", PL_no_modify);
6ad8f254
NC
1928}
1929
4cbe3a7d
DD
1930/* does not return, used in util.c perlio.c and win32.c
1931 This is typically called when malloc returns NULL.
1932*/
1933void
88772978 1934Perl_croak_no_mem(void)
4cbe3a7d
DD
1935{
1936 dTHX;
77c1c05b 1937
375ed12a
JH
1938 int fd = PerlIO_fileno(Perl_error_log);
1939 if (fd < 0)
1940 SETERRNO(EBADF,RMS_IFI);
1941 else {
1942 /* Can't use PerlIO to write as it allocates memory */
b469f1e0 1943 PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
375ed12a 1944 }
4cbe3a7d
DD
1945 my_exit(1);
1946}
1947
3d04513d
DD
1948/* does not return, used only in POPSTACK */
1949void
1950Perl_croak_popstack(void)
1951{
1952 dTHX;
1953 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1954 my_exit(1);
1955}
1956
6ad8f254 1957/*
44170c9a 1958=for apidoc warn_sv
ccfc67b7 1959
c5df3096 1960This is an XS interface to Perl's C<warn> function.
954c1994 1961
c5df3096
Z
1962C<baseex> is the error message or object. If it is a reference, it
1963will be used as-is. Otherwise it is used as a string, and if it does
1964not end with a newline then it will be extended with some indication of
1965the current location in the code, as described for L</mess_sv>.
9983fa3c 1966
c5df3096
Z
1967The error message or object will by default be written to standard error,
1968but this is subject to modification by a C<$SIG{__WARN__}> handler.
9983fa3c 1969
c5df3096
Z
1970To warn with a simple string message, the L</warn> function may be
1971more convenient.
954c1994
GS
1972
1973=cut
1974*/
1975
cea2e8a9 1976void
c5df3096 1977Perl_warn_sv(pTHX_ SV *baseex)
cea2e8a9 1978{
c5df3096
Z
1979 SV *ex = mess_sv(baseex, 0);
1980 PERL_ARGS_ASSERT_WARN_SV;
1981 if (!invoke_exception_hook(ex, TRUE))
1982 write_to_stderr(ex);
cea2e8a9
GS
1983}
1984
c5df3096 1985/*
44170c9a 1986=for apidoc vwarn
c5df3096
Z
1987
1988This is an XS interface to Perl's C<warn> function.
1989
3d12c238 1990This is like C<L</warn>>, but C<args> are an encapsulated
4d4f193c 1991argument list.
c5df3096
Z
1992
1993Unlike with L</vcroak>, C<pat> is not permitted to be null.
1994
1995=cut
1996*/
1997
c5be433b
GS
1998void
1999Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 2000{
c5df3096 2001 SV *ex = vmess(pat, args);
7918f24d 2002 PERL_ARGS_ASSERT_VWARN;
c5df3096
Z
2003 if (!invoke_exception_hook(ex, TRUE))
2004 write_to_stderr(ex);
2005}
7918f24d 2006
c5df3096 2007/*
44170c9a 2008=for apidoc warn
3b4eef1c 2009=for apidoc_item warn_nocontext
87582a92 2010
3b4eef1c 2011These are XS interfaces to Perl's C<warn> function.
c5df3096 2012
3b4eef1c
KW
2013They take a sprintf-style format pattern and argument list, which are used to
2014generate a string message. If the message does not end with a newline, then it
2015will be extended with some indication of the current location in the code, as
2016described for C<L</mess_sv>>.
c5df3096
Z
2017
2018The error message or object will by default be written to standard error,
2019but this is subject to modification by a C<$SIG{__WARN__}> handler.
2020
3b4eef1c 2021Unlike with C<L</croak>>, C<pat> is not permitted to be null.
c5df3096 2022
3b4eef1c
KW
2023The two forms differ only in that C<warn_nocontext> does not take a thread
2024context (C<aTHX>) parameter, so is used in situations where the caller doesn't
2025already have the thread context.
3d12c238 2026
c5df3096
Z
2027=cut
2028*/
8d063cd8 2029
c5be433b 2030#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
2031void
2032Perl_warn_nocontext(const char *pat, ...)
2033{
2034 dTHX;
2035 va_list args;
7918f24d 2036 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
cea2e8a9 2037 va_start(args, pat);
c5be433b 2038 vwarn(pat, &args);
cea2e8a9
GS
2039 va_end(args);
2040}
2041#endif /* PERL_IMPLICIT_CONTEXT */
2042
2043void
2044Perl_warn(pTHX_ const char *pat, ...)
2045{
2046 va_list args;
7918f24d 2047 PERL_ARGS_ASSERT_WARN;
cea2e8a9 2048 va_start(args, pat);
c5be433b 2049 vwarn(pat, &args);
cea2e8a9
GS
2050 va_end(args);
2051}
2052
3b4eef1c
KW
2053/*
2054=for apidoc warner
2055=for apidoc_item warner_nocontext
2056
2057These output a warning of the specified category (or categories) given by
2058C<err>, using the sprintf-style format pattern C<pat>, and argument list.
2059
2060C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
2061C<packWARN4> macros populated with the appropriate number of warning
2062categories. If any of the warning categories they specify is fatal, a fatal
2063exception is thrown.
2064
2065In any event a message is generated by the pattern and arguments. If the
2066message does not end with a newline, then it will be extended with some
2067indication of the current location in the code, as described for L</mess_sv>.
2068
2069The error message or object will by default be written to standard error,
2070but this is subject to modification by a C<$SIG{__WARN__}> handler.
2071
2072C<pat> is not permitted to be null.
2073
2074The two forms differ only in that C<warner_nocontext> does not take a thread
2075context (C<aTHX>) parameter, so is used in situations where the caller doesn't
2076already have the thread context.
2077
2078These functions differ from the similarly named C<L</warn>> functions, in that
2079the latter are for XS code to unconditionally display a warning, whereas these
2080are for code that may be compiling a perl program, and does extra checking to
2081see if the warning should be fatal.
2082
2083=for apidoc ck_warner
2084=for apidoc_item ck_warner_d
2085If none of the warning categories given by C<err> are enabled, do nothing;
2086otherwise call C<L</warner>> or C<L</warner_nocontext>> with the passed-in
2087parameters;.
2088
2089C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
2090C<packWARN4> macros populated with the appropriate number of warning
2091categories.
2092
2093The two forms differ only in that C<ck_warner_d> should be used if warnings for
2094any of the categories are by default enabled.
2095
2096=for apidoc vwarner
2097This is like C<L</warner>>, but C<args> are an encapsulated argument list.
2098
2099=cut
2100*/
2101
c5be433b
GS
2102#if defined(PERL_IMPLICIT_CONTEXT)
2103void
2104Perl_warner_nocontext(U32 err, const char *pat, ...)
2105{
27da23d5 2106 dTHX;
c5be433b 2107 va_list args;
7918f24d 2108 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
c5be433b
GS
2109 va_start(args, pat);
2110 vwarner(err, pat, &args);
2111 va_end(args);
2112}
2113#endif /* PERL_IMPLICIT_CONTEXT */
2114
599cee73 2115void
9b387841
NC
2116Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
2117{
2118 PERL_ARGS_ASSERT_CK_WARNER_D;
2119
2120 if (Perl_ckwarn_d(aTHX_ err)) {
2121 va_list args;
2122 va_start(args, pat);
2123 vwarner(err, pat, &args);
2124 va_end(args);
2125 }
2126}
2127
2128void
a2a5de95
NC
2129Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
2130{
2131 PERL_ARGS_ASSERT_CK_WARNER;
2132
2133 if (Perl_ckwarn(aTHX_ err)) {
2134 va_list args;
2135 va_start(args, pat);
2136 vwarner(err, pat, &args);
2137 va_end(args);
2138 }
2139}
2140
2141void
864dbfa3 2142Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM
2143{
2144 va_list args;
7918f24d 2145 PERL_ARGS_ASSERT_WARNER;
c5be433b
GS
2146 va_start(args, pat);
2147 vwarner(err, pat, &args);
2148 va_end(args);
2149}
2150
2151void
2152Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
2153{
7918f24d 2154 PERL_ARGS_ASSERT_VWARNER;
46b27d2f
LM
2155 if (
2156 (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
2157 !(PL_in_eval & EVAL_KEEPERR)
2158 ) {
a3b680e6 2159 SV * const msv = vmess(pat, args);
599cee73 2160
594b6fac
LM
2161 if (PL_parser && PL_parser->error_count) {
2162 qerror(msv);
2163 }
2164 else {
2165 invoke_exception_hook(msv, FALSE);
2166 die_unwind(msv);
2167 }
599cee73
PM
2168 }
2169 else {
d13b0d77 2170 Perl_vwarn(aTHX_ pat, args);
599cee73
PM
2171 }
2172}
2173
f54ba1c2
DM
2174/* implements the ckWARN? macros */
2175
2176bool
2177Perl_ckwarn(pTHX_ U32 w)
2178{
ad287e37 2179 /* If lexical warnings have not been set, use $^W. */
3c3f8cd6
AB
2180 if (isLEXWARN_off)
2181 return PL_dowarn & G_WARN_ON;
ad287e37 2182
26c7b074 2183 return ckwarn_common(w);
f54ba1c2
DM
2184}
2185
2186/* implements the ckWARN?_d macro */
2187
2188bool
2189Perl_ckwarn_d(pTHX_ U32 w)
2190{
ad287e37 2191 /* If lexical warnings have not been set then default classes warn. */
3c3f8cd6
AB
2192 if (isLEXWARN_off)
2193 return TRUE;
ad287e37 2194
26c7b074
NC
2195 return ckwarn_common(w);
2196}
2197
2198static bool
2199S_ckwarn_common(pTHX_ U32 w)
2200{
3c3f8cd6
AB
2201 if (PL_curcop->cop_warnings == pWARN_ALL)
2202 return TRUE;
ad287e37
NC
2203
2204 if (PL_curcop->cop_warnings == pWARN_NONE)
2205 return FALSE;
2206
98fe6610
NC
2207 /* Check the assumption that at least the first slot is non-zero. */
2208 assert(unpackWARN1(w));
2209
2210 /* Check the assumption that it is valid to stop as soon as a zero slot is
2211 seen. */
2212 if (!unpackWARN2(w)) {
2213 assert(!unpackWARN3(w));
2214 assert(!unpackWARN4(w));
2215 } else if (!unpackWARN3(w)) {
2216 assert(!unpackWARN4(w));
2217 }
2218
26c7b074
NC
2219 /* Right, dealt with all the special cases, which are implemented as non-
2220 pointers, so there is a pointer to a real warnings mask. */
98fe6610
NC
2221 do {
2222 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2223 return TRUE;
2224 } while (w >>= WARNshift);
2225
2226 return FALSE;
f54ba1c2
DM
2227}
2228
72dc9ed5
NC
2229/* Set buffer=NULL to get a new one. */
2230STRLEN *
8ee4cf24 2231Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
72dc9ed5 2232 STRLEN size) {
5af88345
FC
2233 const MEM_SIZE len_wanted =
2234 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
35da51f7 2235 PERL_UNUSED_CONTEXT;
7918f24d 2236 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
72dc9ed5 2237
10edeb5d
JH
2238 buffer = (STRLEN*)
2239 (specialWARN(buffer) ?
2240 PerlMemShared_malloc(len_wanted) :
2241 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC
2242 buffer[0] = size;
2243 Copy(bits, (buffer + 1), size, char);
5af88345
FC
2244 if (size < WARNsize)
2245 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
72dc9ed5
NC
2246 return buffer;
2247}
f54ba1c2 2248
e6587932
DM
2249/* since we've already done strlen() for both nam and val
2250 * we can use that info to make things faster than
2251 * sprintf(s, "%s=%s", nam, val)
2252 */
2253#define my_setenv_format(s, nam, nlen, val, vlen) \
2254 Copy(nam, s, nlen, char); \
2255 *(s+nlen) = '='; \
2256 Copy(val, s+(nlen+1), vlen, char); \
2257 *(s+(nlen+1+vlen)) = '\0'
2258
adebb90d
DM
2259
2260
c5d12488 2261#ifdef USE_ENVIRON_ARRAY
de5576aa 2262/* NB: VMS' my_setenv() is in vms.c */
34716e2a 2263
3d50648c
DM
2264/* Configure doesn't test for HAS_SETENV yet, so decide based on platform.
2265 * For Solaris, setenv() and unsetenv() were introduced in Solaris 9, so
2266 * testing for HAS UNSETENV is sufficient.
2267 */
822c8b4d 2268# if defined(__CYGWIN__)|| defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
3d50648c
DM
2269# define MY_HAS_SETENV
2270# endif
2271
34716e2a
DM
2272/* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if
2273 * 'current' is non-null, with up to three sizes that are added together.
2274 * It handles integer overflow.
2275 */
3d50648c 2276# ifndef MY_HAS_SETENV
34716e2a
DM
2277static char *
2278S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size)
2279{
2280 void *p;
2281 Size_t sl, l = l1 + l2;
2282
2283 if (l < l2)
2284 goto panic;
2285 l += l3;
2286 if (l < l3)
2287 goto panic;
2288 sl = l * size;
2289 if (sl < l)
2290 goto panic;
2291
2292 p = current
2293 ? safesysrealloc(current, sl)
2294 : safesysmalloc(sl);
2295 if (p)
2296 return (char*)p;
2297
2298 panic:
2299 croak_memory_wrap();
2300}
3d50648c 2301# endif
34716e2a
DM
2302
2303
adebb90d 2304# if !defined(WIN32) && !defined(NETWARE)
34716e2a 2305
df641d45 2306/*
51b56f5c 2307=for apidoc_section Utility Functions
df641d45
KW
2308=for apidoc my_setenv
2309
2310A wrapper for the C library L<setenv(3)>. Don't use the latter, as the perl
2311version has desirable safeguards
2312
2313=cut
2314*/
2315
8d063cd8 2316void
e1ec3a88 2317Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 2318{
adebb90d 2319# ifdef __amigaos4__
6e3136a6 2320 amigaos4_obtain_environ(__FUNCTION__);
adebb90d
DM
2321# endif
2322
2323# ifdef USE_ITHREADS
24f3e849
KW
2324 /* only parent thread can modify process environment, so no need to use a
2325 * mutex */
4efc5df6 2326 if (PL_curinterp == aTHX)
adebb90d 2327# endif
4efc5df6 2328 {
adebb90d
DM
2329
2330# ifndef PERL_USE_SAFE_PUTENV
50acdf95 2331 if (!PL_use_safe_putenv) {
b7d87861 2332 /* most putenv()s leak, so we manipulate environ directly */
34716e2a
DM
2333 UV i;
2334 Size_t vlen, nlen = strlen(nam);
b7d87861
JH
2335
2336 /* where does it go? */
2337 for (i = 0; environ[i]; i++) {
34716e2a 2338 if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=')
b7d87861
JH
2339 break;
2340 }
c5d12488 2341
b7d87861 2342 if (environ == PL_origenviron) { /* need we copy environment? */
34716e2a 2343 UV j, max;
b7d87861
JH
2344 char **tmpenv;
2345
2346 max = i;
2347 while (environ[max])
2348 max++;
adebb90d 2349
34716e2a
DM
2350 /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */
2351 tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*));
adebb90d 2352
b7d87861 2353 for (j=0; j<max; j++) { /* copy environment */
34716e2a
DM
2354 const Size_t len = strlen(environ[j]);
2355 tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1);
b7d87861
JH
2356 Copy(environ[j], tmpenv[j], len+1, char);
2357 }
adebb90d 2358
b7d87861
JH
2359 tmpenv[max] = NULL;
2360 environ = tmpenv; /* tell exec where it is now */
2361 }
adebb90d 2362
b7d87861
JH
2363 if (!val) {
2364 safesysfree(environ[i]);
2365 while (environ[i]) {
2366 environ[i] = environ[i+1];
2367 i++;
2368 }
adebb90d 2369# ifdef __amigaos4__
6e3136a6 2370 goto my_setenv_out;
adebb90d 2371# else
b7d87861 2372 return;
adebb90d 2373# endif
b7d87861 2374 }
adebb90d 2375
b7d87861 2376 if (!environ[i]) { /* does not exist yet */
34716e2a 2377 environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*));
b7d87861
JH
2378 environ[i+1] = NULL; /* make sure it's null terminated */
2379 }
2380 else
2381 safesysfree(environ[i]);
34716e2a 2382
b7d87861
JH
2383 vlen = strlen(val);
2384
34716e2a 2385 environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1);
b7d87861
JH
2386 /* all that work just for this */
2387 my_setenv_format(environ[i], nam, nlen, val, vlen);
adebb90d
DM
2388 }
2389 else {
2390
2391# endif /* !PERL_USE_SAFE_PUTENV */
2392
3d50648c 2393# ifdef MY_HAS_SETENV
adebb90d 2394# if defined(HAS_UNSETENV)
88f5bc07
AB
2395 if (val == NULL) {
2396 (void)unsetenv(nam);
2397 } else {
2398 (void)setenv(nam, val, 1);
2399 }
adebb90d 2400# else /* ! HAS_UNSETENV */
88f5bc07 2401 (void)setenv(nam, val, 1);
adebb90d
DM
2402# endif /* HAS_UNSETENV */
2403
2404# elif defined(HAS_UNSETENV)
2405
88f5bc07 2406 if (val == NULL) {
ba88ff58
MJ
2407 if (environ) /* old glibc can crash with null environ */
2408 (void)unsetenv(nam);
88f5bc07 2409 } else {
34716e2a
DM
2410 const Size_t nlen = strlen(nam);
2411 const Size_t vlen = strlen(val);
2412 char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
88f5bc07
AB
2413 my_setenv_format(new_env, nam, nlen, val, vlen);
2414 (void)putenv(new_env);
2415 }
adebb90d
DM
2416
2417# else /* ! HAS_UNSETENV */
2418
88f5bc07 2419 char *new_env;
34716e2a
DM
2420 const Size_t nlen = strlen(nam);
2421 Size_t vlen;
88f5bc07
AB
2422 if (!val) {
2423 val = "";
2424 }
2425 vlen = strlen(val);
34716e2a 2426 new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
88f5bc07
AB
2427 /* all that work just for this */
2428 my_setenv_format(new_env, nam, nlen, val, vlen);
2429 (void)putenv(new_env);
adebb90d 2430
3d50648c 2431# endif /* MY_HAS_SETENV */
adebb90d
DM
2432
2433# ifndef PERL_USE_SAFE_PUTENV
50acdf95 2434 }
adebb90d 2435# endif
4efc5df6 2436 }
adebb90d
DM
2437
2438# ifdef __amigaos4__
6e3136a6
AB
2439my_setenv_out:
2440 amigaos4_release_environ(__FUNCTION__);
adebb90d 2441# endif
8d063cd8
LW
2442}
2443
adebb90d 2444# else /* WIN32 || NETWARE */
68dc0745
PP
2445
2446void
72229eff 2447Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 2448{
eb578fdb 2449 char *envstr;
34716e2a
DM
2450 const Size_t nlen = strlen(nam);
2451 Size_t vlen;
e6587932 2452
c5d12488
JH
2453 if (!val) {
2454 val = "";
ac5c734f 2455 }
c5d12488 2456 vlen = strlen(val);
34716e2a 2457 envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
c5d12488
JH
2458 my_setenv_format(envstr, nam, nlen, val, vlen);
2459 (void)PerlEnv_putenv(envstr);
ff69e883 2460 safesysfree(envstr);
3e3baf6d
TB
2461}
2462
adebb90d
DM
2463# endif /* WIN32 || NETWARE */
2464
2465#endif /* USE_ENVIRON_ARRAY */
2466
2467
3e3baf6d 2468
378cc40b 2469
16d20bd9 2470#ifdef UNLINK_ALL_VERSIONS
79072805 2471I32
6e732051 2472Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 2473{
35da51f7 2474 I32 retries = 0;
378cc40b 2475
7918f24d
NC
2476 PERL_ARGS_ASSERT_UNLNK;
2477
35da51f7
AL
2478 while (PerlLIO_unlink(f) >= 0)
2479 retries++;
2480 return retries ? 0 : -1;
378cc40b
LW
2481}
2482#endif
2483
4a7d1889 2484PerlIO *
c9289b7b 2485Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
4a7d1889 2486{
f6fb4e44 2487#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
1f852d0d 2488 int p[2];
eb578fdb
KW
2489 I32 This, that;
2490 Pid_t pid;
1f852d0d
NIS
2491 SV *sv;
2492 I32 did_pipes = 0;
2493 int pp[2];
2494
7918f24d
NC
2495 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2496
1f852d0d
NIS
2497 PERL_FLUSHALL_FOR_CHILD;
2498 This = (*mode == 'w');
2499 that = !This;
284167a5 2500 if (TAINTING_get) {
1f852d0d
NIS
2501 taint_env();
2502 taint_proper("Insecure %s%s", "EXEC");
2503 }
884fc2d3 2504 if (PerlProc_pipe_cloexec(p) < 0)
4608196e 2505 return NULL;
1f852d0d 2506 /* Try for another pipe pair for error return */
74df577f 2507 if (PerlProc_pipe_cloexec(pp) >= 0)
1f852d0d 2508 did_pipes = 1;
52e18b1f 2509 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS
2510 if (errno != EAGAIN) {
2511 PerlLIO_close(p[This]);
4e6dfe71 2512 PerlLIO_close(p[that]);
1f852d0d
NIS
2513 if (did_pipes) {
2514 PerlLIO_close(pp[0]);
2515 PerlLIO_close(pp[1]);
2516 }
4608196e 2517 return NULL;
1f852d0d 2518 }
a2a5de95 2519 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
1f852d0d
NIS
2520 sleep(5);
2521 }
2522 if (pid == 0) {
2523 /* Child */
1f852d0d
NIS
2524#undef THIS
2525#undef THAT
2526#define THIS that
2527#define THAT This
1f852d0d 2528 /* Close parent's end of error status pipe (if any) */
74df577f 2529 if (did_pipes)
1f852d0d 2530 PerlLIO_close(pp[0]);
1f852d0d
NIS
2531 /* Now dup our end of _the_ pipe to right position */
2532 if (p[THIS] != (*mode == 'r')) {
2533 PerlLIO_dup2(p[THIS], *mode == 'r');
2534 PerlLIO_close(p[THIS]);
4e6dfe71
GS
2535 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2536 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2537 }
30c869b8
LT
2538 else {
2539 setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
4e6dfe71 2540 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
30c869b8 2541 }
1f852d0d
NIS
2542#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2543 /* No automatic close - do it by hand */
b7953727
JH
2544# ifndef NOFILE
2545# define NOFILE 20
2546# endif
a080fe3d
NIS
2547 {
2548 int fd;
2549
2550 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2551 if (fd != pp[1])
a080fe3d
NIS
2552 PerlLIO_close(fd);
2553 }
1f852d0d
NIS
2554 }
2555#endif
a0714e2c 2556 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS
2557 PerlProc__exit(1);
2558#undef THIS
2559#undef THAT
2560 }
2561 /* Parent */
1f852d0d
NIS
2562 if (did_pipes)
2563 PerlLIO_close(pp[1]);
2564 /* Keep the lower of the two fd numbers */
2565 if (p[that] < p[This]) {
884fc2d3 2566 PerlLIO_dup2_cloexec(p[This], p[that]);
1f852d0d
NIS
2567 PerlLIO_close(p[This]);
2568 p[This] = p[that];
2569 }
4e6dfe71
GS
2570 else
2571 PerlLIO_close(p[that]); /* close child's end of pipe */
2572
1f852d0d 2573 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2574 SvUPGRADE(sv,SVt_IV);
45977657 2575 SvIV_set(sv, pid);
1f852d0d
NIS
2576 PL_forkprocess = pid;
2577 /* If we managed to get status pipe check for exec fail */
2578 if (did_pipes && pid > 0) {
2579 int errkid;
35bc1e35 2580 unsigned read_total = 0;
1f852d0d 2581
35bc1e35 2582 while (read_total < sizeof(int)) {
19742f39 2583 const SSize_t n1 = PerlLIO_read(pp[0],
35bc1e35
JK
2584 (void*)(((char*)&errkid)+read_total),
2585 (sizeof(int)) - read_total);
1f852d0d
NIS
2586 if (n1 <= 0)
2587 break;
35bc1e35 2588 read_total += n1;
1f852d0d
NIS
2589 }
2590 PerlLIO_close(pp[0]);
2591 did_pipes = 0;
35bc1e35 2592 if (read_total) { /* Error */
1f852d0d 2593 int pid2, status;
8c51524e 2594 PerlLIO_close(p[This]);
35bc1e35
JK
2595 if (read_total != sizeof(int))
2596 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", read_total);
1f852d0d
NIS
2597 do {
2598 pid2 = wait4pid(pid, &status, 0);
2599 } while (pid2 == -1 && errno == EINTR);
2600 errno = errkid; /* Propagate errno from kid */
4608196e 2601 return NULL;
1f852d0d
NIS
2602 }
2603 }
2604 if (did_pipes)
2605 PerlLIO_close(pp[0]);
2606 return PerlIO_fdopen(p[This], mode);
2607#else
8492b23f 2608# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
4e205ed6 2609 return my_syspopen4(aTHX_ NULL, mode, n, args);
8492b23f
TC
2610# elif defined(WIN32)
2611 return win32_popenlist(mode, n, args);
9d419b5f 2612# else
4a7d1889
NIS
2613 Perl_croak(aTHX_ "List form of piped open not implemented");
2614 return (PerlIO *) NULL;
9d419b5f 2615# endif
1f852d0d 2616#endif
4a7d1889
NIS
2617}
2618
4dd5370d
AB
2619 /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2620#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
760ac839 2621PerlIO *
3dd43144 2622Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c
LW
2623{
2624 int p[2];
eb578fdb
KW
2625 I32 This, that;
2626 Pid_t pid;
79072805 2627 SV *sv;
bfce84ec 2628 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ
2629 I32 did_pipes = 0;
2630 int pp[2];
a687059c 2631
7918f24d
NC
2632 PERL_ARGS_ASSERT_MY_POPEN;
2633
45bc9206 2634 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ
2635#ifdef OS2
2636 if (doexec) {
23da6c43 2637 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2638 }
a1d180c4 2639#endif
8ac85365
NIS
2640 This = (*mode == 'w');
2641 that = !This;
284167a5 2642 if (doexec && TAINTING_get) {
bbce6d69
PP
2643 taint_env();
2644 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2645 }
884fc2d3 2646 if (PerlProc_pipe_cloexec(p) < 0)
4608196e 2647 return NULL;
74df577f 2648 if (doexec && PerlProc_pipe_cloexec(pp) >= 0)
e446cec8 2649 did_pipes = 1;
52e18b1f 2650 while ((pid = PerlProc_fork()) < 0) {
a687059c 2651 if (errno != EAGAIN) {
6ad3d225 2652 PerlLIO_close(p[This]);
b5ac89c3 2653 PerlLIO_close(p[that]);
e446cec8
IZ
2654 if (did_pipes) {
2655 PerlLIO_close(pp[0]);
2656 PerlLIO_close(pp[1]);
2657 }
a687059c 2658 if (!doexec)
b3647a36 2659 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2660 return NULL;
a687059c 2661 }
a2a5de95 2662 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW
2663 sleep(5);
2664 }
2665 if (pid == 0) {
79072805 2666
30ac6d9b
GS
2667#undef THIS
2668#undef THAT
a687059c 2669#define THIS that
8ac85365 2670#define THAT This
74df577f 2671 if (did_pipes)
e446cec8 2672 PerlLIO_close(pp[0]);
a687059c 2673 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS
2674 PerlLIO_dup2(p[THIS], *mode == 'r');
2675 PerlLIO_close(p[THIS]);
b5ac89c3
NIS
2676 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2677 PerlLIO_close(p[THAT]);
a687059c 2678 }
c6fe5b98
LT
2679 else {
2680 setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
b5ac89c3 2681 PerlLIO_close(p[THAT]);
c6fe5b98 2682 }
4435c477 2683#ifndef OS2
a687059c 2684 if (doexec) {
a0d0e21e 2685#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
2686#ifndef NOFILE
2687#define NOFILE 20
2688#endif
a080fe3d 2689 {
3aed30dc 2690 int fd;
a080fe3d
NIS
2691
2692 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2693 if (fd != pp[1])
3aed30dc 2694 PerlLIO_close(fd);
a080fe3d 2695 }
ae986130 2696#endif
a080fe3d
NIS
2697 /* may or may not use the shell */
2698 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2699 PerlProc__exit(1);
a687059c 2700 }
4435c477 2701#endif /* defined OS2 */
713cef20
IZ
2702
2703#ifdef PERLIO_USING_CRLF
2704 /* Since we circumvent IO layers when we manipulate low-level
2705 filedescriptors directly, need to manually switch to the
2706 default, binary, low-level mode; see PerlIOBuf_open(). */
2707 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2708#endif
3280af22 2709 PL_forkprocess = 0;
ca0c25f6 2710#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2711 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2712#endif
4608196e 2713 return NULL;
a687059c
LW
2714#undef THIS
2715#undef THAT
2716 }
e446cec8
IZ
2717 if (did_pipes)
2718 PerlLIO_close(pp[1]);
8ac85365 2719 if (p[that] < p[This]) {
884fc2d3 2720 PerlLIO_dup2_cloexec(p[This], p[that]);
6ad3d225 2721 PerlLIO_close(p[This]);
8ac85365 2722 p[This] = p[that];
62b28dd9 2723 }
b5ac89c3
NIS
2724 else
2725 PerlLIO_close(p[that]);
2726
3280af22 2727 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2728 SvUPGRADE(sv,SVt_IV);
45977657 2729 SvIV_set(sv, pid);
3280af22 2730 PL_forkprocess = pid;
e446cec8
IZ
2731 if (did_pipes && pid > 0) {
2732 int errkid;
bb7a0f54 2733 unsigned n = 0;
e446cec8
IZ
2734
2735 while (n < sizeof(int)) {
19742f39 2736 const SSize_t n1 = PerlLIO_read(pp[0],
e446cec8
IZ
2737 (void*)(((char*)&errkid)+n),
2738 (sizeof(int)) - n);
2739 if (n1 <= 0)
2740 break;
2741 n += n1;
2742 }
2f96c702
IZ
2743 PerlLIO_close(pp[0]);
2744 did_pipes = 0;
e446cec8 2745 if (n) { /* Error */
faa466a7 2746 int pid2, status;
8c51524e 2747 PerlLIO_close(p[This]);
e446cec8 2748 if (n != sizeof(int))
5637ef5b 2749 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
faa466a7
RG
2750 do {
2751 pid2 = wait4pid(pid, &status, 0);
2752 } while (pid2 == -1 && errno == EINTR);
e446cec8 2753 errno = errkid; /* Propagate errno from kid */
4608196e 2754 return NULL;
e446cec8
IZ
2755 }
2756 }
2757 if (did_pipes)
2758 PerlLIO_close(pp[0]);
8ac85365 2759 return PerlIO_fdopen(p[This], mode);
a687059c 2760}
8ad758c7 2761#elif defined(DJGPP)
2b96b0a5
JH
2762FILE *djgpp_popen();
2763PerlIO *
cef6ea9d 2764Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH
2765{
2766 PERL_FLUSHALL_FOR_CHILD;
2767 /* Call system's popen() to get a FILE *, then import it.
2768 used 0 for 2nd parameter to PerlIO_importFILE;
2769 apparently not used
2770 */
2771 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2772}
8ad758c7 2773#elif defined(__LIBCATAMOUNT__)
9c12f1e5
RGS
2774PerlIO *
2775Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2776{
2777 return NULL;
2778}
7c0587c8
LW
2779
2780#endif /* !DOSISH */
a687059c 2781
52e18b1f
GS
2782/* this is called in parent before the fork() */
2783void
2784Perl_atfork_lock(void)
80b94025
JH
2785#if defined(USE_ITHREADS)
2786# ifdef USE_PERLIO
2787 PERL_TSA_ACQUIRE(PL_perlio_mutex)
2788# endif
2789# ifdef MYMALLOC
2790 PERL_TSA_ACQUIRE(PL_malloc_mutex)
2791# endif
2792 PERL_TSA_ACQUIRE(PL_op_mutex)
2793#endif
52e18b1f 2794{
3db8f154 2795#if defined(USE_ITHREADS)
52e18b1f 2796 /* locks must be held in locking order (if any) */
4da80956
P
2797# ifdef USE_PERLIO
2798 MUTEX_LOCK(&PL_perlio_mutex);
2799# endif
52e18b1f
GS
2800# ifdef MYMALLOC
2801 MUTEX_LOCK(&PL_malloc_mutex);
2802# endif
2803 OP_REFCNT_LOCK;
2804#endif
2805}
2806
2807/* this is called in both parent and child after the fork() */
2808void
2809Perl_atfork_unlock(void)
80b94025
JH
2810#if defined(USE_ITHREADS)
2811# ifdef USE_PERLIO
2812 PERL_TSA_RELEASE(PL_perlio_mutex)
2813# endif
2814# ifdef MYMALLOC
2815 PERL_TSA_RELEASE(PL_malloc_mutex)
2816# endif
2817 PERL_TSA_RELEASE(PL_op_mutex)
2818#endif
52e18b1f 2819{
3db8f154 2820#if defined(USE_ITHREADS)
52e18b1f 2821 /* locks must be released in same order as in atfork_lock() */
4da80956
P
2822# ifdef USE_PERLIO
2823 MUTEX_UNLOCK(&PL_perlio_mutex);
2824# endif
52e18b1f
GS
2825# ifdef MYMALLOC
2826 MUTEX_UNLOCK(&PL_malloc_mutex);
2827# endif
2828 OP_REFCNT_UNLOCK;
2829#endif
2830}
2831
2832Pid_t
2833Perl_my_fork(void)
2834{
2835#if defined(HAS_FORK)
2836 Pid_t pid;
3db8f154 2837#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS
2838 atfork_lock();
2839 pid = fork();
2840 atfork_unlock();
2841#else
2842 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2843 * handlers elsewhere in the code */
2844 pid = fork();
2845#endif
2846 return pid;
40262ff4
AB
2847#elif defined(__amigaos4__)
2848 return amigaos_fork();
52e18b1f
GS
2849#else
2850 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2851 Perl_croak_nocontext("fork() not available");
b961a566 2852 return 0;
52e18b1f
GS
2853#endif /* HAS_FORK */
2854}
2855
fe14fcc3 2856#ifndef HAS_DUP2
fec02dd3 2857int
ba106d47 2858dup2(int oldfd, int newfd)
a687059c 2859{
a0d0e21e 2860#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
2861 if (oldfd == newfd)
2862 return oldfd;
6ad3d225 2863 PerlLIO_close(newfd);
fec02dd3 2864 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2865#else
fc36a67e
PP
2866#define DUP2_MAX_FDS 256
2867 int fdtmp[DUP2_MAX_FDS];
79072805 2868 I32 fdx = 0;
ae986130
LW
2869 int fd;
2870
fe14fcc3 2871 if (oldfd == newfd)
fec02dd3 2872 return oldfd;
6ad3d225 2873 PerlLIO_close(newfd);
fc36a67e 2874 /* good enough for low fd's... */
6ad3d225 2875 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2876 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2877 PerlLIO_close(fd);
fc36a67e
PP
2878 fd = -1;
2879 break;
2880 }
ae986130 2881 fdtmp[fdx++] = fd;
fc36a67e 2882 }
ae986130 2883 while (fdx > 0)
6ad3d225 2884 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2885 return fd;
62b28dd9 2886#endif
a687059c
LW
2887}
2888#endif
2889
64ca3a65 2890#ifndef PERL_MICRO
ff68c719
PP
2891#ifdef HAS_SIGACTION
2892
962fce0f 2893/*
51b56f5c 2894=for apidoc_section Signals
962fce0f
KW
2895=for apidoc rsignal
2896
2897A wrapper for the C library L<signal(2)>. Don't use the latter, as the Perl
2898version knows things that interact with the rest of the perl interpreter.
2899
2900=cut
2901*/
2902
ff68c719 2903Sighandler_t
864dbfa3 2904Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719
PP
2905{
2906 struct sigaction act, oact;
2907
a10b1e10
JH
2908#ifdef USE_ITHREADS
2909 /* only "parent" interpreter can diddle signals */
2910 if (PL_curinterp != aTHX)
8aad04aa 2911 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2912#endif
2913
8d61efc5 2914 act.sa_handler = handler;
ff68c719
PP
2915 sigemptyset(&act.sa_mask);
2916 act.sa_flags = 0;
2917#ifdef SA_RESTART
4ffa73a3
JH
2918 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2919 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2920#endif
358837b8 2921#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2922 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2923 act.sa_flags |= SA_NOCLDWAIT;
2924#endif
ff68c719 2925 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2926 return (Sighandler_t) SIG_ERR;
ff68c719 2927 else
8aad04aa 2928 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2929}
2930
2931Sighandler_t
864dbfa3 2932Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
2933{
2934 struct sigaction oact;
96a5add6 2935 PERL_UNUSED_CONTEXT;
ff68c719
PP
2936
2937 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2938 return (Sighandler_t) SIG_ERR;
ff68c719 2939 else
8aad04aa 2940 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2941}
2942
2943int
864dbfa3 2944Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2945{
20b7effb 2946#ifdef USE_ITHREADS
20b7effb 2947#endif
ff68c719
PP
2948 struct sigaction act;
2949
7918f24d
NC
2950 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2951
a10b1e10
JH
2952#ifdef USE_ITHREADS
2953 /* only "parent" interpreter can diddle signals */
2954 if (PL_curinterp != aTHX)
2955 return -1;
2956#endif
2957
8d61efc5 2958 act.sa_handler = handler;
ff68c719
PP
2959 sigemptyset(&act.sa_mask);
2960 act.sa_flags = 0;
2961#ifdef SA_RESTART
4ffa73a3
JH
2962 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2963 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2964#endif
36b5d377 2965#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2966 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2967 act.sa_flags |= SA_NOCLDWAIT;
2968#endif
ff68c719
PP
2969 return sigaction(signo, &act, save);
2970}
2971
2972int
864dbfa3 2973Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2974{
20b7effb 2975#ifdef USE_ITHREADS
20b7effb
JH
2976#endif
2977 PERL_UNUSED_CONTEXT;
a10b1e10
JH
2978#ifdef USE_ITHREADS
2979 /* only "parent" interpreter can diddle signals */
2980 if (PL_curinterp != aTHX)
2981 return -1;
2982#endif
2983
ff68c719
PP
2984 return sigaction(signo, save, (struct sigaction *)NULL);
2985}
2986
2987#else /* !HAS_SIGACTION */
2988
2989Sighandler_t
864dbfa3 2990Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2991{
39f1703b 2992#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2993 /* only "parent" interpreter can diddle signals */
2994 if (PL_curinterp != aTHX)
8aad04aa 2995 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2996#endif
2997
6ad3d225 2998 return PerlProc_signal(signo, handler);
ff68c719
PP
2999}
3000
fabdb6c0 3001static Signal_t
4e35701f 3002sig_trap(int signo)
ff68c719 3003{
27da23d5 3004 PL_sig_trapped++;
ff68c719
PP
3005}
3006
3007Sighandler_t
864dbfa3 3008Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
3009{
3010 Sighandler_t oldsig;
3011
39f1703b 3012#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3013 /* only "parent" interpreter can diddle signals */
3014 if (PL_curinterp != aTHX)
8aad04aa 3015 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
3016#endif
3017
27da23d5 3018 PL_sig_trapped = 0;
6ad3d225
GS
3019 oldsig = PerlProc_signal(signo, sig_trap);
3020 PerlProc_signal(signo, oldsig);
27da23d5 3021 if (PL_sig_trapped)
3aed30dc 3022 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719
PP
3023 return oldsig;
3024}
3025
3026int
864dbfa3 3027Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 3028{
39f1703b 3029#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3030 /* only "parent" interpreter can diddle signals */
3031 if (PL_curinterp != aTHX)
3032 return -1;
3033#endif
6ad3d225 3034 *save = PerlProc_signal(signo, handler);
8aad04aa 3035 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3036}
3037
3038int
864dbfa3 3039Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 3040{
39f1703b 3041#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3042 /* only "parent" interpreter can diddle signals */
3043 if (PL_curinterp != aTHX)
3044 return -1;
3045#endif
8aad04aa 3046 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3047}
3048
3049#endif /* !HAS_SIGACTION */
64ca3a65 3050#endif /* !PERL_MICRO */
ff68c719 3051
5f05dabc 3052 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
53f73940 3053#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
79072805 3054I32
864dbfa3 3055Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 3056{
a687059c 3057 int status;
a0d0e21e 3058 SV **svp;
d8a83dd3 3059 Pid_t pid;
2e0cfa16 3060 Pid_t pid2 = 0;
03136e13 3061 bool close_failed;
4ee39169 3062 dSAVEDERRNO;
2e0cfa16 3063 const int fd = PerlIO_fileno(ptr);
e9d373c4
TC
3064 bool should_wait;
3065
3066 svp = av_fetch(PL_fdpid,fd,TRUE);
3067 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3068 SvREFCNT_dec(*svp);
3069 *svp = NULL;
2e0cfa16 3070
97cb92d6 3071#if defined(USE_PERLIO)
2e0cfa16
FC
3072 /* Find out whether the refcount is low enough for us to wait for the
3073 child proc without blocking. */
e9d373c4 3074 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
b6ae43b7 3075#else
e9d373c4 3076 should_wait = pid > 0;
b6ae43b7 3077#endif
a687059c 3078
ddcf38b7
IZ
3079#ifdef OS2
3080 if (pid == -1) { /* Opened by popen. */
3081 return my_syspclose(ptr);
3082 }
a1d180c4 3083#endif
f1618b10
CS
3084 close_failed = (PerlIO_close(ptr) == EOF);
3085 SAVE_ERRNO;
2e0cfa16 3086 if (should_wait) do {
1d3434b8
GS
3087 pid2 = wait4pid(pid, &status, 0);
3088 } while (pid2 == -1 && errno == EINTR);
03136e13 3089 if (close_failed) {
4ee39169 3090 RESTORE_ERRNO;
03136e13
CS
3091 return -1;
3092 }
2e0cfa16
FC
3093 return(
3094 should_wait
3095 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3096 : 0
3097 );
20188a90 3098}
8ad758c7 3099#elif defined(__LIBCATAMOUNT__)
9c12f1e5
RGS
3100I32
3101Perl_my_pclose(pTHX_ PerlIO *ptr)
3102{
3103 return -1;
3104}
4633a7c4
LW
3105#endif /* !DOSISH */
3106
e37778c2 3107#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 3108I32
d8a83dd3 3109Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 3110{
27da23d5 3111 I32 result = 0;
7918f24d 3112 PERL_ARGS_ASSERT_WAIT4PID;
ca0c25f6 3113#ifdef PERL_USES_PL_PIDSTATUS
d4c02743
TC
3114 if (!pid) {
3115 /* PERL_USES_PL_PIDSTATUS is only defined when neither
3116 waitpid() nor wait4() is available, or on OS/2, which
3117 doesn't appear to support waiting for a progress group
3118 member, so we can only treat a 0 pid as an unknown child.
3119 */
3120 errno = ECHILD;
3121 return -1;
3122 }
b7953727 3123 {
3aed30dc 3124 if (pid > 0) {
12072db5
NC
3125 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3126 pid, rather than a string form. */
c4420975 3127 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS
3128 if (svp && *svp != &PL_sv_undef) {
3129 *statusp = SvIVX(*svp);
12072db5
NC
3130 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3131 G_DISCARD);
3aed30dc
HS
3132 return pid;
3133 }
3134 }
3135 else {
3136 HE *entry;
3137
3138 hv_iterinit(PL_pidstatus);
3139 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 3140 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 3141 I32 len;
0bcc34c2 3142 const char * const spid = hv_iterkey(entry,&len);
27da23d5 3143
12072db5
NC
3144 assert (len == sizeof(Pid_t));
3145 memcpy((char *)&pid, spid, len);
3aed30dc 3146 *statusp = SvIVX(sv);
7b9a3241
NC
3147 /* The hash iterator is currently on this entry, so simply
3148 calling hv_delete would trigger the lazy delete, which on
f6bab5f6 3149 aggregate does more work, because next call to hv_iterinit()
7b9a3241
NC
3150 would spot the flag, and have to call the delete routine,
3151 while in the meantime any new entries can't re-use that
3152 memory. */
3153 hv_iterinit(PL_pidstatus);
7ea75b61 3154 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS
3155 return pid;
3156 }
20188a90
LW
3157 }
3158 }
68a29c53 3159#endif
79072805 3160#ifdef HAS_WAITPID
367f3c24
IZ
3161# ifdef HAS_WAITPID_RUNTIME
3162 if (!HAS_WAITPID_RUNTIME)
3163 goto hard_way;
3164# endif
cddd4526 3165 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 3166 goto finish;
367f3c24
IZ
3167#endif
3168#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
d4c02743 3169 result = wait4(pid,statusp,flags,NULL);
dfcfdb64 3170 goto finish;
367f3c24 3171#endif
ca0c25f6 3172#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 3173#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 3174 hard_way:
27da23d5 3175#endif
a0d0e21e 3176 {
a0d0e21e 3177 if (flags)
cea2e8a9 3178 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 3179 else {
76e3520e 3180 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW
3181 pidgone(result,*statusp);
3182 if (result < 0)
3183 *statusp = -1;
3184 }
a687059c
LW
3185 }
3186#endif
27da23d5 3187#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 3188 finish:
27da23d5 3189#endif
cddd4526
NIS
3190 if (result < 0 && errno == EINTR) {
3191 PERL_ASYNC_CHECK();
48dbb59e 3192 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS
3193 }
3194 return result;
a687059c 3195}
2986a63f 3196#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 3197
ca0c25f6 3198#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 3199void
ed4173ef 3200S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 3201{
eb578fdb 3202 SV *sv;
a687059c 3203
12072db5 3204 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 3205 SvUPGRADE(sv,SVt_IV);
45977657 3206 SvIV_set(sv, status);
20188a90 3207 return;
a687059c 3208}
ca0c25f6 3209#endif
a687059c 3210
6de23f80 3211#if defined(OS2)
7c0587c8 3212int pclose();
ddcf38b7
IZ
3213#ifdef HAS_FORK
3214int /* Cannot prototype with I32
3215 in os2ish.h. */
ba106d47 3216my_syspclose(PerlIO *ptr)
ddcf38b7 3217#else
79072805 3218I32
864dbfa3 3219Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 3220#endif
a687059c 3221{
760ac839 3222 /* Needs work for PerlIO ! */
c4420975 3223 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 3224 const I32 result = pclose(f);
2b96b0a5
JH
3225 PerlIO_releaseFILE(ptr,f);
3226 return result;
3227}
3228#endif
3229
933fea7f 3230#if defined(DJGPP)
2b96b0a5
JH
3231int djgpp_pclose();
3232I32
3233Perl_my_pclose(pTHX_ PerlIO *ptr)
3234{
3235 /* Needs work for PerlIO ! */
c4420975 3236 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 3237 I32 result = djgpp_pclose(f);
933fea7f 3238 result = (result << 8) & 0xff00;
760ac839
LW
3239 PerlIO_releaseFILE(ptr,f);
3240 return result;
a687059c 3241}
7c0587c8 3242#endif
9f68db38 3243
16fa5c11 3244#define PERL_REPEATCPY_LINEAR 4
9f68db38 3245void
5aaab254 3246Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
9f68db38 3247{
7918f24d
NC
3248 PERL_ARGS_ASSERT_REPEATCPY;
3249
223f01db
KW
3250 assert(len >= 0);
3251
2709980d 3252 if (count < 0)
d1decf2b 3253 croak_memory_wrap();
2709980d 3254
16fa5c11
VP
3255 if (len == 1)
3256 memset(to, *from, count);
3257 else if (count) {
eb578fdb 3258 char *p = to;
26e1303d 3259 IV items, linear, half;
16fa5c11
VP
3260
3261 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3262 for (items = 0; items < linear; ++items) {
eb578fdb 3263 const char *q = from;
26e1303d 3264 IV todo;
16fa5c11
VP
3265 for (todo = len; todo > 0; todo--)
3266 *p++ = *q++;
3267 }
3268
3269 half = count / 2;
3270 while (items <= half) {
26e1303d 3271 IV size = items * len;
16fa5c11
VP
3272 memcpy(p, to, size);
3273 p += size;
3274 items *= 2;
9f68db38 3275 }
16fa5c11
VP
3276
3277 if (count > items)
3278 memcpy(p, to, (count - items) * len);
9f68db38
LW
3279 }
3280}
0f85fab0 3281
fe14fcc3 3282#ifndef HAS_RENAME
79072805 3283I32
4373e329 3284Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3285{
93a17b20
LW
3286 char *fa = strrchr(a,'/');
3287 char *fb = strrchr(b,'/');
c623ac67
GS
3288 Stat_t tmpstatbuf1;
3289 Stat_t tmpstatbuf2;
c4420975 3290 SV * const tmpsv = sv_newmortal();
62b28dd9 3291
7918f24d
NC
3292 PERL_ARGS_ASSERT_SAME_DIRENT;
3293
62b28dd9
LW
3294 if (fa)
3295 fa++;
3296 else
3297 fa = a;
3298 if (fb)
3299 fb++;
3300 else
3301 fb = b;
3302 if (strNE(a,b))
3303 return FALSE;
3304 if (fa == a)
76f68e9b 3305 sv_setpvs(tmpsv, ".");
62b28dd9 3306 else
46fc3d4c 3307 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3308 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
3309 return FALSE;
3310 if (fb == b)
76f68e9b 3311 sv_setpvs(tmpsv, ".");
62b28dd9 3312 else
46fc3d4c 3313 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3314 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
3315 return FALSE;
3316 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3317 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3318}
fe14fcc3
LW
3319#endif /* !HAS_RENAME */
3320
491527d0 3321char*
7f315aed
NC
3322Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3323 const char *const *const search_ext, I32 flags)
491527d0 3324{
bd61b366
SS
3325 const char *xfound = NULL;
3326 char *xfailed = NULL;
0f31cffe 3327 char tmpbuf[MAXPATHLEN];
eb578fdb 3328 char *s;
5f74f29c 3329 I32 len = 0;
491527d0 3330 int retval;
39a02377 3331 char *bufend;
7c458fae 3332#if defined(DOSISH) && !defined(OS2)
491527d0
GS
3333# define SEARCH_EXTS ".bat", ".cmd", NULL
3334# define MAX_EXT_LEN 4
3335#endif
3336#ifdef OS2
3337# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3338# define MAX_EXT_LEN 4
3339#endif
3340#ifdef VMS
3341# define SEARCH_EXTS ".pl", ".com", NULL
3342# define MAX_EXT_LEN 4
3343#endif
3344 /* additional extensions to try in each dir if scriptname not found */
3345#ifdef SEARCH_EXTS
0bcc34c2 3346 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3347 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3348 int extidx = 0, i = 0;
bd61b366 3349 const char *curext = NULL;
491527d0 3350#else
53c1dcc0 3351 PERL_UNUSED_ARG(search_ext);
491527d0
GS
3352# define MAX_EXT_LEN 0
3353#endif
3354
7918f24d
NC
3355 PERL_ARGS_ASSERT_FIND_SCRIPT;
3356
491527d0
GS
3357 /*
3358 * If dosearch is true and if scriptname does not contain path
3359 * delimiters, search the PATH for scriptname.
3360 *
3361 * If SEARCH_EXTS is also defined, will look for each
3362 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3363 * while searching the PATH.
3364 *
3365 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3366 * proceeds as follows:
3367 * If DOSISH or VMSISH:
3368 * + look for ./scriptname{,.foo,.bar}
3369 * + search the PATH for scriptname{,.foo,.bar}
3370 *
3371 * If !DOSISH:
3372 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3373 * this will not look in '.' if it's not in the PATH)
3374 */
84486fc6 3375 tmpbuf[0] = '\0';
491527d0
GS
3376
3377#ifdef VMS
3378# ifdef ALWAYS_DEFTYPES
3379 len = strlen(scriptname);
3380 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3381 int idx = 0, deftypes = 1;
491527d0
GS
3382 bool seen_dot = 1;
3383
bd61b366 3384 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3385# else
3386 if (dosearch) {
c4420975 3387 int idx = 0, deftypes = 1;
491527d0
GS
3388 bool seen_dot = 1;
3389
bd61b366 3390 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3391# endif
3392 /* The first time through, just add SEARCH_EXTS to whatever we
3393 * already have, so we can check for default file types. */
3394 while (deftypes ||
84486fc6 3395 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0 3396 {
2aa28b86 3397 Stat_t statbuf;
491527d0
GS
3398 if (deftypes) {
3399 deftypes = 0;
84486fc6 3400 *tmpbuf = '\0';
491527d0 3401 }
84486fc6
GS
3402 if ((strlen(tmpbuf) + strlen(scriptname)
3403 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3404 continue; /* don't search dir with too-long name */
6fca0082 3405 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS
3406#else /* !VMS */
3407
3408#ifdef DOSISH
3409 if (strEQ(scriptname, "-"))
3410 dosearch = 0;
3411 if (dosearch) { /* Look in '.' first. */
fe2774ed 3412 const char *cur = scriptname;
491527d0
GS
3413#ifdef SEARCH_EXTS
3414 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3415 while (ext[i])
3416 if (strEQ(ext[i++],curext)) {
3417 extidx = -1; /* already has an ext */
3418 break;
3419 }
3420 do {
3421#endif
3422 DEBUG_p(PerlIO_printf(Perl_debug_log,
3423 "Looking for %s\n",cur));
45a23732 3424 {
0cc19a43 3425 Stat_t statbuf;
45a23732
DD
3426 if (PerlLIO_stat(cur,&statbuf) >= 0
3427 && !S_ISDIR(statbuf.st_mode)) {
3428 dosearch = 0;
3429 scriptname = cur;
491527d0 3430#ifdef SEARCH_EXTS
45a23732 3431 break;
491527d0 3432#endif
45a23732 3433 }
491527d0
GS
3434 }
3435#ifdef SEARCH_EXTS
3436 if (cur == scriptname) {
3437 len = strlen(scriptname);
84486fc6 3438 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3439 break;
9e4425f7
SH
3440 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3441 cur = tmpbuf;
491527d0
GS
3442 }
3443 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3444 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS
3445#endif
3446 }
3447#endif
3448
3449 if (dosearch && !strchr(scriptname, '/')
3450#ifdef DOSISH
3451 && !strchr(scriptname, '\\')
3452#endif
cd39f2b6 3453 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3454 {
491527d0 3455 bool seen_dot = 0;
92f0c265 3456
39a02377
DM
3457 bufend = s + strlen(s);
3458 while (s < bufend) {
45a23732 3459 Stat_t statbuf;
7c458fae 3460# ifdef DOSISH
491527d0 3461 for (len = 0; *s
491527d0 3462 && *s != ';'; len++, s++) {
84486fc6
GS
3463 if (len < sizeof tmpbuf)
3464 tmpbuf[len] = *s;
491527d0 3465 }
84486fc6
GS
3466 if (len < sizeof tmpbuf)
3467 tmpbuf[len] = '\0';
7c458fae 3468# else
e80af1fd
TC
3469 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3470 ':', &len);
7c458fae 3471# endif
39a02377 3472 if (s < bufend)
491527d0 3473 s++;
84486fc6 3474 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS
3475 continue; /* don't search dir with too-long name */
3476 if (len
7c458fae 3477# ifdef DOSISH
84486fc6
GS
3478 && tmpbuf[len - 1] != '/'
3479 && tmpbuf[len - 1] != '\\'
490a0e98 3480# endif
491527d0 3481 )
84486fc6
GS
3482 tmpbuf[len++] = '/';
3483 if (len == 2 && tmpbuf[0] == '.')
491527d0 3484 seen_dot = 1;
28f0d0ec 3485 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS
3486#endif /* !VMS */
3487
3488#ifdef SEARCH_EXTS
84486fc6 3489 len = strlen(tmpbuf);
491527d0
GS
3490 if (extidx > 0) /* reset after previous loop */
3491 extidx = 0;
3492 do {
3493#endif
84486fc6 3494 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
45a23732
DD
3495 retval = PerlLIO_stat(tmpbuf,&statbuf);
3496 if (S_ISDIR(statbuf.st_mode)) {
017f25f1
IZ
3497 retval = -1;
3498 }
491527d0
GS
3499#ifdef SEARCH_EXTS
3500 } while ( retval < 0 /* not there */
3501 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3502 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS
3503 );
3504#endif
3505 if (retval < 0)
3506 continue;
45a23732
DD
3507 if (S_ISREG(statbuf.st_mode)
3508 && cando(S_IRUSR,TRUE,&statbuf)
e37778c2 3509#if !defined(DOSISH)
45a23732 3510 && cando(S_IXUSR,TRUE,&statbuf)
491527d0
GS
3511#endif
3512 )
3513 {
3aed30dc 3514 xfound = tmpbuf; /* bingo! */
491527d0
GS
3515 break;
3516 }
3517 if (!xfailed)
84486fc6 3518 xfailed = savepv(tmpbuf);
491527d0
GS
3519 }
3520#ifndef DOSISH
45a23732
DD
3521 {
3522 Stat_t statbuf;
3523 if (!xfound && !seen_dot && !xfailed &&
3524 (PerlLIO_stat(scriptname,&statbuf) < 0
3525 || S_ISDIR(statbuf.st_mode)))
3526#endif
3527 seen_dot = 1; /* Disable message. */
3528#ifndef DOSISH
3529 }
491527d0 3530#endif
9ccb31f9
GS
3531 if (!xfound) {
3532 if (flags & 1) { /* do or die? */
6ad282c7 3533 /* diag_listed_as: Can't execute %s */
3aed30dc 3534 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS
3535 (xfailed ? "execute" : "find"),
3536 (xfailed ? xfailed : scriptname),
3537 (xfailed ? "" : " on PATH"),
3538 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3539 }
bd61b366 3540 scriptname = NULL;
9ccb31f9 3541 }
43c5f42d 3542 Safefree(xfailed);
491527d0
GS
3543 scriptname = xfound;
3544 }
bd61b366 3545 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS
3546}
3547
ba869deb
GS
3548#ifndef PERL_GET_CONTEXT_DEFINED
3549
3550void *
3551Perl_get_context(void)
3552{
3db8f154 3553#if defined(USE_ITHREADS)
ba869deb
GS
3554# ifdef OLD_PTHREADS_API
3555 pthread_addr_t t;
6535c371 3556 int error = pthread_getspecific(PL_thr_key, &t);
5637ef5b
NC
3557 if (error)
3558 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
ba869deb 3559 return (void*)t;
8ad758c7 3560# elif defined(I_MACH_CTHREADS)
8b8b35ab 3561 return (void*)cthread_data(cthread_self());
8ad758c7 3562# else
8b8b35ab 3563 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
c44d3fdb 3564# endif
ba869deb
GS
3565#else
3566 return (void*)NULL;
3567#endif
3568}
3569
3570void
3571Perl_set_context(void *t)
3572{
20b7effb 3573#if defined(USE_ITHREADS)
20b7effb 3574#endif
7918f24d 3575 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3576#if defined(USE_ITHREADS)
c44d3fdb
GS
3577# ifdef I_MACH_CTHREADS
3578 cthread_set_data(cthread_self(), t);
3579# else
5637ef5b
NC
3580 {