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