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