This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Moving variables to their innermost scope.
[perl5.git] / util.c
CommitLineData
a0d0e21e 1/* util.c
a687059c 2 *
1129b882
NC
3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
a687059c 5 *
d48672a2
LW
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8d063cd8 8 *
8d063cd8 9 */
a0d0e21e
LW
10
11/*
4ac71550
TC
12 * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content.' --Gandalf to Pippin
14 *
cdad3b53 15 * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
a0d0e21e 16 */
8d063cd8 17
166f8a29
DM
18/* This file contains assorted utility routines.
19 * Which is a polite way of saying any stuff that people couldn't think of
20 * a better place for. Amongst other things, it includes the warning and
21 * dieing stuff, plus wrappers for malloc code.
22 */
23
8d063cd8 24#include "EXTERN.h"
864dbfa3 25#define PERL_IN_UTIL_C
8d063cd8 26#include "perl.h"
7dc86639 27#include "reentr.h"
62b28dd9 28
97cb92d6 29#if defined(USE_PERLIO)
2e0cfa16 30#include "perliol.h" /* For PerlIOUnix_refcnt */
6f408c34 31#endif
2e0cfa16 32
64ca3a65 33#ifndef PERL_MICRO
a687059c 34#include <signal.h>
36477c24
PP
35#ifndef SIG_ERR
36# define SIG_ERR ((Sighandler_t) -1)
37#endif
64ca3a65 38#endif
36477c24 39
3be8f094
TC
40#include <math.h>
41#include <stdlib.h>
42
172d2248
OS
43#ifdef __Lynx__
44/* Missing protos on LynxOS */
45int putenv(char *);
46#endif
47
40262ff4
AB
48#ifdef __amigaos__
49# include "amigaos4/amigaio.h"
50#endif
51
868439a2
JH
52#ifdef HAS_SELECT
53# ifdef I_SYS_SELECT
54# include <sys/select.h>
55# endif
56#endif
57
470dd224 58#ifdef USE_C_BACKTRACE
0762e42f
JH
59# ifdef I_BFD
60# define USE_BFD
61# ifdef PERL_DARWIN
62# undef USE_BFD /* BFD is useless in OS X. */
63# endif
64# ifdef USE_BFD
65# include <bfd.h>
66# endif
67# endif
470dd224
JH
68# ifdef I_DLFCN
69# include <dlfcn.h>
70# endif
71# ifdef I_EXECINFO
72# include <execinfo.h>
73# endif
74#endif
75
b001a0d1
FC
76#ifdef PERL_DEBUG_READONLY_COW
77# include <sys/mman.h>
78#endif
79
8d063cd8 80#define FLUSH
8d063cd8 81
a687059c
LW
82/* NOTE: Do not call the next three routines directly. Use the macros
83 * in handy.h, so that we can easily redefine everything to do tracking of
84 * allocated hunks back to the original New to track down any memory leaks.
20cec16a 85 * XXX This advice seems to be widely ignored :-( --AD August 1996.
a687059c
LW
86 */
87
79a92154 88#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
1f4d2d4e
NC
89# define ALWAYS_NEED_THX
90#endif
91
b001a0d1
FC
92#if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
93static void
94S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
95{
96 if (header->readonly
97 && mprotect(header, header->size, PROT_READ|PROT_WRITE))
98 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
99 header, header->size, errno);
100}
101
102static void
103S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
104{
105 if (header->readonly
106 && mprotect(header, header->size, PROT_READ))
107 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
108 header, header->size, errno);
109}
110# define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
111# define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
112#else
113# define maybe_protect_rw(foo) NOOP
114# define maybe_protect_ro(foo) NOOP
115#endif
116
3f07c2bc
FC
117#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
118 /* Use memory_debug_header */
119# define USE_MDH
120# if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
121 || defined(PERL_DEBUG_READONLY_COW)
122# define MDH_HAS_SIZE
123# endif
124#endif
125
26fa51c3
AMS
126/* paranoid version of system's malloc() */
127
bd4080b3 128Malloc_t
4f63d024 129Perl_safesysmalloc(MEM_SIZE size)
8d063cd8 130{
1f4d2d4e 131#ifdef ALWAYS_NEED_THX
54aff467 132 dTHX;
0cb20dae 133#endif
bd4080b3 134 Malloc_t ptr;
9efda33a
TC
135
136#ifdef USE_MDH
137 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
138 goto out_of_memory;
a78adc84 139 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
9efda33a 140#endif
34de22dd 141#ifdef DEBUGGING
03c5309f 142 if ((SSize_t)size < 0)
147e3846 143 Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
34de22dd 144#endif
b001a0d1
FC
145 if (!size) size = 1; /* malloc(0) is NASTY on our system */
146#ifdef PERL_DEBUG_READONLY_COW
147 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
148 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
149 perror("mmap failed");
150 abort();
151 }
152#else
153 ptr = (Malloc_t)PerlMem_malloc(size?size:1);
154#endif
da927450 155 PERL_ALLOC_CHECK(ptr);
bd61b366 156 if (ptr != NULL) {
3f07c2bc 157#ifdef USE_MDH
7cb608b5
NC
158 struct perl_memory_debug_header *const header
159 = (struct perl_memory_debug_header *)ptr;
9a083ecf
NC
160#endif
161
162#ifdef PERL_POISON
7e337ee0 163 PoisonNew(((char *)ptr), size, char);
9a083ecf 164#endif
7cb608b5 165
9a083ecf 166#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC
167 header->interpreter = aTHX;
168 /* Link us into the list. */
169 header->prev = &PL_memory_debug_header;
170 header->next = PL_memory_debug_header.next;
171 PL_memory_debug_header.next = header;
b001a0d1 172 maybe_protect_rw(header->next);
7cb608b5 173 header->next->prev = header;
b001a0d1
FC
174 maybe_protect_ro(header->next);
175# ifdef PERL_DEBUG_READONLY_COW
176 header->readonly = 0;
cd1541b2 177# endif
e8dda941 178#endif
3f07c2bc 179#ifdef MDH_HAS_SIZE
b001a0d1
FC
180 header->size = size;
181#endif
b033d668 182 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
147e3846 183 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
b033d668
DD
184
185 }
8d063cd8 186 else {
296f0d56 187#ifdef USE_MDH
9efda33a 188 out_of_memory:
296f0d56
TC
189#endif
190 {
191#ifndef ALWAYS_NEED_THX
192 dTHX;
193#endif
194 if (PL_nomemok)
195 ptr = NULL;
196 else
197 croak_no_mem();
198 }
8d063cd8 199 }
b033d668 200 return ptr;
8d063cd8
LW
201}
202
f2517201 203/* paranoid version of system's realloc() */
8d063cd8 204
bd4080b3 205Malloc_t
4f63d024 206Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
8d063cd8 207{
1f4d2d4e 208#ifdef ALWAYS_NEED_THX
54aff467 209 dTHX;
0cb20dae 210#endif
bd4080b3 211 Malloc_t ptr;
b001a0d1
FC
212#ifdef PERL_DEBUG_READONLY_COW
213 const MEM_SIZE oldsize = where
a78adc84 214 ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
b001a0d1
FC
215 : 0;
216#endif
9a34ef1d 217#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
6ad3d225 218 Malloc_t PerlMem_realloc();
ecfc5424 219#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
8d063cd8 220
7614df0c 221 if (!size) {
f2517201 222 safesysfree(where);
b033d668 223 ptr = NULL;
7614df0c 224 }
b033d668
DD
225 else if (!where) {
226 ptr = safesysmalloc(size);
227 }
228 else {
3f07c2bc 229#ifdef USE_MDH
b033d668 230 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
9efda33a
TC
231 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
232 goto out_of_memory;
b033d668
DD
233 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
234 {
235 struct perl_memory_debug_header *const header
236 = (struct perl_memory_debug_header *)where;
7cb608b5 237
b001a0d1 238# ifdef PERL_TRACK_MEMPOOL
b033d668
DD
239 if (header->interpreter != aTHX) {
240 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
241 header->interpreter, aTHX);
242 }
243 assert(header->next->prev == header);
244 assert(header->prev->next == header);
cd1541b2 245# ifdef PERL_POISON
b033d668
DD
246 if (header->size > size) {
247 const MEM_SIZE freed_up = header->size - size;
248 char *start_of_freed = ((char *)where) + size;
249 PoisonFree(start_of_freed, freed_up, char);
250 }
cd1541b2 251# endif
b001a0d1 252# endif
3f07c2bc 253# ifdef MDH_HAS_SIZE
b033d668 254 header->size = size;
b001a0d1 255# endif
b033d668 256 }
e8dda941 257#endif
34de22dd 258#ifdef DEBUGGING
b033d668 259 if ((SSize_t)size < 0)
147e3846 260 Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);
34de22dd 261#endif
b001a0d1 262#ifdef PERL_DEBUG_READONLY_COW
b033d668
DD
263 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
264 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
265 perror("mmap failed");
266 abort();
267 }
268 Copy(where,ptr,oldsize < size ? oldsize : size,char);
269 if (munmap(where, oldsize)) {
270 perror("munmap failed");
271 abort();
272 }
b001a0d1 273#else
b033d668 274 ptr = (Malloc_t)PerlMem_realloc(where,size);
b001a0d1 275#endif
b033d668 276 PERL_ALLOC_CHECK(ptr);
a1d180c4 277
4fd0a9b8
NC
278 /* MUST do this fixup first, before doing ANYTHING else, as anything else
279 might allocate memory/free/move memory, and until we do the fixup, it
280 may well be chasing (and writing to) free memory. */
b033d668 281 if (ptr != NULL) {
b001a0d1 282#ifdef PERL_TRACK_MEMPOOL
b033d668
DD
283 struct perl_memory_debug_header *const header
284 = (struct perl_memory_debug_header *)ptr;
7cb608b5 285
9a083ecf 286# ifdef PERL_POISON
b033d668
DD
287 if (header->size < size) {
288 const MEM_SIZE fresh = size - header->size;
289 char *start_of_fresh = ((char *)ptr) + size;
290 PoisonNew(start_of_fresh, fresh, char);
291 }
9a083ecf
NC
292# endif
293
b033d668
DD
294 maybe_protect_rw(header->next);
295 header->next->prev = header;
296 maybe_protect_ro(header->next);
297 maybe_protect_rw(header->prev);
298 header->prev->next = header;
299 maybe_protect_ro(header->prev);
b001a0d1 300#endif
b033d668
DD
301 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
302 }
4fd0a9b8
NC
303
304 /* In particular, must do that fixup above before logging anything via
305 *printf(), as it can reallocate memory, which can cause SEGVs. */
306
147e3846
KW
307 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
308 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
4fd0a9b8 309
b033d668 310 if (ptr == NULL) {
296f0d56 311#ifdef USE_MDH
9efda33a 312 out_of_memory:
296f0d56
TC
313#endif
314 {
315#ifndef ALWAYS_NEED_THX
316 dTHX;
317#endif
318 if (PL_nomemok)
319 ptr = NULL;
320 else
321 croak_no_mem();
322 }
0cb20dae 323 }
8d063cd8 324 }
b033d668 325 return ptr;
8d063cd8
LW
326}
327
f2517201 328/* safe version of system's free() */
8d063cd8 329
54310121 330Free_t
4f63d024 331Perl_safesysfree(Malloc_t where)
8d063cd8 332{
79a92154 333#ifdef ALWAYS_NEED_THX
54aff467 334 dTHX;
155aba94 335#endif
147e3846 336 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
378cc40b 337 if (where) {
3f07c2bc 338#ifdef USE_MDH
6edcbed6 339 Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
cd1541b2 340 {
7cb608b5 341 struct perl_memory_debug_header *const header
6edcbed6 342 = (struct perl_memory_debug_header *)where_intrn;
7cb608b5 343
3f07c2bc 344# ifdef MDH_HAS_SIZE
b001a0d1
FC
345 const MEM_SIZE size = header->size;
346# endif
347# ifdef PERL_TRACK_MEMPOOL
7cb608b5 348 if (header->interpreter != aTHX) {
5637ef5b
NC
349 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
350 header->interpreter, aTHX);
7cb608b5
NC
351 }
352 if (!header->prev) {
cd1541b2
NC
353 Perl_croak_nocontext("panic: duplicate free");
354 }
5637ef5b
NC
355 if (!(header->next))
356 Perl_croak_nocontext("panic: bad free, header->next==NULL");
357 if (header->next->prev != header || header->prev->next != header) {
358 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
359 "header=%p, ->prev->next=%p",
360 header->next->prev, header,
361 header->prev->next);
cd1541b2 362 }
7cb608b5 363 /* Unlink us from the chain. */
b001a0d1 364 maybe_protect_rw(header->next);
7cb608b5 365 header->next->prev = header->prev;
b001a0d1
FC
366 maybe_protect_ro(header->next);
367 maybe_protect_rw(header->prev);
7cb608b5 368 header->prev->next = header->next;
b001a0d1
FC
369 maybe_protect_ro(header->prev);
370 maybe_protect_rw(header);
7cb608b5 371# ifdef PERL_POISON
6edcbed6 372 PoisonNew(where_intrn, size, char);
cd1541b2 373# endif
7cb608b5
NC
374 /* Trigger the duplicate free warning. */
375 header->next = NULL;
b001a0d1
FC
376# endif
377# ifdef PERL_DEBUG_READONLY_COW
6edcbed6 378 if (munmap(where_intrn, size)) {
b001a0d1
FC
379 perror("munmap failed");
380 abort();
381 }
382# endif
7cb608b5 383 }
6edcbed6
DD
384#else
385 Malloc_t where_intrn = where;
386#endif /* USE_MDH */
b001a0d1 387#ifndef PERL_DEBUG_READONLY_COW
6edcbed6 388 PerlMem_free(where_intrn);
b001a0d1 389#endif
378cc40b 390 }
8d063cd8
LW
391}
392
f2517201 393/* safe version of system's calloc() */
1050c9ca 394
bd4080b3 395Malloc_t
4f63d024 396Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
1050c9ca 397{
1f4d2d4e 398#ifdef ALWAYS_NEED_THX
54aff467 399 dTHX;
0cb20dae 400#endif
bd4080b3 401 Malloc_t ptr;
3f07c2bc 402#if defined(USE_MDH) || defined(DEBUGGING)
ad7244db 403 MEM_SIZE total_size = 0;
4b1123b9 404#endif
1050c9ca 405
ad7244db 406 /* Even though calloc() for zero bytes is strange, be robust. */
4b1123b9 407 if (size && (count <= MEM_SIZE_MAX / size)) {
3f07c2bc 408#if defined(USE_MDH) || defined(DEBUGGING)
ad7244db 409 total_size = size * count;
4b1123b9
NC
410#endif
411 }
ad7244db 412 else
d1decf2b 413 croak_memory_wrap();
3f07c2bc 414#ifdef USE_MDH
a78adc84
DM
415 if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
416 total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
ad7244db 417 else
d1decf2b 418 croak_memory_wrap();
ad7244db 419#endif
1050c9ca 420#ifdef DEBUGGING
03c5309f 421 if ((SSize_t)size < 0 || (SSize_t)count < 0)
147e3846 422 Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
5637ef5b 423 (UV)size, (UV)count);
1050c9ca 424#endif
b001a0d1
FC
425#ifdef PERL_DEBUG_READONLY_COW
426 if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
427 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
428 perror("mmap failed");
429 abort();
430 }
431#elif defined(PERL_TRACK_MEMPOOL)
e1a95402
NC
432 /* Have to use malloc() because we've added some space for our tracking
433 header. */
ad7244db
JH
434 /* malloc(0) is non-portable. */
435 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
e1a95402
NC
436#else
437 /* Use calloc() because it might save a memset() if the memory is fresh
438 and clean from the OS. */
ad7244db
JH
439 if (count && size)
440 ptr = (Malloc_t)PerlMem_calloc(count, size);
441 else /* calloc(0) is non-portable. */
442 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
e8dda941 443#endif
da927450 444 PERL_ALLOC_CHECK(ptr);
147e3846 445 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
bd61b366 446 if (ptr != NULL) {
3f07c2bc 447#ifdef USE_MDH
7cb608b5
NC
448 {
449 struct perl_memory_debug_header *const header
450 = (struct perl_memory_debug_header *)ptr;
451
b001a0d1 452# ifndef PERL_DEBUG_READONLY_COW
e1a95402 453 memset((void*)ptr, 0, total_size);
b001a0d1
FC
454# endif
455# ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC
456 header->interpreter = aTHX;
457 /* Link us into the list. */
458 header->prev = &PL_memory_debug_header;
459 header->next = PL_memory_debug_header.next;
460 PL_memory_debug_header.next = header;
b001a0d1 461 maybe_protect_rw(header->next);
7cb608b5 462 header->next->prev = header;
b001a0d1
FC
463 maybe_protect_ro(header->next);
464# ifdef PERL_DEBUG_READONLY_COW
465 header->readonly = 0;
466# endif
467# endif
3f07c2bc 468# ifdef MDH_HAS_SIZE
e1a95402 469 header->size = total_size;
cd1541b2 470# endif
a78adc84 471 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
7cb608b5 472 }
e8dda941 473#endif
1050c9ca
PP
474 return ptr;
475 }
0cb20dae 476 else {
1f4d2d4e 477#ifndef ALWAYS_NEED_THX
0cb20dae
NC
478 dTHX;
479#endif
480 if (PL_nomemok)
481 return NULL;
4cbe3a7d 482 croak_no_mem();
0cb20dae 483 }
1050c9ca
PP
484}
485
cae6d0e5
GS
486/* These must be defined when not using Perl's malloc for binary
487 * compatibility */
488
489#ifndef MYMALLOC
490
491Malloc_t Perl_malloc (MEM_SIZE nbytes)
492{
20b7effb
JH
493#ifdef PERL_IMPLICIT_SYS
494 dTHX;
495#endif
077a72a9 496 return (Malloc_t)PerlMem_malloc(nbytes);
cae6d0e5
GS
497}
498
499Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
500{
20b7effb
JH
501#ifdef PERL_IMPLICIT_SYS
502 dTHX;
503#endif
077a72a9 504 return (Malloc_t)PerlMem_calloc(elements, size);
cae6d0e5
GS
505}
506
507Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
508{
20b7effb
JH
509#ifdef PERL_IMPLICIT_SYS
510 dTHX;
511#endif
077a72a9 512 return (Malloc_t)PerlMem_realloc(where, nbytes);
cae6d0e5
GS
513}
514
515Free_t Perl_mfree (Malloc_t where)
516{
20b7effb
JH
517#ifdef PERL_IMPLICIT_SYS
518 dTHX;
519#endif
cae6d0e5
GS
520 PerlMem_free(where);
521}
522
523#endif
524
19e16554
DM
525/* copy a string up to some (non-backslashed) delimiter, if any.
526 * With allow_escape, converts \<delimiter> to <delimiter>, while leaves
527 * \<non-delimiter> as-is.
528 * Returns the position in the src string of the closing delimiter, if
529 * any, or returns fromend otherwise.
530 * This is the internal implementation for Perl_delimcpy and
531 * Perl_delimcpy_no_escape.
532 */
8d063cd8 533
ba0a4150 534static char *
31ee10f1 535S_delimcpy_intern(char *to, const char *toend, const char *from,
ba0a4150
FC
536 const char *fromend, int delim, I32 *retlen,
537 const bool allow_escape)
8d063cd8 538{
eb578fdb 539 I32 tolen;
35da51f7 540
7918f24d
NC
541 PERL_ARGS_ASSERT_DELIMCPY;
542
fc36a67e 543 for (tolen = 0; from < fromend; from++, tolen++) {
19e16554 544 if (allow_escape && *from == '\\' && from + 1 < fromend) {
35da51f7 545 if (from[1] != delim) {
fc36a67e
PP
546 if (to < toend)
547 *to++ = *from;
548 tolen++;
fc36a67e 549 }
35da51f7 550 from++;
378cc40b 551 }
bedebaa5 552 else if (*from == delim)
8d063cd8 553 break;
fc36a67e
PP
554 if (to < toend)
555 *to++ = *from;
8d063cd8 556 }
bedebaa5
CS
557 if (to < toend)
558 *to = '\0';
fc36a67e 559 *retlen = tolen;
73d840c0 560 return (char *)from;
8d063cd8
LW
561}
562
ba0a4150
FC
563char *
564Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
565{
566 PERL_ARGS_ASSERT_DELIMCPY;
567
31ee10f1 568 return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1);
ba0a4150
FC
569}
570
571char *
572Perl_delimcpy_no_escape(char *to, const char *toend, const char *from,
573 const char *fromend, int delim, I32 *retlen)
574{
575 PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
576
31ee10f1 577 return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 0);
ba0a4150
FC
578}
579
fcfc5a27
KW
580/*
581=head1 Miscellaneous Functions
582
583=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end
584
585Find the first (leftmost) occurrence of a sequence of bytes within another
586sequence. This is the Perl version of C<strstr()>, extended to handle
587arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL>
588is what the initial C<n> in the function name stands for; some systems have an
589equivalent, C<memmem()>, but with a somewhat different API).
590
591Another way of thinking about this function is finding a needle in a haystack.
592C<big> points to the first byte in the haystack. C<big_end> points to one byte
593beyond the final byte in the haystack. C<little> points to the first byte in
594the needle. C<little_end> points to one byte beyond the final byte in the
595needle. All the parameters must be non-C<NULL>.
596
597The function returns C<NULL> if there is no occurrence of C<little> within
598C<big>. If C<little> is the empty string, C<big> is returned.
599
600Because this function operates at the byte level, and because of the inherent
601characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the
602needle and the haystack are strings with the same UTF-8ness, but not if the
603UTF-8ness differs.
604
605=cut
606
607*/
a687059c
LW
608
609char *
04c9e624 610Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
8d063cd8 611{
7918f24d 612 PERL_ARGS_ASSERT_NINSTR;
b8070b07
KW
613
614#ifdef HAS_MEMMEM
615 return ninstr(big, bigend, little, lend);
616#else
617
4c8626be
GA
618 if (little >= lend)
619 return (char*)big;
620 {
8ba22ff4 621 const char first = *little;
8ba22ff4 622 bigend -= lend - little++;
4c8626be
GA
623 OUTER:
624 while (big <= bigend) {
b0ca24ee 625 if (*big++ == first) {
19742f39 626 const char *s, *x;
b0ca24ee
JH
627 for (x=big,s=little; s < lend; x++,s++) {
628 if (*s != *x)
629 goto OUTER;
630 }
631 return (char*)(big-1);
4c8626be 632 }
4c8626be 633 }
378cc40b 634 }
bd61b366 635 return NULL;
b8070b07
KW
636
637#endif
638
a687059c
LW
639}
640
fcfc5a27
KW
641/*
642=head1 Miscellaneous Functions
643
644=for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end
645
646Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
647sequence of bytes within another sequence, returning C<NULL> if there is no
648such occurrence.
649
650=cut
651
652*/
a687059c
LW
653
654char *
5aaab254 655Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
a687059c 656{
eb578fdb
KW
657 const char *bigbeg;
658 const I32 first = *little;
659 const char * const littleend = lend;
a687059c 660
7918f24d
NC
661 PERL_ARGS_ASSERT_RNINSTR;
662
260d78c9 663 if (little >= littleend)
08105a92 664 return (char*)bigend;
a687059c
LW
665 bigbeg = big;
666 big = bigend - (littleend - little++);
667 while (big >= bigbeg) {
eb578fdb 668 const char *s, *x;
a687059c
LW
669 if (*big-- != first)
670 continue;
671 for (x=big+2,s=little; s < littleend; /**/ ) {
4fc877ac 672 if (*s != *x)
a687059c 673 break;
4fc877ac
AL
674 else {
675 x++;
676 s++;
a687059c
LW
677 }
678 }
679 if (s >= littleend)
08105a92 680 return (char*)(big+1);
378cc40b 681 }
bd61b366 682 return NULL;
378cc40b 683}
a687059c 684
cf93c79d
IZ
685/* As a space optimization, we do not compile tables for strings of length
686 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
687 special-cased in fbm_instr().
688
689 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
690
954c1994 691/*
ccfc67b7
JH
692=head1 Miscellaneous Functions
693
954c1994
GS
694=for apidoc fbm_compile
695
796b6530 696Analyses the string in order to make fast searches on it using C<fbm_instr()>
954c1994
GS
697-- the Boyer-Moore algorithm.
698
699=cut
700*/
701
378cc40b 702void
7506f9c3 703Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
378cc40b 704{
eb578fdb 705 const U8 *s;
ea725ce6 706 STRLEN i;
0b71040e 707 STRLEN len;
79072805 708 U32 frequency = 256;
2bda37ba 709 MAGIC *mg;
00cccd05 710 PERL_DEB( STRLEN rarest = 0 );
79072805 711
7918f24d
NC
712 PERL_ARGS_ASSERT_FBM_COMPILE;
713
948d2370 714 if (isGV_with_GP(sv) || SvROK(sv))
4265b45d
NC
715 return;
716
9402563a
NC
717 if (SvVALID(sv))
718 return;
719
c517dc2b 720 if (flags & FBMcf_TAIL) {
890ce7af 721 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
396482e1 722 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
c517dc2b
JH
723 if (mg && mg->mg_len >= 0)
724 mg->mg_len++;
725 }
11609d9c 726 if (!SvPOK(sv) || SvNIOKp(sv))
66379c06
FC
727 s = (U8*)SvPV_force_mutable(sv, len);
728 else s = (U8 *)SvPV_mutable(sv, len);
d1be9408 729 if (len == 0) /* TAIL might be on a zero-length string. */
cf93c79d 730 return;
c13a5c80 731 SvUPGRADE(sv, SVt_PVMG);
78d0cf80 732 SvIOK_off(sv);
8eeaf79a 733 SvNOK_off(sv);
2bda37ba 734
a5c7cb08 735 /* add PERL_MAGIC_bm magic holding the FBM lookup table */
2bda37ba
NC
736
737 assert(!mg_find(sv, PERL_MAGIC_bm));
738 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
739 assert(mg);
740
02128f11 741 if (len > 2) {
21aeb718
NC
742 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
743 the BM table. */
66a1b24b 744 const U8 mlen = (len>255) ? 255 : (U8)len;
2bda37ba 745 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
eb578fdb 746 U8 *table;
cf93c79d 747
2bda37ba 748 Newx(table, 256, U8);
7506f9c3 749 memset((void*)table, mlen, 256);
2bda37ba
NC
750 mg->mg_ptr = (char *)table;
751 mg->mg_len = 256;
752
753 s += len - 1; /* last char */
02128f11 754 i = 0;
cf93c79d
IZ
755 while (s >= sb) {
756 if (table[*s] == mlen)
7506f9c3 757 table[*s] = (U8)i;
cf93c79d
IZ
758 s--, i++;
759 }
378cc40b 760 }
378cc40b 761
9cbe880b 762 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
bbce6d69 763 for (i = 0; i < len; i++) {
22c35a8c 764 if (PL_freq[s[i]] < frequency) {
00cccd05 765 PERL_DEB( rarest = i );
22c35a8c 766 frequency = PL_freq[s[i]];
378cc40b
LW
767 }
768 }
cf93c79d 769 BmUSEFUL(sv) = 100; /* Initial value */
b4204fb6 770 ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL);
147e3846 771 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %" UVuf "\n",
d80cf470 772 s[rarest], (UV)rarest));
378cc40b
LW
773}
774
cf93c79d 775
954c1994
GS
776/*
777=for apidoc fbm_instr
778
3f4963df 779Returns the location of the SV in the string delimited by C<big> and
41c8d07a
DM
780C<bigend> (C<bigend>) is the char following the last char).
781It returns C<NULL> if the string can't be found. The C<sv>
796b6530 782does not have to be C<fbm_compiled>, but the search will not be as fast
954c1994
GS
783then.
784
785=cut
41c8d07a
DM
786
787If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string
788during FBM compilation due to FBMcf_TAIL in flags. It indicates that
789the littlestr must be anchored to the end of bigstr (or to any \n if
790FBMrf_MULTILINE).
791
792E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
793while /abc$/ compiles to "abc\n" with SvTAIL() true.
794
795A littlestr of "abc", !SvTAIL matches as /abc/;
796a littlestr of "ab\n", SvTAIL matches as:
797 without FBMrf_MULTILINE: /ab\n?\z/
798 with FBMrf_MULTILINE: /ab\n/ || /ab\z/;
799
800(According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
801 "If SvTAIL is actually due to \Z or \z, this gives false positives
802 if multiline".
954c1994
GS
803*/
804
41c8d07a 805
378cc40b 806char *
5aaab254 807Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
378cc40b 808{
eb578fdb 809 unsigned char *s;
cf93c79d 810 STRLEN l;
eb578fdb
KW
811 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
812 STRLEN littlelen = l;
813 const I32 multiline = flags & FBMrf_MULTILINE;
4e8879f3
DM
814 bool valid = SvVALID(littlestr);
815 bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE;
cf93c79d 816
7918f24d
NC
817 PERL_ARGS_ASSERT_FBM_INSTR;
818
eb160463 819 if ((STRLEN)(bigend - big) < littlelen) {
e08d24ff 820 if ( tail
eb160463 821 && ((STRLEN)(bigend - big) == littlelen - 1)
a1d180c4 822 && (littlelen == 1
12ae5dfc 823 || (*big == *little &&
27da23d5 824 memEQ((char *)big, (char *)little, littlelen - 1))))
cf93c79d 825 return (char*)big;
bd61b366 826 return NULL;
cf93c79d 827 }
378cc40b 828
21aeb718
NC
829 switch (littlelen) { /* Special cases for 0, 1 and 2 */
830 case 0:
831 return (char*)big; /* Cannot be SvTAIL! */
41c8d07a 832
21aeb718 833 case 1:
e08d24ff 834 if (tail && !multiline) /* Anchor only! */
147f21b5
DM
835 /* [-1] is safe because we know that bigend != big. */
836 return (char *) (bigend - (bigend[-1] == '\n'));
837
838 s = (unsigned char *)memchr((void*)big, *little, bigend-big);
839 if (s)
840 return (char *)s;
e08d24ff 841 if (tail)
cf93c79d 842 return (char *) bigend;
bd61b366 843 return NULL;
41c8d07a 844
21aeb718 845 case 2:
e08d24ff 846 if (tail && !multiline) {
147f21b5
DM
847 /* a littlestr with SvTAIL must be of the form "X\n" (where X
848 * is a single char). It is anchored, and can only match
849 * "....X\n" or "....X" */
850 if (bigend[-2] == *little && bigend[-1] == '\n')
cf93c79d
IZ
851 return (char*)bigend - 2;
852 if (bigend[-1] == *little)
853 return (char*)bigend - 1;
bd61b366 854 return NULL;
cf93c79d 855 }
147f21b5 856
cf93c79d 857 {
147f21b5
DM
858 /* memchr() is likely to be very fast, possibly using whatever
859 * hardware support is available, such as checking a whole
860 * cache line in one instruction.
861 * So for a 2 char pattern, calling memchr() is likely to be
862 * faster than running FBM, or rolling our own. The previous
863 * version of this code was roll-your-own which typically
864 * only needed to read every 2nd char, which was good back in
865 * the day, but no longer.
866 */
867 unsigned char c1 = little[0];
868 unsigned char c2 = little[1];
869
870 /* *** for all this case, bigend points to the last char,
871 * not the trailing \0: this makes the conditions slightly
872 * simpler */
873 bigend--;
874 s = big;
875 if (c1 != c2) {
876 while (s < bigend) {
877 /* do a quick test for c1 before calling memchr();
878 * this avoids the expensive fn call overhead when
879 * there are lots of c1's */
880 if (LIKELY(*s != c1)) {
881 s++;
882 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
883 if (!s)
884 break;
885 }
886 if (s[1] == c2)
887 return (char*)s;
888
889 /* failed; try searching for c2 this time; that way
890 * we don't go pathologically slow when the string
891 * consists mostly of c1's or vice versa.
892 */
893 s += 2;
894 if (s > bigend)
895 break;
896 s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
897 if (!s)
898 break;
899 if (s[-1] == c1)
900 return (char*)s - 1;
901 }
902 }
903 else {
904 /* c1, c2 the same */
905 while (s < bigend) {
906 if (s[0] == c1) {
907 got_1char:
908 if (s[1] == c1)
909 return (char*)s;
910 s += 2;
911 }
912 else {
913 s++;
914 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
915 if (!s || s >= bigend)
916 break;
917 goto got_1char;
918 }
919 }
920 }
921
922 /* failed to find 2 chars; try anchored match at end without
923 * the \n */
e08d24ff 924 if (tail && bigend[0] == little[0])
147f21b5
DM
925 return (char *)bigend;
926 return NULL;
927 }
41c8d07a 928
21aeb718
NC
929 default:
930 break; /* Only lengths 0 1 and 2 have special-case code. */
d48672a2 931 }
21aeb718 932
e08d24ff 933 if (tail && !multiline) { /* tail anchored? */
bbce6d69 934 s = bigend - littlelen;
a1d180c4 935 if (s >= big && bigend[-1] == '\n' && *s == *little
cf93c79d
IZ
936 /* Automatically of length > 2 */
937 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
7506f9c3 938 {
bbce6d69 939 return (char*)s; /* how sweet it is */
7506f9c3
GS
940 }
941 if (s[1] == *little
942 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
943 {
cf93c79d 944 return (char*)s + 1; /* how sweet it is */
7506f9c3 945 }
bd61b366 946 return NULL;
02128f11 947 }
41c8d07a 948
4e8879f3 949 if (!valid) {
147f21b5 950 /* not compiled; use Perl_ninstr() instead */
c4420975 951 char * const b = ninstr((char*)big,(char*)bigend,
cf93c79d
IZ
952 (char*)little, (char*)little + littlelen);
953
add424da 954 assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
cf93c79d 955 return b;
a687059c 956 }
a1d180c4 957
3566a07d
NC
958 /* Do actual FBM. */
959 if (littlelen > (STRLEN)(bigend - big))
960 return NULL;
961
962 {
2bda37ba 963 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
eb578fdb 964 const unsigned char *oldlittle;
cf93c79d 965
316ebaf2
JH
966 assert(mg);
967
cf93c79d
IZ
968 --littlelen; /* Last char found by table lookup */
969
970 s = big + littlelen;
971 little += littlelen; /* last char */
972 oldlittle = little;
973 if (s < bigend) {
316ebaf2 974 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
147f21b5 975 const unsigned char lastc = *little;
eb578fdb 976 I32 tmp;
cf93c79d
IZ
977
978 top2:
7506f9c3 979 if ((tmp = table[*s])) {
147f21b5
DM
980 /* *s != lastc; earliest position it could match now is
981 * tmp slots further on */
982 if ((s += tmp) >= bigend)
983 goto check_end;
984 if (LIKELY(*s != lastc)) {
985 s++;
986 s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
987 if (!s) {
988 s = bigend;
989 goto check_end;
990 }
991 goto top2;
992 }
cf93c79d 993 }
147f21b5
DM
994
995
996 /* hand-rolled strncmp(): less expensive than calling the
997 * real function (maybe???) */
998 {
eb578fdb 999 unsigned char * const olds = s;
cf93c79d
IZ
1000
1001 tmp = littlelen;
1002
1003 while (tmp--) {
1004 if (*--s == *--little)
1005 continue;
cf93c79d
IZ
1006 s = olds + 1; /* here we pay the price for failure */
1007 little = oldlittle;
1008 if (s < bigend) /* fake up continue to outer loop */
1009 goto top2;
1010 goto check_end;
1011 }
1012 return (char *)s;
a687059c 1013 }
378cc40b 1014 }
cf93c79d 1015 check_end:
c8029a41 1016 if ( s == bigend
e08d24ff 1017 && tail
12ae5dfc
JH
1018 && memEQ((char *)(bigend - littlelen),
1019 (char *)(oldlittle - littlelen), littlelen) )
cf93c79d 1020 return (char*)bigend - littlelen;
bd61b366 1021 return NULL;
378cc40b 1022 }
378cc40b
LW
1023}
1024
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
2346 while (len--)
2347 *loc++ = ch;
99fff99d 2348 return vloc;
fc36a67e
PP
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 2542 unsigned n = 0;
1f852d0d
NIS
2543
2544 while (n < sizeof(int)) {
19742f39 2545 const SSize_t n1 = PerlLIO_read(pp[0],
1f852d0d
NIS
2546 (void*)(((char*)&errkid)+n),
2547 (sizeof(int)) - n);
2548 if (n1 <= 0)
2549 break;
2550 n += n1;
2551 }
2552 PerlLIO_close(pp[0]);
2553 did_pipes = 0;
2554 if (n) { /* Error */
2555 int pid2, status;
8c51524e 2556 PerlLIO_close(p[This]);
1f852d0d 2557 if (n != sizeof(int))
5637ef5b 2558 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
1f852d0d
NIS
2559 do {
2560 pid2 = wait4pid(pid, &status, 0);
2561 } while (pid2 == -1 && errno == EINTR);
2562 errno = errkid; /* Propagate errno from kid */
4608196e 2563 return NULL;
1f852d0d
NIS
2564 }
2565 }
2566 if (did_pipes)
2567 PerlLIO_close(pp[0]);
2568 return PerlIO_fdopen(p[This], mode);
2569#else
8492b23f 2570# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
4e205ed6 2571 return my_syspopen4(aTHX_ NULL, mode, n, args);
8492b23f
TC
2572# elif defined(WIN32)
2573 return win32_popenlist(mode, n, args);
9d419b5f 2574# else
4a7d1889
NIS
2575 Perl_croak(aTHX_ "List form of piped open not implemented");
2576 return (PerlIO *) NULL;
9d419b5f 2577# endif
1f852d0d 2578#endif
4a7d1889
NIS
2579}
2580
4dd5370d
AB
2581 /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2582#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
760ac839 2583PerlIO *
3dd43144 2584Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c
LW
2585{
2586 int p[2];
eb578fdb
KW
2587 I32 This, that;
2588 Pid_t pid;
79072805 2589 SV *sv;
bfce84ec 2590 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ
2591 I32 did_pipes = 0;
2592 int pp[2];
a687059c 2593
7918f24d
NC
2594 PERL_ARGS_ASSERT_MY_POPEN;
2595
45bc9206 2596 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ
2597#ifdef OS2
2598 if (doexec) {
23da6c43 2599 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2600 }
a1d180c4 2601#endif
8ac85365
NIS
2602 This = (*mode == 'w');
2603 that = !This;
284167a5 2604 if (doexec && TAINTING_get) {
bbce6d69
PP
2605 taint_env();
2606 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2607 }
c2267164 2608 if (PerlProc_pipe(p) < 0)
4608196e 2609 return NULL;
e446cec8
IZ
2610 if (doexec && PerlProc_pipe(pp) >= 0)
2611 did_pipes = 1;
52e18b1f 2612 while ((pid = PerlProc_fork()) < 0) {
a687059c 2613 if (errno != EAGAIN) {
6ad3d225 2614 PerlLIO_close(p[This]);
b5ac89c3 2615 PerlLIO_close(p[that]);
e446cec8
IZ
2616 if (did_pipes) {
2617 PerlLIO_close(pp[0]);
2618 PerlLIO_close(pp[1]);
2619 }
a687059c 2620 if (!doexec)
b3647a36 2621 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2622 return NULL;
a687059c 2623 }
a2a5de95 2624 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW
2625 sleep(5);
2626 }
2627 if (pid == 0) {
79072805 2628
30ac6d9b
GS
2629#undef THIS
2630#undef THAT
a687059c 2631#define THIS that
8ac85365 2632#define THAT This
e446cec8
IZ
2633 if (did_pipes) {
2634 PerlLIO_close(pp[0]);
2635#if defined(HAS_FCNTL) && defined(F_SETFD)
375ed12a
JH
2636 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2637 return NULL;
e446cec8
IZ
2638#endif
2639 }
a687059c 2640 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS
2641 PerlLIO_dup2(p[THIS], *mode == 'r');
2642 PerlLIO_close(p[THIS]);
b5ac89c3
NIS
2643 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2644 PerlLIO_close(p[THAT]);
a687059c 2645 }
b5ac89c3
NIS
2646 else
2647 PerlLIO_close(p[THAT]);
4435c477 2648#ifndef OS2
a687059c 2649 if (doexec) {
a0d0e21e 2650#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
2651#ifndef NOFILE
2652#define NOFILE 20
2653#endif
a080fe3d 2654 {
3aed30dc 2655 int fd;
a080fe3d
NIS
2656
2657 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2658 if (fd != pp[1])
3aed30dc 2659 PerlLIO_close(fd);
a080fe3d 2660 }
ae986130 2661#endif
a080fe3d
NIS
2662 /* may or may not use the shell */
2663 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2664 PerlProc__exit(1);
a687059c 2665 }
4435c477 2666#endif /* defined OS2 */
713cef20
IZ
2667
2668#ifdef PERLIO_USING_CRLF
2669 /* Since we circumvent IO layers when we manipulate low-level
2670 filedescriptors directly, need to manually switch to the
2671 default, binary, low-level mode; see PerlIOBuf_open(). */
2672 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2673#endif
3280af22 2674 PL_forkprocess = 0;
ca0c25f6 2675#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2676 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2677#endif
4608196e 2678 return NULL;
a687059c
LW
2679#undef THIS
2680#undef THAT
2681 }
b5ac89c3 2682 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ
2683 if (did_pipes)
2684 PerlLIO_close(pp[1]);
8ac85365 2685 if (p[that] < p[This]) {
6ad3d225
GS
2686 PerlLIO_dup2(p[This], p[that]);
2687 PerlLIO_close(p[This]);
8ac85365 2688 p[This] = p[that];
62b28dd9 2689 }
b5ac89c3
NIS
2690 else
2691 PerlLIO_close(p[that]);
2692
3280af22 2693 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2694 SvUPGRADE(sv,SVt_IV);
45977657 2695 SvIV_set(sv, pid);
3280af22 2696 PL_forkprocess = pid;
e446cec8
IZ
2697 if (did_pipes && pid > 0) {
2698 int errkid;
bb7a0f54 2699 unsigned n = 0;
e446cec8
IZ
2700
2701 while (n < sizeof(int)) {
19742f39 2702 const SSize_t n1 = PerlLIO_read(pp[0],
e446cec8
IZ
2703 (void*)(((char*)&errkid)+n),
2704 (sizeof(int)) - n);
2705 if (n1 <= 0)
2706 break;
2707 n += n1;
2708 }
2f96c702
IZ
2709 PerlLIO_close(pp[0]);
2710 did_pipes = 0;
e446cec8 2711 if (n) { /* Error */
faa466a7 2712 int pid2, status;
8c51524e 2713 PerlLIO_close(p[This]);
e446cec8 2714 if (n != sizeof(int))
5637ef5b 2715 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
faa466a7
RG
2716 do {
2717 pid2 = wait4pid(pid, &status, 0);
2718 } while (pid2 == -1 && errno == EINTR);
e446cec8 2719 errno = errkid; /* Propagate errno from kid */
4608196e 2720 return NULL;
e446cec8
IZ
2721 }
2722 }
2723 if (did_pipes)
2724 PerlLIO_close(pp[0]);
8ac85365 2725 return PerlIO_fdopen(p[This], mode);
a687059c 2726}
7c0587c8 2727#else
2b96b0a5
JH
2728#if defined(DJGPP)
2729FILE *djgpp_popen();
2730PerlIO *
cef6ea9d 2731Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH
2732{
2733 PERL_FLUSHALL_FOR_CHILD;
2734 /* Call system's popen() to get a FILE *, then import it.
2735 used 0 for 2nd parameter to PerlIO_importFILE;
2736 apparently not used
2737 */
2738 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2739}
9c12f1e5
RGS
2740#else
2741#if defined(__LIBCATAMOUNT__)
2742PerlIO *
2743Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2744{
2745 return NULL;
2746}
2747#endif
2b96b0a5 2748#endif
7c0587c8
LW
2749
2750#endif /* !DOSISH */
a687059c 2751
52e18b1f
GS
2752/* this is called in parent before the fork() */
2753void
2754Perl_atfork_lock(void)
80b94025
JH
2755#if defined(USE_ITHREADS)
2756# ifdef USE_PERLIO
2757 PERL_TSA_ACQUIRE(PL_perlio_mutex)
2758# endif
2759# ifdef MYMALLOC
2760 PERL_TSA_ACQUIRE(PL_malloc_mutex)
2761# endif
2762 PERL_TSA_ACQUIRE(PL_op_mutex)
2763#endif
52e18b1f 2764{
3db8f154 2765#if defined(USE_ITHREADS)
20b7effb 2766 dVAR;
52e18b1f 2767 /* locks must be held in locking order (if any) */
4da80956
P
2768# ifdef USE_PERLIO
2769 MUTEX_LOCK(&PL_perlio_mutex);
2770# endif
52e18b1f
GS
2771# ifdef MYMALLOC
2772 MUTEX_LOCK(&PL_malloc_mutex);
2773# endif
2774 OP_REFCNT_LOCK;
2775#endif
2776}
2777
2778/* this is called in both parent and child after the fork() */
2779void
2780Perl_atfork_unlock(void)
80b94025
JH
2781#if defined(USE_ITHREADS)
2782# ifdef USE_PERLIO
2783 PERL_TSA_RELEASE(PL_perlio_mutex)
2784# endif
2785# ifdef MYMALLOC
2786 PERL_TSA_RELEASE(PL_malloc_mutex)
2787# endif
2788 PERL_TSA_RELEASE(PL_op_mutex)
2789#endif
52e18b1f 2790{
3db8f154 2791#if defined(USE_ITHREADS)
20b7effb 2792 dVAR;
52e18b1f 2793 /* locks must be released in same order as in atfork_lock() */
4da80956
P
2794# ifdef USE_PERLIO
2795 MUTEX_UNLOCK(&PL_perlio_mutex);
2796# endif
52e18b1f
GS
2797# ifdef MYMALLOC
2798 MUTEX_UNLOCK(&PL_malloc_mutex);
2799# endif
2800 OP_REFCNT_UNLOCK;
2801#endif
2802}
2803
2804Pid_t
2805Perl_my_fork(void)
2806{
2807#if defined(HAS_FORK)
2808 Pid_t pid;
3db8f154 2809#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS
2810 atfork_lock();
2811 pid = fork();
2812 atfork_unlock();
2813#else
2814 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2815 * handlers elsewhere in the code */
2816 pid = fork();
2817#endif
2818 return pid;
40262ff4
AB
2819#elif defined(__amigaos4__)
2820 return amigaos_fork();
52e18b1f
GS
2821#else
2822 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2823 Perl_croak_nocontext("fork() not available");
b961a566 2824 return 0;
52e18b1f
GS
2825#endif /* HAS_FORK */
2826}
2827
fe14fcc3 2828#ifndef HAS_DUP2
fec02dd3 2829int
ba106d47 2830dup2(int oldfd, int newfd)
a687059c 2831{
a0d0e21e 2832#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
2833 if (oldfd == newfd)
2834 return oldfd;
6ad3d225 2835 PerlLIO_close(newfd);
fec02dd3 2836 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2837#else
fc36a67e
PP
2838#define DUP2_MAX_FDS 256
2839 int fdtmp[DUP2_MAX_FDS];
79072805 2840 I32 fdx = 0;
ae986130
LW
2841 int fd;
2842
fe14fcc3 2843 if (oldfd == newfd)
fec02dd3 2844 return oldfd;
6ad3d225 2845 PerlLIO_close(newfd);
fc36a67e 2846 /* good enough for low fd's... */
6ad3d225 2847 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2848 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2849 PerlLIO_close(fd);
fc36a67e
PP
2850 fd = -1;
2851 break;
2852 }
ae986130 2853 fdtmp[fdx++] = fd;
fc36a67e 2854 }
ae986130 2855 while (fdx > 0)
6ad3d225 2856 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2857 return fd;
62b28dd9 2858#endif
a687059c
LW
2859}
2860#endif
2861
64ca3a65 2862#ifndef PERL_MICRO
ff68c719
PP
2863#ifdef HAS_SIGACTION
2864
2865Sighandler_t
864dbfa3 2866Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719
PP
2867{
2868 struct sigaction act, oact;
2869
a10b1e10 2870#ifdef USE_ITHREADS
20b7effb 2871 dVAR;
a10b1e10
JH
2872 /* only "parent" interpreter can diddle signals */
2873 if (PL_curinterp != aTHX)
8aad04aa 2874 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2875#endif
2876
8aad04aa 2877 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2878 sigemptyset(&act.sa_mask);
2879 act.sa_flags = 0;
2880#ifdef SA_RESTART
4ffa73a3
JH
2881 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2882 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2883#endif
358837b8 2884#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2885 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2886 act.sa_flags |= SA_NOCLDWAIT;
2887#endif
ff68c719 2888 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2889 return (Sighandler_t) SIG_ERR;
ff68c719 2890 else
8aad04aa 2891 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2892}
2893
2894Sighandler_t
864dbfa3 2895Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
2896{
2897 struct sigaction oact;
96a5add6 2898 PERL_UNUSED_CONTEXT;
ff68c719
PP
2899
2900 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2901 return (Sighandler_t) SIG_ERR;
ff68c719 2902 else
8aad04aa 2903 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2904}
2905
2906int
864dbfa3 2907Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2908{
20b7effb 2909#ifdef USE_ITHREADS
27da23d5 2910 dVAR;
20b7effb 2911#endif
ff68c719
PP
2912 struct sigaction act;
2913
7918f24d
NC
2914 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2915
a10b1e10
JH
2916#ifdef USE_ITHREADS
2917 /* only "parent" interpreter can diddle signals */
2918 if (PL_curinterp != aTHX)
2919 return -1;
2920#endif
2921
8aad04aa 2922 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2923 sigemptyset(&act.sa_mask);
2924 act.sa_flags = 0;
2925#ifdef SA_RESTART
4ffa73a3
JH
2926 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2927 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2928#endif
36b5d377 2929#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2930 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2931 act.sa_flags |= SA_NOCLDWAIT;
2932#endif
ff68c719
PP
2933 return sigaction(signo, &act, save);
2934}
2935
2936int
864dbfa3 2937Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2938{
20b7effb 2939#ifdef USE_ITHREADS
27da23d5 2940 dVAR;
20b7effb
JH
2941#endif
2942 PERL_UNUSED_CONTEXT;
a10b1e10
JH
2943#ifdef USE_ITHREADS
2944 /* only "parent" interpreter can diddle signals */
2945 if (PL_curinterp != aTHX)
2946 return -1;
2947#endif
2948
ff68c719
PP
2949 return sigaction(signo, save, (struct sigaction *)NULL);
2950}
2951
2952#else /* !HAS_SIGACTION */
2953
2954Sighandler_t
864dbfa3 2955Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2956{
39f1703b 2957#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2958 /* only "parent" interpreter can diddle signals */
2959 if (PL_curinterp != aTHX)
8aad04aa 2960 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2961#endif
2962
6ad3d225 2963 return PerlProc_signal(signo, handler);
ff68c719
PP
2964}
2965
fabdb6c0 2966static Signal_t
4e35701f 2967sig_trap(int signo)
ff68c719 2968{
27da23d5
JH
2969 dVAR;
2970 PL_sig_trapped++;
ff68c719
PP
2971}
2972
2973Sighandler_t
864dbfa3 2974Perl_rsignal_state(pTHX_ int signo)
ff68c719 2975{
27da23d5 2976 dVAR;
ff68c719
PP
2977 Sighandler_t oldsig;
2978
39f1703b 2979#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2980 /* only "parent" interpreter can diddle signals */
2981 if (PL_curinterp != aTHX)
8aad04aa 2982 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2983#endif
2984
27da23d5 2985 PL_sig_trapped = 0;
6ad3d225
GS
2986 oldsig = PerlProc_signal(signo, sig_trap);
2987 PerlProc_signal(signo, oldsig);
27da23d5 2988 if (PL_sig_trapped)
3aed30dc 2989 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719
PP
2990 return oldsig;
2991}
2992
2993int
864dbfa3 2994Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2995{
39f1703b 2996#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2997 /* only "parent" interpreter can diddle signals */
2998 if (PL_curinterp != aTHX)
2999 return -1;
3000#endif
6ad3d225 3001 *save = PerlProc_signal(signo, handler);
8aad04aa 3002 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3003}
3004
3005int
864dbfa3 3006Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 3007{
39f1703b 3008#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3009 /* only "parent" interpreter can diddle signals */
3010 if (PL_curinterp != aTHX)
3011 return -1;
3012#endif
8aad04aa 3013 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3014}
3015
3016#endif /* !HAS_SIGACTION */
64ca3a65 3017#endif /* !PERL_MICRO */
ff68c719 3018
5f05dabc 3019 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
53f73940 3020#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
79072805 3021I32
864dbfa3 3022Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 3023{
a687059c 3024 int status;
a0d0e21e 3025 SV **svp;
d8a83dd3 3026 Pid_t pid;
2e0cfa16 3027 Pid_t pid2 = 0;
03136e13 3028 bool close_failed;
4ee39169 3029 dSAVEDERRNO;
2e0cfa16 3030 const int fd = PerlIO_fileno(ptr);
e9d373c4
TC
3031 bool should_wait;
3032
3033 svp = av_fetch(PL_fdpid,fd,TRUE);
3034 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3035 SvREFCNT_dec(*svp);
3036 *svp = NULL;
2e0cfa16 3037
97cb92d6 3038#if defined(USE_PERLIO)
2e0cfa16
FC
3039 /* Find out whether the refcount is low enough for us to wait for the
3040 child proc without blocking. */
e9d373c4 3041 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
b6ae43b7 3042#else
e9d373c4 3043 should_wait = pid > 0;
b6ae43b7 3044#endif
a687059c 3045
ddcf38b7
IZ
3046#ifdef OS2
3047 if (pid == -1) { /* Opened by popen. */
3048 return my_syspclose(ptr);
3049 }
a1d180c4 3050#endif
f1618b10
CS
3051 close_failed = (PerlIO_close(ptr) == EOF);
3052 SAVE_ERRNO;
2e0cfa16 3053 if (should_wait) do {
1d3434b8
GS
3054 pid2 = wait4pid(pid, &status, 0);
3055 } while (pid2 == -1 && errno == EINTR);
03136e13 3056 if (close_failed) {
4ee39169 3057 RESTORE_ERRNO;
03136e13
CS
3058 return -1;
3059 }
2e0cfa16
FC
3060 return(
3061 should_wait
3062 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3063 : 0
3064 );
20188a90 3065}
9c12f1e5
RGS
3066#else
3067#if defined(__LIBCATAMOUNT__)
3068I32
3069Perl_my_pclose(pTHX_ PerlIO *ptr)
3070{
3071 return -1;
3072}
3073#endif
4633a7c4
LW
3074#endif /* !DOSISH */
3075
e37778c2 3076#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 3077I32
d8a83dd3 3078Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 3079{
27da23d5 3080 I32 result = 0;
7918f24d 3081 PERL_ARGS_ASSERT_WAIT4PID;
ca0c25f6 3082#ifdef PERL_USES_PL_PIDSTATUS
d4c02743
TC
3083 if (!pid) {
3084 /* PERL_USES_PL_PIDSTATUS is only defined when neither
3085 waitpid() nor wait4() is available, or on OS/2, which
3086 doesn't appear to support waiting for a progress group
3087 member, so we can only treat a 0 pid as an unknown child.
3088 */
3089 errno = ECHILD;
3090 return -1;
3091 }
b7953727 3092 {
3aed30dc 3093 if (pid > 0) {
12072db5
NC
3094 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3095 pid, rather than a string form. */
c4420975 3096 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS
3097 if (svp && *svp != &PL_sv_undef) {
3098 *statusp = SvIVX(*svp);
12072db5
NC
3099 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3100 G_DISCARD);
3aed30dc
HS
3101 return pid;
3102 }
3103 }
3104 else {
3105 HE *entry;
3106
3107 hv_iterinit(PL_pidstatus);
3108 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 3109 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 3110 I32 len;
0bcc34c2 3111 const char * const spid = hv_iterkey(entry,&len);
27da23d5 3112
12072db5
NC
3113 assert (len == sizeof(Pid_t));
3114 memcpy((char *)&pid, spid, len);
3aed30dc 3115 *statusp = SvIVX(sv);
7b9a3241
NC
3116 /* The hash iterator is currently on this entry, so simply
3117 calling hv_delete would trigger the lazy delete, which on
f6bab5f6 3118 aggregate does more work, because next call to hv_iterinit()
7b9a3241
NC
3119 would spot the flag, and have to call the delete routine,
3120 while in the meantime any new entries can't re-use that
3121 memory. */
3122 hv_iterinit(PL_pidstatus);
7ea75b61 3123 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS
3124 return pid;
3125 }
20188a90
LW
3126 }
3127 }
68a29c53 3128#endif
79072805 3129#ifdef HAS_WAITPID
367f3c24
IZ
3130# ifdef HAS_WAITPID_RUNTIME
3131 if (!HAS_WAITPID_RUNTIME)
3132 goto hard_way;
3133# endif
cddd4526 3134 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 3135 goto finish;
367f3c24
IZ
3136#endif
3137#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
d4c02743 3138 result = wait4(pid,statusp,flags,NULL);
dfcfdb64 3139 goto finish;
367f3c24 3140#endif
ca0c25f6 3141#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 3142#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 3143 hard_way:
27da23d5 3144#endif
a0d0e21e 3145 {
a0d0e21e 3146 if (flags)
cea2e8a9 3147 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 3148 else {
76e3520e 3149 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW
3150 pidgone(result,*statusp);
3151 if (result < 0)
3152 *statusp = -1;
3153 }
a687059c
LW
3154 }
3155#endif
27da23d5 3156#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 3157 finish:
27da23d5 3158#endif
cddd4526
NIS
3159 if (result < 0 && errno == EINTR) {
3160 PERL_ASYNC_CHECK();
48dbb59e 3161 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS
3162 }
3163 return result;
a687059c 3164}
2986a63f 3165#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 3166
ca0c25f6 3167#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 3168void
ed4173ef 3169S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 3170{
eb578fdb 3171 SV *sv;
a687059c 3172
12072db5 3173 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 3174 SvUPGRADE(sv,SVt_IV);
45977657 3175 SvIV_set(sv, status);
20188a90 3176 return;
a687059c 3177}
ca0c25f6 3178#endif
a687059c 3179
6de23f80 3180#if defined(OS2)
7c0587c8 3181int pclose();
ddcf38b7
IZ
3182#ifdef HAS_FORK
3183int /* Cannot prototype with I32
3184 in os2ish.h. */
ba106d47 3185my_syspclose(PerlIO *ptr)
ddcf38b7 3186#else
79072805 3187I32
864dbfa3 3188Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 3189#endif
a687059c 3190{
760ac839 3191 /* Needs work for PerlIO ! */
c4420975 3192 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 3193 const I32 result = pclose(f);
2b96b0a5
JH
3194 PerlIO_releaseFILE(ptr,f);
3195 return result;
3196}
3197#endif
3198
933fea7f 3199#if defined(DJGPP)
2b96b0a5
JH
3200int djgpp_pclose();
3201I32
3202Perl_my_pclose(pTHX_ PerlIO *ptr)
3203{
3204 /* Needs work for PerlIO ! */
c4420975 3205 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 3206 I32 result = djgpp_pclose(f);
933fea7f 3207 result = (result << 8) & 0xff00;
760ac839
LW
3208 PerlIO_releaseFILE(ptr,f);
3209 return result;
a687059c 3210}
7c0587c8 3211#endif
9f68db38 3212
16fa5c11 3213#define PERL_REPEATCPY_LINEAR 4
9f68db38 3214void
5aaab254 3215Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
9f68db38 3216{
7918f24d
NC
3217 PERL_ARGS_ASSERT_REPEATCPY;
3218
223f01db
KW
3219 assert(len >= 0);
3220
2709980d 3221 if (count < 0)
d1decf2b 3222 croak_memory_wrap();
2709980d 3223
16fa5c11
VP
3224 if (len == 1)
3225 memset(to, *from, count);
3226 else if (count) {
eb578fdb 3227 char *p = to;
26e1303d 3228 IV items, linear, half;
16fa5c11
VP
3229
3230 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3231 for (items = 0; items < linear; ++items) {
eb578fdb 3232 const char *q = from;
26e1303d 3233 IV todo;
16fa5c11
VP
3234 for (todo = len; todo > 0; todo--)
3235 *p++ = *q++;
3236 }
3237
3238 half = count / 2;
3239 while (items <= half) {
26e1303d 3240 IV size = items * len;
16fa5c11
VP
3241 memcpy(p, to, size);
3242 p += size;
3243 items *= 2;
9f68db38 3244 }
16fa5c11
VP
3245
3246 if (count > items)
3247 memcpy(p, to, (count - items) * len);
9f68db38
LW
3248 }
3249}
0f85fab0 3250
fe14fcc3 3251#ifndef HAS_RENAME
79072805 3252I32
4373e329 3253Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3254{
93a17b20
LW
3255 char *fa = strrchr(a,'/');
3256 char *fb = strrchr(b,'/');
c623ac67
GS
3257 Stat_t tmpstatbuf1;
3258 Stat_t tmpstatbuf2;
c4420975 3259 SV * const tmpsv = sv_newmortal();
62b28dd9 3260
7918f24d
NC
3261 PERL_ARGS_ASSERT_SAME_DIRENT;
3262
62b28dd9
LW
3263 if (fa)
3264 fa++;
3265 else
3266 fa = a;
3267 if (fb)
3268 fb++;
3269 else
3270 fb = b;
3271 if (strNE(a,b))
3272 return FALSE;
3273 if (fa == a)
76f68e9b 3274 sv_setpvs(tmpsv, ".");
62b28dd9 3275 else
46fc3d4c 3276 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3277 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
3278 return FALSE;
3279 if (fb == b)
76f68e9b 3280 sv_setpvs(tmpsv, ".");
62b28dd9 3281 else
46fc3d4c 3282 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3283 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
3284 return FALSE;
3285 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3286 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3287}
fe14fcc3
LW
3288#endif /* !HAS_RENAME */
3289
491527d0 3290char*
7f315aed
NC
3291Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3292 const char *const *const search_ext, I32 flags)
491527d0 3293{
bd61b366
SS
3294 const char *xfound = NULL;
3295 char *xfailed = NULL;
0f31cffe 3296 char tmpbuf[MAXPATHLEN];
eb578fdb 3297 char *s;
5f74f29c 3298 I32 len = 0;
491527d0 3299 int retval;
39a02377 3300 char *bufend;
7c458fae 3301#if defined(DOSISH) && !defined(OS2)
491527d0
GS
3302# define SEARCH_EXTS ".bat", ".cmd", NULL
3303# define MAX_EXT_LEN 4
3304#endif
3305#ifdef OS2
3306# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3307# define MAX_EXT_LEN 4
3308#endif
3309#ifdef VMS
3310# define SEARCH_EXTS ".pl", ".com", NULL
3311# define MAX_EXT_LEN 4
3312#endif
3313 /* additional extensions to try in each dir if scriptname not found */
3314#ifdef SEARCH_EXTS
0bcc34c2 3315 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3316 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3317 int extidx = 0, i = 0;
bd61b366 3318 const char *curext = NULL;
491527d0 3319#else
53c1dcc0 3320 PERL_UNUSED_ARG(search_ext);
491527d0
GS
3321# define MAX_EXT_LEN 0
3322#endif
3323
7918f24d
NC
3324 PERL_ARGS_ASSERT_FIND_SCRIPT;
3325
491527d0
GS
3326 /*
3327 * If dosearch is true and if scriptname does not contain path
3328 * delimiters, search the PATH for scriptname.
3329 *
3330 * If SEARCH_EXTS is also defined, will look for each
3331 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3332 * while searching the PATH.
3333 *
3334 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3335 * proceeds as follows:
3336 * If DOSISH or VMSISH:
3337 * + look for ./scriptname{,.foo,.bar}
3338 * + search the PATH for scriptname{,.foo,.bar}
3339 *
3340 * If !DOSISH:
3341 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3342 * this will not look in '.' if it's not in the PATH)
3343 */
84486fc6 3344 tmpbuf[0] = '\0';
491527d0
GS
3345
3346#ifdef VMS
3347# ifdef ALWAYS_DEFTYPES
3348 len = strlen(scriptname);
3349 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3350 int idx = 0, deftypes = 1;
491527d0
GS
3351 bool seen_dot = 1;
3352
bd61b366 3353 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3354# else
3355 if (dosearch) {
c4420975 3356 int idx = 0, deftypes = 1;
491527d0
GS
3357 bool seen_dot = 1;
3358
bd61b366 3359 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3360# endif
3361 /* The first time through, just add SEARCH_EXTS to whatever we
3362 * already have, so we can check for default file types. */
3363 while (deftypes ||
84486fc6 3364 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0 3365 {
2aa28b86 3366 Stat_t statbuf;
491527d0
GS
3367 if (deftypes) {
3368 deftypes = 0;
84486fc6 3369 *tmpbuf = '\0';
491527d0 3370 }
84486fc6
GS
3371 if ((strlen(tmpbuf) + strlen(scriptname)
3372 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3373 continue; /* don't search dir with too-long name */
6fca0082 3374 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS
3375#else /* !VMS */
3376
3377#ifdef DOSISH
3378 if (strEQ(scriptname, "-"))
3379 dosearch = 0;
3380 if (dosearch) { /* Look in '.' first. */
fe2774ed 3381 const char *cur = scriptname;
491527d0
GS
3382#ifdef SEARCH_EXTS
3383 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3384 while (ext[i])
3385 if (strEQ(ext[i++],curext)) {
3386 extidx = -1; /* already has an ext */
3387 break;
3388 }
3389 do {
3390#endif
3391 DEBUG_p(PerlIO_printf(Perl_debug_log,
3392 "Looking for %s\n",cur));
45a23732 3393 {
0cc19a43 3394 Stat_t statbuf;
45a23732
DD
3395 if (PerlLIO_stat(cur,&statbuf) >= 0
3396 && !S_ISDIR(statbuf.st_mode)) {
3397 dosearch = 0;
3398 scriptname = cur;
491527d0 3399#ifdef SEARCH_EXTS
45a23732 3400 break;
491527d0 3401#endif
45a23732 3402 }
491527d0
GS
3403 }
3404#ifdef SEARCH_EXTS
3405 if (cur == scriptname) {
3406 len = strlen(scriptname);
84486fc6 3407 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3408 break;
9e4425f7
SH
3409 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3410 cur = tmpbuf;
491527d0
GS
3411 }
3412 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3413 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS
3414#endif
3415 }
3416#endif
3417
3418 if (dosearch && !strchr(scriptname, '/')
3419#ifdef DOSISH
3420 && !strchr(scriptname, '\\')
3421#endif
cd39f2b6 3422 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3423 {
491527d0 3424 bool seen_dot = 0;
92f0c265 3425
39a02377
DM
3426 bufend = s + strlen(s);
3427 while (s < bufend) {
45a23732 3428 Stat_t statbuf;
7c458fae 3429# ifdef DOSISH
491527d0 3430 for (len = 0; *s
491527d0 3431 && *s != ';'; len++, s++) {
84486fc6
GS
3432 if (len < sizeof tmpbuf)
3433 tmpbuf[len] = *s;
491527d0 3434 }
84486fc6
GS
3435 if (len < sizeof tmpbuf)
3436 tmpbuf[len] = '\0';
7c458fae 3437# else
39a02377 3438 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS
3439 ':',
3440 &len);
7c458fae 3441# endif
39a02377 3442 if (s < bufend)
491527d0 3443 s++;
84486fc6 3444 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS
3445 continue; /* don't search dir with too-long name */
3446 if (len
7c458fae 3447# ifdef DOSISH
84486fc6
GS
3448 && tmpbuf[len - 1] != '/'
3449 && tmpbuf[len - 1] != '\\'
490a0e98 3450# endif
491527d0 3451 )
84486fc6
GS
3452 tmpbuf[len++] = '/';
3453 if (len == 2 && tmpbuf[0] == '.')
491527d0 3454 seen_dot = 1;
28f0d0ec 3455 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS
3456#endif /* !VMS */
3457
3458#ifdef SEARCH_EXTS
84486fc6 3459 len = strlen(tmpbuf);
491527d0
GS
3460 if (extidx > 0) /* reset after previous loop */
3461 extidx = 0;
3462 do {
3463#endif
84486fc6 3464 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
45a23732
DD
3465 retval = PerlLIO_stat(tmpbuf,&statbuf);
3466 if (S_ISDIR(statbuf.st_mode)) {
017f25f1
IZ
3467 retval = -1;
3468 }
491527d0
GS
3469#ifdef SEARCH_EXTS
3470 } while ( retval < 0 /* not there */
3471 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3472 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS
3473 );
3474#endif
3475 if (retval < 0)
3476 continue;
45a23732
DD
3477 if (S_ISREG(statbuf.st_mode)
3478 && cando(S_IRUSR,TRUE,&statbuf)
e37778c2 3479#if !defined(DOSISH)
45a23732 3480 && cando(S_IXUSR,TRUE,&statbuf)
491527d0
GS
3481#endif
3482 )
3483 {
3aed30dc 3484 xfound = tmpbuf; /* bingo! */
491527d0
GS
3485 break;
3486 }
3487 if (!xfailed)
84486fc6 3488 xfailed = savepv(tmpbuf);
491527d0
GS
3489 }
3490#ifndef DOSISH
45a23732
DD
3491 {
3492 Stat_t statbuf;
3493 if (!xfound && !seen_dot && !xfailed &&
3494 (PerlLIO_stat(scriptname,&statbuf) < 0
3495 || S_ISDIR(statbuf.st_mode)))
3496#endif
3497 seen_dot = 1; /* Disable message. */
3498#ifndef DOSISH
3499 }
491527d0 3500#endif
9ccb31f9
GS
3501 if (!xfound) {
3502 if (flags & 1) { /* do or die? */
6ad282c7 3503 /* diag_listed_as: Can't execute %s */
3aed30dc 3504 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS
3505 (xfailed ? "execute" : "find"),
3506 (xfailed ? xfailed : scriptname),
3507 (xfailed ? "" : " on PATH"),
3508 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3509 }
bd61b366 3510 scriptname = NULL;
9ccb31f9 3511 }
43c5f42d 3512 Safefree(xfailed);
491527d0
GS
3513 scriptname = xfound;
3514 }
bd61b366 3515 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS
3516}
3517
ba869deb
GS
3518#ifndef PERL_GET_CONTEXT_DEFINED
3519
3520void *
3521Perl_get_context(void)
3522{
3db8f154 3523#if defined(USE_ITHREADS)
20b7effb 3524 dVAR;
ba869deb
GS
3525# ifdef OLD_PTHREADS_API
3526 pthread_addr_t t;
5637ef5b
NC
3527 int error = pthread_getspecific(PL_thr_key, &t)
3528 if (error)
3529 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
ba869deb
GS
3530 return (void*)t;
3531# else
bce813aa 3532# ifdef I_MACH_CTHREADS
8b8b35ab 3533 return (void*)cthread_data(cthread_self());
bce813aa 3534# else
8b8b35ab
JH
3535 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3536# endif
c44d3fdb 3537# endif
ba869deb
GS
3538#else
3539 return (void*)NULL;
3540#endif
3541}
3542
3543void
3544Perl_set_context(void *t)
3545{
20b7effb 3546#if defined(USE_ITHREADS)
8772537c 3547 dVAR;
20b7effb 3548#endif
7918f24d 3549 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3550#if defined(USE_ITHREADS)
c44d3fdb
GS
3551# ifdef I_MACH_CTHREADS
3552 cthread_set_data(cthread_self(), t);
3553# else
5637ef5b
NC
3554 {
3555 const int error = pthread_setspecific(PL_thr_key, t);
3556 if (error)
3557 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3558 }
c44d3fdb 3559# endif
b464bac0 3560#else
8772537c 3561 PERL_UNUSED_ARG(t);
ba869deb
GS
3562#endif
3563}
3564
3565#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3566
27da23d5 3567#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3568struct perl_vars *
864dbfa3 3569Perl_GetVars(pTHX)
22239a37 3570{
23491f1d
JH
3571 PERL_UNUSED_CONTEXT;
3572 return &PL_Vars;
22239a37 3573}
31fb1209
NIS
3574#endif
3575
1cb0ed9b 3576char **
864dbfa3 3577Perl_get_op_names(pTHX)
31fb1209 3578{
96a5add6
AL