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