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