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