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