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