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