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