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