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