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
Perl_fbm_instr(): remove dead code.
[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 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 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 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 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 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;
4c8626be 622 const char *s, *x;
8ba22ff4 623 bigend -= lend - little++;
4c8626be
GA		 624 OUTER:
625 while (big <= bigend) {
b0ca24ee
JH		 626 if (*big++ == first) {
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
41c8d07a 1025
e6226b18
KW		 1026/*
1027=for apidoc foldEQ
1028
796b6530
KW		 1029Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1030same
e6226b18
KW		 1031case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
1032match themselves and their opposite case counterparts. Non-cased and non-ASCII
1033range bytes match only themselves.
1034
1035=cut
1036*/
1037
1038
79072805 1039I32
5aaab254 1040Perl_foldEQ(const char *s1, const char *s2, I32 len)
79072805 1041{
eb578fdb
KW		 1042 const U8 *a = (const U8 *)s1;
1043 const U8 *b = (const U8 *)s2;
96a5add6 1044
e6226b18 1045 PERL_ARGS_ASSERT_FOLDEQ;
7918f24d 1046
223f01db
KW		 1047 assert(len >= 0);
1048
79072805 1049 while (len--) {
22c35a8c 1050 if (*a != *b && *a != PL_fold[*b])
e6226b18 1051 return 0;
bbce6d69 1052 a++,b++;
1053 }
e6226b18 1054 return 1;
bbce6d69 1055}
1b9f127b 1056I32
5aaab254 1057Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1b9f127b
KW		 1058{
1059 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
1060 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1061 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
1062 * does it check that the strings each have at least 'len' characters */
1063
eb578fdb
KW		 1064 const U8 *a = (const U8 *)s1;
1065 const U8 *b = (const U8 *)s2;
1b9f127b
KW		 1066
1067 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1068
223f01db
KW		 1069 assert(len >= 0);
1070
1b9f127b
KW		 1071 while (len--) {
1072 if (*a != *b && *a != PL_fold_latin1[*b]) {
1073 return 0;
1074 }
1075 a++, b++;
1076 }
1077 return 1;
1078}
bbce6d69 1079
e6226b18
KW		 1080/*
1081=for apidoc foldEQ_locale
1082
796b6530
KW		 1083Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1084same case-insensitively in the current locale; false otherwise.
e6226b18
KW		 1085
1086=cut
1087*/
1088
bbce6d69 1089I32
5aaab254 1090Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
bbce6d69 1091{
27da23d5 1092 dVAR;
eb578fdb
KW		 1093 const U8 *a = (const U8 *)s1;
1094 const U8 *b = (const U8 *)s2;
96a5add6 1095
e6226b18 1096 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
7918f24d 1097
223f01db
KW		 1098 assert(len >= 0);
1099
bbce6d69 1100 while (len--) {
22c35a8c 1101 if (*a != *b && *a != PL_fold_locale[*b])
e6226b18 1102 return 0;
bbce6d69 1103 a++,b++;
79072805 1104 }
e6226b18 1105 return 1;
79072805
LW		 1106}
1107
8d063cd8
LW		 1108/* copy a string to a safe spot */
1109
954c1994 1110/*
ccfc67b7
JH		 1111=head1 Memory Management
1112
954c1994
GS		 1113=for apidoc savepv
1114
72d33970
FC		 1115Perl's version of C<strdup()>. Returns a pointer to a newly allocated
1116string which is a duplicate of C<pv>. The size of the string is
30a15352
KW		 1117determined by C<strlen()>, which means it may not contain embedded C<NUL>
1118characters and must have a trailing C<NUL>. The memory allocated for the new
1119string can be freed with the C<Safefree()> function.
954c1994 1120
0358c255
KW		 1121On some platforms, Windows for example, all allocated memory owned by a thread
1122is deallocated when that thread ends. So if you need that not to happen, you
1123need to use the shared memory functions, such as C<L</savesharedpv>>.
1124
954c1994
GS		 1125=cut
1126*/
1127
8d063cd8 1128char *
efdfce31 1129Perl_savepv(pTHX_ const char *pv)
8d063cd8 1130{
96a5add6 1131 PERL_UNUSED_CONTEXT;
e90e2364 1132 if (!pv)
bd61b366 1133 return NULL;
66a1b24b
AL		 1134 else {
1135 char *newaddr;
1136 const STRLEN pvlen = strlen(pv)+1;
10edeb5d
JH		 1137 Newx(newaddr, pvlen, char);
1138 return (char*)memcpy(newaddr, pv, pvlen);
66a1b24b 1139 }
8d063cd8
LW		 1140}
1141
a687059c
LW		 1142/* same thing but with a known length */
1143
954c1994
GS		 1144/*
1145=for apidoc savepvn
1146
72d33970 1147Perl's version of what C<strndup()> would be if it existed. Returns a
61a925ed 1148pointer to a newly allocated string which is a duplicate of the first
72d33970 1149C<len> bytes from C<pv>, plus a trailing
6602b933 1150C<NUL> byte. The memory allocated for
cbf82dd0 1151the new string can be freed with the C<Safefree()> function.
954c1994 1152
0358c255
KW		 1153On some platforms, Windows for example, all allocated memory owned by a thread
1154is deallocated when that thread ends. So if you need that not to happen, you
1155need to use the shared memory functions, such as C<L</savesharedpvn>>.
1156
954c1994
GS		 1157=cut
1158*/
1159
a687059c 1160char *
5aaab254 1161Perl_savepvn(pTHX_ const char *pv, I32 len)
a687059c 1162{
eb578fdb 1163 char *newaddr;
96a5add6 1164 PERL_UNUSED_CONTEXT;
a687059c 1165
223f01db
KW		 1166 assert(len >= 0);
1167
a02a5408 1168 Newx(newaddr,len+1,char);
92110913 1169 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
efdfce31 1170 if (pv) {
e90e2364
NC		 1171 /* might not be null terminated */
1172 newaddr[len] = '\0';
07409e01 1173 return (char *) CopyD(pv,newaddr,len,char);
92110913
NIS		 1174 }
1175 else {
07409e01 1176 return (char *) ZeroD(newaddr,len+1,char);
92110913 1177 }
a687059c
LW		 1178}
1179
05ec9bb3
NIS		 1180/*
1181=for apidoc savesharedpv
1182
61a925ed
AMS		 1183A version of C<savepv()> which allocates the duplicate string in memory
1184which is shared between threads.
05ec9bb3
NIS		 1185
1186=cut
1187*/
1188char *
efdfce31 1189Perl_savesharedpv(pTHX_ const char *pv)
05ec9bb3 1190{
eb578fdb 1191 char *newaddr;
490a0e98 1192 STRLEN pvlen;
dc3bf405
BF		 1193
1194 PERL_UNUSED_CONTEXT;
1195
e90e2364 1196 if (!pv)
bd61b366 1197 return NULL;
e90e2364 1198
490a0e98
NC		 1199 pvlen = strlen(pv)+1;
1200 newaddr = (char*)PerlMemShared_malloc(pvlen);
e90e2364 1201 if (!newaddr) {
4cbe3a7d 1202 croak_no_mem();
05ec9bb3 1203 }
10edeb5d 1204 return (char*)memcpy(newaddr, pv, pvlen);
05ec9bb3
NIS		 1205}
1206
2e0de35c 1207/*
d9095cec
NC		 1208=for apidoc savesharedpvn
1209
1210A version of C<savepvn()> which allocates the duplicate string in memory
796b6530 1211which is shared between threads. (With the specific difference that a C<NULL>
d9095cec
NC		 1212pointer is not acceptable)
1213
1214=cut
1215*/
1216char *
1217Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1218{
1219 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
7918f24d 1220
dc3bf405 1221 PERL_UNUSED_CONTEXT;
6379d4a9 1222 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
7918f24d 1223
d9095cec 1224 if (!newaddr) {
4cbe3a7d 1225 croak_no_mem();
d9095cec
NC		 1226 }
1227 newaddr[len] = '\0';
1228 return (char*)memcpy(newaddr, pv, len);
1229}
1230
1231/*
2e0de35c
NC		 1232=for apidoc savesvpv
1233
6832267f 1234A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
2e0de35c
NC		 1235the passed in SV using C<SvPV()>
1236
0358c255
KW		 1237On some platforms, Windows for example, all allocated memory owned by a thread
1238is deallocated when that thread ends. So if you need that not to happen, you
1239need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1240
2e0de35c
NC		 1241=cut
1242*/
1243
1244char *
1245Perl_savesvpv(pTHX_ SV *sv)
1246{
1247 STRLEN len;
7452cf6a 1248 const char * const pv = SvPV_const(sv, len);
eb578fdb 1249 char *newaddr;
2e0de35c 1250
7918f24d
NC		 1251 PERL_ARGS_ASSERT_SAVESVPV;
1252
26866f99 1253 ++len;
a02a5408 1254 Newx(newaddr,len,char);
07409e01 1255 return (char *) CopyD(pv,newaddr,len,char);
2e0de35c 1256}
05ec9bb3 1257
9dcc53ea
Z		 1258/*
1259=for apidoc savesharedsvpv
1260
1261A version of C<savesharedpv()> which allocates the duplicate string in
1262memory which is shared between threads.
1263
1264=cut
1265*/
1266
1267char *
1268Perl_savesharedsvpv(pTHX_ SV *sv)
1269{
1270 STRLEN len;
1271 const char * const pv = SvPV_const(sv, len);
1272
1273 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1274
1275 return savesharedpvn(pv, len);
1276}
05ec9bb3 1277
cea2e8a9 1278/* the SV for Perl_form() and mess() is not kept in an arena */
fc36a67e 1279
76e3520e 1280STATIC SV *
cea2e8a9 1281S_mess_alloc(pTHX)
fc36a67e 1282{
1283 SV *sv;
1284 XPVMG *any;
1285
627364f1 1286 if (PL_phase != PERL_PHASE_DESTRUCT)
84bafc02 1287 return newSVpvs_flags("", SVs_TEMP);
e72dc28c 1288
0372dbb6
GS		 1289 if (PL_mess_sv)
1290 return PL_mess_sv;
1291
fc36a67e 1292 /* Create as PVMG now, to avoid any upgrading later */
a02a5408
JC		 1293 Newx(sv, 1, SV);
1294 Newxz(any, 1, XPVMG);
fc36a67e 1295 SvFLAGS(sv) = SVt_PVMG;
1296 SvANY(sv) = (void*)any;
6136c704 1297 SvPV_set(sv, NULL);
fc36a67e 1298 SvREFCNT(sv) = 1 << 30; /* practically infinite */
e72dc28c 1299 PL_mess_sv = sv;
fc36a67e 1300 return sv;
1301}
1302
c5be433b 1303#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1304char *
1305Perl_form_nocontext(const char* pat, ...)
1306{
1307 dTHX;
c5be433b 1308 char *retval;
cea2e8a9 1309 va_list args;
7918f24d 1310 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
cea2e8a9 1311 va_start(args, pat);
c5be433b 1312 retval = vform(pat, &args);
cea2e8a9 1313 va_end(args);
c5be433b 1314 return retval;
cea2e8a9 1315}
c5be433b 1316#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1317
7c9e965c 1318/*
ccfc67b7 1319=head1 Miscellaneous Functions
7c9e965c
JP		 1320=for apidoc form
1321
1322Takes a sprintf-style format pattern and conventional
1323(non-SV) arguments and returns the formatted string.
1324
1325 (char *) Perl_form(pTHX_ const char* pat, ...)
1326
1327can be used any place a string (char *) is required:
1328
1329 char * s = Perl_form("%d.%d",major,minor);
1330
1331Uses a single private buffer so if you want to format several strings you
1332must explicitly copy the earlier strings away (and free the copies when you
1333are done).
1334
1335=cut
1336*/
1337
8990e307 1338char *
864dbfa3 1339Perl_form(pTHX_ const char* pat, ...)
8990e307 1340{
c5be433b 1341 char *retval;
46fc3d4c 1342 va_list args;
7918f24d 1343 PERL_ARGS_ASSERT_FORM;
46fc3d4c 1344 va_start(args, pat);
c5be433b 1345 retval = vform(pat, &args);
46fc3d4c 1346 va_end(args);
c5be433b
GS		 1347 return retval;
1348}
1349
1350char *
1351Perl_vform(pTHX_ const char *pat, va_list *args)
1352{
2d03de9c 1353 SV * const sv = mess_alloc();
7918f24d 1354 PERL_ARGS_ASSERT_VFORM;
4608196e 1355 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
e72dc28c 1356 return SvPVX(sv);
46fc3d4c 1357}
a687059c 1358
c5df3096
Z		 1359/*
1360=for apidoc Am|SV *|mess|const char *pat|...
1361
1362Take a sprintf-style format pattern and argument list. These are used to
1363generate a string message. If the message does not end with a newline,
1364then it will be extended with some indication of the current location
1365in the code, as described for L</mess_sv>.
1366
1367Normally, the resulting message is returned in a new mortal SV.
1368During global destruction a single SV may be shared between uses of
1369this function.
1370
1371=cut
1372*/
1373
5a844595
GS		 1374#if defined(PERL_IMPLICIT_CONTEXT)
1375SV *
1376Perl_mess_nocontext(const char *pat, ...)
1377{
1378 dTHX;
1379 SV *retval;
1380 va_list args;
7918f24d 1381 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
5a844595
GS		 1382 va_start(args, pat);
1383 retval = vmess(pat, &args);
1384 va_end(args);
1385 return retval;
1386}
1387#endif /* PERL_IMPLICIT_CONTEXT */
1388
06bf62c7 1389SV *
5a844595
GS		 1390Perl_mess(pTHX_ const char *pat, ...)
1391{
1392 SV *retval;
1393 va_list args;
7918f24d 1394 PERL_ARGS_ASSERT_MESS;
5a844595
GS		 1395 va_start(args, pat);
1396 retval = vmess(pat, &args);
1397 va_end(args);
1398 return retval;
1399}
1400
25502127
FC		 1401const COP*
1402Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1403 bool opnext)
ae7d165c 1404{
25502127
FC		 1405 /* Look for curop starting from o. cop is the last COP we've seen. */
1406 /* opnext means that curop is actually the ->op_next of the op we are
1407 seeking. */
ae7d165c 1408
7918f24d
NC		 1409 PERL_ARGS_ASSERT_CLOSEST_COP;
1410
25502127
FC		 1411 if (!o || !curop || (
1412 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1413 ))
fabdb6c0 1414 return cop;
ae7d165c
PJ		 1415
1416 if (o->op_flags & OPf_KIDS) {
5f66b61c 1417 const OP *kid;
e6dae479 1418 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
5f66b61c 1419 const COP *new_cop;
ae7d165c
PJ		 1420
1421 /* If the OP_NEXTSTATE has been optimised away we can still use it
1422 * the get the file and line number. */
1423
1424 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
5f66b61c 1425 cop = (const COP *)kid;
ae7d165c
PJ		 1426
1427 /* Keep searching, and return when we've found something. */
1428
25502127 1429 new_cop = closest_cop(cop, kid, curop, opnext);
fabdb6c0
AL		 1430 if (new_cop)
1431 return new_cop;
ae7d165c
PJ		 1432 }
1433 }
1434
1435 /* Nothing found. */
1436
5f66b61c 1437 return NULL;
ae7d165c
PJ		 1438}
1439
c5df3096
Z		 1440/*
1441=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1442
1443Expands a message, intended for the user, to include an indication of
1444the current location in the code, if the message does not already appear
1445to be complete.
1446
1447C<basemsg> is the initial message or object. If it is a reference, it
1448will be used as-is and will be the result of this function. Otherwise it
1449is used as a string, and if it already ends with a newline, it is taken
1450to be complete, and the result of this function will be the same string.
1451If the message does not end with a newline, then a segment such as C<at
1452foo.pl line 37> will be appended, and possibly other clauses indicating
1453the current state of execution. The resulting message will end with a
1454dot and a newline.
1455
1456Normally, the resulting message is returned in a new mortal SV.
1457During global destruction a single SV may be shared between uses of this
1458function. If C<consume> is true, then the function is permitted (but not
1459required) to modify and return C<basemsg> instead of allocating a new SV.
1460
1461=cut
1462*/
1463
5a844595 1464SV *
c5df3096 1465Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
46fc3d4c 1466{
c5df3096 1467 SV *sv;
46fc3d4c 1468
0762e42f 1469#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
470dd224
JH		 1470 {
1471 char *ws;
22ff3130 1472 UV wi;
470dd224 1473 /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
22ff3130
HS		 1474 if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
1475 && grok_atoUV(ws, &wi, NULL)
1476 && wi <= PERL_INT_MAX
1477 ) {
1478 Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
470dd224
JH		 1479 }
1480 }
1481#endif
1482
c5df3096
Z		 1483 PERL_ARGS_ASSERT_MESS_SV;
1484
1485 if (SvROK(basemsg)) {
1486 if (consume) {
1487 sv = basemsg;
1488 }
1489 else {
1490 sv = mess_alloc();
1491 sv_setsv(sv, basemsg);
1492 }
1493 return sv;
1494 }
1495
1496 if (SvPOK(basemsg) && consume) {
1497 sv = basemsg;
1498 }
1499 else {
1500 sv = mess_alloc();
1501 sv_copypv(sv, basemsg);
1502 }
7918f24d 1503
46fc3d4c 1504 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
ae7d165c
PJ		 1505 /*
1506 * Try and find the file and line for PL_op. This will usually be
1507 * PL_curcop, but it might be a cop that has been optimised away. We
1508 * can try to find such a cop by searching through the optree starting
1509 * from the sibling of PL_curcop.
1510 */
1511
f4c61774
DM		 1512 if (PL_curcop) {
1513 const COP *cop =
1514 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
1515 if (!cop)
1516 cop = PL_curcop;
1517
1518 if (CopLINE(cop))
1519 Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
1520 OutCopFILE(cop), (IV)CopLINE(cop));
1521 }
1522
191f87d5
DH		 1523 /* Seems that GvIO() can be untrustworthy during global destruction. */
1524 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1525 && IoLINES(GvIOp(PL_last_in_gv)))
1526 {
2748e602 1527 STRLEN l;
e1ec3a88 1528 const bool line_mode = (RsSIMPLE(PL_rs) &&
2748e602 1529 *SvPV_const(PL_rs,l) == '\n' && l == 1);
147e3846 1530 Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,
3b46b707
BF		 1531 SVfARG(PL_last_in_gv == PL_argvgv
1532 ? &PL_sv_no
1533 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
edc2eac3
JH		 1534 line_mode ? "line" : "chunk",
1535 (IV)IoLINES(GvIOp(PL_last_in_gv)));
a687059c 1536 }
627364f1 1537 if (PL_phase == PERL_PHASE_DESTRUCT)
5f66b61c
AL		 1538 sv_catpvs(sv, " during global destruction");
1539 sv_catpvs(sv, ".\n");
a687059c 1540 }
06bf62c7 1541 return sv;
a687059c
LW		 1542}
1543
c5df3096
Z		 1544/*
1545=for apidoc Am|SV *|vmess|const char *pat|va_list *args
1546
1547C<pat> and C<args> are a sprintf-style format pattern and encapsulated
801caa78
KW		 1548argument list, respectively. These are used to generate a string message. If
1549the
c5df3096
Z		 1550message does not end with a newline, then it will be extended with
1551some indication of the current location in the code, as described for
1552L</mess_sv>.
1553
1554Normally, the resulting message is returned in a new mortal SV.
1555During global destruction a single SV may be shared between uses of
1556this function.
1557
1558=cut
1559*/
1560
1561SV *
1562Perl_vmess(pTHX_ const char *pat, va_list *args)
1563{
c5df3096
Z		 1564 SV * const sv = mess_alloc();
1565
1566 PERL_ARGS_ASSERT_VMESS;
1567
1568 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1569 return mess_sv(sv, 1);
1570}
1571
7ff03255 1572void
7d0994e0 1573Perl_write_to_stderr(pTHX_ SV* msv)
7ff03255
SG		 1574{
1575 IO *io;
1576 MAGIC *mg;
1577
7918f24d
NC		 1578 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1579
7ff03255
SG		 1580 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1581 && (io = GvIO(PL_stderrgv))
daba3364 1582 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
36925d9e 1583 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
d1d7a15d 1584 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
7ff03255 1585 else {
53c1dcc0 1586 PerlIO * const serr = Perl_error_log;
7ff03255 1587
83c55556 1588 do_print(msv, serr);
7ff03255 1589 (void)PerlIO_flush(serr);
7ff03255
SG		 1590 }
1591}
1592
c5df3096
Z		 1593/*
1594=head1 Warning and Dieing
1595*/
1596
1597/* Common code used in dieing and warning */
1598
1599STATIC SV *
1600S_with_queued_errors(pTHX_ SV *ex)
1601{
1602 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1603 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1604 sv_catsv(PL_errors, ex);
1605 ex = sv_mortalcopy(PL_errors);
1606 SvCUR_set(PL_errors, 0);
1607 }
1608 return ex;
1609}
3ab1ac99 1610
46d9c920 1611STATIC bool
c5df3096 1612S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
63315e18
NC		 1613{
1614 HV *stash;
1615 GV *gv;
1616 CV *cv;
46d9c920
NC		 1617 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1618 /* sv_2cv might call Perl_croak() or Perl_warner() */
1619 SV * const oldhook = *hook;
1620
c5df3096
Z		 1621 if (!oldhook)
1622 return FALSE;
63315e18 1623
63315e18 1624 ENTER;
46d9c920
NC		 1625 SAVESPTR(*hook);
1626 *hook = NULL;
1627 cv = sv_2cv(oldhook, &stash, &gv, 0);
63315e18
NC		 1628 LEAVE;
1629 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1630 dSP;
c5df3096 1631 SV *exarg;
63315e18
NC		 1632
1633 ENTER;
2782061f 1634 save_re_context();
46d9c920
NC		 1635 if (warn) {
1636 SAVESPTR(*hook);
1637 *hook = NULL;
1638 }
c5df3096
Z		 1639 exarg = newSVsv(ex);
1640 SvREADONLY_on(exarg);
1641 SAVEFREESV(exarg);
63315e18 1642
46d9c920 1643 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
63315e18 1644 PUSHMARK(SP);
c5df3096 1645 XPUSHs(exarg);
63315e18 1646 PUTBACK;
daba3364 1647 call_sv(MUTABLE_SV(cv), G_DISCARD);
63315e18
NC		 1648 POPSTACK;
1649 LEAVE;
46d9c920 1650 return TRUE;
63315e18 1651 }
46d9c920 1652 return FALSE;
63315e18
NC		 1653}
1654
c5df3096
Z		 1655/*
1656=for apidoc Am|OP *|die_sv|SV *baseex
e07360fa 1657
c5df3096
Z		 1658Behaves the same as L</croak_sv>, except for the return type.
1659It should be used only where the C<OP *> return type is required.
1660The function never actually returns.
e07360fa 1661
c5df3096
Z		 1662=cut
1663*/
e07360fa 1664
f8d5a522
DD		 1665#ifdef _MSC_VER
1666# pragma warning( push )
1667# pragma warning( disable : 4646 ) /* warning C4646: function declared with
1668 __declspec(noreturn) has non-void return type */
1669# pragma warning( disable : 4645 ) /* warning C4645: function declared with
1670__declspec(noreturn) has a return statement */
1671#endif
c5df3096
Z		 1672OP *
1673Perl_die_sv(pTHX_ SV *baseex)
36477c24 1674{
c5df3096
Z		 1675 PERL_ARGS_ASSERT_DIE_SV;
1676 croak_sv(baseex);
e5964223 1677 /* NOTREACHED */
117af67d 1678 NORETURN_FUNCTION_END;
36477c24 1679}
f8d5a522
DD		 1680#ifdef _MSC_VER
1681# pragma warning( pop )
1682#endif
36477c24 1683
c5df3096
Z		 1684/*
1685=for apidoc Am|OP *|die|const char *pat|...
1686
1687Behaves the same as L</croak>, except for the return type.
1688It should be used only where the C<OP *> return type is required.
1689The function never actually returns.
1690
1691=cut
1692*/
1693
c5be433b 1694#if defined(PERL_IMPLICIT_CONTEXT)
f8d5a522
DD		 1695#ifdef _MSC_VER
1696# pragma warning( push )
1697# pragma warning( disable : 4646 ) /* warning C4646: function declared with
1698 __declspec(noreturn) has non-void return type */
1699# pragma warning( disable : 4645 ) /* warning C4645: function declared with
1700__declspec(noreturn) has a return statement */
1701#endif
cea2e8a9
GS		 1702OP *
1703Perl_die_nocontext(const char* pat, ...)
a687059c 1704{
cea2e8a9 1705 dTHX;
a687059c 1706 va_list args;
cea2e8a9 1707 va_start(args, pat);
c5df3096 1708 vcroak(pat, &args);
e5964223 1709 NOT_REACHED; /* NOTREACHED */
cea2e8a9 1710 va_end(args);
117af67d 1711 NORETURN_FUNCTION_END;
cea2e8a9 1712}
f8d5a522
DD		 1713#ifdef _MSC_VER
1714# pragma warning( pop )
1715#endif
c5be433b 1716#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1717
f8d5a522
DD		 1718#ifdef _MSC_VER
1719# pragma warning( push )
1720# pragma warning( disable : 4646 ) /* warning C4646: function declared with
1721 __declspec(noreturn) has non-void return type */
1722# pragma warning( disable : 4645 ) /* warning C4645: function declared with
1723__declspec(noreturn) has a return statement */
1724#endif
cea2e8a9
GS		 1725OP *
1726Perl_die(pTHX_ const char* pat, ...)
1727{
cea2e8a9
GS		 1728 va_list args;
1729 va_start(args, pat);
c5df3096 1730 vcroak(pat, &args);
e5964223 1731 NOT_REACHED; /* NOTREACHED */
cea2e8a9 1732 va_end(args);
117af67d 1733 NORETURN_FUNCTION_END;
cea2e8a9 1734}
f8d5a522
DD		 1735#ifdef _MSC_VER
1736# pragma warning( pop )
1737#endif
cea2e8a9 1738
c5df3096
Z		 1739/*
1740=for apidoc Am|void|croak_sv|SV *baseex
1741
1742This is an XS interface to Perl's C<die> function.
1743
1744C<baseex> is the error message or object. If it is a reference, it
1745will be used as-is. Otherwise it is used as a string, and if it does
1746not end with a newline then it will be extended with some indication of
1747the current location in the code, as described for L</mess_sv>.
1748
1749The error message or object will be used as an exception, by default
1750returning control to the nearest enclosing C<eval>, but subject to
1751modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1752function never returns normally.
1753
1754To die with a simple string message, the L</croak> function may be
1755more convenient.
1756
1757=cut
1758*/
1759
c5be433b 1760void
c5df3096 1761Perl_croak_sv(pTHX_ SV *baseex)
cea2e8a9 1762{
c5df3096
Z		 1763 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1764 PERL_ARGS_ASSERT_CROAK_SV;
1765 invoke_exception_hook(ex, FALSE);
1766 die_unwind(ex);
1767}
1768
1769/*
1770=for apidoc Am|void|vcroak|const char *pat|va_list *args
1771
1772This is an XS interface to Perl's C<die> function.
1773
1774C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1775argument list. These are used to generate a string message. If the
1776message does not end with a newline, then it will be extended with
1777some indication of the current location in the code, as described for
1778L</mess_sv>.
1779
1780The error message will be used as an exception, by default
1781returning control to the nearest enclosing C<eval>, but subject to
1782modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1783function never returns normally.
a687059c 1784
c5df3096
Z		 1785For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1786(C<$@>) will be used as an error message or object instead of building an
1787error message from arguments. If you want to throw a non-string object,
1788or build an error message in an SV yourself, it is preferable to use
1789the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
5a844595 1790
c5df3096
Z		 1791=cut
1792*/
1793
1794void
1795Perl_vcroak(pTHX_ const char* pat, va_list *args)
1796{
1797 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1798 invoke_exception_hook(ex, FALSE);
1799 die_unwind(ex);
a687059c
LW		 1800}
1801
c5df3096
Z		 1802/*
1803=for apidoc Am|void|croak|const char *pat|...
1804
1805This is an XS interface to Perl's C<die> function.
1806
1807Take a sprintf-style format pattern and argument list. These are used to
1808generate a string message. If the message does not end with a newline,
1809then it will be extended with some indication of the current location
1810in the code, as described for L</mess_sv>.
1811
1812The error message will be used as an exception, by default
1813returning control to the nearest enclosing C<eval>, but subject to
1814modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1815function never returns normally.
1816
1817For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1818(C<$@>) will be used as an error message or object instead of building an
1819error message from arguments. If you want to throw a non-string object,
1820or build an error message in an SV yourself, it is preferable to use
1821the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1822
1823=cut
1824*/
1825
c5be433b 1826#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1827void
cea2e8a9 1828Perl_croak_nocontext(const char *pat, ...)
a687059c 1829{
cea2e8a9 1830 dTHX;
a687059c 1831 va_list args;
cea2e8a9 1832 va_start(args, pat);
c5be433b 1833 vcroak(pat, &args);
e5964223 1834 NOT_REACHED; /* NOTREACHED */
cea2e8a9
GS		 1835 va_end(args);
1836}
1837#endif /* PERL_IMPLICIT_CONTEXT */
1838
c5df3096
Z		 1839void
1840Perl_croak(pTHX_ const char *pat, ...)
1841{
1842 va_list args;
1843 va_start(args, pat);
1844 vcroak(pat, &args);
e5964223 1845 NOT_REACHED; /* NOTREACHED */
c5df3096
Z		 1846 va_end(args);
1847}
1848
954c1994 1849/*
6ad8f254
NC		 1850=for apidoc Am|void|croak_no_modify
1851
1852Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
72d33970 1853terser object code than using C<Perl_croak>. Less code used on exception code
6ad8f254
NC		 1854paths reduces CPU cache pressure.
1855
d8e47b5c 1856=cut
6ad8f254
NC		 1857*/
1858
1859void
88772978 1860Perl_croak_no_modify(void)
6ad8f254 1861{
cb077ed2 1862 Perl_croak_nocontext( "%s", PL_no_modify);
6ad8f254
NC		 1863}
1864
4cbe3a7d
DD		 1865/* does not return, used in util.c perlio.c and win32.c
1866 This is typically called when malloc returns NULL.
1867*/
1868void
88772978 1869Perl_croak_no_mem(void)
4cbe3a7d
DD		 1870{
1871 dTHX;
77c1c05b 1872
375ed12a
JH		 1873 int fd = PerlIO_fileno(Perl_error_log);
1874 if (fd < 0)
1875 SETERRNO(EBADF,RMS_IFI);
1876 else {
1877 /* Can't use PerlIO to write as it allocates memory */
b469f1e0 1878 PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
375ed12a 1879 }
4cbe3a7d
DD		 1880 my_exit(1);
1881}
1882
3d04513d
DD		 1883/* does not return, used only in POPSTACK */
1884void
1885Perl_croak_popstack(void)
1886{
1887 dTHX;
1888 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1889 my_exit(1);
1890}
1891
6ad8f254 1892/*
c5df3096 1893=for apidoc Am|void|warn_sv|SV *baseex
ccfc67b7 1894
c5df3096 1895This is an XS interface to Perl's C<warn> function.
954c1994 1896
c5df3096
Z		 1897C<baseex> is the error message or object. If it is a reference, it
1898will be used as-is. Otherwise it is used as a string, and if it does
1899not end with a newline then it will be extended with some indication of
1900the current location in the code, as described for L</mess_sv>.
9983fa3c 1901
c5df3096
Z		 1902The error message or object will by default be written to standard error,
1903but this is subject to modification by a C<$SIG{__WARN__}> handler.
9983fa3c 1904
c5df3096
Z		 1905To warn with a simple string message, the L</warn> function may be
1906more convenient.
954c1994
GS		 1907
1908=cut
1909*/
1910
cea2e8a9 1911void
c5df3096 1912Perl_warn_sv(pTHX_ SV *baseex)
cea2e8a9 1913{
c5df3096
Z		 1914 SV *ex = mess_sv(baseex, 0);
1915 PERL_ARGS_ASSERT_WARN_SV;
1916 if (!invoke_exception_hook(ex, TRUE))
1917 write_to_stderr(ex);
cea2e8a9
GS		 1918}
1919
c5df3096
Z		 1920/*
1921=for apidoc Am|void|vwarn|const char *pat|va_list *args
1922
1923This is an XS interface to Perl's C<warn> function.
1924
1925C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1926argument list. These are used to generate a string message. If the
1927message does not end with a newline, then it will be extended with
1928some indication of the current location in the code, as described for
1929L</mess_sv>.
1930
1931The error message or object will by default be written to standard error,
1932but this is subject to modification by a C<$SIG{__WARN__}> handler.
1933
1934Unlike with L</vcroak>, C<pat> is not permitted to be null.
1935
1936=cut
1937*/
1938
c5be433b
GS		 1939void
1940Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1941{
c5df3096 1942 SV *ex = vmess(pat, args);
7918f24d 1943 PERL_ARGS_ASSERT_VWARN;
c5df3096
Z		 1944 if (!invoke_exception_hook(ex, TRUE))
1945 write_to_stderr(ex);
1946}
7918f24d 1947
c5df3096
Z		 1948/*
1949=for apidoc Am|void|warn|const char *pat|...
87582a92 1950
c5df3096
Z		 1951This is an XS interface to Perl's C<warn> function.
1952
1953Take a sprintf-style format pattern and argument list. These are used to
1954generate a string message. If the message does not end with a newline,
1955then it will be extended with some indication of the current location
1956in the code, as described for L</mess_sv>.
1957
1958The error message or object will by default be written to standard error,
1959but this is subject to modification by a C<$SIG{__WARN__}> handler.
1960
1961Unlike with L</croak>, C<pat> is not permitted to be null.
1962
1963=cut
1964*/
8d063cd8 1965
c5be433b 1966#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1967void
1968Perl_warn_nocontext(const char *pat, ...)
1969{
1970 dTHX;
1971 va_list args;
7918f24d 1972 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
cea2e8a9 1973 va_start(args, pat);
c5be433b 1974 vwarn(pat, &args);
cea2e8a9
GS		 1975 va_end(args);
1976}
1977#endif /* PERL_IMPLICIT_CONTEXT */
1978
1979void
1980Perl_warn(pTHX_ const char *pat, ...)
1981{
1982 va_list args;
7918f24d 1983 PERL_ARGS_ASSERT_WARN;
cea2e8a9 1984 va_start(args, pat);
c5be433b 1985 vwarn(pat, &args);
cea2e8a9
GS		 1986 va_end(args);
1987}
1988
c5be433b
GS		 1989#if defined(PERL_IMPLICIT_CONTEXT)
1990void
1991Perl_warner_nocontext(U32 err, const char *pat, ...)
1992{
27da23d5 1993 dTHX;
c5be433b 1994 va_list args;
7918f24d 1995 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
c5be433b
GS		 1996 va_start(args, pat);
1997 vwarner(err, pat, &args);
1998 va_end(args);
1999}
2000#endif /* PERL_IMPLICIT_CONTEXT */
2001
599cee73 2002void
9b387841
NC		 2003Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
2004{
2005 PERL_ARGS_ASSERT_CK_WARNER_D;
2006
2007 if (Perl_ckwarn_d(aTHX_ err)) {
2008 va_list args;
2009 va_start(args, pat);
2010 vwarner(err, pat, &args);
2011 va_end(args);
2012 }
2013}
2014
2015void
a2a5de95
NC		 2016Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
2017{
2018 PERL_ARGS_ASSERT_CK_WARNER;
2019
2020 if (Perl_ckwarn(aTHX_ err)) {
2021 va_list args;
2022 va_start(args, pat);
2023 vwarner(err, pat, &args);
2024 va_end(args);
2025 }
2026}
2027
2028void
864dbfa3 2029Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM		 2030{
2031 va_list args;
7918f24d 2032 PERL_ARGS_ASSERT_WARNER;
c5be433b
GS		 2033 va_start(args, pat);
2034 vwarner(err, pat, &args);
2035 va_end(args);
2036}
2037
2038void
2039Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
2040{
27da23d5 2041 dVAR;
7918f24d 2042 PERL_ARGS_ASSERT_VWARNER;
46b27d2f
LM		 2043 if (
2044 (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
2045 !(PL_in_eval & EVAL_KEEPERR)
2046 ) {
a3b680e6 2047 SV * const msv = vmess(pat, args);
599cee73 2048
594b6fac
LM		 2049 if (PL_parser && PL_parser->error_count) {
2050 qerror(msv);
2051 }
2052 else {
2053 invoke_exception_hook(msv, FALSE);
2054 die_unwind(msv);
2055 }
599cee73
PM		 2056 }
2057 else {
d13b0d77 2058 Perl_vwarn(aTHX_ pat, args);
599cee73
PM		 2059 }
2060}
2061
f54ba1c2
DM		 2062/* implements the ckWARN? macros */
2063
2064bool
2065Perl_ckwarn(pTHX_ U32 w)
2066{
ad287e37 2067 /* If lexical warnings have not been set, use $^W. */
3c3f8cd6
AB		 2068 if (isLEXWARN_off)
2069 return PL_dowarn & G_WARN_ON;
ad287e37 2070
26c7b074 2071 return ckwarn_common(w);
f54ba1c2
DM		 2072}
2073
2074/* implements the ckWARN?_d macro */
2075
2076bool
2077Perl_ckwarn_d(pTHX_ U32 w)
2078{
ad287e37 2079 /* If lexical warnings have not been set then default classes warn. */
3c3f8cd6
AB		 2080 if (isLEXWARN_off)
2081 return TRUE;
ad287e37 2082
26c7b074
NC		 2083 return ckwarn_common(w);
2084}
2085
2086static bool
2087S_ckwarn_common(pTHX_ U32 w)
2088{
3c3f8cd6
AB		 2089 if (PL_curcop->cop_warnings == pWARN_ALL)
2090 return TRUE;
ad287e37
NC		 2091
2092 if (PL_curcop->cop_warnings == pWARN_NONE)
2093 return FALSE;
2094
98fe6610
NC		 2095 /* Check the assumption that at least the first slot is non-zero. */
2096 assert(unpackWARN1(w));
2097
2098 /* Check the assumption that it is valid to stop as soon as a zero slot is
2099 seen. */
2100 if (!unpackWARN2(w)) {
2101 assert(!unpackWARN3(w));
2102 assert(!unpackWARN4(w));
2103 } else if (!unpackWARN3(w)) {
2104 assert(!unpackWARN4(w));
2105 }
2106
26c7b074
NC		 2107 /* Right, dealt with all the special cases, which are implemented as non-
2108 pointers, so there is a pointer to a real warnings mask. */
98fe6610
NC		 2109 do {
2110 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2111 return TRUE;
2112 } while (w >>= WARNshift);
2113
2114 return FALSE;
f54ba1c2
DM		 2115}
2116
72dc9ed5
NC		 2117/* Set buffer=NULL to get a new one. */
2118STRLEN *
8ee4cf24 2119Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
72dc9ed5 2120 STRLEN size) {
5af88345
FC		 2121 const MEM_SIZE len_wanted =
2122 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
35da51f7 2123 PERL_UNUSED_CONTEXT;
7918f24d 2124 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
72dc9ed5 2125
10edeb5d
JH		 2126 buffer = (STRLEN*)
2127 (specialWARN(buffer) ?
2128 PerlMemShared_malloc(len_wanted) :
2129 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC		 2130 buffer[0] = size;
2131 Copy(bits, (buffer + 1), size, char);
5af88345
FC		 2132 if (size < WARNsize)
2133 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
72dc9ed5
NC		 2134 return buffer;
2135}
f54ba1c2 2136
e6587932
DM		 2137/* since we've already done strlen() for both nam and val
2138 * we can use that info to make things faster than
2139 * sprintf(s, "%s=%s", nam, val)
2140 */
2141#define my_setenv_format(s, nam, nlen, val, vlen) \
2142 Copy(nam, s, nlen, char); \
2143 *(s+nlen) = '='; \
2144 Copy(val, s+(nlen+1), vlen, char); \
2145 *(s+(nlen+1+vlen)) = '\0'
2146
c5d12488
JH		 2147#ifdef USE_ENVIRON_ARRAY
2148 /* VMS' my_setenv() is in vms.c */
2149#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 2150void
e1ec3a88 2151Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 2152{
27da23d5 2153 dVAR;
ea34f6bd 2154#ifdef __amigaos4__
6e3136a6
AB		 2155 amigaos4_obtain_environ(__FUNCTION__);
2156#endif
4efc5df6
GS		 2157#ifdef USE_ITHREADS
2158 /* only parent thread can modify process environment */
2159 if (PL_curinterp == aTHX)
2160#endif
2161 {
f2517201 2162#ifndef PERL_USE_SAFE_PUTENV
50acdf95 2163 if (!PL_use_safe_putenv) {
b7d87861
JH		 2164 /* most putenv()s leak, so we manipulate environ directly */
2165 I32 i;
2166 const I32 len = strlen(nam);
2167 int nlen, vlen;
2168
2169 /* where does it go? */
2170 for (i = 0; environ[i]; i++) {
2171 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2172 break;
2173 }
c5d12488 2174
b7d87861
JH		 2175 if (environ == PL_origenviron) { /* need we copy environment? */
2176 I32 j;
2177 I32 max;
2178 char **tmpenv;
2179
2180 max = i;
2181 while (environ[max])
2182 max++;
2183 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2184 for (j=0; j<max; j++) { /* copy environment */
2185 const int len = strlen(environ[j]);
2186 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2187 Copy(environ[j], tmpenv[j], len+1, char);
2188 }
2189 tmpenv[max] = NULL;
2190 environ = tmpenv; /* tell exec where it is now */
2191 }
2192 if (!val) {
2193 safesysfree(environ[i]);
2194 while (environ[i]) {
2195 environ[i] = environ[i+1];
2196 i++;
2197 }
ea34f6bd 2198#ifdef __amigaos4__
6e3136a6
AB		 2199 goto my_setenv_out;
2200#else
b7d87861 2201 return;
6e3136a6 2202#endif
b7d87861
JH		 2203 }
2204 if (!environ[i]) { /* does not exist yet */
2205 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2206 environ[i+1] = NULL; /* make sure it's null terminated */
2207 }
2208 else
2209 safesysfree(environ[i]);
2210 nlen = strlen(nam);
2211 vlen = strlen(val);
2212
2213 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2214 /* all that work just for this */
2215 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95 2216 } else {
c5d12488 2217# endif
235c1d5f
AD		 2218 /* This next branch should only be called #if defined(HAS_SETENV), but
2219 Configure doesn't test for that yet. For Solaris, setenv() and unsetenv()
2220 were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
2221 */
12ffbb10 2222# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
88f5bc07
AB		 2223# if defined(HAS_UNSETENV)
2224 if (val == NULL) {
2225 (void)unsetenv(nam);
2226 } else {
2227 (void)setenv(nam, val, 1);
2228 }
2229# else /* ! HAS_UNSETENV */
2230 (void)setenv(nam, val, 1);
2231# endif /* HAS_UNSETENV */
47dafe4d 2232# else
88f5bc07
AB		 2233# if defined(HAS_UNSETENV)
2234 if (val == NULL) {
ba88ff58
MJ		 2235 if (environ) /* old glibc can crash with null environ */
2236 (void)unsetenv(nam);
88f5bc07 2237 } else {
c4420975
AL		 2238 const int nlen = strlen(nam);
2239 const int vlen = strlen(val);
2240 char * const new_env =
88f5bc07
AB		 2241 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2242 my_setenv_format(new_env, nam, nlen, val, vlen);
2243 (void)putenv(new_env);
2244 }
2245# else /* ! HAS_UNSETENV */
2246 char *new_env;
c4420975
AL		 2247 const int nlen = strlen(nam);
2248 int vlen;
88f5bc07
AB		 2249 if (!val) {
2250 val = "";
2251 }
2252 vlen = strlen(val);
2253 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2254 /* all that work just for this */
2255 my_setenv_format(new_env, nam, nlen, val, vlen);
2256 (void)putenv(new_env);
2257# endif /* HAS_UNSETENV */
47dafe4d 2258# endif /* __CYGWIN__ */
50acdf95
MS		 2259#ifndef PERL_USE_SAFE_PUTENV
2260 }
2261#endif
4efc5df6 2262 }
ea34f6bd 2263#ifdef __amigaos4__
6e3136a6
AB		 2264my_setenv_out:
2265 amigaos4_release_environ(__FUNCTION__);
2266#endif
8d063cd8
LW		 2267}
2268
c5d12488 2269#else /* WIN32 || NETWARE */
68dc0745 2270
2271void
72229eff 2272Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 2273{
27da23d5 2274 dVAR;
eb578fdb 2275 char *envstr;
c5d12488
JH		 2276 const int nlen = strlen(nam);
2277 int vlen;
e6587932 2278
c5d12488
JH		 2279 if (!val) {
2280 val = "";
ac5c734f 2281 }
c5d12488
JH		 2282 vlen = strlen(val);
2283 Newx(envstr, nlen+vlen+2, char);
2284 my_setenv_format(envstr, nam, nlen, val, vlen);
2285 (void)PerlEnv_putenv(envstr);
2286 Safefree(envstr);
3e3baf6d
TB		 2287}
2288
c5d12488 2289#endif /* WIN32 || NETWARE */
3e3baf6d 2290
739a0b84 2291#endif /* !VMS */
378cc40b 2292
16d20bd9 2293#ifdef UNLINK_ALL_VERSIONS
79072805 2294I32
6e732051 2295Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 2296{
35da51f7 2297 I32 retries = 0;
378cc40b 2298
7918f24d
NC		 2299 PERL_ARGS_ASSERT_UNLNK;
2300
35da51f7
AL		 2301 while (PerlLIO_unlink(f) >= 0)
2302 retries++;
2303 return retries ? 0 : -1;
378cc40b
LW		 2304}
2305#endif
2306
99fff99d
LM		 2307/* this is a drop-in replacement for bcopy(), except for the return
2308 * value, which we need to be able to emulate memcpy() */
af4291a8 2309#if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY))
99fff99d
LM		 2310void *
2311Perl_my_bcopy(const void *vfrom, void *vto, size_t len)
378cc40b 2312{
af4291a8
LM		 2313#if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
2314 bcopy(vfrom, vto, len);
2315#else
99fff99d
LM		 2316 const unsigned char *from = (const unsigned char *)vfrom;
2317 unsigned char *to = (unsigned char *)vto;
378cc40b 2318
7918f24d
NC		 2319 PERL_ARGS_ASSERT_MY_BCOPY;
2320
7c0587c8
LW		 2321 if (from - to >= 0) {
2322 while (len--)
2323 *to++ = *from++;
2324 }
2325 else {
2326 to += len;
2327 from += len;
2328 while (len--)
faf8582f 2329 *(--to) = *(--from);
7c0587c8 2330 }
af4291a8
LM		 2331#endif
2332
99fff99d 2333 return vto;
378cc40b 2334}
ffed7fef 2335#endif
378cc40b 2336
7a3f2258 2337/* this is a drop-in replacement for memset() */
fc36a67e 2338#ifndef HAS_MEMSET
2339void *
99fff99d 2340Perl_my_memset(void *vloc, int ch, size_t len)
fc36a67e 2341{
99fff99d 2342 unsigned char *loc = (unsigned char *)vloc;
fc36a67e 2343
7918f24d
NC		 2344 PERL_ARGS_ASSERT_MY_MEMSET;
2345
fc36a67e 2346 while (len--)
2347 *loc++ = ch;
99fff99d 2348 return vloc;
fc36a67e 2349}
2350#endif
2351
7a3f2258 2352/* this is a drop-in replacement for bzero() */
7c0587c8 2353#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
99fff99d
LM		 2354void *
2355Perl_my_bzero(void *vloc, size_t len)
378cc40b 2356{
99fff99d 2357 unsigned char *loc = (unsigned char *)vloc;
378cc40b 2358
7918f24d
NC		 2359 PERL_ARGS_ASSERT_MY_BZERO;
2360
378cc40b
LW		 2361 while (len--)
2362 *loc++ = 0;
99fff99d 2363 return vloc;
378cc40b
LW		 2364}
2365#endif
7c0587c8 2366
7a3f2258 2367/* this is a drop-in replacement for memcmp() */
36477c24 2368#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
99fff99d
LM		 2369int
2370Perl_my_memcmp(const void *vs1, const void *vs2, size_t len)
7c0587c8 2371{
99fff99d
LM		 2372 const U8 *a = (const U8 *)vs1;
2373 const U8 *b = (const U8 *)vs2;
2374 int tmp;
7c0587c8 2375
7918f24d
NC		 2376 PERL_ARGS_ASSERT_MY_MEMCMP;
2377
7c0587c8 2378 while (len--) {
27da23d5 2379 if ((tmp = *a++ - *b++))
7c0587c8
LW		 2380 return tmp;
2381 }
2382 return 0;
2383}
36477c24 2384#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 2385
fe14fcc3 2386#ifndef HAS_VPRINTF
d05d9be5
AD		 2387/* This vsprintf replacement should generally never get used, since
2388 vsprintf was available in both System V and BSD 2.11. (There may
2389 be some cross-compilation or embedded set-ups where it is needed,
2390 however.)
2391
2392 If you encounter a problem in this function, it's probably a symptom
2393 that Configure failed to detect your system's vprintf() function.
2394 See the section on "item vsprintf" in the INSTALL file.
2395
2396 This version may compile on systems with BSD-ish <stdio.h>,
2397 but probably won't on others.
2398*/
a687059c 2399
85e6fe83 2400#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 2401char *
2402#else
2403int
2404#endif
d05d9be5 2405vsprintf(char *dest, const char *pat, void *args)
a687059c
LW		 2406{
2407 FILE fakebuf;
2408
d05d9be5
AD		 2409#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2410 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2411 FILE_cnt(&fakebuf) = 32767;
2412#else
2413 /* These probably won't compile -- If you really need
2414 this, you'll have to figure out some other method. */
a687059c
LW		 2415 fakebuf._ptr = dest;
2416 fakebuf._cnt = 32767;
d05d9be5 2417#endif
35c8bce7
LW		 2418#ifndef _IOSTRG
2419#define _IOSTRG 0
2420#endif
a687059c
LW		 2421 fakebuf._flag = _IOWRT|_IOSTRG;
2422 _doprnt(pat, args, &fakebuf); /* what a kludge */
d05d9be5
AD		 2423#if defined(STDIO_PTR_LVALUE)
2424 *(FILE_ptr(&fakebuf)++) = '\0';
2425#else
2426 /* PerlIO has probably #defined away fputc, but we want it here. */
2427# ifdef fputc
2428# undef fputc /* XXX Should really restore it later */
2429# endif
2430 (void)fputc('\0', &fakebuf);
2431#endif
85e6fe83 2432#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 2433 return(dest);
2434#else
2435 return 0; /* perl doesn't use return value */
2436#endif
2437}
2438
fe14fcc3 2439#endif /* HAS_VPRINTF */
a687059c 2440
4a7d1889 2441PerlIO *
c9289b7b 2442Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
4a7d1889 2443{
f6fb4e44 2444#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
1f852d0d 2445 int p[2];
eb578fdb
KW		 2446 I32 This, that;
2447 Pid_t pid;
1f852d0d
NIS		 2448 SV *sv;
2449 I32 did_pipes = 0;
2450 int pp[2];
2451
7918f24d
NC		 2452 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2453
1f852d0d
NIS		 2454 PERL_FLUSHALL_FOR_CHILD;
2455 This = (*mode == 'w');
2456 that = !This;
284167a5 2457 if (TAINTING_get) {
1f852d0d
NIS		 2458 taint_env();
2459 taint_proper("Insecure %s%s", "EXEC");
2460 }
2461 if (PerlProc_pipe(p) < 0)
4608196e 2462 return NULL;
1f852d0d
NIS		 2463 /* Try for another pipe pair for error return */
2464 if (PerlProc_pipe(pp) >= 0)
2465 did_pipes = 1;
52e18b1f 2466 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS		 2467 if (errno != EAGAIN) {
2468 PerlLIO_close(p[This]);
4e6dfe71 2469 PerlLIO_close(p[that]);
1f852d0d
NIS		 2470 if (did_pipes) {
2471 PerlLIO_close(pp[0]);
2472 PerlLIO_close(pp[1]);
2473 }
4608196e 2474 return NULL;
1f852d0d 2475 }
a2a5de95 2476 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
1f852d0d
NIS		 2477 sleep(5);
2478 }
2479 if (pid == 0) {
2480 /* Child */
1f852d0d
NIS		 2481#undef THIS
2482#undef THAT
2483#define THIS that
2484#define THAT This
1f852d0d
NIS		 2485 /* Close parent's end of error status pipe (if any) */
2486 if (did_pipes) {
2487 PerlLIO_close(pp[0]);
131d45a9 2488#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1f852d0d 2489 /* Close error pipe automatically if exec works */
375ed12a
JH		 2490 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2491 return NULL;
1f852d0d
NIS		 2492#endif
2493 }
2494 /* Now dup our end of _the_ pipe to right position */
2495 if (p[THIS] != (*mode == 'r')) {
2496 PerlLIO_dup2(p[THIS], *mode == 'r');
2497 PerlLIO_close(p[THIS]);
4e6dfe71
GS		 2498 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2499 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2500 }
4e6dfe71
GS		 2501 else
2502 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS		 2503#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2504 /* No automatic close - do it by hand */
b7953727
JH		 2505# ifndef NOFILE
2506# define NOFILE 20
2507# endif
a080fe3d
NIS		 2508 {
2509 int fd;
2510
2511 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2512 if (fd != pp[1])
a080fe3d
NIS		 2513 PerlLIO_close(fd);
2514 }
1f852d0d
NIS		 2515 }
2516#endif
a0714e2c 2517 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS		 2518 PerlProc__exit(1);
2519#undef THIS
2520#undef THAT
2521 }
2522 /* Parent */
52e18b1f 2523 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS		 2524 if (did_pipes)
2525 PerlLIO_close(pp[1]);
2526 /* Keep the lower of the two fd numbers */
2527 if (p[that] < p[This]) {
2528 PerlLIO_dup2(p[This], p[that]);
2529 PerlLIO_close(p[This]);
2530 p[This] = p[that];
2531 }
4e6dfe71
GS		 2532 else
2533 PerlLIO_close(p[that]); /* close child's end of pipe */
2534
1f852d0d 2535 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2536 SvUPGRADE(sv,SVt_IV);
45977657 2537 SvIV_set(sv, pid);
1f852d0d
NIS		 2538 PL_forkprocess = pid;
2539 /* If we managed to get status pipe check for exec fail */
2540 if (did_pipes && pid > 0) {
2541 int errkid;
bb7a0f54
MHM		 2542 unsigned n = 0;
2543 SSize_t n1;
1f852d0d
NIS		 2544
2545 while (n < sizeof(int)) {
2546 n1 = PerlLIO_read(pp[0],
2547 (void*)(((char*)&errkid)+n),
2548 (sizeof(int)) - n);
2549 if (n1 <= 0)
2550 break;
2551 n += n1;
2552 }
2553 PerlLIO_close(pp[0]);
2554 did_pipes = 0;
2555 if (n) { /* Error */
2556 int pid2, status;
8c51524e 2557 PerlLIO_close(p[This]);
1f852d0d 2558 if (n != sizeof(int))
5637ef5b 2559 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
1f852d0d
NIS		 2560 do {
2561 pid2 = wait4pid(pid, &status, 0);
2562 } while (pid2 == -1 && errno == EINTR);
2563 errno = errkid; /* Propagate errno from kid */
4608196e 2564 return NULL;
1f852d0d
NIS		 2565 }
2566 }
2567 if (did_pipes)
2568 PerlLIO_close(pp[0]);
2569 return PerlIO_fdopen(p[This], mode);
2570#else
8492b23f 2571# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
4e205ed6 2572 return my_syspopen4(aTHX_ NULL, mode, n, args);
8492b23f
TC		 2573# elif defined(WIN32)
2574 return win32_popenlist(mode, n, args);
9d419b5f 2575# else
4a7d1889
NIS		 2576 Perl_croak(aTHX_ "List form of piped open not implemented");
2577 return (PerlIO *) NULL;
9d419b5f 2578# endif
1f852d0d 2579#endif
4a7d1889
NIS		 2580}
2581
4dd5370d
AB		 2582 /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2583#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
760ac839 2584PerlIO *
3dd43144 2585Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c
LW		 2586{
2587 int p[2];
eb578fdb
KW		 2588 I32 This, that;
2589 Pid_t pid;
79072805 2590 SV *sv;
bfce84ec 2591 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ		 2592 I32 did_pipes = 0;
2593 int pp[2];
a687059c 2594
7918f24d
NC		 2595 PERL_ARGS_ASSERT_MY_POPEN;
2596
45bc9206 2597 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 2598#ifdef OS2
2599 if (doexec) {
23da6c43 2600 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2601 }
a1d180c4 2602#endif
8ac85365
NIS		 2603 This = (*mode == 'w');
2604 that = !This;
284167a5 2605 if (doexec && TAINTING_get) {
bbce6d69 2606 taint_env();
2607 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2608 }
c2267164 2609 if (PerlProc_pipe(p) < 0)
4608196e 2610 return NULL;
e446cec8
IZ		 2611 if (doexec && PerlProc_pipe(pp) >= 0)
2612 did_pipes = 1;
52e18b1f 2613 while ((pid = PerlProc_fork()) < 0) {
a687059c 2614 if (errno != EAGAIN) {
6ad3d225 2615 PerlLIO_close(p[This]);
b5ac89c3 2616 PerlLIO_close(p[that]);
e446cec8
IZ		 2617 if (did_pipes) {
2618 PerlLIO_close(pp[0]);
2619 PerlLIO_close(pp[1]);
2620 }
a687059c 2621 if (!doexec)
b3647a36 2622 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2623 return NULL;
a687059c 2624 }
a2a5de95 2625 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW		 2626 sleep(5);
2627 }
2628 if (pid == 0) {
79072805 2629
30ac6d9b
GS		 2630#undef THIS
2631#undef THAT
a687059c 2632#define THIS that
8ac85365 2633#define THAT This
e446cec8
IZ		 2634 if (did_pipes) {
2635 PerlLIO_close(pp[0]);
2636#if defined(HAS_FCNTL) && defined(F_SETFD)
375ed12a
JH		 2637 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2638 return NULL;
e446cec8
IZ		 2639#endif
2640 }
a687059c 2641 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 2642 PerlLIO_dup2(p[THIS], *mode == 'r');
2643 PerlLIO_close(p[THIS]);
b5ac89c3
NIS		 2644 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2645 PerlLIO_close(p[THAT]);
a687059c 2646 }
b5ac89c3
NIS		 2647 else
2648 PerlLIO_close(p[THAT]);
4435c477 2649#ifndef OS2
a687059c 2650 if (doexec) {
a0d0e21e 2651#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 2652#ifndef NOFILE
2653#define NOFILE 20
2654#endif
a080fe3d 2655 {
3aed30dc 2656 int fd;
a080fe3d
NIS		 2657
2658 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2659 if (fd != pp[1])
3aed30dc 2660 PerlLIO_close(fd);
a080fe3d 2661 }
ae986130 2662#endif
a080fe3d
NIS		 2663 /* may or may not use the shell */
2664 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2665 PerlProc__exit(1);
a687059c 2666 }
4435c477 2667#endif /* defined OS2 */
713cef20
IZ		 2668
2669#ifdef PERLIO_USING_CRLF
2670 /* Since we circumvent IO layers when we manipulate low-level
2671 filedescriptors directly, need to manually switch to the
2672 default, binary, low-level mode; see PerlIOBuf_open(). */
2673 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2674#endif
3280af22 2675 PL_forkprocess = 0;
ca0c25f6 2676#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2677 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2678#endif
4608196e 2679 return NULL;
a687059c
LW		 2680#undef THIS
2681#undef THAT
2682 }
b5ac89c3 2683 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ		 2684 if (did_pipes)
2685 PerlLIO_close(pp[1]);
8ac85365 2686 if (p[that] < p[This]) {
6ad3d225
GS		 2687 PerlLIO_dup2(p[This], p[that]);
2688 PerlLIO_close(p[This]);
8ac85365 2689 p[This] = p[that];
62b28dd9 2690 }
b5ac89c3
NIS		 2691 else
2692 PerlLIO_close(p[that]);
2693
3280af22 2694 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2695 SvUPGRADE(sv,SVt_IV);
45977657 2696 SvIV_set(sv, pid);
3280af22 2697 PL_forkprocess = pid;
e446cec8
IZ		 2698 if (did_pipes && pid > 0) {
2699 int errkid;
bb7a0f54
MHM		 2700 unsigned n = 0;
2701 SSize_t n1;
e446cec8
IZ		 2702
2703 while (n < sizeof(int)) {
2704 n1 = PerlLIO_read(pp[0],
2705 (void*)(((char*)&errkid)+n),
2706 (sizeof(int)) - n);
2707 if (n1 <= 0)
2708 break;
2709 n += n1;
2710 }
2f96c702
IZ		 2711 PerlLIO_close(pp[0]);
2712 did_pipes = 0;
e446cec8 2713 if (n) { /* Error */
faa466a7 2714 int pid2, status;
8c51524e 2715 PerlLIO_close(p[This]);
e446cec8 2716 if (n != sizeof(int))
5637ef5b 2717 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
faa466a7
RG		 2718 do {
2719 pid2 = wait4pid(pid, &status, 0);
2720 } while (pid2 == -1 && errno == EINTR);
e446cec8 2721 errno = errkid; /* Propagate errno from kid */
4608196e 2722 return NULL;
e446cec8
IZ		 2723 }
2724 }
2725 if (did_pipes)
2726 PerlLIO_close(pp[0]);
8ac85365 2727 return PerlIO_fdopen(p[This], mode);
a687059c 2728}
7c0587c8 2729#else
2b96b0a5
JH		 2730#if defined(DJGPP)
2731FILE *djgpp_popen();
2732PerlIO *
cef6ea9d 2733Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH		 2734{
2735 PERL_FLUSHALL_FOR_CHILD;
2736 /* Call system's popen() to get a FILE *, then import it.
2737 used 0 for 2nd parameter to PerlIO_importFILE;
2738 apparently not used
2739 */
2740 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2741}
9c12f1e5
RGS		 2742#else
2743#if defined(__LIBCATAMOUNT__)
2744PerlIO *
2745Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2746{
2747 return NULL;
2748}
2749#endif
2b96b0a5 2750#endif
7c0587c8
LW		 2751
2752#endif /* !DOSISH */
a687059c 2753
52e18b1f
GS		 2754/* this is called in parent before the fork() */
2755void
2756Perl_atfork_lock(void)
80b94025
JH		 2757#if defined(USE_ITHREADS)
2758# ifdef USE_PERLIO
2759 PERL_TSA_ACQUIRE(PL_perlio_mutex)
2760# endif
2761# ifdef MYMALLOC
2762 PERL_TSA_ACQUIRE(PL_malloc_mutex)
2763# endif
2764 PERL_TSA_ACQUIRE(PL_op_mutex)
2765#endif
52e18b1f 2766{
3db8f154 2767#if defined(USE_ITHREADS)
20b7effb 2768 dVAR;
52e18b1f 2769 /* locks must be held in locking order (if any) */
4da80956
P		 2770# ifdef USE_PERLIO
2771 MUTEX_LOCK(&PL_perlio_mutex);
2772# endif
52e18b1f
GS		 2773# ifdef MYMALLOC
2774 MUTEX_LOCK(&PL_malloc_mutex);
2775# endif
2776 OP_REFCNT_LOCK;
2777#endif
2778}
2779
2780/* this is called in both parent and child after the fork() */
2781void
2782Perl_atfork_unlock(void)
80b94025
JH		 2783#if defined(USE_ITHREADS)
2784# ifdef USE_PERLIO
2785 PERL_TSA_RELEASE(PL_perlio_mutex)
2786# endif
2787# ifdef MYMALLOC
2788 PERL_TSA_RELEASE(PL_malloc_mutex)
2789# endif
2790 PERL_TSA_RELEASE(PL_op_mutex)
2791#endif
52e18b1f 2792{
3db8f154 2793#if defined(USE_ITHREADS)
20b7effb 2794 dVAR;
52e18b1f 2795 /* locks must be released in same order as in atfork_lock() */
4da80956
P		 2796# ifdef USE_PERLIO
2797 MUTEX_UNLOCK(&PL_perlio_mutex);
2798# endif
52e18b1f
GS		 2799# ifdef MYMALLOC
2800 MUTEX_UNLOCK(&PL_malloc_mutex);
2801# endif
2802 OP_REFCNT_UNLOCK;
2803#endif
2804}
2805
2806Pid_t
2807Perl_my_fork(void)
2808{
2809#if defined(HAS_FORK)
2810 Pid_t pid;
3db8f154 2811#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2812 atfork_lock();
2813 pid = fork();
2814 atfork_unlock();
2815#else
2816 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2817 * handlers elsewhere in the code */
2818 pid = fork();
2819#endif
2820 return pid;
40262ff4
AB		 2821#elif defined(__amigaos4__)
2822 return amigaos_fork();
52e18b1f
GS		 2823#else
2824 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2825 Perl_croak_nocontext("fork() not available");
b961a566 2826 return 0;
52e18b1f
GS		 2827#endif /* HAS_FORK */
2828}
2829
fe14fcc3 2830#ifndef HAS_DUP2
fec02dd3 2831int
ba106d47 2832dup2(int oldfd, int newfd)
a687059c 2833{
a0d0e21e 2834#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2835 if (oldfd == newfd)
2836 return oldfd;
6ad3d225 2837 PerlLIO_close(newfd);
fec02dd3 2838 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2839#else
fc36a67e 2840#define DUP2_MAX_FDS 256
2841 int fdtmp[DUP2_MAX_FDS];
79072805 2842 I32 fdx = 0;
ae986130
LW		 2843 int fd;
2844
fe14fcc3 2845 if (oldfd == newfd)
fec02dd3 2846 return oldfd;
6ad3d225 2847 PerlLIO_close(newfd);
fc36a67e 2848 /* good enough for low fd's... */
6ad3d225 2849 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2850 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2851 PerlLIO_close(fd);
fc36a67e 2852 fd = -1;
2853 break;
2854 }
ae986130 2855 fdtmp[fdx++] = fd;
fc36a67e 2856 }
ae986130 2857 while (fdx > 0)
6ad3d225 2858 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2859 return fd;
62b28dd9 2860#endif
a687059c
LW		 2861}
2862#endif
2863
64ca3a65 2864#ifndef PERL_MICRO
ff68c719 2865#ifdef HAS_SIGACTION
2866
2867Sighandler_t
864dbfa3 2868Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2869{
2870 struct sigaction act, oact;
2871
a10b1e10 2872#ifdef USE_ITHREADS
20b7effb 2873 dVAR;
a10b1e10
JH		 2874 /* only "parent" interpreter can diddle signals */
2875 if (PL_curinterp != aTHX)
8aad04aa 2876 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2877#endif
2878
8aad04aa 2879 act.sa_handler = (void(*)(int))handler;
ff68c719 2880 sigemptyset(&act.sa_mask);
2881 act.sa_flags = 0;
2882#ifdef SA_RESTART
4ffa73a3
JH		 2883 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2884 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2885#endif
358837b8 2886#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2887 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2888 act.sa_flags |= SA_NOCLDWAIT;
2889#endif
ff68c719 2890 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2891 return (Sighandler_t) SIG_ERR;
ff68c719 2892 else
8aad04aa 2893 return (Sighandler_t) oact.sa_handler;
ff68c719 2894}
2895
2896Sighandler_t
864dbfa3 2897Perl_rsignal_state(pTHX_ int signo)
ff68c719 2898{
2899 struct sigaction oact;
96a5add6 2900 PERL_UNUSED_CONTEXT;
ff68c719 2901
2902 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2903 return (Sighandler_t) SIG_ERR;
ff68c719 2904 else
8aad04aa 2905 return (Sighandler_t) oact.sa_handler;
ff68c719 2906}
2907
2908int
864dbfa3 2909Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2910{
20b7effb 2911#ifdef USE_ITHREADS
27da23d5 2912 dVAR;
20b7effb 2913#endif
ff68c719 2914 struct sigaction act;
2915
7918f24d
NC		 2916 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2917
a10b1e10
JH		 2918#ifdef USE_ITHREADS
2919 /* only "parent" interpreter can diddle signals */
2920 if (PL_curinterp != aTHX)
2921 return -1;
2922#endif
2923
8aad04aa 2924 act.sa_handler = (void(*)(int))handler;
ff68c719 2925 sigemptyset(&act.sa_mask);
2926 act.sa_flags = 0;
2927#ifdef SA_RESTART
4ffa73a3
JH		 2928 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2929 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2930#endif
36b5d377 2931#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2932 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2933 act.sa_flags |= SA_NOCLDWAIT;
2934#endif
ff68c719 2935 return sigaction(signo, &act, save);
2936}
2937
2938int
864dbfa3 2939Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2940{
20b7effb 2941#ifdef USE_ITHREADS
27da23d5 2942 dVAR;
20b7effb
JH		 2943#endif
2944 PERL_UNUSED_CONTEXT;
a10b1e10
JH		 2945#ifdef USE_ITHREADS
2946 /* only "parent" interpreter can diddle signals */
2947 if (PL_curinterp != aTHX)
2948 return -1;
2949#endif
2950
ff68c719 2951 return sigaction(signo, save, (struct sigaction *)NULL);
2952}
2953
2954#else /* !HAS_SIGACTION */
2955
2956Sighandler_t
864dbfa3 2957Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2958{
39f1703b 2959#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2960 /* only "parent" interpreter can diddle signals */
2961 if (PL_curinterp != aTHX)
8aad04aa 2962 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2963#endif
2964
6ad3d225 2965 return PerlProc_signal(signo, handler);
ff68c719 2966}
2967
fabdb6c0 2968static Signal_t
4e35701f 2969sig_trap(int signo)
ff68c719 2970{
27da23d5
JH		 2971 dVAR;
2972 PL_sig_trapped++;
ff68c719 2973}
2974
2975Sighandler_t
864dbfa3 2976Perl_rsignal_state(pTHX_ int signo)
ff68c719 2977{
27da23d5 2978 dVAR;
ff68c719 2979 Sighandler_t oldsig;
2980
39f1703b 2981#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2982 /* only "parent" interpreter can diddle signals */
2983 if (PL_curinterp != aTHX)
8aad04aa 2984 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2985#endif
2986
27da23d5 2987 PL_sig_trapped = 0;
6ad3d225
GS		 2988 oldsig = PerlProc_signal(signo, sig_trap);
2989 PerlProc_signal(signo, oldsig);
27da23d5 2990 if (PL_sig_trapped)
3aed30dc 2991 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2992 return oldsig;
2993}
2994
2995int
864dbfa3 2996Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2997{
39f1703b 2998#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2999 /* only "parent" interpreter can diddle signals */
3000 if (PL_curinterp != aTHX)
3001 return -1;
3002#endif
6ad3d225 3003 *save = PerlProc_signal(signo, handler);
8aad04aa 3004 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 3005}
3006
3007int
864dbfa3 3008Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 3009{
39f1703b 3010#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 3011 /* only "parent" interpreter can diddle signals */
3012 if (PL_curinterp != aTHX)
3013 return -1;
3014#endif
8aad04aa 3015 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 3016}
3017
3018#endif /* !HAS_SIGACTION */
64ca3a65 3019#endif /* !PERL_MICRO */
ff68c719 3020
5f05dabc 3021 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
53f73940 3022#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
79072805 3023I32
864dbfa3 3024Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 3025{
a687059c 3026 int status;
a0d0e21e 3027 SV **svp;
d8a83dd3 3028 Pid_t pid;
2e0cfa16 3029 Pid_t pid2 = 0;
03136e13 3030 bool close_failed;
4ee39169 3031 dSAVEDERRNO;
2e0cfa16 3032 const int fd = PerlIO_fileno(ptr);
e9d373c4
TC		 3033 bool should_wait;
3034
3035 svp = av_fetch(PL_fdpid,fd,TRUE);
3036 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3037 SvREFCNT_dec(*svp);
3038 *svp = NULL;
2e0cfa16 3039
97cb92d6 3040#if defined(USE_PERLIO)
2e0cfa16
FC		 3041 /* Find out whether the refcount is low enough for us to wait for the
3042 child proc without blocking. */
e9d373c4 3043 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
b6ae43b7 3044#else
e9d373c4 3045 should_wait = pid > 0;
b6ae43b7 3046#endif
a687059c 3047
ddcf38b7
IZ		 3048#ifdef OS2
3049 if (pid == -1) { /* Opened by popen. */
3050 return my_syspclose(ptr);
3051 }
a1d180c4 3052#endif
f1618b10
CS		 3053 close_failed = (PerlIO_close(ptr) == EOF);
3054 SAVE_ERRNO;
2e0cfa16 3055 if (should_wait) do {
1d3434b8
GS		 3056 pid2 = wait4pid(pid, &status, 0);
3057 } while (pid2 == -1 && errno == EINTR);
03136e13 3058 if (close_failed) {
4ee39169 3059 RESTORE_ERRNO;
03136e13
CS		 3060 return -1;
3061 }
2e0cfa16
FC		 3062 return(
3063 should_wait
3064 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3065 : 0
3066 );
20188a90 3067}
9c12f1e5
RGS		 3068#else
3069#if defined(__LIBCATAMOUNT__)
3070I32
3071Perl_my_pclose(pTHX_ PerlIO *ptr)
3072{
3073 return -1;
3074}
3075#endif
4633a7c4
LW		 3076#endif /* !DOSISH */
3077
e37778c2 3078#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 3079I32
d8a83dd3 3080Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 3081{
27da23d5 3082 I32 result = 0;
7918f24d 3083 PERL_ARGS_ASSERT_WAIT4PID;
ca0c25f6 3084#ifdef PERL_USES_PL_PIDSTATUS
d4c02743
TC		 3085 if (!pid) {
3086 /* PERL_USES_PL_PIDSTATUS is only defined when neither
3087 waitpid() nor wait4() is available, or on OS/2, which
3088 doesn't appear to support waiting for a progress group
3089 member, so we can only treat a 0 pid as an unknown child.
3090 */
3091 errno = ECHILD;
3092 return -1;
3093 }
b7953727 3094 {
3aed30dc 3095 if (pid > 0) {
12072db5
NC		 3096 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3097 pid, rather than a string form. */
c4420975 3098 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS		 3099 if (svp && *svp != &PL_sv_undef) {
3100 *statusp = SvIVX(*svp);
12072db5
NC		 3101 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3102 G_DISCARD);
3aed30dc
HS		 3103 return pid;
3104 }
3105 }
3106 else {
3107 HE *entry;
3108
3109 hv_iterinit(PL_pidstatus);
3110 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 3111 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 3112 I32 len;
0bcc34c2 3113 const char * const spid = hv_iterkey(entry,&len);
27da23d5 3114
12072db5
NC		 3115 assert (len == sizeof(Pid_t));
3116 memcpy((char *)&pid, spid, len);
3aed30dc 3117 *statusp = SvIVX(sv);
7b9a3241
NC		 3118 /* The hash iterator is currently on this entry, so simply
3119 calling hv_delete would trigger the lazy delete, which on
f6bab5f6 3120 aggregate does more work, because next call to hv_iterinit()
7b9a3241
NC		 3121 would spot the flag, and have to call the delete routine,
3122 while in the meantime any new entries can't re-use that
3123 memory. */
3124 hv_iterinit(PL_pidstatus);
7ea75b61 3125 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS		 3126 return pid;
3127 }
20188a90
LW		 3128 }
3129 }
68a29c53 3130#endif
79072805 3131#ifdef HAS_WAITPID
367f3c24
IZ		 3132# ifdef HAS_WAITPID_RUNTIME
3133 if (!HAS_WAITPID_RUNTIME)
3134 goto hard_way;
3135# endif
cddd4526 3136 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 3137 goto finish;
367f3c24
IZ		 3138#endif
3139#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
d4c02743 3140 result = wait4(pid,statusp,flags,NULL);
dfcfdb64 3141 goto finish;
367f3c24 3142#endif
ca0c25f6 3143#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 3144#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 3145 hard_way:
27da23d5 3146#endif
a0d0e21e 3147 {
a0d0e21e 3148 if (flags)
cea2e8a9 3149 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 3150 else {
76e3520e 3151 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 3152 pidgone(result,*statusp);
3153 if (result < 0)
3154 *statusp = -1;
3155 }
a687059c
LW		 3156 }
3157#endif
27da23d5 3158#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 3159 finish:
27da23d5 3160#endif
cddd4526
NIS		 3161 if (result < 0 && errno == EINTR) {
3162 PERL_ASYNC_CHECK();
48dbb59e 3163 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS		 3164 }
3165 return result;
a687059c 3166}
2986a63f 3167#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 3168
ca0c25f6 3169#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 3170void
ed4173ef 3171S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 3172{
eb578fdb 3173 SV *sv;
a687059c 3174
12072db5 3175 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 3176 SvUPGRADE(sv,SVt_IV);
45977657 3177 SvIV_set(sv, status);
20188a90 3178 return;
a687059c 3179}
ca0c25f6 3180#endif
a687059c 3181
6de23f80 3182#if defined(OS2)
7c0587c8 3183int pclose();
ddcf38b7
IZ		 3184#ifdef HAS_FORK
3185int /* Cannot prototype with I32
3186 in os2ish.h. */
ba106d47 3187my_syspclose(PerlIO *ptr)
ddcf38b7 3188#else
79072805 3189I32
864dbfa3 3190Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 3191#endif
a687059c 3192{
760ac839 3193 /* Needs work for PerlIO ! */
c4420975 3194 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 3195 const I32 result = pclose(f);
2b96b0a5
JH		 3196 PerlIO_releaseFILE(ptr,f);
3197 return result;
3198}
3199#endif
3200
933fea7f 3201#if defined(DJGPP)
2b96b0a5
JH		 3202int djgpp_pclose();
3203I32
3204Perl_my_pclose(pTHX_ PerlIO *ptr)
3205{
3206 /* Needs work for PerlIO ! */
c4420975 3207 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 3208 I32 result = djgpp_pclose(f);
933fea7f 3209 result = (result << 8) & 0xff00;
760ac839
LW		 3210 PerlIO_releaseFILE(ptr,f);
3211 return result;
a687059c 3212}
7c0587c8 3213#endif
9f68db38 3214
16fa5c11 3215#define PERL_REPEATCPY_LINEAR 4
9f68db38 3216void
5aaab254 3217Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
9f68db38 3218{
7918f24d
NC		 3219 PERL_ARGS_ASSERT_REPEATCPY;
3220
223f01db
KW		 3221 assert(len >= 0);
3222
2709980d 3223 if (count < 0)
d1decf2b 3224 croak_memory_wrap();
2709980d 3225
16fa5c11
VP		 3226 if (len == 1)
3227 memset(to, *from, count);
3228 else if (count) {
eb578fdb 3229 char *p = to;
26e1303d 3230 IV items, linear, half;
16fa5c11
VP		 3231
3232 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3233 for (items = 0; items < linear; ++items) {
eb578fdb 3234 const char *q = from;
26e1303d 3235 IV todo;
16fa5c11
VP		 3236 for (todo = len; todo > 0; todo--)
3237 *p++ = *q++;
3238 }
3239
3240 half = count / 2;
3241 while (items <= half) {
26e1303d 3242 IV size = items * len;
16fa5c11
VP		 3243 memcpy(p, to, size);
3244 p += size;
3245 items *= 2;
9f68db38 3246 }
16fa5c11
VP		 3247
3248 if (count > items)
3249 memcpy(p, to, (count - items) * len);
9f68db38
LW		 3250 }
3251}
0f85fab0 3252
fe14fcc3 3253#ifndef HAS_RENAME
79072805 3254I32
4373e329 3255Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3256{
93a17b20
LW		 3257 char *fa = strrchr(a,'/');
3258 char *fb = strrchr(b,'/');
c623ac67
GS		 3259 Stat_t tmpstatbuf1;
3260 Stat_t tmpstatbuf2;
c4420975 3261 SV * const tmpsv = sv_newmortal();
62b28dd9 3262
7918f24d
NC		 3263 PERL_ARGS_ASSERT_SAME_DIRENT;
3264
62b28dd9
LW		 3265 if (fa)
3266 fa++;
3267 else
3268 fa = a;
3269 if (fb)
3270 fb++;
3271 else
3272 fb = b;
3273 if (strNE(a,b))
3274 return FALSE;
3275 if (fa == a)
76f68e9b 3276 sv_setpvs(tmpsv, ".");
62b28dd9 3277 else
46fc3d4c 3278 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3279 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 3280 return FALSE;
3281 if (fb == b)
76f68e9b 3282 sv_setpvs(tmpsv, ".");
62b28dd9 3283 else
46fc3d4c 3284 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3285 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 3286 return FALSE;
3287 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3288 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3289}
fe14fcc3
LW		 3290#endif /* !HAS_RENAME */
3291
491527d0 3292char*
7f315aed
NC		 3293Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3294 const char *const *const search_ext, I32 flags)
491527d0 3295{
bd61b366
SS		 3296 const char *xfound = NULL;
3297 char *xfailed = NULL;
0f31cffe 3298 char tmpbuf[MAXPATHLEN];
eb578fdb 3299 char *s;
5f74f29c 3300 I32 len = 0;
491527d0 3301 int retval;
39a02377 3302 char *bufend;
7c458fae 3303#if defined(DOSISH) && !defined(OS2)
491527d0
GS		 3304# define SEARCH_EXTS ".bat", ".cmd", NULL
3305# define MAX_EXT_LEN 4
3306#endif
3307#ifdef OS2
3308# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3309# define MAX_EXT_LEN 4
3310#endif
3311#ifdef VMS
3312# define SEARCH_EXTS ".pl", ".com", NULL
3313# define MAX_EXT_LEN 4
3314#endif
3315 /* additional extensions to try in each dir if scriptname not found */
3316#ifdef SEARCH_EXTS
0bcc34c2 3317 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3318 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3319 int extidx = 0, i = 0;
bd61b366 3320 const char *curext = NULL;
491527d0 3321#else
53c1dcc0 3322 PERL_UNUSED_ARG(search_ext);
491527d0
GS		 3323# define MAX_EXT_LEN 0
3324#endif
3325
7918f24d
NC		 3326 PERL_ARGS_ASSERT_FIND_SCRIPT;
3327
491527d0
GS		 3328 /*
3329 * If dosearch is true and if scriptname does not contain path
3330 * delimiters, search the PATH for scriptname.
3331 *
3332 * If SEARCH_EXTS is also defined, will look for each
3333 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3334 * while searching the PATH.
3335 *
3336 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3337 * proceeds as follows:
3338 * If DOSISH or VMSISH:
3339 * + look for ./scriptname{,.foo,.bar}
3340 * + search the PATH for scriptname{,.foo,.bar}
3341 *
3342 * If !DOSISH:
3343 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3344 * this will not look in '.' if it's not in the PATH)
3345 */
84486fc6 3346 tmpbuf[0] = '\0';
491527d0
GS		 3347
3348#ifdef VMS
3349# ifdef ALWAYS_DEFTYPES
3350 len = strlen(scriptname);
3351 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3352 int idx = 0, deftypes = 1;
491527d0
GS		 3353 bool seen_dot = 1;
3354
bd61b366 3355 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3356# else
3357 if (dosearch) {
c4420975 3358 int idx = 0, deftypes = 1;
491527d0
GS		 3359 bool seen_dot = 1;
3360
bd61b366 3361 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3362# endif
3363 /* The first time through, just add SEARCH_EXTS to whatever we
3364 * already have, so we can check for default file types. */
3365 while (deftypes ||
84486fc6 3366 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0 3367 {
2aa28b86 3368 Stat_t statbuf;
491527d0
GS		 3369 if (deftypes) {
3370 deftypes = 0;
84486fc6 3371 *tmpbuf = '\0';
491527d0 3372 }
84486fc6
GS		 3373 if ((strlen(tmpbuf) + strlen(scriptname)
3374 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3375 continue; /* don't search dir with too-long name */
6fca0082 3376 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS		 3377#else /* !VMS */
3378
3379#ifdef DOSISH
3380 if (strEQ(scriptname, "-"))
3381 dosearch = 0;
3382 if (dosearch) { /* Look in '.' first. */
fe2774ed 3383 const char *cur = scriptname;
491527d0
GS		 3384#ifdef SEARCH_EXTS
3385 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3386 while (ext[i])
3387 if (strEQ(ext[i++],curext)) {
3388 extidx = -1; /* already has an ext */
3389 break;
3390 }
3391 do {
3392#endif
3393 DEBUG_p(PerlIO_printf(Perl_debug_log,
3394 "Looking for %s\n",cur));
45a23732 3395 {
0cc19a43 3396 Stat_t statbuf;
45a23732
DD		 3397 if (PerlLIO_stat(cur,&statbuf) >= 0
3398 && !S_ISDIR(statbuf.st_mode)) {
3399 dosearch = 0;
3400 scriptname = cur;
491527d0 3401#ifdef SEARCH_EXTS
45a23732 3402 break;
491527d0 3403#endif
45a23732 3404 }
491527d0
GS		 3405 }
3406#ifdef SEARCH_EXTS
3407 if (cur == scriptname) {
3408 len = strlen(scriptname);
84486fc6 3409 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3410 break;
9e4425f7
SH		 3411 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3412 cur = tmpbuf;
491527d0
GS		 3413 }
3414 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3415 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS		 3416#endif
3417 }
3418#endif
3419
3420 if (dosearch && !strchr(scriptname, '/')
3421#ifdef DOSISH
3422 && !strchr(scriptname, '\\')
3423#endif
cd39f2b6 3424 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3425 {
491527d0 3426 bool seen_dot = 0;
92f0c265 3427
39a02377
DM		 3428 bufend = s + strlen(s);
3429 while (s < bufend) {
45a23732 3430 Stat_t statbuf;
7c458fae 3431# ifdef DOSISH
491527d0 3432 for (len = 0; *s
491527d0 3433 && *s != ';'; len++, s++) {
84486fc6
GS		 3434 if (len < sizeof tmpbuf)
3435 tmpbuf[len] = *s;
491527d0 3436 }
84486fc6
GS		 3437 if (len < sizeof tmpbuf)
3438 tmpbuf[len] = '\0';
7c458fae 3439# else
39a02377 3440 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS		 3441 ':',
3442 &len);
7c458fae 3443# endif
39a02377 3444 if (s < bufend)
491527d0 3445 s++;
84486fc6 3446 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS		 3447 continue; /* don't search dir with too-long name */
3448 if (len
7c458fae 3449# ifdef DOSISH
84486fc6
GS		 3450 && tmpbuf[len - 1] != '/'
3451 && tmpbuf[len - 1] != '\\'
490a0e98 3452# endif
491527d0 3453 )
84486fc6
GS		 3454 tmpbuf[len++] = '/';
3455 if (len == 2 && tmpbuf[0] == '.')
491527d0 3456 seen_dot = 1;
28f0d0ec 3457 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS		 3458#endif /* !VMS */
3459
3460#ifdef SEARCH_EXTS
84486fc6 3461 len = strlen(tmpbuf);
491527d0
GS		 3462 if (extidx > 0) /* reset after previous loop */
3463 extidx = 0;
3464 do {
3465#endif
84486fc6 3466 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
45a23732
DD		 3467 retval = PerlLIO_stat(tmpbuf,&statbuf);
3468 if (S_ISDIR(statbuf.st_mode)) {
017f25f1
IZ		 3469 retval = -1;
3470 }
491527d0
GS		 3471#ifdef SEARCH_EXTS
3472 } while ( retval < 0 /* not there */
3473 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3474 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS		 3475 );
3476#endif
3477 if (retval < 0)
3478 continue;
45a23732
DD		 3479 if (S_ISREG(statbuf.st_mode)
3480 && cando(S_IRUSR,TRUE,&statbuf)
e37778c2 3481#if !defined(DOSISH)
45a23732 3482 && cando(S_IXUSR,TRUE,&statbuf)
491527d0
GS		 3483#endif
3484 )
3485 {
3aed30dc 3486 xfound = tmpbuf; /* bingo! */
491527d0
GS		 3487 break;
3488 }
3489 if (!xfailed)
84486fc6 3490 xfailed = savepv(tmpbuf);
491527d0
GS		 3491 }
3492#ifndef DOSISH
45a23732
DD		 3493 {
3494 Stat_t statbuf;
3495 if (!xfound && !seen_dot && !xfailed &&
3496 (PerlLIO_stat(scriptname,&statbuf) < 0
3497 || S_ISDIR(statbuf.st_mode)))
3498#endif
3499 seen_dot = 1; /* Disable message. */
3500#ifndef DOSISH
3501 }
491527d0 3502#endif
9ccb31f9
GS		 3503 if (!xfound) {
3504 if (flags & 1) { /* do or die? */
6ad282c7 3505 /* diag_listed_as: Can't execute %s */
3aed30dc 3506 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 3507 (xfailed ? "execute" : "find"),
3508 (xfailed ? xfailed : scriptname),
3509 (xfailed ? "" : " on PATH"),
3510 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3511 }
bd61b366 3512 scriptname = NULL;
9ccb31f9 3513 }
43c5f42d 3514 Safefree(xfailed);
491527d0
GS		 3515 scriptname = xfound;
3516 }
bd61b366 3517 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS		 3518}
3519
ba869deb
GS		 3520#ifndef PERL_GET_CONTEXT_DEFINED
3521
3522void *
3523Perl_get_context(void)
3524{
3db8f154 3525#if defined(USE_ITHREADS)
20b7effb 3526 dVAR;
ba869deb
GS		 3527# ifdef OLD_PTHREADS_API
3528 pthread_addr_t t;
5637ef5b
NC		 3529 int error = pthread_getspecific(PL_thr_key, &t)
3530 if (error)
3531 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
ba869deb
GS		 3532 return (void*)t;
3533# else
bce813aa 3534# ifdef I_MACH_CTHREADS
8b8b35ab 3535 return (void*)cthread_data(cthread_self());
bce813aa 3536# else
8b8b35ab
JH		 3537 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3538# endif
c44d3fdb 3539# endif
ba869deb
GS		 3540#else
3541 return (void*)NULL;
3542#endif
3543}
3544
3545void
3546Perl_set_context(void *t)
3547{
20b7effb 3548#if defined(USE_ITHREADS)
8772537c 3549 dVAR;
20b7effb 3550#endif
7918f24d 3551 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3552#if defined(USE_ITHREADS)
c44d3fdb
GS		 3553# ifdef I_MACH_CTHREADS
3554 cthread_set_data(cthread_self(), t);
3555# else
5637ef5b
NC		 3556 {
3557 const int error = pthread_setspecific(PL_thr_key, t);
3558 if (error)
3559 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3560 }
c44d3fdb 3561# endif
b464bac0 3562#else
8772537c 3563 PERL_UNUSED_ARG(t);
ba869deb
GS		 3564#endif
3565}
3566
3567#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3568
27da23d5 3569#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3570struct perl_vars *
864dbfa3 3571Perl_GetVars(pTHX)
22239a37 3572{
23491f1d
JH		 3573 PERL_UNUSED_CONTEXT;
3574 return &PL_Vars;
22239a37 3575}
31fb1209
NIS		 3576#endif
3577
1cb0ed9b 3578char **
864dbfa3 3579Perl_get_op_names(pTHX)
31fb1209 3580{
96a5add6
AL		 3581 PERL_UNUSED_CONTEXT;
3582 return (char **)PL_op_name;
31fb1209
NIS		 3583}
3584