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