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