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