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