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