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