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