This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Add Perl_ck_warner(), which combines Perl_ckwarn() and Perl_warner().
[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 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 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 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 331 return ptr;
332 }
3280af22 333 else if (PL_nomemok)
bd61b366 334 return NULL;
0bd48802 335 return write_no_mem();
1050c9ca 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 *
04c9e624 372Perl_delimcpy(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;
35da51f7 375
7918f24d
NC		 376 PERL_ARGS_ASSERT_DELIMCPY;
377
fc36a67e 378 for (tolen = 0; from < fromend; from++, tolen++) {
378cc40b 379 if (*from == '\\') {
35da51f7 380 if (from[1] != delim) {
fc36a67e 381 if (to < toend)
382 *to++ = *from;
383 tolen++;
fc36a67e 384 }
35da51f7 385 from++;
378cc40b 386 }
bedebaa5 387 else if (*from == delim)
8d063cd8 388 break;
fc36a67e 389 if (to < toend)
390 *to++ = *from;
8d063cd8 391 }
bedebaa5
CS		 392 if (to < toend)
393 *to = '\0';
fc36a67e 394 *retlen = tolen;
73d840c0 395 return (char *)from;
8d063cd8
LW		 396}
397
398/* return ptr to little string in big string, NULL if not found */
378cc40b 399/* This routine was donated by Corey Satten. */
8d063cd8
LW		 400
401char *
04c9e624 402Perl_instr(register const char *big, register const char *little)
378cc40b 403{
79072805 404 register I32 first;
378cc40b 405
7918f24d
NC		 406 PERL_ARGS_ASSERT_INSTR;
407
a687059c 408 if (!little)
08105a92 409 return (char*)big;
a687059c 410 first = *little++;
378cc40b 411 if (!first)
08105a92 412 return (char*)big;
378cc40b 413 while (*big) {
66a1b24b 414 register const char *s, *x;
378cc40b
LW		 415 if (*big++ != first)
416 continue;
417 for (x=big,s=little; *s; /**/ ) {
418 if (!*x)
bd61b366 419 return NULL;
4fc877ac 420 if (*s != *x)
378cc40b 421 break;
4fc877ac
AL		 422 else {
423 s++;
424 x++;
378cc40b
LW		 425 }
426 }
427 if (!*s)
08105a92 428 return (char*)(big-1);
378cc40b 429 }
bd61b366 430 return NULL;
378cc40b 431}
8d063cd8 432
a687059c
LW		 433/* same as instr but allow embedded nulls */
434
435char *
04c9e624 436Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
8d063cd8 437{
7918f24d 438 PERL_ARGS_ASSERT_NINSTR;
4c8626be
GA		 439 if (little >= lend)
440 return (char*)big;
441 {
8ba22ff4 442 const char first = *little;
4c8626be 443 const char *s, *x;
8ba22ff4 444 bigend -= lend - little++;
4c8626be
GA		 445 OUTER:
446 while (big <= bigend) {
b0ca24ee
JH		 447 if (*big++ == first) {
448 for (x=big,s=little; s < lend; x++,s++) {
449 if (*s != *x)
450 goto OUTER;
451 }
452 return (char*)(big-1);
4c8626be 453 }
4c8626be 454 }
378cc40b 455 }
bd61b366 456 return NULL;
a687059c
LW		 457}
458
459/* reverse of the above--find last substring */
460
461char *
04c9e624 462Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
a687059c 463{
08105a92 464 register const char *bigbeg;
e1ec3a88 465 register const I32 first = *little;
7452cf6a 466 register const char * const littleend = lend;
a687059c 467
7918f24d
NC		 468 PERL_ARGS_ASSERT_RNINSTR;
469
260d78c9 470 if (little >= littleend)
08105a92 471 return (char*)bigend;
a687059c
LW		 472 bigbeg = big;
473 big = bigend - (littleend - little++);
474 while (big >= bigbeg) {
66a1b24b 475 register const char *s, *x;
a687059c
LW		 476 if (*big-- != first)
477 continue;
478 for (x=big+2,s=little; s < littleend; /**/ ) {
4fc877ac 479 if (*s != *x)
a687059c 480 break;
4fc877ac
AL		 481 else {
482 x++;
483 s++;
a687059c
LW		 484 }
485 }
486 if (s >= littleend)
08105a92 487 return (char*)(big+1);
378cc40b 488 }
bd61b366 489 return NULL;
378cc40b 490}
a687059c 491
cf93c79d
IZ		 492/* As a space optimization, we do not compile tables for strings of length
493 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
494 special-cased in fbm_instr().
495
496 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
497
954c1994 498/*
ccfc67b7
JH		 499=head1 Miscellaneous Functions
500
954c1994
GS		 501=for apidoc fbm_compile
502
503Analyses the string in order to make fast searches on it using fbm_instr()
504-- the Boyer-Moore algorithm.
505
506=cut
507*/
508
378cc40b 509void
7506f9c3 510Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
378cc40b 511{
97aff369 512 dVAR;
0d46e09a 513 register const U8 *s;
79072805 514 register U32 i;
0b71040e 515 STRLEN len;
cb742848 516 U32 rarest = 0;
79072805
LW		 517 U32 frequency = 256;
518
7918f24d
NC		 519 PERL_ARGS_ASSERT_FBM_COMPILE;
520
c517dc2b 521 if (flags & FBMcf_TAIL) {
890ce7af 522 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
396482e1 523 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
c517dc2b
JH		 524 if (mg && mg->mg_len >= 0)
525 mg->mg_len++;
526 }
9cbe880b 527 s = (U8*)SvPV_force_mutable(sv, len);
d1be9408 528 if (len == 0) /* TAIL might be on a zero-length string. */
cf93c79d 529 return;
cecf5685 530 SvUPGRADE(sv, SVt_PVGV);
78d0cf80 531 SvIOK_off(sv);
8eeaf79a
NC		 532 SvNOK_off(sv);
533 SvVALID_on(sv);
02128f11 534 if (len > 2) {
9cbe880b 535 const unsigned char *sb;
66a1b24b 536 const U8 mlen = (len>255) ? 255 : (U8)len;
890ce7af 537 register U8 *table;
cf93c79d 538
d8419e03
NC		 539 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
540 table
541 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
542 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
7506f9c3 543 memset((void*)table, mlen, 256);
02128f11 544 i = 0;
7506f9c3 545 sb = s - mlen + 1; /* first char (maybe) */
cf93c79d
IZ		 546 while (s >= sb) {
547 if (table[*s] == mlen)
7506f9c3 548 table[*s] = (U8)i;
cf93c79d
IZ		 549 s--, i++;
550 }
d0688fc4
NC		 551 } else {
552 Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
378cc40b 553 }
a0714e2c 554 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
378cc40b 555
9cbe880b 556 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
bbce6d69 557 for (i = 0; i < len; i++) {
22c35a8c 558 if (PL_freq[s[i]] < frequency) {
bbce6d69 559 rarest = i;
22c35a8c 560 frequency = PL_freq[s[i]];
378cc40b
LW		 561 }
562 }
610460f9 563 BmFLAGS(sv) = (U8)flags;
79072805 564 BmRARE(sv) = s[rarest];
44a10c71 565 BmPREVIOUS(sv) = rarest;
cf93c79d
IZ		 566 BmUSEFUL(sv) = 100; /* Initial value */
567 if (flags & FBMcf_TAIL)
568 SvTAIL_on(sv);
8eeaf79a
NC		 569 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
570 BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
378cc40b
LW		 571}
572
cf93c79d
IZ		 573/* If SvTAIL(littlestr), it has a fake '\n' at end. */
574/* If SvTAIL is actually due to \Z or \z, this gives false positives
575 if multiline */
576
954c1994
GS		 577/*
578=for apidoc fbm_instr
579
580Returns the location of the SV in the string delimited by C<str> and
bd61b366 581C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
954c1994
GS		 582does not have to be fbm_compiled, but the search will not be as fast
583then.
584
585=cut
586*/
587
378cc40b 588char *
864dbfa3 589Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
378cc40b 590{
a687059c 591 register unsigned char *s;
cf93c79d 592 STRLEN l;
9cbe880b
NC		 593 register const unsigned char *little
594 = (const unsigned char *)SvPV_const(littlestr,l);
cf93c79d 595 register STRLEN littlelen = l;
e1ec3a88 596 register const I32 multiline = flags & FBMrf_MULTILINE;
cf93c79d 597
7918f24d
NC		 598 PERL_ARGS_ASSERT_FBM_INSTR;
599
eb160463 600 if ((STRLEN)(bigend - big) < littlelen) {
a1d180c4 601 if ( SvTAIL(littlestr)
eb160463 602 && ((STRLEN)(bigend - big) == littlelen - 1)
a1d180c4 603 && (littlelen == 1
12ae5dfc 604 || (*big == *little &&
27da23d5 605 memEQ((char *)big, (char *)little, littlelen - 1))))
cf93c79d 606 return (char*)big;
bd61b366 607 return NULL;
cf93c79d 608 }
378cc40b 609
cf93c79d 610 if (littlelen <= 2) { /* Special-cased */
cf93c79d
IZ		 611
612 if (littlelen == 1) {
613 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
614 /* Know that bigend != big. */
615 if (bigend[-1] == '\n')
616 return (char *)(bigend - 1);
617 return (char *) bigend;
618 }
619 s = big;
620 while (s < bigend) {
621 if (*s == *little)
622 return (char *)s;
623 s++;
624 }
625 if (SvTAIL(littlestr))
626 return (char *) bigend;
bd61b366 627 return NULL;
cf93c79d
IZ		 628 }
629 if (!littlelen)
630 return (char*)big; /* Cannot be SvTAIL! */
631
632 /* littlelen is 2 */
633 if (SvTAIL(littlestr) && !multiline) {
634 if (bigend[-1] == '\n' && bigend[-2] == *little)
635 return (char*)bigend - 2;
636 if (bigend[-1] == *little)
637 return (char*)bigend - 1;
bd61b366 638 return NULL;
cf93c79d
IZ		 639 }
640 {
641 /* This should be better than FBM if c1 == c2, and almost
642 as good otherwise: maybe better since we do less indirection.
643 And we save a lot of memory by caching no table. */
66a1b24b
AL		 644 const unsigned char c1 = little[0];
645 const unsigned char c2 = little[1];
cf93c79d
IZ		 646
647 s = big + 1;
648 bigend--;
649 if (c1 != c2) {
650 while (s <= bigend) {
651 if (s[0] == c2) {
652 if (s[-1] == c1)
653 return (char*)s - 1;
654 s += 2;
655 continue;
3fe6f2dc 656 }
cf93c79d
IZ		 657 next_chars:
658 if (s[0] == c1) {
659 if (s == bigend)
660 goto check_1char_anchor;
661 if (s[1] == c2)
662 return (char*)s;
663 else {
664 s++;
665 goto next_chars;
666 }
667 }
668 else
669 s += 2;
670 }
671 goto check_1char_anchor;
672 }
673 /* Now c1 == c2 */
674 while (s <= bigend) {
675 if (s[0] == c1) {
676 if (s[-1] == c1)
677 return (char*)s - 1;
678 if (s == bigend)
679 goto check_1char_anchor;
680 if (s[1] == c1)
681 return (char*)s;
682 s += 3;
02128f11 683 }
c277df42 684 else
cf93c79d 685 s += 2;
c277df42 686 }
c277df42 687 }
cf93c79d
IZ		 688 check_1char_anchor: /* One char and anchor! */
689 if (SvTAIL(littlestr) && (*bigend == *little))
690 return (char *)bigend; /* bigend is already decremented. */
bd61b366 691 return NULL;
d48672a2 692 }
cf93c79d 693 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
bbce6d69 694 s = bigend - littlelen;
a1d180c4 695 if (s >= big && bigend[-1] == '\n' && *s == *little
cf93c79d
IZ		 696 /* Automatically of length > 2 */
697 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
7506f9c3 698 {
bbce6d69 699 return (char*)s; /* how sweet it is */
7506f9c3
GS		 700 }
701 if (s[1] == *little
702 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
703 {
cf93c79d 704 return (char*)s + 1; /* how sweet it is */
7506f9c3 705 }
bd61b366 706 return NULL;
02128f11 707 }
cecf5685 708 if (!SvVALID(littlestr)) {
c4420975 709 char * const b = ninstr((char*)big,(char*)bigend,
cf93c79d
IZ		 710 (char*)little, (char*)little + littlelen);
711
712 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
713 /* Chop \n from littlestr: */
714 s = bigend - littlelen + 1;
7506f9c3
GS		 715 if (*s == *little
716 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
717 {
3fe6f2dc 718 return (char*)s;
7506f9c3 719 }
bd61b366 720 return NULL;
a687059c 721 }
cf93c79d 722 return b;
a687059c 723 }
a1d180c4 724
3566a07d
NC		 725 /* Do actual FBM. */
726 if (littlelen > (STRLEN)(bigend - big))
727 return NULL;
728
729 {
d8419e03
NC		 730 register const unsigned char * const table
731 = little + littlelen + PERL_FBM_TABLE_OFFSET;
0d46e09a 732 register const unsigned char *oldlittle;
cf93c79d 733
cf93c79d
IZ		 734 --littlelen; /* Last char found by table lookup */
735
736 s = big + littlelen;
737 little += littlelen; /* last char */
738 oldlittle = little;
739 if (s < bigend) {
740 register I32 tmp;
741
742 top2:
7506f9c3 743 if ((tmp = table[*s])) {
cf93c79d 744 if ((s += tmp) < bigend)
62b28dd9 745 goto top2;
cf93c79d
IZ		 746 goto check_end;
747 }
748 else { /* less expensive than calling strncmp() */
66a1b24b 749 register unsigned char * const olds = s;
cf93c79d
IZ		 750
751 tmp = littlelen;
752
753 while (tmp--) {
754 if (*--s == *--little)
755 continue;
cf93c79d
IZ		 756 s = olds + 1; /* here we pay the price for failure */
757 little = oldlittle;
758 if (s < bigend) /* fake up continue to outer loop */
759 goto top2;
760 goto check_end;
761 }
762 return (char *)s;
a687059c 763 }
378cc40b 764 }
cf93c79d 765 check_end:
c8029a41 766 if ( s == bigend
8eeaf79a 767 && (BmFLAGS(littlestr) & FBMcf_TAIL)
12ae5dfc
JH		 768 && memEQ((char *)(bigend - littlelen),
769 (char *)(oldlittle - littlelen), littlelen) )
cf93c79d 770 return (char*)bigend - littlelen;
bd61b366 771 return NULL;
378cc40b 772 }
378cc40b
LW		 773}
774
c277df42
IZ		 775/* start_shift, end_shift are positive quantities which give offsets
776 of ends of some substring of bigstr.
a0288114 777 If "last" we want the last occurrence.
c277df42 778 old_posp is the way of communication between consequent calls if
a1d180c4 779 the next call needs to find the .
c277df42 780 The initial *old_posp should be -1.
cf93c79d
IZ		 781
782 Note that we take into account SvTAIL, so one can get extra
783 optimizations if _ALL flag is set.
c277df42
IZ		 784 */
785
cf93c79d 786/* If SvTAIL is actually due to \Z or \z, this gives false positives
26fa51c3 787 if PL_multiline. In fact if !PL_multiline the authoritative answer
cf93c79d
IZ		 788 is not supported yet. */
789
378cc40b 790char *
864dbfa3 791Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
378cc40b 792{
97aff369 793 dVAR;
0d46e09a 794 register const unsigned char *big;
79072805
LW		 795 register I32 pos;
796 register I32 previous;
797 register I32 first;
0d46e09a 798 register const unsigned char *little;
c277df42 799 register I32 stop_pos;
0d46e09a 800 register const unsigned char *littleend;
c277df42 801 I32 found = 0;
378cc40b 802
7918f24d
NC		 803 PERL_ARGS_ASSERT_SCREAMINSTR;
804
cecf5685
NC		 805 assert(SvTYPE(littlestr) == SVt_PVGV);
806 assert(SvVALID(littlestr));
d372c834 807
c277df42 808 if (*old_posp == -1
3280af22 809 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
cf93c79d
IZ		 810 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
811 cant_find:
a1d180c4 812 if ( BmRARE(littlestr) == '\n'
85c508c3 813 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
cfd0369c 814 little = (const unsigned char *)(SvPVX_const(littlestr));
cf93c79d
IZ		 815 littleend = little + SvCUR(littlestr);
816 first = *little++;
817 goto check_tail;
818 }
bd61b366 819 return NULL;
cf93c79d
IZ		 820 }
821
cfd0369c 822 little = (const unsigned char *)(SvPVX_const(littlestr));
79072805 823 littleend = little + SvCUR(littlestr);
378cc40b 824 first = *little++;
c277df42 825 /* The value of pos we can start at: */
79072805 826 previous = BmPREVIOUS(littlestr);
cfd0369c 827 big = (const unsigned char *)(SvPVX_const(bigstr));
c277df42
IZ		 828 /* The value of pos we can stop at: */
829 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
cf93c79d 830 if (previous + start_shift > stop_pos) {
0fe87f7c
HS		 831/*
832 stop_pos does not include SvTAIL in the count, so this check is incorrect
833 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
834*/
835#if 0
cf93c79d
IZ		 836 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
837 goto check_tail;
0fe87f7c 838#endif
bd61b366 839 return NULL;
cf93c79d 840 }
c277df42 841 while (pos < previous + start_shift) {
3280af22 842 if (!(pos += PL_screamnext[pos]))
cf93c79d 843 goto cant_find;
378cc40b 844 }
de3bb511 845 big -= previous;
bbce6d69 846 do {
0d46e09a 847 register const unsigned char *s, *x;
ef64f398 848 if (pos >= stop_pos) break;
bbce6d69 849 if (big[pos] != first)
850 continue;
851 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
bbce6d69 852 if (*s++ != *x++) {
853 s--;
854 break;
378cc40b 855 }
bbce6d69 856 }
c277df42
IZ		 857 if (s == littleend) {
858 *old_posp = pos;
859 if (!last) return (char *)(big+pos);
860 found = 1;
861 }
3280af22 862 } while ( pos += PL_screamnext[pos] );
a1d180c4 863 if (last && found)
cf93c79d 864 return (char *)(big+(*old_posp));
cf93c79d
IZ		 865 check_tail:
866 if (!SvTAIL(littlestr) || (end_shift > 0))
bd61b366 867 return NULL;
cf93c79d 868 /* Ignore the trailing "\n". This code is not microoptimized */
cfd0369c 869 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
cf93c79d
IZ		 870 stop_pos = littleend - little; /* Actual littlestr len */
871 if (stop_pos == 0)
872 return (char*)big;
873 big -= stop_pos;
874 if (*big == first
12ae5dfc
JH		 875 && ((stop_pos == 1) ||
876 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
cf93c79d 877 return (char*)big;
bd61b366 878 return NULL;
8d063cd8
LW		 879}
880
79072805 881I32
04c9e624 882Perl_ibcmp(const char *s1, const char *s2, register I32 len)
79072805 883{
e1ec3a88
AL		 884 register const U8 *a = (const U8 *)s1;
885 register const U8 *b = (const U8 *)s2;
96a5add6 886
7918f24d
NC		 887 PERL_ARGS_ASSERT_IBCMP;
888
79072805 889 while (len--) {
22c35a8c 890 if (*a != *b && *a != PL_fold[*b])
bbce6d69 891 return 1;
892 a++,b++;
893 }
894 return 0;
895}
896
897I32
04c9e624 898Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
bbce6d69 899{
27da23d5 900 dVAR;
e1ec3a88
AL		 901 register const U8 *a = (const U8 *)s1;
902 register const U8 *b = (const U8 *)s2;
96a5add6 903
7918f24d
NC		 904 PERL_ARGS_ASSERT_IBCMP_LOCALE;
905
bbce6d69 906 while (len--) {
22c35a8c 907 if (*a != *b && *a != PL_fold_locale[*b])
bbce6d69 908 return 1;
909 a++,b++;
79072805
LW		 910 }
911 return 0;
912}
913
8d063cd8
LW		 914/* copy a string to a safe spot */
915
954c1994 916/*
ccfc67b7
JH		 917=head1 Memory Management
918
954c1994
GS		 919=for apidoc savepv
920
61a925ed
AMS		 921Perl's version of C<strdup()>. Returns a pointer to a newly allocated
922string which is a duplicate of C<pv>. The size of the string is
923determined by C<strlen()>. The memory allocated for the new string can
924be freed with the C<Safefree()> function.
954c1994
GS		 925
926=cut
927*/
928
8d063cd8 929char *
efdfce31 930Perl_savepv(pTHX_ const char *pv)
8d063cd8 931{
96a5add6 932 PERL_UNUSED_CONTEXT;
e90e2364 933 if (!pv)
bd61b366 934 return NULL;
66a1b24b
AL		 935 else {
936 char *newaddr;
937 const STRLEN pvlen = strlen(pv)+1;
10edeb5d
JH		 938 Newx(newaddr, pvlen, char);
939 return (char*)memcpy(newaddr, pv, pvlen);
66a1b24b 940 }
8d063cd8
LW		 941}
942
a687059c
LW		 943/* same thing but with a known length */
944
954c1994
GS		 945/*
946=for apidoc savepvn
947
61a925ed
AMS		 948Perl's version of what C<strndup()> would be if it existed. Returns a
949pointer to a newly allocated string which is a duplicate of the first
cbf82dd0
NC		 950C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
951the new string can be freed with the C<Safefree()> function.
954c1994
GS		 952
953=cut
954*/
955
a687059c 956char *
efdfce31 957Perl_savepvn(pTHX_ const char *pv, register I32 len)
a687059c
LW		 958{
959 register char *newaddr;
96a5add6 960 PERL_UNUSED_CONTEXT;
a687059c 961
a02a5408 962 Newx(newaddr,len+1,char);
92110913 963 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
efdfce31 964 if (pv) {
e90e2364
NC		 965 /* might not be null terminated */
966 newaddr[len] = '\0';
07409e01 967 return (char *) CopyD(pv,newaddr,len,char);
92110913
NIS		 968 }
969 else {
07409e01 970 return (char *) ZeroD(newaddr,len+1,char);
92110913 971 }
a687059c
LW		 972}
973
05ec9bb3
NIS		 974/*
975=for apidoc savesharedpv
976
61a925ed
AMS		 977A version of C<savepv()> which allocates the duplicate string in memory
978which is shared between threads.
05ec9bb3
NIS		 979
980=cut
981*/
982char *
efdfce31 983Perl_savesharedpv(pTHX_ const char *pv)
05ec9bb3 984{
e90e2364 985 register char *newaddr;
490a0e98 986 STRLEN pvlen;
e90e2364 987 if (!pv)
bd61b366 988 return NULL;
e90e2364 989
490a0e98
NC		 990 pvlen = strlen(pv)+1;
991 newaddr = (char*)PerlMemShared_malloc(pvlen);
e90e2364 992 if (!newaddr) {
0bd48802 993 return write_no_mem();
05ec9bb3 994 }
10edeb5d 995 return (char*)memcpy(newaddr, pv, pvlen);
05ec9bb3
NIS		 996}
997
2e0de35c 998/*
d9095cec
NC		 999=for apidoc savesharedpvn
1000
1001A version of C<savepvn()> which allocates the duplicate string in memory
1002which is shared between threads. (With the specific difference that a NULL
1003pointer is not acceptable)
1004
1005=cut
1006*/
1007char *
1008Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1009{
1010 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
7918f24d
NC		 1011
1012 PERL_ARGS_ASSERT_SAVESHAREDPVN;
1013
d9095cec
NC		 1014 if (!newaddr) {
1015 return write_no_mem();
1016 }
1017 newaddr[len] = '\0';
1018 return (char*)memcpy(newaddr, pv, len);
1019}
1020
1021/*
2e0de35c
NC		 1022=for apidoc savesvpv
1023
6832267f 1024A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
2e0de35c
NC		 1025the passed in SV using C<SvPV()>
1026
1027=cut
1028*/
1029
1030char *
1031Perl_savesvpv(pTHX_ SV *sv)
1032{
1033 STRLEN len;
7452cf6a 1034 const char * const pv = SvPV_const(sv, len);
2e0de35c
NC		 1035 register char *newaddr;
1036
7918f24d
NC		 1037 PERL_ARGS_ASSERT_SAVESVPV;
1038
26866f99 1039 ++len;
a02a5408 1040 Newx(newaddr,len,char);
07409e01 1041 return (char *) CopyD(pv,newaddr,len,char);
2e0de35c 1042}
05ec9bb3
NIS		 1043
1044
cea2e8a9 1045/* the SV for Perl_form() and mess() is not kept in an arena */
fc36a67e 1046
76e3520e 1047STATIC SV *
cea2e8a9 1048S_mess_alloc(pTHX)
fc36a67e 1049{
97aff369 1050 dVAR;
fc36a67e 1051 SV *sv;
1052 XPVMG *any;
1053
e72dc28c 1054 if (!PL_dirty)
84bafc02 1055 return newSVpvs_flags("", SVs_TEMP);
e72dc28c 1056
0372dbb6
GS		 1057 if (PL_mess_sv)
1058 return PL_mess_sv;
1059
fc36a67e 1060 /* Create as PVMG now, to avoid any upgrading later */
a02a5408
JC		 1061 Newx(sv, 1, SV);
1062 Newxz(any, 1, XPVMG);
fc36a67e 1063 SvFLAGS(sv) = SVt_PVMG;
1064 SvANY(sv) = (void*)any;
6136c704 1065 SvPV_set(sv, NULL);
fc36a67e 1066 SvREFCNT(sv) = 1 << 30; /* practically infinite */
e72dc28c 1067 PL_mess_sv = sv;
fc36a67e 1068 return sv;
1069}
1070
c5be433b 1071#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1072char *
1073Perl_form_nocontext(const char* pat, ...)
1074{
1075 dTHX;
c5be433b 1076 char *retval;
cea2e8a9 1077 va_list args;
7918f24d 1078 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
cea2e8a9 1079 va_start(args, pat);
c5be433b 1080 retval = vform(pat, &args);
cea2e8a9 1081 va_end(args);
c5be433b 1082 return retval;
cea2e8a9 1083}
c5be433b 1084#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1085
7c9e965c 1086/*
ccfc67b7 1087=head1 Miscellaneous Functions
7c9e965c
JP		 1088=for apidoc form
1089
1090Takes a sprintf-style format pattern and conventional
1091(non-SV) arguments and returns the formatted string.
1092
1093 (char *) Perl_form(pTHX_ const char* pat, ...)
1094
1095can be used any place a string (char *) is required:
1096
1097 char * s = Perl_form("%d.%d",major,minor);
1098
1099Uses a single private buffer so if you want to format several strings you
1100must explicitly copy the earlier strings away (and free the copies when you
1101are done).
1102
1103=cut
1104*/
1105
8990e307 1106char *
864dbfa3 1107Perl_form(pTHX_ const char* pat, ...)
8990e307 1108{
c5be433b 1109 char *retval;
46fc3d4c 1110 va_list args;
7918f24d 1111 PERL_ARGS_ASSERT_FORM;
46fc3d4c 1112 va_start(args, pat);
c5be433b 1113 retval = vform(pat, &args);
46fc3d4c 1114 va_end(args);
c5be433b
GS		 1115 return retval;
1116}
1117
1118char *
1119Perl_vform(pTHX_ const char *pat, va_list *args)
1120{
2d03de9c 1121 SV * const sv = mess_alloc();
7918f24d 1122 PERL_ARGS_ASSERT_VFORM;
4608196e 1123 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
e72dc28c 1124 return SvPVX(sv);
46fc3d4c 1125}
a687059c 1126
5a844595
GS		 1127#if defined(PERL_IMPLICIT_CONTEXT)
1128SV *
1129Perl_mess_nocontext(const char *pat, ...)
1130{
1131 dTHX;
1132 SV *retval;
1133 va_list args;
7918f24d 1134 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
5a844595
GS		 1135 va_start(args, pat);
1136 retval = vmess(pat, &args);
1137 va_end(args);
1138 return retval;
1139}
1140#endif /* PERL_IMPLICIT_CONTEXT */
1141
06bf62c7 1142SV *
5a844595
GS		 1143Perl_mess(pTHX_ const char *pat, ...)
1144{
1145 SV *retval;
1146 va_list args;
7918f24d 1147 PERL_ARGS_ASSERT_MESS;
5a844595
GS		 1148 va_start(args, pat);
1149 retval = vmess(pat, &args);
1150 va_end(args);
1151 return retval;
1152}
1153
5f66b61c
AL		 1154STATIC const COP*
1155S_closest_cop(pTHX_ const COP *cop, const OP *o)
ae7d165c 1156{
97aff369 1157 dVAR;
ae7d165c
PJ		 1158 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1159
7918f24d
NC		 1160 PERL_ARGS_ASSERT_CLOSEST_COP;
1161
fabdb6c0
AL		 1162 if (!o || o == PL_op)
1163 return cop;
ae7d165c
PJ		 1164
1165 if (o->op_flags & OPf_KIDS) {
5f66b61c 1166 const OP *kid;
fabdb6c0 1167 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
5f66b61c 1168 const COP *new_cop;
ae7d165c
PJ		 1169
1170 /* If the OP_NEXTSTATE has been optimised away we can still use it
1171 * the get the file and line number. */
1172
1173 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
5f66b61c 1174 cop = (const COP *)kid;
ae7d165c
PJ		 1175
1176 /* Keep searching, and return when we've found something. */
1177
1178 new_cop = closest_cop(cop, kid);
fabdb6c0
AL		 1179 if (new_cop)
1180 return new_cop;
ae7d165c
PJ		 1181 }
1182 }
1183
1184 /* Nothing found. */
1185
5f66b61c 1186 return NULL;
ae7d165c
PJ		 1187}
1188
5a844595
GS		 1189SV *
1190Perl_vmess(pTHX_ const char *pat, va_list *args)
46fc3d4c 1191{
97aff369 1192 dVAR;
c4420975 1193 SV * const sv = mess_alloc();
46fc3d4c 1194
7918f24d
NC		 1195 PERL_ARGS_ASSERT_VMESS;
1196
5f66b61c 1197 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
46fc3d4c 1198 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
ae7d165c
PJ		 1199 /*
1200 * Try and find the file and line for PL_op. This will usually be
1201 * PL_curcop, but it might be a cop that has been optimised away. We
1202 * can try to find such a cop by searching through the optree starting
1203 * from the sibling of PL_curcop.
1204 */
1205
e1ec3a88 1206 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
5f66b61c
AL		 1207 if (!cop)
1208 cop = PL_curcop;
ae7d165c
PJ		 1209
1210 if (CopLINE(cop))
ed094faf 1211 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
3aed30dc 1212 OutCopFILE(cop), (IV)CopLINE(cop));
191f87d5
DH		 1213 /* Seems that GvIO() can be untrustworthy during global destruction. */
1214 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1215 && IoLINES(GvIOp(PL_last_in_gv)))
1216 {
e1ec3a88 1217 const bool line_mode = (RsSIMPLE(PL_rs) &&
95a20fc0 1218 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
57def98f 1219 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
5f66b61c 1220 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
edc2eac3
JH		 1221 line_mode ? "line" : "chunk",
1222 (IV)IoLINES(GvIOp(PL_last_in_gv)));
a687059c 1223 }
5f66b61c
AL		 1224 if (PL_dirty)
1225 sv_catpvs(sv, " during global destruction");
1226 sv_catpvs(sv, ".\n");
a687059c 1227 }
06bf62c7 1228 return sv;
a687059c
LW		 1229}
1230
7ff03255
SG		 1231void
1232Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1233{
27da23d5 1234 dVAR;
7ff03255
SG		 1235 IO *io;
1236 MAGIC *mg;
1237
7918f24d
NC		 1238 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1239
7ff03255
SG		 1240 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1241 && (io = GvIO(PL_stderrgv))
daba3364 1242 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
7ff03255
SG		 1243 {
1244 dSP;
1245 ENTER;
1246 SAVETMPS;
1247
1248 save_re_context();
1249 SAVESPTR(PL_stderrgv);
a0714e2c 1250 PL_stderrgv = NULL;
7ff03255
SG		 1251
1252 PUSHSTACKi(PERLSI_MAGIC);
1253
1254 PUSHMARK(SP);
1255 EXTEND(SP,2);
daba3364 1256 PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
6e449a3a 1257 mPUSHp(message, msglen);
7ff03255
SG		 1258 PUTBACK;
1259 call_method("PRINT", G_SCALAR);
1260
1261 POPSTACK;
1262 FREETMPS;
1263 LEAVE;
1264 }
1265 else {
1266#ifdef USE_SFIO
1267 /* SFIO can really mess with your errno */
4ee39169 1268 dSAVED_ERRNO;
7ff03255 1269#endif
53c1dcc0 1270 PerlIO * const serr = Perl_error_log;
7ff03255
SG		 1271
1272 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1273 (void)PerlIO_flush(serr);
1274#ifdef USE_SFIO
4ee39169 1275 RESTORE_ERRNO;
7ff03255
SG		 1276#endif
1277 }
1278}
1279
46d9c920 1280/* Common code used by vcroak, vdie, vwarn and vwarner */
3ab1ac99 1281
46d9c920
NC		 1282STATIC bool
1283S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
63315e18 1284{
97aff369 1285 dVAR;
63315e18
NC		 1286 HV *stash;
1287 GV *gv;
1288 CV *cv;
46d9c920
NC		 1289 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1290 /* sv_2cv might call Perl_croak() or Perl_warner() */
1291 SV * const oldhook = *hook;
1292
1293 assert(oldhook);
63315e18 1294
63315e18 1295 ENTER;
46d9c920
NC		 1296 SAVESPTR(*hook);
1297 *hook = NULL;
1298 cv = sv_2cv(oldhook, &stash, &gv, 0);
63315e18
NC		 1299 LEAVE;
1300 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1301 dSP;
1302 SV *msg;
1303
1304 ENTER;
1305 save_re_context();
46d9c920
NC		 1306 if (warn) {
1307 SAVESPTR(*hook);
1308 *hook = NULL;
1309 }
1310 if (warn || message) {
740cce10 1311 msg = newSVpvn_flags(message, msglen, utf8);
63315e18
NC		 1312 SvREADONLY_on(msg);
1313 SAVEFREESV(msg);
1314 }
1315 else {
1316 msg = ERRSV;
1317 }
1318
46d9c920 1319 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
63315e18
NC		 1320 PUSHMARK(SP);
1321 XPUSHs(msg);
1322 PUTBACK;
daba3364 1323 call_sv(MUTABLE_SV(cv), G_DISCARD);
63315e18
NC		 1324 POPSTACK;
1325 LEAVE;
46d9c920 1326 return TRUE;
63315e18 1327 }
46d9c920 1328 return FALSE;
63315e18
NC		 1329}
1330
cfd0369c 1331STATIC const char *
e07360fa
AT		 1332S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1333 I32* utf8)
1334{
1335 dVAR;
cfd0369c 1336 const char *message;
e07360fa
AT		 1337
1338 if (pat) {
890ce7af 1339 SV * const msv = vmess(pat, args);
e07360fa
AT		 1340 if (PL_errors && SvCUR(PL_errors)) {
1341 sv_catsv(PL_errors, msv);
cfd0369c 1342 message = SvPV_const(PL_errors, *msglen);
e07360fa
AT		 1343 SvCUR_set(PL_errors, 0);
1344 }
1345 else
cfd0369c 1346 message = SvPV_const(msv,*msglen);
e07360fa
AT		 1347 *utf8 = SvUTF8(msv);
1348 }
1349 else {
bd61b366 1350 message = NULL;
e07360fa
AT		 1351 }
1352
e07360fa 1353 if (PL_diehook) {
46d9c920 1354 S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
e07360fa
AT		 1355 }
1356 return message;
1357}
1358
1f676739 1359static OP *
e3cf49e2 1360S_vdie(pTHX_ const char* pat, va_list *args)
36477c24 1361{
97aff369 1362 dVAR;
73d840c0 1363 const char *message;
e1ec3a88 1364 const int was_in_eval = PL_in_eval;
06bf62c7 1365 STRLEN msglen;
ff882698 1366 I32 utf8 = 0;
36477c24 1367
890ce7af 1368 message = vdie_croak_common(pat, args, &msglen, &utf8);
36477c24 1369
06bf62c7 1370 PL_restartop = die_where(message, msglen);
ff882698 1371 SvFLAGS(ERRSV) |= utf8;
3280af22 1372 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
6224f72b 1373 JMPENV_JUMP(3);
3280af22 1374 return PL_restartop;
36477c24 1375}
1376
c5be433b 1377#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1378OP *
1379Perl_die_nocontext(const char* pat, ...)
a687059c 1380{
cea2e8a9
GS		 1381 dTHX;
1382 OP *o;
a687059c 1383 va_list args;
cea2e8a9 1384 va_start(args, pat);
c5be433b 1385 o = vdie(pat, &args);
cea2e8a9
GS		 1386 va_end(args);
1387 return o;
1388}
c5be433b 1389#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9
GS		 1390
1391OP *
1392Perl_die(pTHX_ const char* pat, ...)
1393{
1394 OP *o;
1395 va_list args;
1396 va_start(args, pat);
c5be433b 1397 o = vdie(pat, &args);
cea2e8a9
GS		 1398 va_end(args);
1399 return o;
1400}
1401
c5be433b
GS		 1402void
1403Perl_vcroak(pTHX_ const char* pat, va_list *args)
cea2e8a9 1404{
97aff369 1405 dVAR;
73d840c0 1406 const char *message;
06bf62c7 1407 STRLEN msglen;
ff882698 1408 I32 utf8 = 0;
a687059c 1409
3ab1ac99 1410 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
5a844595 1411
3280af22 1412 if (PL_in_eval) {
06bf62c7 1413 PL_restartop = die_where(message, msglen);
ff882698 1414 SvFLAGS(ERRSV) |= utf8;
6224f72b 1415 JMPENV_JUMP(3);
a0d0e21e 1416 }
84414e3e 1417 else if (!message)
cfd0369c 1418 message = SvPVx_const(ERRSV, msglen);
84414e3e 1419
7ff03255 1420 write_to_stderr(message, msglen);
f86702cc 1421 my_failure_exit();
a687059c
LW		 1422}
1423
c5be433b 1424#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1425void
cea2e8a9 1426Perl_croak_nocontext(const char *pat, ...)
a687059c 1427{
cea2e8a9 1428 dTHX;
a687059c 1429 va_list args;
cea2e8a9 1430 va_start(args, pat);
c5be433b 1431 vcroak(pat, &args);
cea2e8a9
GS		 1432 /* NOTREACHED */
1433 va_end(args);
1434}
1435#endif /* PERL_IMPLICIT_CONTEXT */
1436
954c1994 1437/*
ccfc67b7
JH		 1438=head1 Warning and Dieing
1439
954c1994
GS		 1440=for apidoc croak
1441
9983fa3c 1442This is the XSUB-writer's interface to Perl's C<die> function.
966353fd
MF		 1443Normally call this function the same way you call the C C<printf>
1444function. Calling C<croak> returns control directly to Perl,
1445sidestepping the normal C order of execution. See C<warn>.
9983fa3c
GS		 1446
1447If you want to throw an exception object, assign the object to
bd61b366 1448C<$@> and then pass C<NULL> to croak():
9983fa3c 1449
64ace3f8 1450 errsv = get_sv("@", GV_ADD);
9983fa3c 1451 sv_setsv(errsv, exception_object);
bd61b366 1452 croak(NULL);
954c1994
GS		 1453
1454=cut
1455*/
1456
cea2e8a9
GS		 1457void
1458Perl_croak(pTHX_ const char *pat, ...)
1459{
1460 va_list args;
1461 va_start(args, pat);
c5be433b 1462 vcroak(pat, &args);
cea2e8a9
GS		 1463 /* NOTREACHED */
1464 va_end(args);
1465}
1466
c5be433b
GS		 1467void
1468Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1469{
27da23d5 1470 dVAR;
06bf62c7 1471 STRLEN msglen;
53c1dcc0
AL		 1472 SV * const msv = vmess(pat, args);
1473 const I32 utf8 = SvUTF8(msv);
1474 const char * const message = SvPV_const(msv, msglen);
a687059c 1475
7918f24d
NC		 1476 PERL_ARGS_ASSERT_VWARN;
1477
3280af22 1478 if (PL_warnhook) {
46d9c920 1479 if (vdie_common(message, msglen, utf8, TRUE))
20cec16a 1480 return;
748a9306 1481 }
87582a92 1482
7ff03255 1483 write_to_stderr(message, msglen);
a687059c 1484}
8d063cd8 1485
c5be433b 1486#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1487void
1488Perl_warn_nocontext(const char *pat, ...)
1489{
1490 dTHX;
1491 va_list args;
7918f24d 1492 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
cea2e8a9 1493 va_start(args, pat);
c5be433b 1494 vwarn(pat, &args);
cea2e8a9
GS		 1495 va_end(args);
1496}
1497#endif /* PERL_IMPLICIT_CONTEXT */
1498
954c1994
GS		 1499/*
1500=for apidoc warn
1501
966353fd
MF		 1502This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1503function the same way you call the C C<printf> function. See C<croak>.
954c1994
GS		 1504
1505=cut
1506*/
1507
cea2e8a9
GS		 1508void
1509Perl_warn(pTHX_ const char *pat, ...)
1510{
1511 va_list args;
7918f24d 1512 PERL_ARGS_ASSERT_WARN;
cea2e8a9 1513 va_start(args, pat);
c5be433b 1514 vwarn(pat, &args);
cea2e8a9
GS		 1515 va_end(args);
1516}
1517
c5be433b
GS		 1518#if defined(PERL_IMPLICIT_CONTEXT)
1519void
1520Perl_warner_nocontext(U32 err, const char *pat, ...)
1521{
27da23d5 1522 dTHX;
c5be433b 1523 va_list args;
7918f24d 1524 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
c5be433b
GS		 1525 va_start(args, pat);
1526 vwarner(err, pat, &args);
1527 va_end(args);
1528}
1529#endif /* PERL_IMPLICIT_CONTEXT */
1530
599cee73 1531void
a2a5de95
NC		 1532Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1533{
1534 PERL_ARGS_ASSERT_CK_WARNER;
1535
1536 if (Perl_ckwarn(aTHX_ err)) {
1537 va_list args;
1538 va_start(args, pat);
1539 vwarner(err, pat, &args);
1540 va_end(args);
1541 }
1542}
1543
1544void
864dbfa3 1545Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM		 1546{
1547 va_list args;
7918f24d 1548 PERL_ARGS_ASSERT_WARNER;
c5be433b
GS		 1549 va_start(args, pat);
1550 vwarner(err, pat, &args);
1551 va_end(args);
1552}
1553
1554void
1555Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1556{
27da23d5 1557 dVAR;
7918f24d 1558 PERL_ARGS_ASSERT_VWARNER;
5f2d9966 1559 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
a3b680e6 1560 SV * const msv = vmess(pat, args);
d13b0d77 1561 STRLEN msglen;
7452cf6a 1562 const char * const message = SvPV_const(msv, msglen);
a3b680e6 1563 const I32 utf8 = SvUTF8(msv);
599cee73 1564
3aed30dc 1565 if (PL_diehook) {
63315e18 1566 assert(message);
46d9c920 1567 S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
3aed30dc
HS		 1568 }
1569 if (PL_in_eval) {
1570 PL_restartop = die_where(message, msglen);
ff882698 1571 SvFLAGS(ERRSV) |= utf8;
3aed30dc
HS		 1572 JMPENV_JUMP(3);
1573 }
7ff03255 1574 write_to_stderr(message, msglen);
3aed30dc 1575 my_failure_exit();
599cee73
PM		 1576 }
1577 else {
d13b0d77 1578 Perl_vwarn(aTHX_ pat, args);
599cee73
PM		 1579 }
1580}
1581
f54ba1c2
DM		 1582/* implements the ckWARN? macros */
1583
1584bool
1585Perl_ckwarn(pTHX_ U32 w)
1586{
97aff369 1587 dVAR;
f8279d10
NC		 1588 return isLEXWARN_on
1589 ? (PL_curcop->cop_warnings != pWARN_NONE
1590 && (
f54ba1c2
DM		 1591 PL_curcop->cop_warnings == pWARN_ALL
1592 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1593 || (unpackWARN2(w) &&
1594 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1595 || (unpackWARN3(w) &&
1596 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1597 || (unpackWARN4(w) &&
1598 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1599 )
f8279d10
NC		 1600 )
1601 : (PL_dowarn & G_WARN_ON);
f54ba1c2
DM		 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 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 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 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{
e37778c2 2258#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !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 2290 }
a2a5de95 2291 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
1f852d0d
NIS		 2292 sleep(5);
2293 }
2294 if (pid == 0) {
2295 /* Child */
1f852d0d
NIS		 2296#undef THIS
2297#undef THAT
2298#define THIS that
2299#define THAT This
1f852d0d
NIS		 2300 /* Close parent's end of error status pipe (if any) */
2301 if (did_pipes) {
2302 PerlLIO_close(pp[0]);
2303#if defined(HAS_FCNTL) && defined(F_SETFD)
2304 /* Close error pipe automatically if exec works */
2305 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2306#endif
2307 }
2308 /* Now dup our end of _the_ pipe to right position */
2309 if (p[THIS] != (*mode == 'r')) {
2310 PerlLIO_dup2(p[THIS], *mode == 'r');
2311 PerlLIO_close(p[THIS]);
4e6dfe71
GS		 2312 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2313 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2314 }
4e6dfe71
GS		 2315 else
2316 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS		 2317#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2318 /* No automatic close - do it by hand */
b7953727
JH		 2319# ifndef NOFILE
2320# define NOFILE 20
2321# endif
a080fe3d
NIS		 2322 {
2323 int fd;
2324
2325 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2326 if (fd != pp[1])
a080fe3d
NIS		 2327 PerlLIO_close(fd);
2328 }
1f852d0d
NIS		 2329 }
2330#endif
a0714e2c 2331 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS		 2332 PerlProc__exit(1);
2333#undef THIS
2334#undef THAT
2335 }
2336 /* Parent */
52e18b1f 2337 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS		 2338 if (did_pipes)
2339 PerlLIO_close(pp[1]);
2340 /* Keep the lower of the two fd numbers */
2341 if (p[that] < p[This]) {
2342 PerlLIO_dup2(p[This], p[that]);
2343 PerlLIO_close(p[This]);
2344 p[This] = p[that];
2345 }
4e6dfe71
GS		 2346 else
2347 PerlLIO_close(p[that]); /* close child's end of pipe */
2348
1f852d0d 2349 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2350 SvUPGRADE(sv,SVt_IV);
45977657 2351 SvIV_set(sv, pid);
1f852d0d
NIS		 2352 PL_forkprocess = pid;
2353 /* If we managed to get status pipe check for exec fail */
2354 if (did_pipes && pid > 0) {
2355 int errkid;
bb7a0f54
MHM		 2356 unsigned n = 0;
2357 SSize_t n1;
1f852d0d
NIS		 2358
2359 while (n < sizeof(int)) {
2360 n1 = PerlLIO_read(pp[0],
2361 (void*)(((char*)&errkid)+n),
2362 (sizeof(int)) - n);
2363 if (n1 <= 0)
2364 break;
2365 n += n1;
2366 }
2367 PerlLIO_close(pp[0]);
2368 did_pipes = 0;
2369 if (n) { /* Error */
2370 int pid2, status;
8c51524e 2371 PerlLIO_close(p[This]);
1f852d0d
NIS		 2372 if (n != sizeof(int))
2373 Perl_croak(aTHX_ "panic: kid popen errno read");
2374 do {
2375 pid2 = wait4pid(pid, &status, 0);
2376 } while (pid2 == -1 && errno == EINTR);
2377 errno = errkid; /* Propagate errno from kid */
4608196e 2378 return NULL;
1f852d0d
NIS		 2379 }
2380 }
2381 if (did_pipes)
2382 PerlLIO_close(pp[0]);
2383 return PerlIO_fdopen(p[This], mode);
2384#else
9d419b5f 2385# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
4e205ed6 2386 return my_syspopen4(aTHX_ NULL, mode, n, args);
9d419b5f 2387# else
4a7d1889
NIS		 2388 Perl_croak(aTHX_ "List form of piped open not implemented");
2389 return (PerlIO *) NULL;
9d419b5f 2390# endif
1f852d0d 2391#endif
4a7d1889
NIS		 2392}
2393
5f05dabc 2394 /* VMS' my_popen() is in VMS.c, same with OS/2. */
e37778c2 2395#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
760ac839 2396PerlIO *
3dd43144 2397Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c 2398{
97aff369 2399 dVAR;
a687059c 2400 int p[2];
8ac85365 2401 register I32 This, that;
d8a83dd3 2402 register Pid_t pid;
79072805 2403 SV *sv;
bfce84ec 2404 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ		 2405 I32 did_pipes = 0;
2406 int pp[2];
a687059c 2407
7918f24d
NC		 2408 PERL_ARGS_ASSERT_MY_POPEN;
2409
45bc9206 2410 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 2411#ifdef OS2
2412 if (doexec) {
23da6c43 2413 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2414 }
a1d180c4 2415#endif
8ac85365
NIS		 2416 This = (*mode == 'w');
2417 that = !This;
3280af22 2418 if (doexec && PL_tainting) {
bbce6d69 2419 taint_env();
2420 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2421 }
c2267164 2422 if (PerlProc_pipe(p) < 0)
4608196e 2423 return NULL;
e446cec8
IZ		 2424 if (doexec && PerlProc_pipe(pp) >= 0)
2425 did_pipes = 1;
52e18b1f 2426 while ((pid = PerlProc_fork()) < 0) {
a687059c 2427 if (errno != EAGAIN) {
6ad3d225 2428 PerlLIO_close(p[This]);
b5ac89c3 2429 PerlLIO_close(p[that]);
e446cec8
IZ		 2430 if (did_pipes) {
2431 PerlLIO_close(pp[0]);
2432 PerlLIO_close(pp[1]);
2433 }
a687059c 2434 if (!doexec)
b3647a36 2435 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2436 return NULL;
a687059c 2437 }
a2a5de95 2438 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW		 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
3280af22 2516 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2517 SvUPGRADE(sv,SVt_IV);
45977657 2518 SvIV_set(sv, pid);
3280af22 2519 PL_forkprocess = pid;
e446cec8
IZ		 2520 if (did_pipes && pid > 0) {
2521 int errkid;
bb7a0f54
MHM		 2522 unsigned n = 0;
2523 SSize_t n1;
e446cec8
IZ		 2524
2525 while (n < sizeof(int)) {
2526 n1 = PerlLIO_read(pp[0],
2527 (void*)(((char*)&errkid)+n),
2528 (sizeof(int)) - n);
2529 if (n1 <= 0)
2530 break;
2531 n += n1;
2532 }
2f96c702
IZ		 2533 PerlLIO_close(pp[0]);
2534 did_pipes = 0;
e446cec8 2535 if (n) { /* Error */
faa466a7 2536 int pid2, status;
8c51524e 2537 PerlLIO_close(p[This]);
e446cec8 2538 if (n != sizeof(int))
cea2e8a9 2539 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2540 do {
2541 pid2 = wait4pid(pid, &status, 0);
2542 } while (pid2 == -1 && errno == EINTR);
e446cec8 2543 errno = errkid; /* Propagate errno from kid */
4608196e 2544 return NULL;
e446cec8
IZ		 2545 }
2546 }
2547 if (did_pipes)
2548 PerlLIO_close(pp[0]);
8ac85365 2549 return PerlIO_fdopen(p[This], mode);
a687059c 2550}
7c0587c8 2551#else
85ca448a 2552#if defined(atarist) || defined(EPOC)
7c0587c8 2553FILE *popen();
760ac839 2554PerlIO *
cef6ea9d 2555Perl_my_popen(pTHX_ const char *cmd, const char *mode)
7c0587c8 2556{
7918f24d 2557 PERL_ARGS_ASSERT_MY_POPEN;
45bc9206 2558 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2559 /* Call system's popen() to get a FILE *, then import it.
2560 used 0 for 2nd parameter to PerlIO_importFILE;
2561 apparently not used
2562 */
2563 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2564}
2b96b0a5
JH		 2565#else
2566#if defined(DJGPP)
2567FILE *djgpp_popen();
2568PerlIO *
cef6ea9d 2569Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH		 2570{
2571 PERL_FLUSHALL_FOR_CHILD;
2572 /* Call system's popen() to get a FILE *, then import it.
2573 used 0 for 2nd parameter to PerlIO_importFILE;
2574 apparently not used
2575 */
2576 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2577}
9c12f1e5
RGS		 2578#else
2579#if defined(__LIBCATAMOUNT__)
2580PerlIO *
2581Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2582{
2583 return NULL;
2584}
2585#endif
2b96b0a5 2586#endif
7c0587c8
LW		 2587#endif
2588
2589#endif /* !DOSISH */
a687059c 2590
52e18b1f
GS		 2591/* this is called in parent before the fork() */
2592void
2593Perl_atfork_lock(void)
2594{
27da23d5 2595 dVAR;
3db8f154 2596#if defined(USE_ITHREADS)
52e18b1f
GS		 2597 /* locks must be held in locking order (if any) */
2598# ifdef MYMALLOC
2599 MUTEX_LOCK(&PL_malloc_mutex);
2600# endif
2601 OP_REFCNT_LOCK;
2602#endif
2603}
2604
2605/* this is called in both parent and child after the fork() */
2606void
2607Perl_atfork_unlock(void)
2608{
27da23d5 2609 dVAR;
3db8f154 2610#if defined(USE_ITHREADS)
52e18b1f
GS		 2611 /* locks must be released in same order as in atfork_lock() */
2612# ifdef MYMALLOC
2613 MUTEX_UNLOCK(&PL_malloc_mutex);
2614# endif
2615 OP_REFCNT_UNLOCK;
2616#endif
2617}
2618
2619Pid_t
2620Perl_my_fork(void)
2621{
2622#if defined(HAS_FORK)
2623 Pid_t pid;
3db8f154 2624#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2625 atfork_lock();
2626 pid = fork();
2627 atfork_unlock();
2628#else
2629 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2630 * handlers elsewhere in the code */
2631 pid = fork();
2632#endif
2633 return pid;
2634#else
2635 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2636 Perl_croak_nocontext("fork() not available");
b961a566 2637 return 0;
52e18b1f
GS		 2638#endif /* HAS_FORK */
2639}
2640
748a9306 2641#ifdef DUMP_FDS
35ff7856 2642void
c9289b7b 2643Perl_dump_fds(pTHX_ const char *const s)
ae986130
LW		 2644{
2645 int fd;
c623ac67 2646 Stat_t tmpstatbuf;
ae986130 2647
7918f24d
NC		 2648 PERL_ARGS_ASSERT_DUMP_FDS;
2649
bf49b057 2650 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2651 for (fd = 0; fd < 32; fd++) {
6ad3d225 2652 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2653 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2654 }
bf49b057 2655 PerlIO_printf(Perl_debug_log,"\n");
27da23d5 2656 return;
ae986130 2657}
35ff7856 2658#endif /* DUMP_FDS */
ae986130 2659
fe14fcc3 2660#ifndef HAS_DUP2
fec02dd3 2661int
ba106d47 2662dup2(int oldfd, int newfd)
a687059c 2663{
a0d0e21e 2664#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2665 if (oldfd == newfd)
2666 return oldfd;
6ad3d225 2667 PerlLIO_close(newfd);
fec02dd3 2668 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2669#else
fc36a67e 2670#define DUP2_MAX_FDS 256
2671 int fdtmp[DUP2_MAX_FDS];
79072805 2672 I32 fdx = 0;
ae986130
LW		 2673 int fd;
2674
fe14fcc3 2675 if (oldfd == newfd)
fec02dd3 2676 return oldfd;
6ad3d225 2677 PerlLIO_close(newfd);
fc36a67e 2678 /* good enough for low fd's... */
6ad3d225 2679 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2680 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2681 PerlLIO_close(fd);
fc36a67e 2682 fd = -1;
2683 break;
2684 }
ae986130 2685 fdtmp[fdx++] = fd;
fc36a67e 2686 }
ae986130 2687 while (fdx > 0)
6ad3d225 2688 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2689 return fd;
62b28dd9 2690#endif
a687059c
LW		 2691}
2692#endif
2693
64ca3a65 2694#ifndef PERL_MICRO
ff68c719 2695#ifdef HAS_SIGACTION
2696
2697Sighandler_t
864dbfa3 2698Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2699{
27da23d5 2700 dVAR;
ff68c719 2701 struct sigaction act, oact;
2702
a10b1e10
JH		 2703#ifdef USE_ITHREADS
2704 /* only "parent" interpreter can diddle signals */
2705 if (PL_curinterp != aTHX)
8aad04aa 2706 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2707#endif
2708
8aad04aa 2709 act.sa_handler = (void(*)(int))handler;
ff68c719 2710 sigemptyset(&act.sa_mask);
2711 act.sa_flags = 0;
2712#ifdef SA_RESTART
4ffa73a3
JH		 2713 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2714 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2715#endif
358837b8 2716#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2717 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2718 act.sa_flags |= SA_NOCLDWAIT;
2719#endif
ff68c719 2720 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2721 return (Sighandler_t) SIG_ERR;
ff68c719 2722 else
8aad04aa 2723 return (Sighandler_t) oact.sa_handler;
ff68c719 2724}
2725
2726Sighandler_t
864dbfa3 2727Perl_rsignal_state(pTHX_ int signo)
ff68c719 2728{
2729 struct sigaction oact;
96a5add6 2730 PERL_UNUSED_CONTEXT;
ff68c719 2731
2732 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2733 return (Sighandler_t) SIG_ERR;
ff68c719 2734 else
8aad04aa 2735 return (Sighandler_t) oact.sa_handler;
ff68c719 2736}
2737
2738int
864dbfa3 2739Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2740{
27da23d5 2741 dVAR;
ff68c719 2742 struct sigaction act;
2743
7918f24d
NC		 2744 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2745
a10b1e10
JH		 2746#ifdef USE_ITHREADS
2747 /* only "parent" interpreter can diddle signals */
2748 if (PL_curinterp != aTHX)
2749 return -1;
2750#endif
2751
8aad04aa 2752 act.sa_handler = (void(*)(int))handler;
ff68c719 2753 sigemptyset(&act.sa_mask);
2754 act.sa_flags = 0;
2755#ifdef SA_RESTART
4ffa73a3
JH		 2756 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2757 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2758#endif
36b5d377 2759#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2760 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2761 act.sa_flags |= SA_NOCLDWAIT;
2762#endif
ff68c719 2763 return sigaction(signo, &act, save);
2764}
2765
2766int
864dbfa3 2767Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2768{
27da23d5 2769 dVAR;
a10b1e10
JH		 2770#ifdef USE_ITHREADS
2771 /* only "parent" interpreter can diddle signals */
2772 if (PL_curinterp != aTHX)
2773 return -1;
2774#endif
2775
ff68c719 2776 return sigaction(signo, save, (struct sigaction *)NULL);
2777}
2778
2779#else /* !HAS_SIGACTION */
2780
2781Sighandler_t
864dbfa3 2782Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2783{
39f1703b 2784#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2785 /* only "parent" interpreter can diddle signals */
2786 if (PL_curinterp != aTHX)
8aad04aa 2787 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2788#endif
2789
6ad3d225 2790 return PerlProc_signal(signo, handler);
ff68c719 2791}
2792
fabdb6c0 2793static Signal_t
4e35701f 2794sig_trap(int signo)
ff68c719 2795{
27da23d5
JH		 2796 dVAR;
2797 PL_sig_trapped++;
ff68c719 2798}
2799
2800Sighandler_t
864dbfa3 2801Perl_rsignal_state(pTHX_ int signo)
ff68c719 2802{
27da23d5 2803 dVAR;
ff68c719 2804 Sighandler_t oldsig;
2805
39f1703b 2806#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2807 /* only "parent" interpreter can diddle signals */
2808 if (PL_curinterp != aTHX)
8aad04aa 2809 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2810#endif
2811
27da23d5 2812 PL_sig_trapped = 0;
6ad3d225
GS		 2813 oldsig = PerlProc_signal(signo, sig_trap);
2814 PerlProc_signal(signo, oldsig);
27da23d5 2815 if (PL_sig_trapped)
3aed30dc 2816 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2817 return oldsig;
2818}
2819
2820int
864dbfa3 2821Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2822{
39f1703b 2823#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2824 /* only "parent" interpreter can diddle signals */
2825 if (PL_curinterp != aTHX)
2826 return -1;
2827#endif
6ad3d225 2828 *save = PerlProc_signal(signo, handler);
8aad04aa 2829 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2830}
2831
2832int
864dbfa3 2833Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2834{
39f1703b 2835#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2836 /* only "parent" interpreter can diddle signals */
2837 if (PL_curinterp != aTHX)
2838 return -1;
2839#endif
8aad04aa 2840 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2841}
2842
2843#endif /* !HAS_SIGACTION */
64ca3a65 2844#endif /* !PERL_MICRO */
ff68c719 2845
5f05dabc 2846 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
e37778c2 2847#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
79072805 2848I32
864dbfa3 2849Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2850{
97aff369 2851 dVAR;
ff68c719 2852 Sigsave_t hstat, istat, qstat;
a687059c 2853 int status;
a0d0e21e 2854 SV **svp;
d8a83dd3
JH		 2855 Pid_t pid;
2856 Pid_t pid2;
03136e13 2857 bool close_failed;
4ee39169 2858 dSAVEDERRNO;
a687059c 2859
3280af22 2860 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
25d92023 2861 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2862 SvREFCNT_dec(*svp);
3280af22 2863 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2864#ifdef OS2
2865 if (pid == -1) { /* Opened by popen. */
2866 return my_syspclose(ptr);
2867 }
a1d180c4 2868#endif
f1618b10
CS		 2869 close_failed = (PerlIO_close(ptr) == EOF);
2870 SAVE_ERRNO;
7c0587c8 2871#ifdef UTS
6ad3d225 2872 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2873#endif
64ca3a65 2874#ifndef PERL_MICRO
8aad04aa
JH		 2875 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2876 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2877 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
64ca3a65 2878#endif
748a9306 2879 do {
1d3434b8
GS		 2880 pid2 = wait4pid(pid, &status, 0);
2881 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2882#ifndef PERL_MICRO
ff68c719 2883 rsignal_restore(SIGHUP, &hstat);
2884 rsignal_restore(SIGINT, &istat);
2885 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2886#endif
03136e13 2887 if (close_failed) {
4ee39169 2888 RESTORE_ERRNO;
03136e13
CS		 2889 return -1;
2890 }
1d3434b8 2891 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2892}
9c12f1e5
RGS		 2893#else
2894#if defined(__LIBCATAMOUNT__)
2895I32
2896Perl_my_pclose(pTHX_ PerlIO *ptr)
2897{
2898 return -1;
2899}
2900#endif
4633a7c4
LW		 2901#endif /* !DOSISH */
2902
e37778c2 2903#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 2904I32
d8a83dd3 2905Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2906{
97aff369 2907 dVAR;
27da23d5 2908 I32 result = 0;
7918f24d 2909 PERL_ARGS_ASSERT_WAIT4PID;
b7953727
JH		 2910 if (!pid)
2911 return -1;
ca0c25f6 2912#ifdef PERL_USES_PL_PIDSTATUS
b7953727 2913 {
3aed30dc 2914 if (pid > 0) {
12072db5
NC		 2915 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2916 pid, rather than a string form. */
c4420975 2917 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS		 2918 if (svp && *svp != &PL_sv_undef) {
2919 *statusp = SvIVX(*svp);
12072db5
NC		 2920 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2921 G_DISCARD);
3aed30dc
HS		 2922 return pid;
2923 }
2924 }
2925 else {
2926 HE *entry;
2927
2928 hv_iterinit(PL_pidstatus);
2929 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 2930 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 2931 I32 len;
0bcc34c2 2932 const char * const spid = hv_iterkey(entry,&len);
27da23d5 2933
12072db5
NC		 2934 assert (len == sizeof(Pid_t));
2935 memcpy((char *)&pid, spid, len);
3aed30dc 2936 *statusp = SvIVX(sv);
7b9a3241
NC		 2937 /* The hash iterator is currently on this entry, so simply
2938 calling hv_delete would trigger the lazy delete, which on
2939 aggregate does more work, beacuse next call to hv_iterinit()
2940 would spot the flag, and have to call the delete routine,
2941 while in the meantime any new entries can't re-use that
2942 memory. */
2943 hv_iterinit(PL_pidstatus);
7ea75b61 2944 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS		 2945 return pid;
2946 }
20188a90
LW		 2947 }
2948 }
68a29c53 2949#endif
79072805 2950#ifdef HAS_WAITPID
367f3c24
IZ		 2951# ifdef HAS_WAITPID_RUNTIME
2952 if (!HAS_WAITPID_RUNTIME)
2953 goto hard_way;
2954# endif
cddd4526 2955 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2956 goto finish;
367f3c24
IZ		 2957#endif
2958#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
4608196e 2959 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
dfcfdb64 2960 goto finish;
367f3c24 2961#endif
ca0c25f6 2962#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 2963#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 2964 hard_way:
27da23d5 2965#endif
a0d0e21e 2966 {
a0d0e21e 2967 if (flags)
cea2e8a9 2968 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2969 else {
76e3520e 2970 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2971 pidgone(result,*statusp);
2972 if (result < 0)
2973 *statusp = -1;
2974 }
a687059c
LW		 2975 }
2976#endif
27da23d5 2977#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 2978 finish:
27da23d5 2979#endif
cddd4526
NIS		 2980 if (result < 0 && errno == EINTR) {
2981 PERL_ASYNC_CHECK();
48dbb59e 2982 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS		 2983 }
2984 return result;
a687059c 2985}
2986a63f 2986#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2987
ca0c25f6 2988#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 2989void
ed4173ef 2990S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2991{
79072805 2992 register SV *sv;
a687059c 2993
12072db5 2994 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 2995 SvUPGRADE(sv,SVt_IV);
45977657 2996 SvIV_set(sv, status);
20188a90 2997 return;
a687059c 2998}
ca0c25f6 2999#endif
a687059c 3000
85ca448a 3001#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 3002int pclose();
ddcf38b7
IZ		 3003#ifdef HAS_FORK
3004int /* Cannot prototype with I32
3005 in os2ish.h. */
ba106d47 3006my_syspclose(PerlIO *ptr)
ddcf38b7 3007#else
79072805 3008I32
864dbfa3 3009Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 3010#endif
a687059c 3011{
760ac839 3012 /* Needs work for PerlIO ! */
c4420975 3013 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 3014 const I32 result = pclose(f);
2b96b0a5
JH		 3015 PerlIO_releaseFILE(ptr,f);
3016 return result;
3017}
3018#endif
3019
933fea7f 3020#if defined(DJGPP)
2b96b0a5
JH		 3021int djgpp_pclose();
3022I32
3023Perl_my_pclose(pTHX_ PerlIO *ptr)
3024{
3025 /* Needs work for PerlIO ! */
c4420975 3026 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 3027 I32 result = djgpp_pclose(f);
933fea7f 3028 result = (result << 8) & 0xff00;
760ac839
LW		 3029 PerlIO_releaseFILE(ptr,f);
3030 return result;
a687059c 3031}
7c0587c8 3032#endif
9f68db38 3033
16fa5c11 3034#define PERL_REPEATCPY_LINEAR 4
9f68db38 3035void
16fa5c11 3036Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
9f68db38 3037{
7918f24d
NC		 3038 PERL_ARGS_ASSERT_REPEATCPY;
3039
16fa5c11
VP		 3040 if (len == 1)
3041 memset(to, *from, count);
3042 else if (count) {
3043 register char *p = to;
3044 I32 items, linear, half;
3045
3046 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3047 for (items = 0; items < linear; ++items) {
3048 register const char *q = from;
3049 I32 todo;
3050 for (todo = len; todo > 0; todo--)
3051 *p++ = *q++;
3052 }
3053
3054 half = count / 2;
3055 while (items <= half) {
3056 I32 size = items * len;
3057 memcpy(p, to, size);
3058 p += size;
3059 items *= 2;
9f68db38 3060 }
16fa5c11
VP		 3061
3062 if (count > items)
3063 memcpy(p, to, (count - items) * len);
9f68db38
LW		 3064 }
3065}
0f85fab0 3066
fe14fcc3 3067#ifndef HAS_RENAME
79072805 3068I32
4373e329 3069Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3070{
93a17b20
LW		 3071 char *fa = strrchr(a,'/');
3072 char *fb = strrchr(b,'/');
c623ac67
GS		 3073 Stat_t tmpstatbuf1;
3074 Stat_t tmpstatbuf2;
c4420975 3075 SV * const tmpsv = sv_newmortal();
62b28dd9 3076
7918f24d
NC		 3077 PERL_ARGS_ASSERT_SAME_DIRENT;
3078
62b28dd9
LW		 3079 if (fa)
3080 fa++;
3081 else
3082 fa = a;
3083 if (fb)
3084 fb++;
3085 else
3086 fb = b;
3087 if (strNE(a,b))
3088 return FALSE;
3089 if (fa == a)
76f68e9b 3090 sv_setpvs(tmpsv, ".");
62b28dd9 3091 else
46fc3d4c 3092 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3093 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 3094 return FALSE;
3095 if (fb == b)
76f68e9b 3096 sv_setpvs(tmpsv, ".");
62b28dd9 3097 else
46fc3d4c 3098 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3099 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 3100 return FALSE;
3101 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3102 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3103}
fe14fcc3
LW		 3104#endif /* !HAS_RENAME */
3105
491527d0 3106char*
7f315aed
NC		 3107Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3108 const char *const *const search_ext, I32 flags)
491527d0 3109{
97aff369 3110 dVAR;
bd61b366
SS		 3111 const char *xfound = NULL;
3112 char *xfailed = NULL;
0f31cffe 3113 char tmpbuf[MAXPATHLEN];
491527d0 3114 register char *s;
5f74f29c 3115 I32 len = 0;
491527d0 3116 int retval;
39a02377 3117 char *bufend;
491527d0
GS		 3118#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3119# define SEARCH_EXTS ".bat", ".cmd", NULL
3120# define MAX_EXT_LEN 4
3121#endif
3122#ifdef OS2
3123# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3124# define MAX_EXT_LEN 4
3125#endif
3126#ifdef VMS
3127# define SEARCH_EXTS ".pl", ".com", NULL
3128# define MAX_EXT_LEN 4
3129#endif
3130 /* additional extensions to try in each dir if scriptname not found */
3131#ifdef SEARCH_EXTS
0bcc34c2 3132 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3133 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3134 int extidx = 0, i = 0;
bd61b366 3135 const char *curext = NULL;
491527d0 3136#else
53c1dcc0 3137 PERL_UNUSED_ARG(search_ext);
491527d0
GS		 3138# define MAX_EXT_LEN 0
3139#endif
3140
7918f24d
NC		 3141 PERL_ARGS_ASSERT_FIND_SCRIPT;
3142
491527d0
GS		 3143 /*
3144 * If dosearch is true and if scriptname does not contain path
3145 * delimiters, search the PATH for scriptname.
3146 *
3147 * If SEARCH_EXTS is also defined, will look for each
3148 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3149 * while searching the PATH.
3150 *
3151 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3152 * proceeds as follows:
3153 * If DOSISH or VMSISH:
3154 * + look for ./scriptname{,.foo,.bar}
3155 * + search the PATH for scriptname{,.foo,.bar}
3156 *
3157 * If !DOSISH:
3158 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3159 * this will not look in '.' if it's not in the PATH)
3160 */
84486fc6 3161 tmpbuf[0] = '\0';
491527d0
GS		 3162
3163#ifdef VMS
3164# ifdef ALWAYS_DEFTYPES
3165 len = strlen(scriptname);
3166 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3167 int idx = 0, deftypes = 1;
491527d0
GS		 3168 bool seen_dot = 1;
3169
bd61b366 3170 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3171# else
3172 if (dosearch) {
c4420975 3173 int idx = 0, deftypes = 1;
491527d0
GS		 3174 bool seen_dot = 1;
3175
bd61b366 3176 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3177# endif
3178 /* The first time through, just add SEARCH_EXTS to whatever we
3179 * already have, so we can check for default file types. */
3180 while (deftypes ||
84486fc6 3181 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 3182 {
3183 if (deftypes) {
3184 deftypes = 0;
84486fc6 3185 *tmpbuf = '\0';
491527d0 3186 }
84486fc6
GS		 3187 if ((strlen(tmpbuf) + strlen(scriptname)
3188 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3189 continue; /* don't search dir with too-long name */
6fca0082 3190 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS		 3191#else /* !VMS */
3192
3193#ifdef DOSISH
3194 if (strEQ(scriptname, "-"))
3195 dosearch = 0;
3196 if (dosearch) { /* Look in '.' first. */
fe2774ed 3197 const char *cur = scriptname;
491527d0
GS		 3198#ifdef SEARCH_EXTS
3199 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3200 while (ext[i])
3201 if (strEQ(ext[i++],curext)) {
3202 extidx = -1; /* already has an ext */
3203 break;
3204 }
3205 do {
3206#endif
3207 DEBUG_p(PerlIO_printf(Perl_debug_log,
3208 "Looking for %s\n",cur));
017f25f1
IZ		 3209 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3210 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 3211 dosearch = 0;
3212 scriptname = cur;
3213#ifdef SEARCH_EXTS
3214 break;
3215#endif
3216 }
3217#ifdef SEARCH_EXTS
3218 if (cur == scriptname) {
3219 len = strlen(scriptname);
84486fc6 3220 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3221 break;
9e4425f7
SH		 3222 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3223 cur = tmpbuf;
491527d0
GS		 3224 }
3225 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3226 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS		 3227#endif
3228 }
3229#endif
3230
3231 if (dosearch && !strchr(scriptname, '/')
3232#ifdef DOSISH
3233 && !strchr(scriptname, '\\')
3234#endif
cd39f2b6 3235 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3236 {
491527d0 3237 bool seen_dot = 0;
92f0c265 3238
39a02377
DM		 3239 bufend = s + strlen(s);
3240 while (s < bufend) {
491527d0
GS		 3241#if defined(atarist) || defined(DOSISH)
3242 for (len = 0; *s
3243# ifdef atarist
3244 && *s != ','
3245# endif
3246 && *s != ';'; len++, s++) {
84486fc6
GS		 3247 if (len < sizeof tmpbuf)
3248 tmpbuf[len] = *s;
491527d0 3249 }
84486fc6
GS		 3250 if (len < sizeof tmpbuf)
3251 tmpbuf[len] = '\0';
491527d0 3252#else /* ! (atarist || DOSISH) */
39a02377 3253 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS		 3254 ':',
3255 &len);
3256#endif /* ! (atarist || DOSISH) */
39a02377 3257 if (s < bufend)
491527d0 3258 s++;
84486fc6 3259 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS		 3260 continue; /* don't search dir with too-long name */
3261 if (len
cd86ed9d 3262# if defined(atarist) || defined(DOSISH)
84486fc6
GS		 3263 && tmpbuf[len - 1] != '/'
3264 && tmpbuf[len - 1] != '\\'
490a0e98 3265# endif
491527d0 3266 )
84486fc6
GS		 3267 tmpbuf[len++] = '/';
3268 if (len == 2 && tmpbuf[0] == '.')
491527d0 3269 seen_dot = 1;
28f0d0ec 3270 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS		 3271#endif /* !VMS */
3272
3273#ifdef SEARCH_EXTS
84486fc6 3274 len = strlen(tmpbuf);
491527d0
GS		 3275 if (extidx > 0) /* reset after previous loop */
3276 extidx = 0;
3277 do {
3278#endif
84486fc6 3279 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3280 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 3281 if (S_ISDIR(PL_statbuf.st_mode)) {
3282 retval = -1;
3283 }
491527d0
GS		 3284#ifdef SEARCH_EXTS
3285 } while ( retval < 0 /* not there */
3286 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3287 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS		 3288 );
3289#endif
3290 if (retval < 0)
3291 continue;
3280af22
NIS		 3292 if (S_ISREG(PL_statbuf.st_mode)
3293 && cando(S_IRUSR,TRUE,&PL_statbuf)
e37778c2 3294#if !defined(DOSISH)
3280af22 3295 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 3296#endif
3297 )
3298 {
3aed30dc 3299 xfound = tmpbuf; /* bingo! */
491527d0
GS		 3300 break;
3301 }
3302 if (!xfailed)
84486fc6 3303 xfailed = savepv(tmpbuf);
491527d0
GS		 3304 }
3305#ifndef DOSISH
017f25f1 3306 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3307 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3308 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 3309#endif
3310 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 3311 if (!xfound) {
3312 if (flags & 1) { /* do or die? */
3aed30dc 3313 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 3314 (xfailed ? "execute" : "find"),
3315 (xfailed ? xfailed : scriptname),
3316 (xfailed ? "" : " on PATH"),
3317 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3318 }
bd61b366 3319 scriptname = NULL;
9ccb31f9 3320 }
43c5f42d 3321 Safefree(xfailed);
491527d0
GS		 3322 scriptname = xfound;
3323 }
bd61b366 3324 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS		 3325}
3326
ba869deb
GS		 3327#ifndef PERL_GET_CONTEXT_DEFINED
3328
3329void *
3330Perl_get_context(void)
3331{
27da23d5 3332 dVAR;
3db8f154 3333#if defined(USE_ITHREADS)
ba869deb
GS		 3334# ifdef OLD_PTHREADS_API
3335 pthread_addr_t t;
3336 if (pthread_getspecific(PL_thr_key, &t))
3337 Perl_croak_nocontext("panic: pthread_getspecific");
3338 return (void*)t;
3339# else
bce813aa 3340# ifdef I_MACH_CTHREADS
8b8b35ab 3341 return (void*)cthread_data(cthread_self());
bce813aa 3342# else
8b8b35ab
JH		 3343 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3344# endif
c44d3fdb 3345# endif
ba869deb
GS		 3346#else
3347 return (void*)NULL;
3348#endif
3349}
3350
3351void
3352Perl_set_context(void *t)
3353{
8772537c 3354 dVAR;
7918f24d 3355 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3356#if defined(USE_ITHREADS)
c44d3fdb
GS		 3357# ifdef I_MACH_CTHREADS
3358 cthread_set_data(cthread_self(), t);
3359# else
ba869deb
GS		 3360 if (pthread_setspecific(PL_thr_key, t))
3361 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 3362# endif
b464bac0 3363#else
8772537c 3364 PERL_UNUSED_ARG(t);
ba869deb
GS		 3365#endif
3366}
3367
3368#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3369
27da23d5 3370#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3371struct perl_vars *
864dbfa3 3372Perl_GetVars(pTHX)
22239a37 3373{
533c011a 3374 return &PL_Vars;
22239a37 3375}
31fb1209
NIS		 3376#endif
3377
1cb0ed9b 3378char **
864dbfa3 3379Perl_get_op_names(pTHX)
31fb1209 3380{
96a5add6
AL		 3381 PERL_UNUSED_CONTEXT;
3382 return (char **)PL_op_name;
31fb1209
NIS		 3383}
3384
1cb0ed9b 3385char **
864dbfa3 3386Perl_get_op_descs(pTHX)
31fb1209 3387{
96a5add6
AL		 3388 PERL_UNUSED_CONTEXT;
3389 return (char **)PL_op_desc;
31fb1209 3390}
9e6b2b00 3391
e1ec3a88 3392const char *
864dbfa3 3393Perl_get_no_modify(pTHX)
9e6b2b00 3394{
96a5add6
AL		 3395 PERL_UNUSED_CONTEXT;
3396 return PL_no_modify;
9e6b2b00
GS		 3397}
3398
3399U32 *
864dbfa3 3400Perl_get_opargs(pTHX)
9e6b2b00 3401{
96a5add6
AL		 3402 PERL_UNUSED_CONTEXT;
3403 return (U32 *)PL_opargs;
9e6b2b00 3404}
51aa15f3 3405
0cb96387
GS		 3406PPADDR_t*
3407Perl_get_ppaddr(pTHX)
3408{
96a5add6
AL		 3409 dVAR;
3410 PERL_UNUSED_CONTEXT;
3411 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 3412}
3413
a6c40364
GS		 3414#ifndef HAS_GETENV_LEN
3415char *
bf4acbe4 3416Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3417{
8772537c 3418 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3419 PERL_UNUSED_CONTEXT;
7918f24d 3420 PERL_ARGS_ASSERT_GETENV_LEN;
a6c40364
GS		 3421 if (env_trans)
3422 *len = strlen(env_trans);
3423 return env_trans;
f675dbe5
CB		 3424}
3425#endif
3426
dc9e4912
GS		 3427
3428MGVTBL*
864dbfa3 3429Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3430{
7452cf6a 3431 const MGVTBL* result;
96a5add6 3432 PERL_UNUSED_CONTEXT;
dc9e4912
GS		 3433
3434 switch(vtbl_id) {
3435 case want_vtbl_sv:
3436 result = &PL_vtbl_sv;
3437 break;
3438 case want_vtbl_env:
3439 result = &PL_vtbl_env;
3440 break;
3441 case want_vtbl_envelem:
3442 result = &PL_vtbl_envelem;
3443 break;
3444 case want_vtbl_sig:
3445 result = &PL_vtbl_sig;
3446 break;
3447 case want_vtbl_sigelem:
3448 result = &PL_vtbl_sigelem;
3449 break;
3450 case want_vtbl_pack:
3451 result = &PL_vtbl_pack;
3452 break;
3453 case want_vtbl_packelem:
3454 result = &PL_vtbl_packelem;
3455 break;
3456 case want_vtbl_dbline:
3457 result = &PL_vtbl_dbline;
3458 break;
3459 case want_vtbl_isa:
3460 result = &PL_vtbl_isa;
3461 break;
3462 case want_vtbl_isaelem:
3463 result = &PL_vtbl_isaelem;
3464 break;
3465 case want_vtbl_arylen:
3466 result = &PL_vtbl_arylen;
3467 break;
dc9e4912
GS		 3468 case want_vtbl_mglob:
3469 result = &PL_vtbl_mglob;
3470 break;
3471 case want_vtbl_nkeys:
3472 result = &PL_vtbl_nkeys;
3473 break;
3474 case want_vtbl_taint:
3475 result = &PL_vtbl_taint;
3476 break;
3477 case want_vtbl_substr:
3478 result = &PL_vtbl_substr;
3479 break;
3480 case want_vtbl_vec:
3481 result = &PL_vtbl_vec;
3482 break;
3483 case want_vtbl_pos:
3484 result = &PL_vtbl_pos;
3485 break;
3486 case want_vtbl_bm:
3487 result = &PL_vtbl_bm;
3488 break;
3489 case want_vtbl_fm:
3490 result = &PL_vtbl_fm;
3491 break;
3492 case want_vtbl_uvar:
3493 result = &PL_vtbl_uvar;
3494 break;
dc9e4912
GS		 3495 case want_vtbl_defelem:
3496 result = &PL_vtbl_defelem;
3497 break;
3498 case want_vtbl_regexp:
3499 result = &PL_vtbl_regexp;
3500 break;
3501 case want_vtbl_regdata:
3502 result = &PL_vtbl_regdata;
3503 break;
3504 case want_vtbl_regdatum:
3505 result = &PL_vtbl_regdatum;
3506 break;
3c90161d 3507#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 3508 case want_vtbl_collxfrm:
3509 result = &PL_vtbl_collxfrm;
3510 break;
3c90161d 3511#endif
dc9e4912
GS		 3512 case want_vtbl_amagic:
3513 result = &PL_vtbl_amagic;
3514 break;
3515 case want_vtbl_amagicelem:
3516 result = &PL_vtbl_amagicelem;
3517 break;
810b8aa5
GS		 3518 case want_vtbl_backref:
3519 result = &PL_vtbl_backref;
3520 break;
7e8c5dac
HS		 3521 case want_vtbl_utf8:
3522 result = &PL_vtbl_utf8;
3523 break;
7452cf6a 3524 default:
4608196e 3525 result = NULL;
7452cf6a 3526 break;
dc9e4912 3527 }
27da23d5 3528 return (MGVTBL*)result;
dc9e4912
GS		 3529}
3530
767df6a1 3531I32
864dbfa3 3532Perl_my_fflush_all(pTHX)
767df6a1 3533{
f800e14d 3534#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 3535 return PerlIO_flush(NULL);
767df6a1 3536#else
8fbdfb7c 3537# if defined(HAS__FWALK)
f13a2bc0 3538 extern int fflush(FILE *);
74cac757
JH		 3539 /* undocumented, unprototyped, but very useful BSDism */
3540 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3541 _fwalk(&fflush);
74cac757 3542 return 0;
8fa7f367 3543# else
8fbdfb7c 3544# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3545 long open_max = -1;
8fbdfb7c 3546# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3547 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3548# else
8fa7f367 3549# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3550 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3551# else
3552# ifdef FOPEN_MAX
74cac757 3553 open_max = FOPEN_MAX;
8fa7f367
JH		 3554# else
3555# ifdef OPEN_MAX
74cac757 3556 open_max = OPEN_MAX;
8fa7f367
JH		 3557# else
3558# ifdef _NFILE
d2201af2 3559 open_max = _NFILE;
8fa7f367
JH		 3560# endif
3561# endif
74cac757 3562# endif
767df6a1
JH		 3563# endif
3564# endif
767df6a1
JH		 3565 if (open_max > 0) {
3566 long i;
3567 for (i = 0; i < open_max; i++)
d2201af2
AD		 3568 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3569 STDIO_STREAM_ARRAY[i]._file < open_max &&
3570 STDIO_STREAM_ARRAY[i]._flag)
3571 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3572 return 0;
3573 }
8fbdfb7c 3574# endif
93189314