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