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