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