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