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