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