This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
amigaos4: save and restore stdio handles around exec
[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
796b6530 633Analyses the string in order to make fast searches on it using C<fbm_instr()>
954c1994
GS
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>
796b6530 735does not have to be C<fbm_compiled>, but the search will not be as fast
954c1994
GS
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
796b6530
KW
932Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
933same
e6226b18
KW
934case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
935match themselves and their opposite case counterparts. Non-cased and non-ASCII
936range bytes match only themselves.
937
938=cut
939*/
940
941
79072805 942I32
5aaab254 943Perl_foldEQ(const char *s1, const char *s2, I32 len)
79072805 944{
eb578fdb
KW
945 const U8 *a = (const U8 *)s1;
946 const U8 *b = (const U8 *)s2;
96a5add6 947
e6226b18 948 PERL_ARGS_ASSERT_FOLDEQ;
7918f24d 949
223f01db
KW
950 assert(len >= 0);
951
79072805 952 while (len--) {
22c35a8c 953 if (*a != *b && *a != PL_fold[*b])
e6226b18 954 return 0;
bbce6d69
PP
955 a++,b++;
956 }
e6226b18 957 return 1;
bbce6d69 958}
1b9f127b 959I32
5aaab254 960Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1b9f127b
KW
961{
962 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
963 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
964 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
965 * does it check that the strings each have at least 'len' characters */
966
eb578fdb
KW
967 const U8 *a = (const U8 *)s1;
968 const U8 *b = (const U8 *)s2;
1b9f127b
KW
969
970 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
971
223f01db
KW
972 assert(len >= 0);
973
1b9f127b
KW
974 while (len--) {
975 if (*a != *b && *a != PL_fold_latin1[*b]) {
976 return 0;
977 }
978 a++, b++;
979 }
980 return 1;
981}
bbce6d69 982
e6226b18
KW
983/*
984=for apidoc foldEQ_locale
985
796b6530
KW
986Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
987same case-insensitively in the current locale; false otherwise.
e6226b18
KW
988
989=cut
990*/
991
bbce6d69 992I32
5aaab254 993Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
bbce6d69 994{
27da23d5 995 dVAR;
eb578fdb
KW
996 const U8 *a = (const U8 *)s1;
997 const U8 *b = (const U8 *)s2;
96a5add6 998
e6226b18 999 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
7918f24d 1000
223f01db
KW
1001 assert(len >= 0);
1002
bbce6d69 1003 while (len--) {
22c35a8c 1004 if (*a != *b && *a != PL_fold_locale[*b])
e6226b18 1005 return 0;
bbce6d69 1006 a++,b++;
79072805 1007 }
e6226b18 1008 return 1;
79072805
LW
1009}
1010
8d063cd8
LW
1011/* copy a string to a safe spot */
1012
954c1994 1013/*
ccfc67b7
JH
1014=head1 Memory Management
1015
954c1994
GS
1016=for apidoc savepv
1017
72d33970
FC
1018Perl's version of C<strdup()>. Returns a pointer to a newly allocated
1019string which is a duplicate of C<pv>. The size of the string is
30a15352
KW
1020determined by C<strlen()>, which means it may not contain embedded C<NUL>
1021characters and must have a trailing C<NUL>. The memory allocated for the new
1022string can be freed with the C<Safefree()> function.
954c1994 1023
0358c255
KW
1024On some platforms, Windows for example, all allocated memory owned by a thread
1025is deallocated when that thread ends. So if you need that not to happen, you
1026need to use the shared memory functions, such as C<L</savesharedpv>>.
1027
954c1994
GS
1028=cut
1029*/
1030
8d063cd8 1031char *
efdfce31 1032Perl_savepv(pTHX_ const char *pv)
8d063cd8 1033{
96a5add6 1034 PERL_UNUSED_CONTEXT;
e90e2364 1035 if (!pv)
bd61b366 1036 return NULL;
66a1b24b
AL
1037 else {
1038 char *newaddr;
1039 const STRLEN pvlen = strlen(pv)+1;
10edeb5d
JH
1040 Newx(newaddr, pvlen, char);
1041 return (char*)memcpy(newaddr, pv, pvlen);
66a1b24b 1042 }
8d063cd8
LW
1043}
1044
a687059c
LW
1045/* same thing but with a known length */
1046
954c1994
GS
1047/*
1048=for apidoc savepvn
1049
72d33970 1050Perl's version of what C<strndup()> would be if it existed. Returns a
61a925ed 1051pointer to a newly allocated string which is a duplicate of the first
72d33970 1052C<len> bytes from C<pv>, plus a trailing
6602b933 1053C<NUL> byte. The memory allocated for
cbf82dd0 1054the new string can be freed with the C<Safefree()> function.
954c1994 1055
0358c255
KW
1056On some platforms, Windows for example, all allocated memory owned by a thread
1057is deallocated when that thread ends. So if you need that not to happen, you
1058need to use the shared memory functions, such as C<L</savesharedpvn>>.
1059
954c1994
GS
1060=cut
1061*/
1062
a687059c 1063char *
5aaab254 1064Perl_savepvn(pTHX_ const char *pv, I32 len)
a687059c 1065{
eb578fdb 1066 char *newaddr;
96a5add6 1067 PERL_UNUSED_CONTEXT;
a687059c 1068
223f01db
KW
1069 assert(len >= 0);
1070
a02a5408 1071 Newx(newaddr,len+1,char);
92110913 1072 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
efdfce31 1073 if (pv) {
e90e2364
NC
1074 /* might not be null terminated */
1075 newaddr[len] = '\0';
07409e01 1076 return (char *) CopyD(pv,newaddr,len,char);
92110913
NIS
1077 }
1078 else {
07409e01 1079 return (char *) ZeroD(newaddr,len+1,char);
92110913 1080 }
a687059c
LW
1081}
1082
05ec9bb3
NIS
1083/*
1084=for apidoc savesharedpv
1085
61a925ed
AMS
1086A version of C<savepv()> which allocates the duplicate string in memory
1087which is shared between threads.
05ec9bb3
NIS
1088
1089=cut
1090*/
1091char *
efdfce31 1092Perl_savesharedpv(pTHX_ const char *pv)
05ec9bb3 1093{
eb578fdb 1094 char *newaddr;
490a0e98 1095 STRLEN pvlen;
dc3bf405
BF
1096
1097 PERL_UNUSED_CONTEXT;
1098
e90e2364 1099 if (!pv)
bd61b366 1100 return NULL;
e90e2364 1101
490a0e98
NC
1102 pvlen = strlen(pv)+1;
1103 newaddr = (char*)PerlMemShared_malloc(pvlen);
e90e2364 1104 if (!newaddr) {
4cbe3a7d 1105 croak_no_mem();
05ec9bb3 1106 }
10edeb5d 1107 return (char*)memcpy(newaddr, pv, pvlen);
05ec9bb3
NIS
1108}
1109
2e0de35c 1110/*
d9095cec
NC
1111=for apidoc savesharedpvn
1112
1113A version of C<savepvn()> which allocates the duplicate string in memory
796b6530 1114which is shared between threads. (With the specific difference that a C<NULL>
d9095cec
NC
1115pointer is not acceptable)
1116
1117=cut
1118*/
1119char *
1120Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1121{
1122 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
7918f24d 1123
dc3bf405 1124 PERL_UNUSED_CONTEXT;
6379d4a9 1125 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
7918f24d 1126
d9095cec 1127 if (!newaddr) {
4cbe3a7d 1128 croak_no_mem();
d9095cec
NC
1129 }
1130 newaddr[len] = '\0';
1131 return (char*)memcpy(newaddr, pv, len);
1132}
1133
1134/*
2e0de35c
NC
1135=for apidoc savesvpv
1136
6832267f 1137A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
2e0de35c
NC
1138the passed in SV using C<SvPV()>
1139
0358c255
KW
1140On some platforms, Windows for example, all allocated memory owned by a thread
1141is deallocated when that thread ends. So if you need that not to happen, you
1142need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1143
2e0de35c
NC
1144=cut
1145*/
1146
1147char *
1148Perl_savesvpv(pTHX_ SV *sv)
1149{
1150 STRLEN len;
7452cf6a 1151 const char * const pv = SvPV_const(sv, len);
eb578fdb 1152 char *newaddr;
2e0de35c 1153
7918f24d
NC
1154 PERL_ARGS_ASSERT_SAVESVPV;
1155
26866f99 1156 ++len;
a02a5408 1157 Newx(newaddr,len,char);
07409e01 1158 return (char *) CopyD(pv,newaddr,len,char);
2e0de35c 1159}
05ec9bb3 1160
9dcc53ea
Z
1161/*
1162=for apidoc savesharedsvpv
1163
1164A version of C<savesharedpv()> which allocates the duplicate string in
1165memory which is shared between threads.
1166
1167=cut
1168*/
1169
1170char *
1171Perl_savesharedsvpv(pTHX_ SV *sv)
1172{
1173 STRLEN len;
1174 const char * const pv = SvPV_const(sv, len);
1175
1176 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1177
1178 return savesharedpvn(pv, len);
1179}
05ec9bb3 1180
cea2e8a9 1181/* the SV for Perl_form() and mess() is not kept in an arena */
fc36a67e 1182
76e3520e 1183STATIC SV *
cea2e8a9 1184S_mess_alloc(pTHX)
fc36a67e
PP
1185{
1186 SV *sv;
1187 XPVMG *any;
1188
627364f1 1189 if (PL_phase != PERL_PHASE_DESTRUCT)
84bafc02 1190 return newSVpvs_flags("", SVs_TEMP);
e72dc28c 1191
0372dbb6
GS
1192 if (PL_mess_sv)
1193 return PL_mess_sv;
1194
fc36a67e 1195 /* Create as PVMG now, to avoid any upgrading later */
a02a5408
JC
1196 Newx(sv, 1, SV);
1197 Newxz(any, 1, XPVMG);
fc36a67e
PP
1198 SvFLAGS(sv) = SVt_PVMG;
1199 SvANY(sv) = (void*)any;
6136c704 1200 SvPV_set(sv, NULL);
fc36a67e 1201 SvREFCNT(sv) = 1 << 30; /* practically infinite */
e72dc28c 1202 PL_mess_sv = sv;
fc36a67e
PP
1203 return sv;
1204}
1205
c5be433b 1206#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1207char *
1208Perl_form_nocontext(const char* pat, ...)
1209{
1210 dTHX;
c5be433b 1211 char *retval;
cea2e8a9 1212 va_list args;
7918f24d 1213 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
cea2e8a9 1214 va_start(args, pat);
c5be433b 1215 retval = vform(pat, &args);
cea2e8a9 1216 va_end(args);
c5be433b 1217 return retval;
cea2e8a9 1218}
c5be433b 1219#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1220
7c9e965c 1221/*
ccfc67b7 1222=head1 Miscellaneous Functions
7c9e965c
JP
1223=for apidoc form
1224
1225Takes a sprintf-style format pattern and conventional
1226(non-SV) arguments and returns the formatted string.
1227
1228 (char *) Perl_form(pTHX_ const char* pat, ...)
1229
1230can be used any place a string (char *) is required:
1231
1232 char * s = Perl_form("%d.%d",major,minor);
1233
1234Uses a single private buffer so if you want to format several strings you
1235must explicitly copy the earlier strings away (and free the copies when you
1236are done).
1237
1238=cut
1239*/
1240
8990e307 1241char *
864dbfa3 1242Perl_form(pTHX_ const char* pat, ...)
8990e307 1243{
c5be433b 1244 char *retval;
46fc3d4c 1245 va_list args;
7918f24d 1246 PERL_ARGS_ASSERT_FORM;
46fc3d4c 1247 va_start(args, pat);
c5be433b 1248 retval = vform(pat, &args);
46fc3d4c 1249 va_end(args);
c5be433b
GS
1250 return retval;
1251}
1252
1253char *
1254Perl_vform(pTHX_ const char *pat, va_list *args)
1255{
2d03de9c 1256 SV * const sv = mess_alloc();
7918f24d 1257 PERL_ARGS_ASSERT_VFORM;
4608196e 1258 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
e72dc28c 1259 return SvPVX(sv);
46fc3d4c 1260}
a687059c 1261
c5df3096
Z
1262/*
1263=for apidoc Am|SV *|mess|const char *pat|...
1264
1265Take a sprintf-style format pattern and argument list. These are used to
1266generate a string message. If the message does not end with a newline,
1267then it will be extended with some indication of the current location
1268in the code, as described for L</mess_sv>.
1269
1270Normally, the resulting message is returned in a new mortal SV.
1271During global destruction a single SV may be shared between uses of
1272this function.
1273
1274=cut
1275*/
1276
5a844595
GS
1277#if defined(PERL_IMPLICIT_CONTEXT)
1278SV *
1279Perl_mess_nocontext(const char *pat, ...)
1280{
1281 dTHX;
1282 SV *retval;
1283 va_list args;
7918f24d 1284 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
5a844595
GS
1285 va_start(args, pat);
1286 retval = vmess(pat, &args);
1287 va_end(args);
1288 return retval;
1289}
1290#endif /* PERL_IMPLICIT_CONTEXT */
1291
06bf62c7 1292SV *
5a844595
GS
1293Perl_mess(pTHX_ const char *pat, ...)
1294{
1295 SV *retval;
1296 va_list args;
7918f24d 1297 PERL_ARGS_ASSERT_MESS;
5a844595
GS
1298 va_start(args, pat);
1299 retval = vmess(pat, &args);
1300 va_end(args);
1301 return retval;
1302}
1303
25502127
FC
1304const COP*
1305Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1306 bool opnext)
ae7d165c 1307{
25502127
FC
1308 /* Look for curop starting from o. cop is the last COP we've seen. */
1309 /* opnext means that curop is actually the ->op_next of the op we are
1310 seeking. */
ae7d165c 1311
7918f24d
NC
1312 PERL_ARGS_ASSERT_CLOSEST_COP;
1313
25502127
FC
1314 if (!o || !curop || (
1315 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1316 ))
fabdb6c0 1317 return cop;
ae7d165c
PJ
1318
1319 if (o->op_flags & OPf_KIDS) {
5f66b61c 1320 const OP *kid;
e6dae479 1321 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
5f66b61c 1322 const COP *new_cop;
ae7d165c
PJ
1323
1324 /* If the OP_NEXTSTATE has been optimised away we can still use it
1325 * the get the file and line number. */
1326
1327 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
5f66b61c 1328 cop = (const COP *)kid;
ae7d165c
PJ
1329
1330 /* Keep searching, and return when we've found something. */
1331
25502127 1332 new_cop = closest_cop(cop, kid, curop, opnext);
fabdb6c0
AL
1333 if (new_cop)
1334 return new_cop;
ae7d165c
PJ
1335 }
1336 }
1337
1338 /* Nothing found. */
1339
5f66b61c 1340 return NULL;
ae7d165c
PJ
1341}
1342
c5df3096
Z
1343/*
1344=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1345
1346Expands a message, intended for the user, to include an indication of
1347the current location in the code, if the message does not already appear
1348to be complete.
1349
1350C<basemsg> is the initial message or object. If it is a reference, it
1351will be used as-is and will be the result of this function. Otherwise it
1352is used as a string, and if it already ends with a newline, it is taken
1353to be complete, and the result of this function will be the same string.
1354If the message does not end with a newline, then a segment such as C<at
1355foo.pl line 37> will be appended, and possibly other clauses indicating
1356the current state of execution. The resulting message will end with a
1357dot and a newline.
1358
1359Normally, the resulting message is returned in a new mortal SV.
1360During global destruction a single SV may be shared between uses of this
1361function. If C<consume> is true, then the function is permitted (but not
1362required) to modify and return C<basemsg> instead of allocating a new SV.
1363
1364=cut
1365*/
1366
5a844595 1367SV *
c5df3096 1368Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
46fc3d4c 1369{
c5df3096 1370 SV *sv;
46fc3d4c 1371
0762e42f 1372#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
470dd224
JH
1373 {
1374 char *ws;
22ff3130 1375 UV wi;
470dd224 1376 /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
22ff3130
HS
1377 if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
1378 && grok_atoUV(ws, &wi, NULL)
1379 && wi <= PERL_INT_MAX
1380 ) {
1381 Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
470dd224
JH
1382 }
1383 }
1384#endif
1385
c5df3096
Z
1386 PERL_ARGS_ASSERT_MESS_SV;
1387
1388 if (SvROK(basemsg)) {
1389 if (consume) {
1390 sv = basemsg;
1391 }
1392 else {
1393 sv = mess_alloc();
1394 sv_setsv(sv, basemsg);
1395 }
1396 return sv;
1397 }
1398
1399 if (SvPOK(basemsg) && consume) {
1400 sv = basemsg;
1401 }
1402 else {
1403 sv = mess_alloc();
1404 sv_copypv(sv, basemsg);
1405 }
7918f24d 1406
46fc3d4c 1407 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
ae7d165c
PJ
1408 /*
1409 * Try and find the file and line for PL_op. This will usually be
1410 * PL_curcop, but it might be a cop that has been optimised away. We
1411 * can try to find such a cop by searching through the optree starting
1412 * from the sibling of PL_curcop.
1413 */
1414
25502127 1415 const COP *cop =
e6dae479 1416 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
5f66b61c
AL
1417 if (!cop)
1418 cop = PL_curcop;
ae7d165c
PJ
1419
1420 if (CopLINE(cop))
ed094faf 1421 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
3aed30dc 1422 OutCopFILE(cop), (IV)CopLINE(cop));
191f87d5
DH
1423 /* Seems that GvIO() can be untrustworthy during global destruction. */
1424 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1425 && IoLINES(GvIOp(PL_last_in_gv)))
1426 {
2748e602 1427 STRLEN l;
e1ec3a88 1428 const bool line_mode = (RsSIMPLE(PL_rs) &&
2748e602 1429 *SvPV_const(PL_rs,l) == '\n' && l == 1);
3b46b707
BF
1430 Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1431 SVfARG(PL_last_in_gv == PL_argvgv
1432 ? &PL_sv_no
1433 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
edc2eac3
JH
1434 line_mode ? "line" : "chunk",
1435 (IV)IoLINES(GvIOp(PL_last_in_gv)));
a687059c 1436 }
627364f1 1437 if (PL_phase == PERL_PHASE_DESTRUCT)
5f66b61c
AL
1438 sv_catpvs(sv, " during global destruction");
1439 sv_catpvs(sv, ".\n");
a687059c 1440 }
06bf62c7 1441 return sv;
a687059c
LW
1442}
1443
c5df3096
Z
1444/*
1445=for apidoc Am|SV *|vmess|const char *pat|va_list *args
1446
1447C<pat> and C<args> are a sprintf-style format pattern and encapsulated
801caa78
KW
1448argument list, respectively. These are used to generate a string message. If
1449the
c5df3096
Z
1450message does not end with a newline, then it will be extended with
1451some indication of the current location in the code, as described for
1452L</mess_sv>.
1453
1454Normally, the resulting message is returned in a new mortal SV.
1455During global destruction a single SV may be shared between uses of
1456this function.
1457
1458=cut
1459*/
1460
1461SV *
1462Perl_vmess(pTHX_ const char *pat, va_list *args)
1463{
c5df3096
Z
1464 SV * const sv = mess_alloc();
1465
1466 PERL_ARGS_ASSERT_VMESS;
1467
1468 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1469 return mess_sv(sv, 1);
1470}
1471
7ff03255 1472void
7d0994e0 1473Perl_write_to_stderr(pTHX_ SV* msv)
7ff03255
SG
1474{
1475 IO *io;
1476 MAGIC *mg;
1477
7918f24d
NC
1478 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1479
7ff03255
SG
1480 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1481 && (io = GvIO(PL_stderrgv))
daba3364 1482 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
36925d9e 1483 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
d1d7a15d 1484 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
7ff03255 1485 else {
53c1dcc0 1486 PerlIO * const serr = Perl_error_log;
7ff03255 1487
83c55556 1488 do_print(msv, serr);
7ff03255 1489 (void)PerlIO_flush(serr);
7ff03255
SG
1490 }
1491}
1492
c5df3096
Z
1493/*
1494=head1 Warning and Dieing
1495*/
1496
1497/* Common code used in dieing and warning */
1498
1499STATIC SV *
1500S_with_queued_errors(pTHX_ SV *ex)
1501{
1502 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1503 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1504 sv_catsv(PL_errors, ex);
1505 ex = sv_mortalcopy(PL_errors);
1506 SvCUR_set(PL_errors, 0);
1507 }
1508 return ex;
1509}
3ab1ac99 1510
46d9c920 1511STATIC bool
c5df3096 1512S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
63315e18
NC
1513{
1514 HV *stash;
1515 GV *gv;
1516 CV *cv;
46d9c920
NC
1517 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1518 /* sv_2cv might call Perl_croak() or Perl_warner() */
1519 SV * const oldhook = *hook;
1520
c5df3096
Z
1521 if (!oldhook)
1522 return FALSE;
63315e18 1523
63315e18 1524 ENTER;
46d9c920
NC
1525 SAVESPTR(*hook);
1526 *hook = NULL;
1527 cv = sv_2cv(oldhook, &stash, &gv, 0);
63315e18
NC
1528 LEAVE;
1529 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1530 dSP;
c5df3096 1531 SV *exarg;
63315e18
NC
1532
1533 ENTER;
2782061f 1534 save_re_context();
46d9c920
NC
1535 if (warn) {
1536 SAVESPTR(*hook);
1537 *hook = NULL;
1538 }
c5df3096
Z
1539 exarg = newSVsv(ex);
1540 SvREADONLY_on(exarg);
1541 SAVEFREESV(exarg);
63315e18 1542
46d9c920 1543 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
63315e18 1544 PUSHMARK(SP);
c5df3096 1545 XPUSHs(exarg);
63315e18 1546 PUTBACK;
daba3364 1547 call_sv(MUTABLE_SV(cv), G_DISCARD);
63315e18
NC
1548 POPSTACK;
1549 LEAVE;
46d9c920 1550 return TRUE;
63315e18 1551 }
46d9c920 1552 return FALSE;
63315e18
NC
1553}
1554
c5df3096
Z
1555/*
1556=for apidoc Am|OP *|die_sv|SV *baseex
e07360fa 1557
c5df3096
Z
1558Behaves the same as L</croak_sv>, except for the return type.
1559It should be used only where the C<OP *> return type is required.
1560The function never actually returns.
e07360fa 1561
c5df3096
Z
1562=cut
1563*/
e07360fa 1564
f8d5a522
DD
1565#ifdef _MSC_VER
1566# pragma warning( push )
1567# pragma warning( disable : 4646 ) /* warning C4646: function declared with
1568 __declspec(noreturn) has non-void return type */
1569# pragma warning( disable : 4645 ) /* warning C4645: function declared with
1570__declspec(noreturn) has a return statement */
1571#endif
c5df3096
Z
1572OP *
1573Perl_die_sv(pTHX_ SV *baseex)
36477c24 1574{
c5df3096
Z
1575 PERL_ARGS_ASSERT_DIE_SV;
1576 croak_sv(baseex);
e5964223 1577 /* NOTREACHED */
117af67d 1578 NORETURN_FUNCTION_END;
36477c24 1579}
f8d5a522
DD
1580#ifdef _MSC_VER
1581# pragma warning( pop )
1582#endif
36477c24 1583
c5df3096
Z
1584/*
1585=for apidoc Am|OP *|die|const char *pat|...
1586
1587Behaves the same as L</croak>, except for the return type.
1588It should be used only where the C<OP *> return type is required.
1589The function never actually returns.
1590
1591=cut
1592*/
1593
c5be433b 1594#if defined(PERL_IMPLICIT_CONTEXT)
f8d5a522
DD
1595#ifdef _MSC_VER
1596# pragma warning( push )
1597# pragma warning( disable : 4646 ) /* warning C4646: function declared with
1598 __declspec(noreturn) has non-void return type */
1599# pragma warning( disable : 4645 ) /* warning C4645: function declared with
1600__declspec(noreturn) has a return statement */
1601#endif
cea2e8a9
GS
1602OP *
1603Perl_die_nocontext(const char* pat, ...)
a687059c 1604{
cea2e8a9 1605 dTHX;
a687059c 1606 va_list args;
cea2e8a9 1607 va_start(args, pat);
c5df3096 1608 vcroak(pat, &args);
e5964223 1609 NOT_REACHED; /* NOTREACHED */
cea2e8a9 1610 va_end(args);
117af67d 1611 NORETURN_FUNCTION_END;
cea2e8a9 1612}
f8d5a522
DD
1613#ifdef _MSC_VER
1614# pragma warning( pop )
1615#endif
c5be433b 1616#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1617
f8d5a522
DD
1618#ifdef _MSC_VER
1619# pragma warning( push )
1620# pragma warning( disable : 4646 ) /* warning C4646: function declared with
1621 __declspec(noreturn) has non-void return type */
1622# pragma warning( disable : 4645 ) /* warning C4645: function declared with
1623__declspec(noreturn) has a return statement */
1624#endif
cea2e8a9
GS
1625OP *
1626Perl_die(pTHX_ const char* pat, ...)
1627{
cea2e8a9
GS
1628 va_list args;
1629 va_start(args, pat);
c5df3096 1630 vcroak(pat, &args);
e5964223 1631 NOT_REACHED; /* NOTREACHED */
cea2e8a9 1632 va_end(args);
117af67d 1633 NORETURN_FUNCTION_END;
cea2e8a9 1634}
f8d5a522
DD
1635#ifdef _MSC_VER
1636# pragma warning( pop )
1637#endif
cea2e8a9 1638
c5df3096
Z
1639/*
1640=for apidoc Am|void|croak_sv|SV *baseex
1641
1642This is an XS interface to Perl's C<die> function.
1643
1644C<baseex> is the error message or object. If it is a reference, it
1645will be used as-is. Otherwise it is used as a string, and if it does
1646not end with a newline then it will be extended with some indication of
1647the current location in the code, as described for L</mess_sv>.
1648
1649The error message or object will be used as an exception, by default
1650returning control to the nearest enclosing C<eval>, but subject to
1651modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1652function never returns normally.
1653
1654To die with a simple string message, the L</croak> function may be
1655more convenient.
1656
1657=cut
1658*/
1659
c5be433b 1660void
c5df3096 1661Perl_croak_sv(pTHX_ SV *baseex)
cea2e8a9 1662{
c5df3096
Z
1663 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1664 PERL_ARGS_ASSERT_CROAK_SV;
1665 invoke_exception_hook(ex, FALSE);
1666 die_unwind(ex);
1667}
1668
1669/*
1670=for apidoc Am|void|vcroak|const char *pat|va_list *args
1671
1672This is an XS interface to Perl's C<die> function.
1673
1674C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1675argument list. These are used to generate a string message. If the
1676message does not end with a newline, then it will be extended with
1677some indication of the current location in the code, as described for
1678L</mess_sv>.
1679
1680The error message will be used as an exception, by default
1681returning control to the nearest enclosing C<eval>, but subject to
1682modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1683function never returns normally.
a687059c 1684
c5df3096
Z
1685For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1686(C<$@>) will be used as an error message or object instead of building an
1687error message from arguments. If you want to throw a non-string object,
1688or build an error message in an SV yourself, it is preferable to use
1689the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
5a844595 1690
c5df3096
Z
1691=cut
1692*/
1693
1694void
1695Perl_vcroak(pTHX_ const char* pat, va_list *args)
1696{
1697 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1698 invoke_exception_hook(ex, FALSE);
1699 die_unwind(ex);
a687059c
LW
1700}
1701
c5df3096
Z
1702/*
1703=for apidoc Am|void|croak|const char *pat|...
1704
1705This is an XS interface to Perl's C<die> function.
1706
1707Take a sprintf-style format pattern and argument list. These are used to
1708generate a string message. If the message does not end with a newline,
1709then it will be extended with some indication of the current location
1710in the code, as described for L</mess_sv>.
1711
1712The error message will be used as an exception, by default
1713returning control to the nearest enclosing C<eval>, but subject to
1714modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1715function never returns normally.
1716
1717For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1718(C<$@>) will be used as an error message or object instead of building an
1719error message from arguments. If you want to throw a non-string object,
1720or build an error message in an SV yourself, it is preferable to use
1721the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1722
1723=cut
1724*/
1725
c5be433b 1726#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1727void
cea2e8a9 1728Perl_croak_nocontext(const char *pat, ...)
a687059c 1729{
cea2e8a9 1730 dTHX;
a687059c 1731 va_list args;
cea2e8a9 1732 va_start(args, pat);
c5be433b 1733 vcroak(pat, &args);
e5964223 1734 NOT_REACHED; /* NOTREACHED */
cea2e8a9
GS
1735 va_end(args);
1736}
1737#endif /* PERL_IMPLICIT_CONTEXT */
1738
c5df3096
Z
1739void
1740Perl_croak(pTHX_ const char *pat, ...)
1741{
1742 va_list args;
1743 va_start(args, pat);
1744 vcroak(pat, &args);
e5964223 1745 NOT_REACHED; /* NOTREACHED */
c5df3096
Z
1746 va_end(args);
1747}
1748
954c1994 1749/*
6ad8f254
NC
1750=for apidoc Am|void|croak_no_modify
1751
1752Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
72d33970 1753terser object code than using C<Perl_croak>. Less code used on exception code
6ad8f254
NC
1754paths reduces CPU cache pressure.
1755
d8e47b5c 1756=cut
6ad8f254
NC
1757*/
1758
1759void
88772978 1760Perl_croak_no_modify(void)
6ad8f254 1761{
cb077ed2 1762 Perl_croak_nocontext( "%s", PL_no_modify);
6ad8f254
NC
1763}
1764
4cbe3a7d
DD
1765/* does not return, used in util.c perlio.c and win32.c
1766 This is typically called when malloc returns NULL.
1767*/
1768void
88772978 1769Perl_croak_no_mem(void)
4cbe3a7d
DD
1770{
1771 dTHX;
77c1c05b 1772
375ed12a
JH
1773 int fd = PerlIO_fileno(Perl_error_log);
1774 if (fd < 0)
1775 SETERRNO(EBADF,RMS_IFI);
1776 else {
1777 /* Can't use PerlIO to write as it allocates memory */
b469f1e0 1778 PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
375ed12a 1779 }
4cbe3a7d
DD
1780 my_exit(1);
1781}
1782
3d04513d
DD
1783/* does not return, used only in POPSTACK */
1784void
1785Perl_croak_popstack(void)
1786{
1787 dTHX;
1788 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1789 my_exit(1);
1790}
1791
6ad8f254 1792/*
c5df3096 1793=for apidoc Am|void|warn_sv|SV *baseex
ccfc67b7 1794
c5df3096 1795This is an XS interface to Perl's C<warn> function.
954c1994 1796
c5df3096
Z
1797C<baseex> is the error message or object. If it is a reference, it
1798will be used as-is. Otherwise it is used as a string, and if it does
1799not end with a newline then it will be extended with some indication of
1800the current location in the code, as described for L</mess_sv>.
9983fa3c 1801
c5df3096
Z
1802The error message or object will by default be written to standard error,
1803but this is subject to modification by a C<$SIG{__WARN__}> handler.
9983fa3c 1804
c5df3096
Z
1805To warn with a simple string message, the L</warn> function may be
1806more convenient.
954c1994
GS
1807
1808=cut
1809*/
1810
cea2e8a9 1811void
c5df3096 1812Perl_warn_sv(pTHX_ SV *baseex)
cea2e8a9 1813{
c5df3096
Z
1814 SV *ex = mess_sv(baseex, 0);
1815 PERL_ARGS_ASSERT_WARN_SV;
1816 if (!invoke_exception_hook(ex, TRUE))
1817 write_to_stderr(ex);
cea2e8a9
GS
1818}
1819
c5df3096
Z
1820/*
1821=for apidoc Am|void|vwarn|const char *pat|va_list *args
1822
1823This is an XS interface to Perl's C<warn> function.
1824
1825C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1826argument list. These are used to generate a string message. If the
1827message does not end with a newline, then it will be extended with
1828some indication of the current location in the code, as described for
1829L</mess_sv>.
1830
1831The error message or object will by default be written to standard error,
1832but this is subject to modification by a C<$SIG{__WARN__}> handler.
1833
1834Unlike with L</vcroak>, C<pat> is not permitted to be null.
1835
1836=cut
1837*/
1838
c5be433b
GS
1839void
1840Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1841{
c5df3096 1842 SV *ex = vmess(pat, args);
7918f24d 1843 PERL_ARGS_ASSERT_VWARN;
c5df3096
Z
1844 if (!invoke_exception_hook(ex, TRUE))
1845 write_to_stderr(ex);
1846}
7918f24d 1847
c5df3096
Z
1848/*
1849=for apidoc Am|void|warn|const char *pat|...
87582a92 1850
c5df3096
Z
1851This is an XS interface to Perl's C<warn> function.
1852
1853Take a sprintf-style format pattern and argument list. These are used to
1854generate a string message. If the message does not end with a newline,
1855then it will be extended with some indication of the current location
1856in the code, as described for L</mess_sv>.
1857
1858The error message or object will by default be written to standard error,
1859but this is subject to modification by a C<$SIG{__WARN__}> handler.
1860
1861Unlike with L</croak>, C<pat> is not permitted to be null.
1862
1863=cut
1864*/
8d063cd8 1865
c5be433b 1866#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1867void
1868Perl_warn_nocontext(const char *pat, ...)
1869{
1870 dTHX;
1871 va_list args;
7918f24d 1872 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
cea2e8a9 1873 va_start(args, pat);
c5be433b 1874 vwarn(pat, &args);
cea2e8a9
GS
1875 va_end(args);
1876}
1877#endif /* PERL_IMPLICIT_CONTEXT */
1878
1879void
1880Perl_warn(pTHX_ const char *pat, ...)
1881{
1882 va_list args;
7918f24d 1883 PERL_ARGS_ASSERT_WARN;
cea2e8a9 1884 va_start(args, pat);
c5be433b 1885 vwarn(pat, &args);
cea2e8a9
GS
1886 va_end(args);
1887}
1888
c5be433b
GS
1889#if defined(PERL_IMPLICIT_CONTEXT)
1890void
1891Perl_warner_nocontext(U32 err, const char *pat, ...)
1892{
27da23d5 1893 dTHX;
c5be433b 1894 va_list args;
7918f24d 1895 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
c5be433b
GS
1896 va_start(args, pat);
1897 vwarner(err, pat, &args);
1898 va_end(args);
1899}
1900#endif /* PERL_IMPLICIT_CONTEXT */
1901
599cee73 1902void
9b387841
NC
1903Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1904{
1905 PERL_ARGS_ASSERT_CK_WARNER_D;
1906
1907 if (Perl_ckwarn_d(aTHX_ err)) {
1908 va_list args;
1909 va_start(args, pat);
1910 vwarner(err, pat, &args);
1911 va_end(args);
1912 }
1913}
1914
1915void
a2a5de95
NC
1916Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1917{
1918 PERL_ARGS_ASSERT_CK_WARNER;
1919
1920 if (Perl_ckwarn(aTHX_ err)) {
1921 va_list args;
1922 va_start(args, pat);
1923 vwarner(err, pat, &args);
1924 va_end(args);
1925 }
1926}
1927
1928void
864dbfa3 1929Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM
1930{
1931 va_list args;
7918f24d 1932 PERL_ARGS_ASSERT_WARNER;
c5be433b
GS
1933 va_start(args, pat);
1934 vwarner(err, pat, &args);
1935 va_end(args);
1936}
1937
1938void
1939Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1940{
27da23d5 1941 dVAR;
7918f24d 1942 PERL_ARGS_ASSERT_VWARNER;
46b27d2f
LM
1943 if (
1944 (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
1945 !(PL_in_eval & EVAL_KEEPERR)
1946 ) {
a3b680e6 1947 SV * const msv = vmess(pat, args);
599cee73 1948
594b6fac
LM
1949 if (PL_parser && PL_parser->error_count) {
1950 qerror(msv);
1951 }
1952 else {
1953 invoke_exception_hook(msv, FALSE);
1954 die_unwind(msv);
1955 }
599cee73
PM
1956 }
1957 else {
d13b0d77 1958 Perl_vwarn(aTHX_ pat, args);
599cee73
PM
1959 }
1960}
1961
f54ba1c2
DM
1962/* implements the ckWARN? macros */
1963
1964bool
1965Perl_ckwarn(pTHX_ U32 w)
1966{
ad287e37 1967 /* If lexical warnings have not been set, use $^W. */
3c3f8cd6
AB
1968 if (isLEXWARN_off)
1969 return PL_dowarn & G_WARN_ON;
ad287e37 1970
26c7b074 1971 return ckwarn_common(w);
f54ba1c2
DM
1972}
1973
1974/* implements the ckWARN?_d macro */
1975
1976bool
1977Perl_ckwarn_d(pTHX_ U32 w)
1978{
ad287e37 1979 /* If lexical warnings have not been set then default classes warn. */
3c3f8cd6
AB
1980 if (isLEXWARN_off)
1981 return TRUE;
ad287e37 1982
26c7b074
NC
1983 return ckwarn_common(w);
1984}
1985
1986static bool
1987S_ckwarn_common(pTHX_ U32 w)
1988{
3c3f8cd6
AB
1989 if (PL_curcop->cop_warnings == pWARN_ALL)
1990 return TRUE;
ad287e37
NC
1991
1992 if (PL_curcop->cop_warnings == pWARN_NONE)
1993 return FALSE;
1994
98fe6610
NC
1995 /* Check the assumption that at least the first slot is non-zero. */
1996 assert(unpackWARN1(w));
1997
1998 /* Check the assumption that it is valid to stop as soon as a zero slot is
1999 seen. */
2000 if (!unpackWARN2(w)) {
2001 assert(!unpackWARN3(w));
2002 assert(!unpackWARN4(w));
2003 } else if (!unpackWARN3(w)) {
2004 assert(!unpackWARN4(w));
2005 }
2006
26c7b074
NC
2007 /* Right, dealt with all the special cases, which are implemented as non-
2008 pointers, so there is a pointer to a real warnings mask. */
98fe6610
NC
2009 do {
2010 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2011 return TRUE;
2012 } while (w >>= WARNshift);
2013
2014 return FALSE;
f54ba1c2
DM
2015}
2016
72dc9ed5
NC
2017/* Set buffer=NULL to get a new one. */
2018STRLEN *
8ee4cf24 2019Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
72dc9ed5 2020 STRLEN size) {
5af88345
FC
2021 const MEM_SIZE len_wanted =
2022 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
35da51f7 2023 PERL_UNUSED_CONTEXT;
7918f24d 2024 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
72dc9ed5 2025
10edeb5d
JH
2026 buffer = (STRLEN*)
2027 (specialWARN(buffer) ?
2028 PerlMemShared_malloc(len_wanted) :
2029 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC
2030 buffer[0] = size;
2031 Copy(bits, (buffer + 1), size, char);
5af88345
FC
2032 if (size < WARNsize)
2033 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
72dc9ed5
NC
2034 return buffer;
2035}
f54ba1c2 2036
e6587932
DM
2037/* since we've already done strlen() for both nam and val
2038 * we can use that info to make things faster than
2039 * sprintf(s, "%s=%s", nam, val)
2040 */
2041#define my_setenv_format(s, nam, nlen, val, vlen) \
2042 Copy(nam, s, nlen, char); \
2043 *(s+nlen) = '='; \
2044 Copy(val, s+(nlen+1), vlen, char); \
2045 *(s+(nlen+1+vlen)) = '\0'
2046
c5d12488
JH
2047#ifdef USE_ENVIRON_ARRAY
2048 /* VMS' my_setenv() is in vms.c */
2049#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 2050void
e1ec3a88 2051Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 2052{
27da23d5 2053 dVAR;
4efc5df6
GS
2054#ifdef USE_ITHREADS
2055 /* only parent thread can modify process environment */
2056 if (PL_curinterp == aTHX)
2057#endif
2058 {
f2517201 2059#ifndef PERL_USE_SAFE_PUTENV
50acdf95 2060 if (!PL_use_safe_putenv) {
b7d87861
JH
2061 /* most putenv()s leak, so we manipulate environ directly */
2062 I32 i;
2063 const I32 len = strlen(nam);
2064 int nlen, vlen;
2065
2066 /* where does it go? */
2067 for (i = 0; environ[i]; i++) {
2068 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2069 break;
2070 }
c5d12488 2071
b7d87861
JH
2072 if (environ == PL_origenviron) { /* need we copy environment? */
2073 I32 j;
2074 I32 max;
2075 char **tmpenv;
2076
2077 max = i;
2078 while (environ[max])
2079 max++;
2080 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2081 for (j=0; j<max; j++) { /* copy environment */
2082 const int len = strlen(environ[j]);
2083 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2084 Copy(environ[j], tmpenv[j], len+1, char);
2085 }
2086 tmpenv[max] = NULL;
2087 environ = tmpenv; /* tell exec where it is now */
2088 }
2089 if (!val) {
2090 safesysfree(environ[i]);
2091 while (environ[i]) {
2092 environ[i] = environ[i+1];
2093 i++;
2094 }
2095 return;
2096 }
2097 if (!environ[i]) { /* does not exist yet */
2098 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2099 environ[i+1] = NULL; /* make sure it's null terminated */
2100 }
2101 else
2102 safesysfree(environ[i]);
2103 nlen = strlen(nam);
2104 vlen = strlen(val);
2105
2106 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2107 /* all that work just for this */
2108 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95 2109 } else {
c5d12488 2110# endif
235c1d5f
AD
2111 /* This next branch should only be called #if defined(HAS_SETENV), but
2112 Configure doesn't test for that yet. For Solaris, setenv() and unsetenv()
2113 were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
2114 */
2115# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV))
88f5bc07
AB
2116# if defined(HAS_UNSETENV)
2117 if (val == NULL) {
2118 (void)unsetenv(nam);
2119 } else {
2120 (void)setenv(nam, val, 1);
2121 }
2122# else /* ! HAS_UNSETENV */
2123 (void)setenv(nam, val, 1);
2124# endif /* HAS_UNSETENV */
47dafe4d 2125# else
88f5bc07
AB
2126# if defined(HAS_UNSETENV)
2127 if (val == NULL) {
ba88ff58
MJ
2128 if (environ) /* old glibc can crash with null environ */
2129 (void)unsetenv(nam);
88f5bc07 2130 } else {
c4420975
AL
2131 const int nlen = strlen(nam);
2132 const int vlen = strlen(val);
2133 char * const new_env =
88f5bc07
AB
2134 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2135 my_setenv_format(new_env, nam, nlen, val, vlen);
2136 (void)putenv(new_env);
2137 }
2138# else /* ! HAS_UNSETENV */
2139 char *new_env;
c4420975
AL
2140 const int nlen = strlen(nam);
2141 int vlen;
88f5bc07
AB
2142 if (!val) {
2143 val = "";
2144 }
2145 vlen = strlen(val);
2146 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2147 /* all that work just for this */
2148 my_setenv_format(new_env, nam, nlen, val, vlen);
2149 (void)putenv(new_env);
2150# endif /* HAS_UNSETENV */
47dafe4d 2151# endif /* __CYGWIN__ */
50acdf95
MS
2152#ifndef PERL_USE_SAFE_PUTENV
2153 }
2154#endif
4efc5df6 2155 }
8d063cd8
LW
2156}
2157
c5d12488 2158#else /* WIN32 || NETWARE */
68dc0745
PP
2159
2160void
72229eff 2161Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 2162{
27da23d5 2163 dVAR;
eb578fdb 2164 char *envstr;
c5d12488
JH
2165 const int nlen = strlen(nam);
2166 int vlen;
e6587932 2167
c5d12488
JH
2168 if (!val) {
2169 val = "";
ac5c734f 2170 }
c5d12488
JH
2171 vlen = strlen(val);
2172 Newx(envstr, nlen+vlen+2, char);
2173 my_setenv_format(envstr, nam, nlen, val, vlen);
2174 (void)PerlEnv_putenv(envstr);
2175 Safefree(envstr);
3e3baf6d
TB
2176}
2177
c5d12488 2178#endif /* WIN32 || NETWARE */
3e3baf6d 2179
739a0b84 2180#endif /* !VMS */
378cc40b 2181
16d20bd9 2182#ifdef UNLINK_ALL_VERSIONS
79072805 2183I32
6e732051 2184Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 2185{
35da51f7 2186 I32 retries = 0;
378cc40b 2187
7918f24d
NC
2188 PERL_ARGS_ASSERT_UNLNK;
2189
35da51f7
AL
2190 while (PerlLIO_unlink(f) >= 0)
2191 retries++;
2192 return retries ? 0 : -1;
378cc40b
LW
2193}
2194#endif
2195
7a3f2258 2196/* this is a drop-in replacement for bcopy() */
2253333f 2197#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 2198char *
5aaab254 2199Perl_my_bcopy(const char *from, char *to, I32 len)
378cc40b 2200{
2d03de9c 2201 char * const retval = to;
378cc40b 2202
7918f24d
NC
2203 PERL_ARGS_ASSERT_MY_BCOPY;
2204
223f01db
KW
2205 assert(len >= 0);
2206
7c0587c8
LW
2207 if (from - to >= 0) {
2208 while (len--)
2209 *to++ = *from++;
2210 }
2211 else {
2212 to += len;
2213 from += len;
2214 while (len--)
faf8582f 2215 *(--to) = *(--from);
7c0587c8 2216 }
378cc40b
LW
2217 return retval;
2218}
ffed7fef 2219#endif
378cc40b 2220
7a3f2258 2221/* this is a drop-in replacement for memset() */
fc36a67e
PP
2222#ifndef HAS_MEMSET
2223void *
5aaab254 2224Perl_my_memset(char *loc, I32 ch, I32 len)
fc36a67e 2225{
2d03de9c 2226 char * const retval = loc;
fc36a67e 2227
7918f24d
NC
2228 PERL_ARGS_ASSERT_MY_MEMSET;
2229
223f01db
KW
2230 assert(len >= 0);
2231
fc36a67e
PP
2232 while (len--)
2233 *loc++ = ch;
2234 return retval;
2235}
2236#endif
2237
7a3f2258 2238/* this is a drop-in replacement for bzero() */
7c0587c8 2239#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 2240char *
5aaab254 2241Perl_my_bzero(char *loc, I32 len)
378cc40b 2242{
2d03de9c 2243 char * const retval = loc;
378cc40b 2244
7918f24d
NC
2245 PERL_ARGS_ASSERT_MY_BZERO;
2246
223f01db
KW
2247 assert(len >= 0);
2248
378cc40b
LW
2249 while (len--)
2250 *loc++ = 0;
2251 return retval;
2252}
2253#endif
7c0587c8 2254
7a3f2258 2255/* this is a drop-in replacement for memcmp() */
36477c24 2256#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 2257I32
5aaab254 2258Perl_my_memcmp(const char *s1, const char *s2, I32 len)
7c0587c8 2259{
eb578fdb
KW
2260 const U8 *a = (const U8 *)s1;
2261 const U8 *b = (const U8 *)s2;
2262 I32 tmp;
7c0587c8 2263
7918f24d
NC
2264 PERL_ARGS_ASSERT_MY_MEMCMP;
2265
223f01db
KW
2266 assert(len >= 0);
2267
7c0587c8 2268 while (len--) {
27da23d5 2269 if ((tmp = *a++ - *b++))
7c0587c8
LW
2270 return tmp;
2271 }
2272 return 0;
2273}
36477c24 2274#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 2275
fe14fcc3 2276#ifndef HAS_VPRINTF
d05d9be5
AD
2277/* This vsprintf replacement should generally never get used, since
2278 vsprintf was available in both System V and BSD 2.11. (There may
2279 be some cross-compilation or embedded set-ups where it is needed,
2280 however.)
2281
2282 If you encounter a problem in this function, it's probably a symptom
2283 that Configure failed to detect your system's vprintf() function.
2284 See the section on "item vsprintf" in the INSTALL file.
2285
2286 This version may compile on systems with BSD-ish <stdio.h>,
2287 but probably won't on others.
2288*/
a687059c 2289
85e6fe83 2290#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2291char *
2292#else
2293int
2294#endif
d05d9be5 2295vsprintf(char *dest, const char *pat, void *args)
a687059c
LW
2296{
2297 FILE fakebuf;
2298
d05d9be5
AD
2299#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2300 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2301 FILE_cnt(&fakebuf) = 32767;
2302#else
2303 /* These probably won't compile -- If you really need
2304 this, you'll have to figure out some other method. */
a687059c
LW
2305 fakebuf._ptr = dest;
2306 fakebuf._cnt = 32767;
d05d9be5 2307#endif
35c8bce7
LW
2308#ifndef _IOSTRG
2309#define _IOSTRG 0
2310#endif
a687059c
LW
2311 fakebuf._flag = _IOWRT|_IOSTRG;
2312 _doprnt(pat, args, &fakebuf); /* what a kludge */
d05d9be5
AD
2313#if defined(STDIO_PTR_LVALUE)
2314 *(FILE_ptr(&fakebuf)++) = '\0';
2315#else
2316 /* PerlIO has probably #defined away fputc, but we want it here. */
2317# ifdef fputc
2318# undef fputc /* XXX Should really restore it later */
2319# endif
2320 (void)fputc('\0', &fakebuf);
2321#endif
85e6fe83 2322#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2323 return(dest);
2324#else
2325 return 0; /* perl doesn't use return value */
2326#endif
2327}
2328
fe14fcc3 2329#endif /* HAS_VPRINTF */
a687059c 2330
4a7d1889 2331PerlIO *
c9289b7b 2332Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
4a7d1889 2333{
739a0b84 2334#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
1f852d0d 2335 int p[2];
eb578fdb
KW
2336 I32 This, that;
2337 Pid_t pid;
1f852d0d
NIS
2338 SV *sv;
2339 I32 did_pipes = 0;
2340 int pp[2];
2341
7918f24d
NC
2342 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2343
1f852d0d
NIS
2344 PERL_FLUSHALL_FOR_CHILD;
2345 This = (*mode == 'w');
2346 that = !This;
284167a5 2347 if (TAINTING_get) {
1f852d0d
NIS
2348 taint_env();
2349 taint_proper("Insecure %s%s", "EXEC");
2350 }
2351 if (PerlProc_pipe(p) < 0)
4608196e 2352 return NULL;
1f852d0d
NIS
2353 /* Try for another pipe pair for error return */
2354 if (PerlProc_pipe(pp) >= 0)
2355 did_pipes = 1;
52e18b1f 2356 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS
2357 if (errno != EAGAIN) {
2358 PerlLIO_close(p[This]);
4e6dfe71 2359 PerlLIO_close(p[that]);
1f852d0d
NIS
2360 if (did_pipes) {
2361 PerlLIO_close(pp[0]);
2362 PerlLIO_close(pp[1]);
2363 }
4608196e 2364 return NULL;
1f852d0d 2365 }
a2a5de95 2366 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
1f852d0d
NIS
2367 sleep(5);
2368 }
2369 if (pid == 0) {
2370 /* Child */
1f852d0d
NIS
2371#undef THIS
2372#undef THAT
2373#define THIS that
2374#define THAT This
1f852d0d
NIS
2375 /* Close parent's end of error status pipe (if any) */
2376 if (did_pipes) {
2377 PerlLIO_close(pp[0]);
131d45a9 2378#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1f852d0d 2379 /* Close error pipe automatically if exec works */
375ed12a
JH
2380 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2381 return NULL;
1f852d0d
NIS
2382#endif
2383 }
2384 /* Now dup our end of _the_ pipe to right position */
2385 if (p[THIS] != (*mode == 'r')) {
2386 PerlLIO_dup2(p[THIS], *mode == 'r');
2387 PerlLIO_close(p[THIS]);
4e6dfe71
GS
2388 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2389 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2390 }
4e6dfe71
GS
2391 else
2392 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS
2393#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2394 /* No automatic close - do it by hand */
b7953727
JH
2395# ifndef NOFILE
2396# define NOFILE 20
2397# endif
a080fe3d
NIS
2398 {
2399 int fd;
2400
2401 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2402 if (fd != pp[1])
a080fe3d
NIS
2403 PerlLIO_close(fd);
2404 }
1f852d0d
NIS
2405 }
2406#endif
a0714e2c 2407 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS
2408 PerlProc__exit(1);
2409#undef THIS
2410#undef THAT
2411 }
2412 /* Parent */
52e18b1f 2413 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS
2414 if (did_pipes)
2415 PerlLIO_close(pp[1]);
2416 /* Keep the lower of the two fd numbers */
2417 if (p[that] < p[This]) {
2418 PerlLIO_dup2(p[This], p[that]);
2419 PerlLIO_close(p[This]);
2420 p[This] = p[that];
2421 }
4e6dfe71
GS
2422 else
2423 PerlLIO_close(p[that]); /* close child's end of pipe */
2424
1f852d0d 2425 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2426 SvUPGRADE(sv,SVt_IV);
45977657 2427 SvIV_set(sv, pid);
1f852d0d
NIS
2428 PL_forkprocess = pid;
2429 /* If we managed to get status pipe check for exec fail */
2430 if (did_pipes && pid > 0) {
2431 int errkid;
bb7a0f54
MHM
2432 unsigned n = 0;
2433 SSize_t n1;
1f852d0d
NIS
2434
2435 while (n < sizeof(int)) {
2436 n1 = PerlLIO_read(pp[0],
2437 (void*)(((char*)&errkid)+n),
2438 (sizeof(int)) - n);
2439 if (n1 <= 0)
2440 break;
2441 n += n1;
2442 }
2443 PerlLIO_close(pp[0]);
2444 did_pipes = 0;
2445 if (n) { /* Error */
2446 int pid2, status;
8c51524e 2447 PerlLIO_close(p[This]);
1f852d0d 2448 if (n != sizeof(int))
5637ef5b 2449 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
1f852d0d
NIS
2450 do {
2451 pid2 = wait4pid(pid, &status, 0);
2452 } while (pid2 == -1 && errno == EINTR);
2453 errno = errkid; /* Propagate errno from kid */
4608196e 2454 return NULL;
1f852d0d
NIS
2455 }
2456 }
2457 if (did_pipes)
2458 PerlLIO_close(pp[0]);
2459 return PerlIO_fdopen(p[This], mode);
2460#else
8492b23f 2461# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
4e205ed6 2462 return my_syspopen4(aTHX_ NULL, mode, n, args);
8492b23f
TC
2463# elif defined(WIN32)
2464 return win32_popenlist(mode, n, args);
9d419b5f 2465# else
4a7d1889
NIS
2466 Perl_croak(aTHX_ "List form of piped open not implemented");
2467 return (PerlIO *) NULL;
9d419b5f 2468# endif
1f852d0d 2469#endif
4a7d1889
NIS
2470}
2471
5f05dabc 2472 /* VMS' my_popen() is in VMS.c, same with OS/2. */
739a0b84 2473#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
760ac839 2474PerlIO *
3dd43144 2475Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c
LW
2476{
2477 int p[2];
eb578fdb
KW
2478 I32 This, that;
2479 Pid_t pid;
79072805 2480 SV *sv;
bfce84ec 2481 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ
2482 I32 did_pipes = 0;
2483 int pp[2];
a687059c 2484
7918f24d
NC
2485 PERL_ARGS_ASSERT_MY_POPEN;
2486
45bc9206 2487 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ
2488#ifdef OS2
2489 if (doexec) {
23da6c43 2490 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2491 }
a1d180c4 2492#endif
8ac85365
NIS
2493 This = (*mode == 'w');
2494 that = !This;
284167a5 2495 if (doexec && TAINTING_get) {
bbce6d69
PP
2496 taint_env();
2497 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2498 }
c2267164 2499 if (PerlProc_pipe(p) < 0)
4608196e 2500 return NULL;
e446cec8
IZ
2501 if (doexec && PerlProc_pipe(pp) >= 0)
2502 did_pipes = 1;
52e18b1f 2503 while ((pid = PerlProc_fork()) < 0) {
a687059c 2504 if (errno != EAGAIN) {
6ad3d225 2505 PerlLIO_close(p[This]);
b5ac89c3 2506 PerlLIO_close(p[that]);
e446cec8
IZ
2507 if (did_pipes) {
2508 PerlLIO_close(pp[0]);
2509 PerlLIO_close(pp[1]);
2510 }
a687059c 2511 if (!doexec)
b3647a36 2512 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2513 return NULL;
a687059c 2514 }
a2a5de95 2515 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW
2516 sleep(5);
2517 }
2518 if (pid == 0) {
79072805 2519
30ac6d9b
GS
2520#undef THIS
2521#undef THAT
a687059c 2522#define THIS that
8ac85365 2523#define THAT This
e446cec8
IZ
2524 if (did_pipes) {
2525 PerlLIO_close(pp[0]);
2526#if defined(HAS_FCNTL) && defined(F_SETFD)
375ed12a
JH
2527 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2528 return NULL;
e446cec8
IZ
2529#endif
2530 }
a687059c 2531 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS
2532 PerlLIO_dup2(p[THIS], *mode == 'r');
2533 PerlLIO_close(p[THIS]);
b5ac89c3
NIS
2534 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2535 PerlLIO_close(p[THAT]);
a687059c 2536 }
b5ac89c3
NIS
2537 else
2538 PerlLIO_close(p[THAT]);
4435c477 2539#ifndef OS2
a687059c 2540 if (doexec) {
a0d0e21e 2541#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
2542#ifndef NOFILE
2543#define NOFILE 20
2544#endif
a080fe3d 2545 {
3aed30dc 2546 int fd;
a080fe3d
NIS
2547
2548 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2549 if (fd != pp[1])
3aed30dc 2550 PerlLIO_close(fd);
a080fe3d 2551 }
ae986130 2552#endif
a080fe3d
NIS
2553 /* may or may not use the shell */
2554 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2555 PerlProc__exit(1);
a687059c 2556 }
4435c477 2557#endif /* defined OS2 */
713cef20
IZ
2558
2559#ifdef PERLIO_USING_CRLF
2560 /* Since we circumvent IO layers when we manipulate low-level
2561 filedescriptors directly, need to manually switch to the
2562 default, binary, low-level mode; see PerlIOBuf_open(). */
2563 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2564#endif
3280af22 2565 PL_forkprocess = 0;
ca0c25f6 2566#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2567 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2568#endif
4608196e 2569 return NULL;
a687059c
LW
2570#undef THIS
2571#undef THAT
2572 }
b5ac89c3 2573 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ
2574 if (did_pipes)
2575 PerlLIO_close(pp[1]);
8ac85365 2576 if (p[that] < p[This]) {
6ad3d225
GS
2577 PerlLIO_dup2(p[This], p[that]);
2578 PerlLIO_close(p[This]);
8ac85365 2579 p[This] = p[that];
62b28dd9 2580 }
b5ac89c3
NIS
2581 else
2582 PerlLIO_close(p[that]);
2583
3280af22 2584 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2585 SvUPGRADE(sv,SVt_IV);
45977657 2586 SvIV_set(sv, pid);
3280af22 2587 PL_forkprocess = pid;
e446cec8
IZ
2588 if (did_pipes && pid > 0) {
2589 int errkid;
bb7a0f54
MHM
2590 unsigned n = 0;
2591 SSize_t n1;
e446cec8
IZ
2592
2593 while (n < sizeof(int)) {
2594 n1 = PerlLIO_read(pp[0],
2595 (void*)(((char*)&errkid)+n),
2596 (sizeof(int)) - n);
2597 if (n1 <= 0)
2598 break;
2599 n += n1;
2600 }
2f96c702
IZ
2601 PerlLIO_close(pp[0]);
2602 did_pipes = 0;
e446cec8 2603 if (n) { /* Error */
faa466a7 2604 int pid2, status;
8c51524e 2605 PerlLIO_close(p[This]);
e446cec8 2606 if (n != sizeof(int))
5637ef5b 2607 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
faa466a7
RG
2608 do {
2609 pid2 = wait4pid(pid, &status, 0);
2610 } while (pid2 == -1 && errno == EINTR);
e446cec8 2611 errno = errkid; /* Propagate errno from kid */
4608196e 2612 return NULL;
e446cec8
IZ
2613 }
2614 }
2615 if (did_pipes)
2616 PerlLIO_close(pp[0]);
8ac85365 2617 return PerlIO_fdopen(p[This], mode);
a687059c 2618}
7c0587c8 2619#else
2b96b0a5
JH
2620#if defined(DJGPP)
2621FILE *djgpp_popen();
2622PerlIO *
cef6ea9d 2623Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH
2624{
2625 PERL_FLUSHALL_FOR_CHILD;
2626 /* Call system's popen() to get a FILE *, then import it.
2627 used 0 for 2nd parameter to PerlIO_importFILE;
2628 apparently not used
2629 */
2630 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2631}
9c12f1e5
RGS
2632#else
2633#if defined(__LIBCATAMOUNT__)
2634PerlIO *
2635Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2636{
2637 return NULL;
2638}
2639#endif
2b96b0a5 2640#endif
7c0587c8
LW
2641
2642#endif /* !DOSISH */
a687059c 2643
52e18b1f
GS
2644/* this is called in parent before the fork() */
2645void
2646Perl_atfork_lock(void)
2647{
3db8f154 2648#if defined(USE_ITHREADS)
20b7effb 2649 dVAR;
52e18b1f 2650 /* locks must be held in locking order (if any) */
4da80956
P
2651# ifdef USE_PERLIO
2652 MUTEX_LOCK(&PL_perlio_mutex);
2653# endif
52e18b1f
GS
2654# ifdef MYMALLOC
2655 MUTEX_LOCK(&PL_malloc_mutex);
2656# endif
2657 OP_REFCNT_LOCK;
2658#endif
2659}
2660
2661/* this is called in both parent and child after the fork() */
2662void
2663Perl_atfork_unlock(void)
2664{
3db8f154 2665#if defined(USE_ITHREADS)
20b7effb 2666 dVAR;
52e18b1f 2667 /* locks must be released in same order as in atfork_lock() */
4da80956
P
2668# ifdef USE_PERLIO
2669 MUTEX_UNLOCK(&PL_perlio_mutex);
2670# endif
52e18b1f
GS
2671# ifdef MYMALLOC
2672 MUTEX_UNLOCK(&PL_malloc_mutex);
2673# endif
2674 OP_REFCNT_UNLOCK;
2675#endif
2676}
2677
2678Pid_t
2679Perl_my_fork(void)
2680{
2681#if defined(HAS_FORK)
2682 Pid_t pid;
3db8f154 2683#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS
2684 atfork_lock();
2685 pid = fork();
2686 atfork_unlock();
2687#else
2688 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2689 * handlers elsewhere in the code */
2690 pid = fork();
2691#endif
2692 return pid;
2693#else
2694 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2695 Perl_croak_nocontext("fork() not available");
b961a566 2696 return 0;
52e18b1f
GS
2697#endif /* HAS_FORK */
2698}
2699
fe14fcc3 2700#ifndef HAS_DUP2
fec02dd3 2701int
ba106d47 2702dup2(int oldfd, int newfd)
a687059c 2703{
a0d0e21e 2704#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
2705 if (oldfd == newfd)
2706 return oldfd;
6ad3d225 2707 PerlLIO_close(newfd);
fec02dd3 2708 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2709#else
fc36a67e
PP
2710#define DUP2_MAX_FDS 256
2711 int fdtmp[DUP2_MAX_FDS];
79072805 2712 I32 fdx = 0;
ae986130
LW
2713 int fd;
2714
fe14fcc3 2715 if (oldfd == newfd)
fec02dd3 2716 return oldfd;
6ad3d225 2717 PerlLIO_close(newfd);
fc36a67e 2718 /* good enough for low fd's... */
6ad3d225 2719 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2720 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2721 PerlLIO_close(fd);
fc36a67e
PP
2722 fd = -1;
2723 break;
2724 }
ae986130 2725 fdtmp[fdx++] = fd;
fc36a67e 2726 }
ae986130 2727 while (fdx > 0)
6ad3d225 2728 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2729 return fd;
62b28dd9 2730#endif
a687059c
LW
2731}
2732#endif
2733
64ca3a65 2734#ifndef PERL_MICRO
ff68c719
PP
2735#ifdef HAS_SIGACTION
2736
2737Sighandler_t
864dbfa3 2738Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719
PP
2739{
2740 struct sigaction act, oact;
2741
a10b1e10 2742#ifdef USE_ITHREADS
20b7effb 2743 dVAR;
a10b1e10
JH
2744 /* only "parent" interpreter can diddle signals */
2745 if (PL_curinterp != aTHX)
8aad04aa 2746 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2747#endif
2748
8aad04aa 2749 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2750 sigemptyset(&act.sa_mask);
2751 act.sa_flags = 0;
2752#ifdef SA_RESTART
4ffa73a3
JH
2753 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2754 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2755#endif
358837b8 2756#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2757 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2758 act.sa_flags |= SA_NOCLDWAIT;
2759#endif
ff68c719 2760 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2761 return (Sighandler_t) SIG_ERR;
ff68c719 2762 else
8aad04aa 2763 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2764}
2765
2766Sighandler_t
864dbfa3 2767Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
2768{
2769 struct sigaction oact;
96a5add6 2770 PERL_UNUSED_CONTEXT;
ff68c719
PP
2771
2772 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2773 return (Sighandler_t) SIG_ERR;
ff68c719 2774 else
8aad04aa 2775 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2776}
2777
2778int
864dbfa3 2779Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2780{
20b7effb 2781#ifdef USE_ITHREADS
27da23d5 2782 dVAR;
20b7effb 2783#endif
ff68c719
PP
2784 struct sigaction act;
2785
7918f24d
NC
2786 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2787
a10b1e10
JH
2788#ifdef USE_ITHREADS
2789 /* only "parent" interpreter can diddle signals */
2790 if (PL_curinterp != aTHX)
2791 return -1;
2792#endif
2793
8aad04aa 2794 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2795 sigemptyset(&act.sa_mask);
2796 act.sa_flags = 0;
2797#ifdef SA_RESTART
4ffa73a3
JH
2798 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2799 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2800#endif
36b5d377 2801#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2802 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2803 act.sa_flags |= SA_NOCLDWAIT;
2804#endif
ff68c719
PP
2805 return sigaction(signo, &act, save);
2806}
2807
2808int
864dbfa3 2809Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2810{
20b7effb 2811#ifdef USE_ITHREADS
27da23d5 2812 dVAR;
20b7effb
JH
2813#endif
2814 PERL_UNUSED_CONTEXT;
a10b1e10
JH
2815#ifdef USE_ITHREADS
2816 /* only "parent" interpreter can diddle signals */
2817 if (PL_curinterp != aTHX)
2818 return -1;
2819#endif
2820
ff68c719
PP
2821 return sigaction(signo, save, (struct sigaction *)NULL);
2822}
2823
2824#else /* !HAS_SIGACTION */
2825
2826Sighandler_t
864dbfa3 2827Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2828{
39f1703b 2829#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2830 /* only "parent" interpreter can diddle signals */
2831 if (PL_curinterp != aTHX)
8aad04aa 2832 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2833#endif
2834
6ad3d225 2835 return PerlProc_signal(signo, handler);
ff68c719
PP
2836}
2837
fabdb6c0 2838static Signal_t
4e35701f 2839sig_trap(int signo)
ff68c719 2840{
27da23d5
JH
2841 dVAR;
2842 PL_sig_trapped++;
ff68c719
PP
2843}
2844
2845Sighandler_t
864dbfa3 2846Perl_rsignal_state(pTHX_ int signo)
ff68c719 2847{
27da23d5 2848 dVAR;
ff68c719
PP
2849 Sighandler_t oldsig;
2850
39f1703b 2851#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2852 /* only "parent" interpreter can diddle signals */
2853 if (PL_curinterp != aTHX)
8aad04aa 2854 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2855#endif
2856
27da23d5 2857 PL_sig_trapped = 0;
6ad3d225
GS
2858 oldsig = PerlProc_signal(signo, sig_trap);
2859 PerlProc_signal(signo, oldsig);
27da23d5 2860 if (PL_sig_trapped)
3aed30dc 2861 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719
PP
2862 return oldsig;
2863}
2864
2865int
864dbfa3 2866Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2867{
39f1703b 2868#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2869 /* only "parent" interpreter can diddle signals */
2870 if (PL_curinterp != aTHX)
2871 return -1;
2872#endif
6ad3d225 2873 *save = PerlProc_signal(signo, handler);
8aad04aa 2874 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
2875}
2876
2877int
864dbfa3 2878Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2879{
39f1703b 2880#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2881 /* only "parent" interpreter can diddle signals */
2882 if (PL_curinterp != aTHX)
2883 return -1;
2884#endif
8aad04aa 2885 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
2886}
2887
2888#endif /* !HAS_SIGACTION */
64ca3a65 2889#endif /* !PERL_MICRO */
ff68c719 2890
5f05dabc 2891 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
739a0b84 2892#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
79072805 2893I32
864dbfa3 2894Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2895{
a687059c 2896 int status;
a0d0e21e 2897 SV **svp;
d8a83dd3 2898 Pid_t pid;
2e0cfa16 2899 Pid_t pid2 = 0;
03136e13 2900 bool close_failed;
4ee39169 2901 dSAVEDERRNO;
2e0cfa16 2902 const int fd = PerlIO_fileno(ptr);
e9d373c4
TC
2903 bool should_wait;
2904
2905 svp = av_fetch(PL_fdpid,fd,TRUE);
2906 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2907 SvREFCNT_dec(*svp);
2908 *svp = NULL;
2e0cfa16 2909
97cb92d6 2910#if defined(USE_PERLIO)
2e0cfa16
FC
2911 /* Find out whether the refcount is low enough for us to wait for the
2912 child proc without blocking. */
e9d373c4 2913 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
b6ae43b7 2914#else
e9d373c4 2915 should_wait = pid > 0;
b6ae43b7 2916#endif
a687059c 2917
ddcf38b7
IZ
2918#ifdef OS2
2919 if (pid == -1) { /* Opened by popen. */
2920 return my_syspclose(ptr);
2921 }
a1d180c4 2922#endif
f1618b10
CS
2923 close_failed = (PerlIO_close(ptr) == EOF);
2924 SAVE_ERRNO;
2e0cfa16 2925 if (should_wait) do {
1d3434b8
GS
2926 pid2 = wait4pid(pid, &status, 0);
2927 } while (pid2 == -1 && errno == EINTR);
03136e13 2928 if (close_failed) {
4ee39169 2929 RESTORE_ERRNO;
03136e13
CS
2930 return -1;
2931 }
2e0cfa16
FC
2932 return(
2933 should_wait
2934 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2935 : 0
2936 );
20188a90 2937}
9c12f1e5
RGS
2938#else
2939#if defined(__LIBCATAMOUNT__)
2940I32
2941Perl_my_pclose(pTHX_ PerlIO *ptr)
2942{
2943 return -1;
2944}
2945#endif
4633a7c4
LW
2946#endif /* !DOSISH */
2947
e37778c2 2948#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 2949I32
d8a83dd3 2950Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2951{
27da23d5 2952 I32 result = 0;
7918f24d 2953 PERL_ARGS_ASSERT_WAIT4PID;
ca0c25f6 2954#ifdef PERL_USES_PL_PIDSTATUS
d4c02743
TC
2955 if (!pid) {
2956 /* PERL_USES_PL_PIDSTATUS is only defined when neither
2957 waitpid() nor wait4() is available, or on OS/2, which
2958 doesn't appear to support waiting for a progress group
2959 member, so we can only treat a 0 pid as an unknown child.
2960 */
2961 errno = ECHILD;
2962 return -1;
2963 }
b7953727 2964 {
3aed30dc 2965 if (pid > 0) {
12072db5
NC
2966 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2967 pid, rather than a string form. */
c4420975 2968 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS
2969 if (svp && *svp != &PL_sv_undef) {
2970 *statusp = SvIVX(*svp);
12072db5
NC
2971 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2972 G_DISCARD);
3aed30dc
HS
2973 return pid;
2974 }
2975 }
2976 else {
2977 HE *entry;
2978
2979 hv_iterinit(PL_pidstatus);
2980 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 2981 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 2982 I32 len;
0bcc34c2 2983 const char * const spid = hv_iterkey(entry,&len);
27da23d5 2984
12072db5
NC
2985 assert (len == sizeof(Pid_t));
2986 memcpy((char *)&pid, spid, len);
3aed30dc 2987 *statusp = SvIVX(sv);
7b9a3241
NC
2988 /* The hash iterator is currently on this entry, so simply
2989 calling hv_delete would trigger the lazy delete, which on
f6bab5f6 2990 aggregate does more work, because next call to hv_iterinit()
7b9a3241
NC
2991 would spot the flag, and have to call the delete routine,
2992 while in the meantime any new entries can't re-use that
2993 memory. */
2994 hv_iterinit(PL_pidstatus);
7ea75b61 2995 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS
2996 return pid;
2997 }
20188a90
LW
2998 }
2999 }
68a29c53 3000#endif
79072805 3001#ifdef HAS_WAITPID
367f3c24
IZ
3002# ifdef HAS_WAITPID_RUNTIME
3003 if (!HAS_WAITPID_RUNTIME)
3004 goto hard_way;
3005# endif
cddd4526 3006 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 3007 goto finish;
367f3c24
IZ
3008#endif
3009#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
d4c02743 3010 result = wait4(pid,statusp,flags,NULL);
dfcfdb64 3011 goto finish;
367f3c24 3012#endif
ca0c25f6 3013#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 3014#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 3015 hard_way:
27da23d5 3016#endif
a0d0e21e 3017 {
a0d0e21e 3018 if (flags)
cea2e8a9 3019 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 3020 else {
76e3520e 3021 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW
3022 pidgone(result,*statusp);
3023 if (result < 0)
3024 *statusp = -1;
3025 }
a687059c
LW
3026 }
3027#endif
27da23d5 3028#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 3029 finish:
27da23d5 3030#endif
cddd4526
NIS
3031 if (result < 0 && errno == EINTR) {
3032 PERL_ASYNC_CHECK();
48dbb59e 3033 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS
3034 }
3035 return result;
a687059c 3036}
2986a63f 3037#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 3038
ca0c25f6 3039#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 3040void
ed4173ef 3041S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 3042{
eb578fdb 3043 SV *sv;
a687059c 3044
12072db5 3045 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 3046 SvUPGRADE(sv,SVt_IV);
45977657 3047 SvIV_set(sv, status);
20188a90 3048 return;
a687059c 3049}
ca0c25f6 3050#endif
a687059c 3051
739a0b84 3052#if defined(OS2)
7c0587c8 3053int pclose();
ddcf38b7
IZ
3054#ifdef HAS_FORK
3055int /* Cannot prototype with I32
3056 in os2ish.h. */
ba106d47 3057my_syspclose(PerlIO *ptr)
ddcf38b7 3058#else
79072805 3059I32
864dbfa3 3060Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 3061#endif
a687059c 3062{
760ac839 3063 /* Needs work for PerlIO ! */
c4420975 3064 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 3065 const I32 result = pclose(f);
2b96b0a5
JH
3066 PerlIO_releaseFILE(ptr,f);
3067 return result;
3068}
3069#endif
3070
933fea7f 3071#if defined(DJGPP)
2b96b0a5
JH
3072int djgpp_pclose();
3073I32
3074Perl_my_pclose(pTHX_ PerlIO *ptr)
3075{
3076 /* Needs work for PerlIO ! */
c4420975 3077 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 3078 I32 result = djgpp_pclose(f);
933fea7f 3079 result = (result << 8) & 0xff00;
760ac839
LW
3080 PerlIO_releaseFILE(ptr,f);
3081 return result;
a687059c 3082}
7c0587c8 3083#endif
9f68db38 3084
16fa5c11 3085#define PERL_REPEATCPY_LINEAR 4
9f68db38 3086void
5aaab254 3087Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
9f68db38 3088{
7918f24d
NC
3089 PERL_ARGS_ASSERT_REPEATCPY;
3090
223f01db
KW
3091 assert(len >= 0);
3092
2709980d 3093 if (count < 0)
d1decf2b 3094 croak_memory_wrap();
2709980d 3095
16fa5c11
VP
3096 if (len == 1)
3097 memset(to, *from, count);
3098 else if (count) {
eb578fdb 3099 char *p = to;
26e1303d 3100 IV items, linear, half;
16fa5c11
VP
3101
3102 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3103 for (items = 0; items < linear; ++items) {
eb578fdb 3104 const char *q = from;
26e1303d 3105 IV todo;
16fa5c11
VP
3106 for (todo = len; todo > 0; todo--)
3107 *p++ = *q++;
3108 }
3109
3110 half = count / 2;
3111 while (items <= half) {
26e1303d 3112 IV size = items * len;
16fa5c11
VP
3113 memcpy(p, to, size);
3114 p += size;
3115 items *= 2;
9f68db38 3116 }
16fa5c11
VP
3117
3118 if (count > items)
3119 memcpy(p, to, (count - items) * len);
9f68db38
LW
3120 }
3121}
0f85fab0 3122
fe14fcc3 3123#ifndef HAS_RENAME
79072805 3124I32
4373e329 3125Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3126{
93a17b20
LW
3127 char *fa = strrchr(a,'/');
3128 char *fb = strrchr(b,'/');
c623ac67
GS
3129 Stat_t tmpstatbuf1;
3130 Stat_t tmpstatbuf2;
c4420975 3131 SV * const tmpsv = sv_newmortal();
62b28dd9 3132
7918f24d
NC
3133 PERL_ARGS_ASSERT_SAME_DIRENT;
3134
62b28dd9
LW
3135 if (fa)
3136 fa++;
3137 else
3138 fa = a;
3139 if (fb)
3140 fb++;
3141 else
3142 fb = b;
3143 if (strNE(a,b))
3144 return FALSE;
3145 if (fa == a)
76f68e9b 3146 sv_setpvs(tmpsv, ".");
62b28dd9 3147 else
46fc3d4c 3148 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3149 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
3150 return FALSE;
3151 if (fb == b)
76f68e9b 3152 sv_setpvs(tmpsv, ".");
62b28dd9 3153 else
46fc3d4c 3154 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3155 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
3156 return FALSE;
3157 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3158 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3159}
fe14fcc3
LW
3160#endif /* !HAS_RENAME */
3161
491527d0 3162char*
7f315aed
NC
3163Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3164 const char *const *const search_ext, I32 flags)
491527d0 3165{
bd61b366
SS
3166 const char *xfound = NULL;
3167 char *xfailed = NULL;
0f31cffe 3168 char tmpbuf[MAXPATHLEN];
eb578fdb 3169 char *s;
5f74f29c 3170 I32 len = 0;
491527d0 3171 int retval;
39a02377 3172 char *bufend;
7c458fae 3173#if defined(DOSISH) && !defined(OS2)
491527d0
GS
3174# define SEARCH_EXTS ".bat", ".cmd", NULL
3175# define MAX_EXT_LEN 4
3176#endif
3177#ifdef OS2
3178# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3179# define MAX_EXT_LEN 4
3180#endif
3181#ifdef VMS
3182# define SEARCH_EXTS ".pl", ".com", NULL
3183# define MAX_EXT_LEN 4
3184#endif
3185 /* additional extensions to try in each dir if scriptname not found */
3186#ifdef SEARCH_EXTS
0bcc34c2 3187 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3188 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3189 int extidx = 0, i = 0;
bd61b366 3190 const char *curext = NULL;
491527d0 3191#else
53c1dcc0 3192 PERL_UNUSED_ARG(search_ext);
491527d0
GS
3193# define MAX_EXT_LEN 0
3194#endif
3195
7918f24d
NC
3196 PERL_ARGS_ASSERT_FIND_SCRIPT;
3197
491527d0
GS
3198 /*
3199 * If dosearch is true and if scriptname does not contain path
3200 * delimiters, search the PATH for scriptname.
3201 *
3202 * If SEARCH_EXTS is also defined, will look for each
3203 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3204 * while searching the PATH.
3205 *
3206 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3207 * proceeds as follows:
3208 * If DOSISH or VMSISH:
3209 * + look for ./scriptname{,.foo,.bar}
3210 * + search the PATH for scriptname{,.foo,.bar}
3211 *
3212 * If !DOSISH:
3213 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3214 * this will not look in '.' if it's not in the PATH)
3215 */
84486fc6 3216 tmpbuf[0] = '\0';
491527d0
GS
3217
3218#ifdef VMS
3219# ifdef ALWAYS_DEFTYPES
3220 len = strlen(scriptname);
3221 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3222 int idx = 0, deftypes = 1;
491527d0
GS
3223 bool seen_dot = 1;
3224
bd61b366 3225 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3226# else
3227 if (dosearch) {
c4420975 3228 int idx = 0, deftypes = 1;
491527d0
GS
3229 bool seen_dot = 1;
3230
bd61b366 3231 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3232# endif
3233 /* The first time through, just add SEARCH_EXTS to whatever we
3234 * already have, so we can check for default file types. */
3235 while (deftypes ||
84486fc6 3236 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS
3237 {
3238 if (deftypes) {
3239 deftypes = 0;
84486fc6 3240 *tmpbuf = '\0';
491527d0 3241 }
84486fc6
GS
3242 if ((strlen(tmpbuf) + strlen(scriptname)
3243 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3244 continue; /* don't search dir with too-long name */
6fca0082 3245 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS
3246#else /* !VMS */
3247
3248#ifdef DOSISH
3249 if (strEQ(scriptname, "-"))
3250 dosearch = 0;
3251 if (dosearch) { /* Look in '.' first. */
fe2774ed 3252 const char *cur = scriptname;
491527d0
GS
3253#ifdef SEARCH_EXTS
3254 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3255 while (ext[i])
3256 if (strEQ(ext[i++],curext)) {
3257 extidx = -1; /* already has an ext */
3258 break;
3259 }
3260 do {
3261#endif
3262 DEBUG_p(PerlIO_printf(Perl_debug_log,
3263 "Looking for %s\n",cur));
017f25f1
IZ
3264 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3265 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS
3266 dosearch = 0;
3267 scriptname = cur;
3268#ifdef SEARCH_EXTS
3269 break;
3270#endif
3271 }
3272#ifdef SEARCH_EXTS
3273 if (cur == scriptname) {
3274 len = strlen(scriptname);
84486fc6 3275 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3276 break;
9e4425f7
SH
3277 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3278 cur = tmpbuf;
491527d0
GS
3279 }
3280 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3281 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS
3282#endif
3283 }
3284#endif
3285
3286 if (dosearch && !strchr(scriptname, '/')
3287#ifdef DOSISH
3288 && !strchr(scriptname, '\\')
3289#endif
cd39f2b6 3290 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3291 {
491527d0 3292 bool seen_dot = 0;
92f0c265 3293
39a02377
DM
3294 bufend = s + strlen(s);
3295 while (s < bufend) {
7c458fae 3296# ifdef DOSISH
491527d0 3297 for (len = 0; *s
491527d0 3298 && *s != ';'; len++, s++) {
84486fc6
GS
3299 if (len < sizeof tmpbuf)
3300 tmpbuf[len] = *s;
491527d0 3301 }
84486fc6
GS
3302 if (len < sizeof tmpbuf)
3303 tmpbuf[len] = '\0';
7c458fae 3304# else
39a02377 3305 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS
3306 ':',
3307 &len);
7c458fae 3308# endif
39a02377 3309 if (s < bufend)
491527d0 3310 s++;
84486fc6 3311 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS
3312 continue; /* don't search dir with too-long name */
3313 if (len
7c458fae 3314# ifdef DOSISH
84486fc6
GS
3315 && tmpbuf[len - 1] != '/'
3316 && tmpbuf[len - 1] != '\\'
490a0e98 3317# endif
491527d0 3318 )
84486fc6
GS
3319 tmpbuf[len++] = '/';
3320 if (len == 2 && tmpbuf[0] == '.')
491527d0 3321 seen_dot = 1;
28f0d0ec 3322 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS
3323#endif /* !VMS */
3324
3325#ifdef SEARCH_EXTS
84486fc6 3326 len = strlen(tmpbuf);
491527d0
GS
3327 if (extidx > 0) /* reset after previous loop */
3328 extidx = 0;
3329 do {
3330#endif
84486fc6 3331 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3332 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ
3333 if (S_ISDIR(PL_statbuf.st_mode)) {
3334 retval = -1;
3335 }
491527d0
GS
3336#ifdef SEARCH_EXTS
3337 } while ( retval < 0 /* not there */
3338 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3339 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS
3340 );
3341#endif
3342 if (retval < 0)
3343 continue;
3280af22
NIS
3344 if (S_ISREG(PL_statbuf.st_mode)
3345 && cando(S_IRUSR,TRUE,&PL_statbuf)
e37778c2 3346#if !defined(DOSISH)
3280af22 3347 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS
3348#endif
3349 )
3350 {
3aed30dc 3351 xfound = tmpbuf; /* bingo! */
491527d0
GS
3352 break;
3353 }
3354 if (!xfailed)
84486fc6 3355 xfailed = savepv(tmpbuf);
491527d0
GS
3356 }
3357#ifndef DOSISH
017f25f1 3358 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3359 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3360 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS
3361#endif
3362 seen_dot = 1; /* Disable message. */
9ccb31f9
GS
3363 if (!xfound) {
3364 if (flags & 1) { /* do or die? */
6ad282c7 3365 /* diag_listed_as: Can't execute %s */
3aed30dc 3366 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS
3367 (xfailed ? "execute" : "find"),
3368 (xfailed ? xfailed : scriptname),
3369 (xfailed ? "" : " on PATH"),
3370 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3371 }
bd61b366 3372 scriptname = NULL;
9ccb31f9 3373 }
43c5f42d 3374 Safefree(xfailed);
491527d0
GS
3375 scriptname = xfound;
3376 }
bd61b366 3377 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS
3378}
3379
ba869deb
GS
3380#ifndef PERL_GET_CONTEXT_DEFINED
3381
3382void *
3383Perl_get_context(void)
3384{
3db8f154 3385#if defined(USE_ITHREADS)
20b7effb 3386 dVAR;
ba869deb
GS
3387# ifdef OLD_PTHREADS_API
3388 pthread_addr_t t;
5637ef5b
NC
3389 int error = pthread_getspecific(PL_thr_key, &t)
3390 if (error)
3391 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
ba869deb
GS
3392 return (void*)t;
3393# else
bce813aa 3394# ifdef I_MACH_CTHREADS
8b8b35ab 3395 return (void*)cthread_data(cthread_self());
bce813aa 3396# else
8b8b35ab
JH
3397 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3398# endif
c44d3fdb 3399# endif
ba869deb
GS
3400#else
3401 return (void*)NULL;
3402#endif
3403}
3404
3405void
3406Perl_set_context(void *t)
3407{
20b7effb 3408#if defined(USE_ITHREADS)
8772537c 3409 dVAR;
20b7effb 3410#endif
7918f24d 3411 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3412#if defined(USE_ITHREADS)
c44d3fdb
GS
3413# ifdef I_MACH_CTHREADS
3414 cthread_set_data(cthread_self(), t);
3415# else
5637ef5b
NC
3416 {
3417 const int error = pthread_setspecific(PL_thr_key, t);
3418 if (error)
3419 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3420 }
c44d3fdb 3421# endif
b464bac0 3422#else
8772537c 3423 PERL_UNUSED_ARG(t);
ba869deb
GS
3424#endif
3425}
3426
3427#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3428
27da23d5 3429#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3430struct perl_vars *
864dbfa3 3431Perl_GetVars(pTHX)
22239a37 3432{
23491f1d
JH
3433 PERL_UNUSED_CONTEXT;
3434 return &PL_Vars;
22239a37 3435}
31fb1209
NIS
3436#endif
3437
1cb0ed9b 3438char **
864dbfa3 3439Perl_get_op_names(pTHX)
31fb1209 3440{
96a5add6
AL
3441 PERL_UNUSED_CONTEXT;
3442 return (char **)PL_op_name;
31fb1209
NIS
3443}
3444
1cb0ed9b 3445char **
864dbfa3 3446Perl_get_op_descs(pTHX)
31fb1209 3447{
96a5add6
AL
3448 PERL_UNUSED_CONTEXT;
3449 return (char **)PL_op_desc;
31fb1209 3450}
9e6b2b00 3451
e1ec3a88 3452const char *
864dbfa3 3453Perl_get_no_modify(pTHX)
9e6b2b00 3454{
96a5add6
AL
3455 PERL_UNUSED_CONTEXT;
3456 return PL_no_modify;
9e6b2b00
GS
3457}
3458
3459U32 *
864dbfa3 3460Perl_get_opargs(pTHX)
9e6b2b00 3461{
96a5add6
AL
3462 PERL_UNUSED_CONTEXT;
3463 return (U32 *)PL_opargs;
9e6b2b00 3464}
51aa15f3 3465
0cb96387
GS
3466PPADDR_t*
3467Perl_get_ppaddr(pTHX)
3468{
96a5add6
AL
3469 dVAR;
3470 PERL_UNUSED_CONTEXT;
3471 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS
3472}
3473
a6c40364
GS
3474#ifndef HAS_GETENV_LEN
3475char *
bf4acbe4 3476Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3477{
8772537c 3478 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3479 PERL_UNUSED_CONTEXT;
7918f24d 3480 PERL_ARGS_ASSERT_GETENV_LEN;
a6c40364
GS
3481 if (env_trans)
3482 *len = strlen(env_trans);
3483 return env_trans;
f675dbe5
CB
3484}
3485#endif
3486
dc9e4912
GS
3487
3488MGVTBL*
864dbfa3 3489Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3490{
96a5add6 3491 PERL_UNUSED_CONTEXT;
dc9e4912 3492
c7fdacb9 3493 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
31114fe9 3494 ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
dc9e4912
GS
3495}
3496
767df6a1 3497I32
864dbfa3 3498Perl_my_fflush_all(pTHX)
767df6a1 3499{
97cb92d6 3500#if defined(USE_PERLIO) || defined(FFLUSH_NULL)
ce720889 3501 return PerlIO_flush(NULL);
767df6a1 3502#else
8fbdfb7c 3503# if defined(HAS__FWALK)
f13a2bc0 3504 extern int fflush(FILE *);
74cac757
JH
3505 /* undocumented, unprototyped, but very useful BSDism */
3506 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3507 _fwalk(&fflush);
74cac757 3508 return 0;
8fa7f367 3509# else
8fbdfb7c 3510# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3511 long open_max = -1;
8fbdfb7c 3512# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3513 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3514# else
8fa7f367 3515# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3516 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH
3517# else
3518# ifdef FOPEN_MAX
74cac757 3519 open_max = FOPEN_MAX;
8fa7f367
JH
3520# else
3521# ifdef OPEN_MAX
74cac757 3522 open_max = OPEN_MAX;
8fa7f367
JH
3523# else
3524# ifdef _NFILE
d2201af2 3525 open_max = _NFILE;
8fa7f367
JH
3526# endif
3527# endif
74cac757 3528# endif
767df6a1
JH
3529# endif
3530# endif
767df6a1
JH
3531 if (open_max > 0) {
3532 long i;
3533 for (i = 0; i < open_max; i++)
d2201af2
AD
3534 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3535 STDIO_STREAM_ARRAY[i]._file < open_max &&
3536 STDIO_STREAM_ARRAY[i]._flag)
3537 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH
3538 return 0;
3539 }
8fbdfb7c 3540# endif
93189314 3541 SETERRNO(EBADF,RMS_IFI);
767df6a1 3542 return EOF;
74cac757 3543# endif
767df6a1
JH
3544#endif
3545}
097ee67d 3546
69282e91 3547void
45219de6 3548Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
a5390457
NC
3549{
3550 if (ckWARN(WARN_IO)) {
0223a801 3551 HEK * const name
c6e4ff34 3552 = gv && (isGV_with_GP(gv))
0223a801 3553 ? GvENAME_HEK((gv))
3b46b707 3554 : NULL;
a5390457
NC
3555 const char * const direction = have == '>' ? "out" : "in";
3556