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