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