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