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
Re: vsprintf
[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
d05d9be5
AD		 1835/* This vsprintf replacement should generally never get used, since
1836 vsprintf was available in both System V and BSD 2.11. (There may
1837 be some cross-compilation or embedded set-ups where it is needed,
1838 however.)
1839
1840 If you encounter a problem in this function, it's probably a symptom
1841 that Configure failed to detect your system's vprintf() function.
1842 See the section on "item vsprintf" in the INSTALL file.
1843
1844 This version may compile on systems with BSD-ish <stdio.h>,
1845 but probably won't on others.
1846*/
a687059c 1847
85e6fe83 1848#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1849char *
1850#else
1851int
1852#endif
d05d9be5 1853vsprintf(char *dest, const char *pat, void *args)
a687059c
LW		 1854{
1855 FILE fakebuf;
1856
d05d9be5
AD		 1857#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
1858 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
1859 FILE_cnt(&fakebuf) = 32767;
1860#else
1861 /* These probably won't compile -- If you really need
1862 this, you'll have to figure out some other method. */
a687059c
LW		 1863 fakebuf._ptr = dest;
1864 fakebuf._cnt = 32767;
d05d9be5 1865#endif
35c8bce7
LW		 1866#ifndef _IOSTRG
1867#define _IOSTRG 0
1868#endif
a687059c
LW		 1869 fakebuf._flag = _IOWRT|_IOSTRG;
1870 _doprnt(pat, args, &fakebuf); /* what a kludge */
d05d9be5
AD		 1871#if defined(STDIO_PTR_LVALUE)
1872 *(FILE_ptr(&fakebuf)++) = '\0';
1873#else
1874 /* PerlIO has probably #defined away fputc, but we want it here. */
1875# ifdef fputc
1876# undef fputc /* XXX Should really restore it later */
1877# endif
1878 (void)fputc('\0', &fakebuf);
1879#endif
85e6fe83 1880#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1881 return(dest);
1882#else
1883 return 0; /* perl doesn't use return value */
1884#endif
1885}
1886
fe14fcc3 1887#endif /* HAS_VPRINTF */
a687059c
LW		 1888
1889#ifdef MYSWAP
ffed7fef 1890#if BYTEORDER != 0x4321
a687059c 1891short
864dbfa3 1892Perl_my_swap(pTHX_ short s)
a687059c
LW		 1893{
1894#if (BYTEORDER & 1) == 0
1895 short result;
1896
1897 result = ((s & 255) << 8) + ((s >> 8) & 255);
1898 return result;
1899#else
1900 return s;
1901#endif
1902}
1903
1904long
864dbfa3 1905Perl_my_htonl(pTHX_ long l)
a687059c
LW		 1906{
1907 union {
1908 long result;
ffed7fef 1909 char c[sizeof(long)];
a687059c
LW		 1910 } u;
1911
ffed7fef 1912#if BYTEORDER == 0x1234
a687059c
LW		 1913 u.c[0] = (l >> 24) & 255;
1914 u.c[1] = (l >> 16) & 255;
1915 u.c[2] = (l >> 8) & 255;
1916 u.c[3] = l & 255;
1917 return u.result;
1918#else
ffed7fef 1919#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1920 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1921#else
79072805
LW		 1922 register I32 o;
1923 register I32 s;
a687059c 1924
ffed7fef
LW		 1925 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1926 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW		 1927 }
1928 return u.result;
1929#endif
1930#endif
1931}
1932
1933long
864dbfa3 1934Perl_my_ntohl(pTHX_ long l)
a687059c
LW		 1935{
1936 union {
1937 long l;
ffed7fef 1938 char c[sizeof(long)];
a687059c
LW		 1939 } u;
1940
ffed7fef 1941#if BYTEORDER == 0x1234
a687059c
LW		 1942 u.c[0] = (l >> 24) & 255;
1943 u.c[1] = (l >> 16) & 255;
1944 u.c[2] = (l >> 8) & 255;
1945 u.c[3] = l & 255;
1946 return u.l;
1947#else
ffed7fef 1948#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1949 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1950#else
79072805
LW		 1951 register I32 o;
1952 register I32 s;
a687059c
LW		 1953
1954 u.l = l;
1955 l = 0;
ffed7fef
LW		 1956 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1957 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW		 1958 }
1959 return l;
1960#endif
1961#endif
1962}
1963
ffed7fef 1964#endif /* BYTEORDER != 0x4321 */
988174c1
LW		 1965#endif /* MYSWAP */
1966
1967/*
1968 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1969 * If these functions are defined,
1970 * the BYTEORDER is neither 0x1234 nor 0x4321.
1971 * However, this is not assumed.
1972 * -DWS
1973 */
1974
1109a392 1975#define HTOLE(name,type) \
988174c1 1976 type \
ba106d47 1977 name (register type n) \
988174c1
LW		 1978 { \
1979 union { \
1980 type value; \
1981 char c[sizeof(type)]; \
1982 } u; \
bb7a0f54
MHM		 1983 register U32 i; \
1984 register U32 s = 0; \
1109a392 1985 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
988174c1
LW		 1986 u.c[i] = (n >> s) & 0xFF; \
1987 } \
1988 return u.value; \
1989 }
1990
1109a392 1991#define LETOH(name,type) \
988174c1 1992 type \
ba106d47 1993 name (register type n) \
988174c1
LW		 1994 { \
1995 union { \
1996 type value; \
1997 char c[sizeof(type)]; \
1998 } u; \
bb7a0f54
MHM		 1999 register U32 i; \
2000 register U32 s = 0; \
988174c1
LW		 2001 u.value = n; \
2002 n = 0; \
1109a392
MHM		 2003 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2004 n |= ((type)(u.c[i] & 0xFF)) << s; \
988174c1
LW		 2005 } \
2006 return n; \
2007 }
2008
1109a392
MHM		 2009/*
2010 * Big-endian byte order functions.
2011 */
2012
2013#define HTOBE(name,type) \
2014 type \
2015 name (register type n) \
2016 { \
2017 union { \
2018 type value; \
2019 char c[sizeof(type)]; \
2020 } u; \
bb7a0f54
MHM		 2021 register U32 i; \
2022 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM		 2023 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2024 u.c[i] = (n >> s) & 0xFF; \
2025 } \
2026 return u.value; \
2027 }
2028
2029#define BETOH(name,type) \
2030 type \
2031 name (register type n) \
2032 { \
2033 union { \
2034 type value; \
2035 char c[sizeof(type)]; \
2036 } u; \
bb7a0f54
MHM		 2037 register U32 i; \
2038 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM		 2039 u.value = n; \
2040 n = 0; \
2041 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2042 n |= ((type)(u.c[i] & 0xFF)) << s; \
2043 } \
2044 return n; \
2045 }
2046
2047/*
2048 * If we just can't do it...
2049 */
2050
2051#define NOT_AVAIL(name,type) \
2052 type \
2053 name (register type n) \
2054 { \
2055 Perl_croak_nocontext(#name "() not available"); \
2056 return n; /* not reached */ \
2057 }
2058
2059
988174c1 2060#if defined(HAS_HTOVS) && !defined(htovs)
1109a392 2061HTOLE(htovs,short)
988174c1
LW		 2062#endif
2063#if defined(HAS_HTOVL) && !defined(htovl)
1109a392 2064HTOLE(htovl,long)
988174c1
LW		 2065#endif
2066#if defined(HAS_VTOHS) && !defined(vtohs)
1109a392 2067LETOH(vtohs,short)
988174c1
LW		 2068#endif
2069#if defined(HAS_VTOHL) && !defined(vtohl)
1109a392
MHM		 2070LETOH(vtohl,long)
2071#endif
2072
2073#ifdef PERL_NEED_MY_HTOLE16
2074# if U16SIZE == 2
2075HTOLE(Perl_my_htole16,U16)
2076# else
2077NOT_AVAIL(Perl_my_htole16,U16)
2078# endif
2079#endif
2080#ifdef PERL_NEED_MY_LETOH16
2081# if U16SIZE == 2
2082LETOH(Perl_my_letoh16,U16)
2083# else
2084NOT_AVAIL(Perl_my_letoh16,U16)
2085# endif
2086#endif
2087#ifdef PERL_NEED_MY_HTOBE16
2088# if U16SIZE == 2
2089HTOBE(Perl_my_htobe16,U16)
2090# else
2091NOT_AVAIL(Perl_my_htobe16,U16)
2092# endif
2093#endif
2094#ifdef PERL_NEED_MY_BETOH16
2095# if U16SIZE == 2
2096BETOH(Perl_my_betoh16,U16)
2097# else
2098NOT_AVAIL(Perl_my_betoh16,U16)
2099# endif
2100#endif
2101
2102#ifdef PERL_NEED_MY_HTOLE32
2103# if U32SIZE == 4
2104HTOLE(Perl_my_htole32,U32)
2105# else
2106NOT_AVAIL(Perl_my_htole32,U32)
2107# endif
2108#endif
2109#ifdef PERL_NEED_MY_LETOH32
2110# if U32SIZE == 4
2111LETOH(Perl_my_letoh32,U32)
2112# else
2113NOT_AVAIL(Perl_my_letoh32,U32)
2114# endif
2115#endif
2116#ifdef PERL_NEED_MY_HTOBE32
2117# if U32SIZE == 4
2118HTOBE(Perl_my_htobe32,U32)
2119# else
2120NOT_AVAIL(Perl_my_htobe32,U32)
2121# endif
2122#endif
2123#ifdef PERL_NEED_MY_BETOH32
2124# if U32SIZE == 4
2125BETOH(Perl_my_betoh32,U32)
2126# else
2127NOT_AVAIL(Perl_my_betoh32,U32)
2128# endif
2129#endif
2130
2131#ifdef PERL_NEED_MY_HTOLE64
2132# if U64SIZE == 8
2133HTOLE(Perl_my_htole64,U64)
2134# else
2135NOT_AVAIL(Perl_my_htole64,U64)
2136# endif
2137#endif
2138#ifdef PERL_NEED_MY_LETOH64
2139# if U64SIZE == 8
2140LETOH(Perl_my_letoh64,U64)
2141# else
2142NOT_AVAIL(Perl_my_letoh64,U64)
2143# endif
2144#endif
2145#ifdef PERL_NEED_MY_HTOBE64
2146# if U64SIZE == 8
2147HTOBE(Perl_my_htobe64,U64)
2148# else
2149NOT_AVAIL(Perl_my_htobe64,U64)
2150# endif
2151#endif
2152#ifdef PERL_NEED_MY_BETOH64
2153# if U64SIZE == 8
2154BETOH(Perl_my_betoh64,U64)
2155# else
2156NOT_AVAIL(Perl_my_betoh64,U64)
2157# endif
988174c1 2158#endif
a687059c 2159
1109a392
MHM		 2160#ifdef PERL_NEED_MY_HTOLES
2161HTOLE(Perl_my_htoles,short)
2162#endif
2163#ifdef PERL_NEED_MY_LETOHS
2164LETOH(Perl_my_letohs,short)
2165#endif
2166#ifdef PERL_NEED_MY_HTOBES
2167HTOBE(Perl_my_htobes,short)
2168#endif
2169#ifdef PERL_NEED_MY_BETOHS
2170BETOH(Perl_my_betohs,short)
2171#endif
2172
2173#ifdef PERL_NEED_MY_HTOLEI
2174HTOLE(Perl_my_htolei,int)
2175#endif
2176#ifdef PERL_NEED_MY_LETOHI
2177LETOH(Perl_my_letohi,int)
2178#endif
2179#ifdef PERL_NEED_MY_HTOBEI
2180HTOBE(Perl_my_htobei,int)
2181#endif
2182#ifdef PERL_NEED_MY_BETOHI
2183BETOH(Perl_my_betohi,int)
2184#endif
2185
2186#ifdef PERL_NEED_MY_HTOLEL
2187HTOLE(Perl_my_htolel,long)
2188#endif
2189#ifdef PERL_NEED_MY_LETOHL
2190LETOH(Perl_my_letohl,long)
2191#endif
2192#ifdef PERL_NEED_MY_HTOBEL
2193HTOBE(Perl_my_htobel,long)
2194#endif
2195#ifdef PERL_NEED_MY_BETOHL
2196BETOH(Perl_my_betohl,long)
2197#endif
2198
2199void
2200Perl_my_swabn(void *ptr, int n)
2201{
2202 register char *s = (char *)ptr;
2203 register char *e = s + (n-1);
2204 register char tc;
2205
2206 for (n /= 2; n > 0; s++, e--, n--) {
2207 tc = *s;
2208 *s = *e;
2209 *e = tc;
2210 }
2211}
2212
4a7d1889
NIS		 2213PerlIO *
2214Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2215{
2986a63f 2216#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
97aff369 2217 dVAR;
1f852d0d
NIS		 2218 int p[2];
2219 register I32 This, that;
2220 register Pid_t pid;
2221 SV *sv;
2222 I32 did_pipes = 0;
2223 int pp[2];
2224
2225 PERL_FLUSHALL_FOR_CHILD;
2226 This = (*mode == 'w');
2227 that = !This;
2228 if (PL_tainting) {
2229 taint_env();
2230 taint_proper("Insecure %s%s", "EXEC");
2231 }
2232 if (PerlProc_pipe(p) < 0)
4608196e 2233 return NULL;
1f852d0d
NIS		 2234 /* Try for another pipe pair for error return */
2235 if (PerlProc_pipe(pp) >= 0)
2236 did_pipes = 1;
52e18b1f 2237 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS		 2238 if (errno != EAGAIN) {
2239 PerlLIO_close(p[This]);
4e6dfe71 2240 PerlLIO_close(p[that]);
1f852d0d
NIS		 2241 if (did_pipes) {
2242 PerlLIO_close(pp[0]);
2243 PerlLIO_close(pp[1]);
2244 }
4608196e 2245 return NULL;
1f852d0d
NIS		 2246 }
2247 sleep(5);
2248 }
2249 if (pid == 0) {
2250 /* Child */
1f852d0d
NIS		 2251#undef THIS
2252#undef THAT
2253#define THIS that
2254#define THAT This
1f852d0d
NIS		 2255 /* Close parent's end of error status pipe (if any) */
2256 if (did_pipes) {
2257 PerlLIO_close(pp[0]);
2258#if defined(HAS_FCNTL) && defined(F_SETFD)
2259 /* Close error pipe automatically if exec works */
2260 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2261#endif
2262 }
2263 /* Now dup our end of _the_ pipe to right position */
2264 if (p[THIS] != (*mode == 'r')) {
2265 PerlLIO_dup2(p[THIS], *mode == 'r');
2266 PerlLIO_close(p[THIS]);
4e6dfe71
GS		 2267 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2268 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2269 }
4e6dfe71
GS		 2270 else
2271 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS		 2272#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2273 /* No automatic close - do it by hand */
b7953727
JH		 2274# ifndef NOFILE
2275# define NOFILE 20
2276# endif
a080fe3d
NIS		 2277 {
2278 int fd;
2279
2280 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2281 if (fd != pp[1])
a080fe3d
NIS		 2282 PerlLIO_close(fd);
2283 }
1f852d0d
NIS		 2284 }
2285#endif
a0714e2c 2286 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS		 2287 PerlProc__exit(1);
2288#undef THIS
2289#undef THAT
2290 }
2291 /* Parent */
52e18b1f 2292 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS		 2293 if (did_pipes)
2294 PerlLIO_close(pp[1]);
2295 /* Keep the lower of the two fd numbers */
2296 if (p[that] < p[This]) {
2297 PerlLIO_dup2(p[This], p[that]);
2298 PerlLIO_close(p[This]);
2299 p[This] = p[that];
2300 }
4e6dfe71
GS		 2301 else
2302 PerlLIO_close(p[that]); /* close child's end of pipe */
2303
1f852d0d
NIS		 2304 LOCK_FDPID_MUTEX;
2305 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2306 UNLOCK_FDPID_MUTEX;
862a34c6 2307 SvUPGRADE(sv,SVt_IV);
45977657 2308 SvIV_set(sv, pid);
1f852d0d
NIS		 2309 PL_forkprocess = pid;
2310 /* If we managed to get status pipe check for exec fail */
2311 if (did_pipes && pid > 0) {
2312 int errkid;
bb7a0f54
MHM		 2313 unsigned n = 0;
2314 SSize_t n1;
1f852d0d
NIS		 2315
2316 while (n < sizeof(int)) {
2317 n1 = PerlLIO_read(pp[0],
2318 (void*)(((char*)&errkid)+n),
2319 (sizeof(int)) - n);
2320 if (n1 <= 0)
2321 break;
2322 n += n1;
2323 }
2324 PerlLIO_close(pp[0]);
2325 did_pipes = 0;
2326 if (n) { /* Error */
2327 int pid2, status;
8c51524e 2328 PerlLIO_close(p[This]);
1f852d0d
NIS		 2329 if (n != sizeof(int))
2330 Perl_croak(aTHX_ "panic: kid popen errno read");
2331 do {
2332 pid2 = wait4pid(pid, &status, 0);
2333 } while (pid2 == -1 && errno == EINTR);
2334 errno = errkid; /* Propagate errno from kid */
4608196e 2335 return NULL;
1f852d0d
NIS		 2336 }
2337 }
2338 if (did_pipes)
2339 PerlLIO_close(pp[0]);
2340 return PerlIO_fdopen(p[This], mode);
2341#else
9d419b5f
IZ		 2342# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2343 return my_syspopen4(aTHX_ Nullch, mode, n, args);
2344# else
4a7d1889
NIS		 2345 Perl_croak(aTHX_ "List form of piped open not implemented");
2346 return (PerlIO *) NULL;
9d419b5f 2347# endif
1f852d0d 2348#endif
4a7d1889
NIS		 2349}
2350
5f05dabc 2351 /* VMS' my_popen() is in VMS.c, same with OS/2. */
cd39f2b6 2352#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 2353PerlIO *
3dd43144 2354Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c 2355{
97aff369 2356 dVAR;
a687059c 2357 int p[2];
8ac85365 2358 register I32 This, that;
d8a83dd3 2359 register Pid_t pid;
79072805 2360 SV *sv;
bfce84ec 2361 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ		 2362 I32 did_pipes = 0;
2363 int pp[2];
a687059c 2364
45bc9206 2365 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 2366#ifdef OS2
2367 if (doexec) {
23da6c43 2368 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2369 }
a1d180c4 2370#endif
8ac85365
NIS		 2371 This = (*mode == 'w');
2372 that = !This;
3280af22 2373 if (doexec && PL_tainting) {
bbce6d69 2374 taint_env();
2375 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2376 }
c2267164 2377 if (PerlProc_pipe(p) < 0)
4608196e 2378 return NULL;
e446cec8
IZ		 2379 if (doexec && PerlProc_pipe(pp) >= 0)
2380 did_pipes = 1;
52e18b1f 2381 while ((pid = PerlProc_fork()) < 0) {
a687059c 2382 if (errno != EAGAIN) {
6ad3d225 2383 PerlLIO_close(p[This]);
b5ac89c3 2384 PerlLIO_close(p[that]);
e446cec8
IZ		 2385 if (did_pipes) {
2386 PerlLIO_close(pp[0]);
2387 PerlLIO_close(pp[1]);
2388 }
a687059c 2389 if (!doexec)
cea2e8a9 2390 Perl_croak(aTHX_ "Can't fork");
4608196e 2391 return NULL;
a687059c
LW		 2392 }
2393 sleep(5);
2394 }
2395 if (pid == 0) {
79072805
LW		 2396 GV* tmpgv;
2397
30ac6d9b
GS		 2398#undef THIS
2399#undef THAT
a687059c 2400#define THIS that
8ac85365 2401#define THAT This
e446cec8
IZ		 2402 if (did_pipes) {
2403 PerlLIO_close(pp[0]);
2404#if defined(HAS_FCNTL) && defined(F_SETFD)
2405 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2406#endif
2407 }
a687059c 2408 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 2409 PerlLIO_dup2(p[THIS], *mode == 'r');
2410 PerlLIO_close(p[THIS]);
b5ac89c3
NIS		 2411 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2412 PerlLIO_close(p[THAT]);
a687059c 2413 }
b5ac89c3
NIS		 2414 else
2415 PerlLIO_close(p[THAT]);
4435c477 2416#ifndef OS2
a687059c 2417 if (doexec) {
a0d0e21e 2418#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 2419#ifndef NOFILE
2420#define NOFILE 20
2421#endif
a080fe3d 2422 {
3aed30dc 2423 int fd;
a080fe3d
NIS		 2424
2425 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2426 if (fd != pp[1])
3aed30dc 2427 PerlLIO_close(fd);
a080fe3d 2428 }
ae986130 2429#endif
a080fe3d
NIS		 2430 /* may or may not use the shell */
2431 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2432 PerlProc__exit(1);
a687059c 2433 }
4435c477 2434#endif /* defined OS2 */
713cef20
IZ		 2435
2436#ifdef PERLIO_USING_CRLF
2437 /* Since we circumvent IO layers when we manipulate low-level
2438 filedescriptors directly, need to manually switch to the
2439 default, binary, low-level mode; see PerlIOBuf_open(). */
2440 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2441#endif
2442
fafc274c 2443 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4d76a344 2444 SvREADONLY_off(GvSV(tmpgv));
7766f137 2445 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS		 2446 SvREADONLY_on(GvSV(tmpgv));
2447 }
2448#ifdef THREADS_HAVE_PIDS
2449 PL_ppid = (IV)getppid();
2450#endif
3280af22 2451 PL_forkprocess = 0;
ca0c25f6 2452#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2453 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2454#endif
4608196e 2455 return NULL;
a687059c
LW		 2456#undef THIS
2457#undef THAT
2458 }
b5ac89c3 2459 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ		 2460 if (did_pipes)
2461 PerlLIO_close(pp[1]);
8ac85365 2462 if (p[that] < p[This]) {
6ad3d225
GS		 2463 PerlLIO_dup2(p[This], p[that]);
2464 PerlLIO_close(p[This]);
8ac85365 2465 p[This] = p[that];
62b28dd9 2466 }
b5ac89c3
NIS		 2467 else
2468 PerlLIO_close(p[that]);
2469
4755096e 2470 LOCK_FDPID_MUTEX;
3280af22 2471 sv = *av_fetch(PL_fdpid,p[This],TRUE);
4755096e 2472 UNLOCK_FDPID_MUTEX;
862a34c6 2473 SvUPGRADE(sv,SVt_IV);
45977657 2474 SvIV_set(sv, pid);
3280af22 2475 PL_forkprocess = pid;
e446cec8
IZ		 2476 if (did_pipes && pid > 0) {
2477 int errkid;
bb7a0f54
MHM		 2478 unsigned n = 0;
2479 SSize_t n1;
e446cec8
IZ		 2480
2481 while (n < sizeof(int)) {
2482 n1 = PerlLIO_read(pp[0],
2483 (void*)(((char*)&errkid)+n),
2484 (sizeof(int)) - n);
2485 if (n1 <= 0)
2486 break;
2487 n += n1;
2488 }
2f96c702
IZ		 2489 PerlLIO_close(pp[0]);
2490 did_pipes = 0;
e446cec8 2491 if (n) { /* Error */
faa466a7 2492 int pid2, status;
8c51524e 2493 PerlLIO_close(p[This]);
e446cec8 2494 if (n != sizeof(int))
cea2e8a9 2495 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2496 do {
2497 pid2 = wait4pid(pid, &status, 0);
2498 } while (pid2 == -1 && errno == EINTR);
e446cec8 2499 errno = errkid; /* Propagate errno from kid */
4608196e 2500 return NULL;
e446cec8
IZ		 2501 }
2502 }
2503 if (did_pipes)
2504 PerlLIO_close(pp[0]);
8ac85365 2505 return PerlIO_fdopen(p[This], mode);
a687059c 2506}
7c0587c8 2507#else
85ca448a 2508#if defined(atarist) || defined(EPOC)
7c0587c8 2509FILE *popen();
760ac839 2510PerlIO *
7dc3a6bf 2511Perl_my_popen((pTHX_ const char *cmd, const char *mode)
7c0587c8 2512{
45bc9206 2513 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2514 /* Call system's popen() to get a FILE *, then import it.
2515 used 0 for 2nd parameter to PerlIO_importFILE;
2516 apparently not used
2517 */
2518 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2519}
2b96b0a5
JH		 2520#else
2521#if defined(DJGPP)
2522FILE *djgpp_popen();
2523PerlIO *
7dc3a6bf 2524Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH		 2525{
2526 PERL_FLUSHALL_FOR_CHILD;
2527 /* Call system's popen() to get a FILE *, then import it.
2528 used 0 for 2nd parameter to PerlIO_importFILE;
2529 apparently not used
2530 */
2531 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2532}
2533#endif
7c0587c8
LW		 2534#endif
2535
2536#endif /* !DOSISH */
a687059c 2537
52e18b1f
GS		 2538/* this is called in parent before the fork() */
2539void
2540Perl_atfork_lock(void)
2541{
27da23d5 2542 dVAR;
3db8f154 2543#if defined(USE_ITHREADS)
52e18b1f
GS		 2544 /* locks must be held in locking order (if any) */
2545# ifdef MYMALLOC
2546 MUTEX_LOCK(&PL_malloc_mutex);
2547# endif
2548 OP_REFCNT_LOCK;
2549#endif
2550}
2551
2552/* this is called in both parent and child after the fork() */
2553void
2554Perl_atfork_unlock(void)
2555{
27da23d5 2556 dVAR;
3db8f154 2557#if defined(USE_ITHREADS)
52e18b1f
GS		 2558 /* locks must be released in same order as in atfork_lock() */
2559# ifdef MYMALLOC
2560 MUTEX_UNLOCK(&PL_malloc_mutex);
2561# endif
2562 OP_REFCNT_UNLOCK;
2563#endif
2564}
2565
2566Pid_t
2567Perl_my_fork(void)
2568{
2569#if defined(HAS_FORK)
2570 Pid_t pid;
3db8f154 2571#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2572 atfork_lock();
2573 pid = fork();
2574 atfork_unlock();
2575#else
2576 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2577 * handlers elsewhere in the code */
2578 pid = fork();
2579#endif
2580 return pid;
2581#else
2582 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2583 Perl_croak_nocontext("fork() not available");
b961a566 2584 return 0;
52e18b1f
GS		 2585#endif /* HAS_FORK */
2586}
2587
748a9306 2588#ifdef DUMP_FDS
35ff7856 2589void
864dbfa3 2590Perl_dump_fds(pTHX_ char *s)
ae986130
LW		 2591{
2592 int fd;
c623ac67 2593 Stat_t tmpstatbuf;
ae986130 2594
bf49b057 2595 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2596 for (fd = 0; fd < 32; fd++) {
6ad3d225 2597 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2598 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2599 }
bf49b057 2600 PerlIO_printf(Perl_debug_log,"\n");
27da23d5 2601 return;
ae986130 2602}
35ff7856 2603#endif /* DUMP_FDS */
ae986130 2604
fe14fcc3 2605#ifndef HAS_DUP2
fec02dd3 2606int
ba106d47 2607dup2(int oldfd, int newfd)
a687059c 2608{
a0d0e21e 2609#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2610 if (oldfd == newfd)
2611 return oldfd;
6ad3d225 2612 PerlLIO_close(newfd);
fec02dd3 2613 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2614#else
fc36a67e 2615#define DUP2_MAX_FDS 256
2616 int fdtmp[DUP2_MAX_FDS];
79072805 2617 I32 fdx = 0;
ae986130
LW		 2618 int fd;
2619
fe14fcc3 2620 if (oldfd == newfd)
fec02dd3 2621 return oldfd;
6ad3d225 2622 PerlLIO_close(newfd);
fc36a67e 2623 /* good enough for low fd's... */
6ad3d225 2624 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2625 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2626 PerlLIO_close(fd);
fc36a67e 2627 fd = -1;
2628 break;
2629 }
ae986130 2630 fdtmp[fdx++] = fd;
fc36a67e 2631 }
ae986130 2632 while (fdx > 0)
6ad3d225 2633 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2634 return fd;
62b28dd9 2635#endif
a687059c
LW		 2636}
2637#endif
2638
64ca3a65 2639#ifndef PERL_MICRO
ff68c719 2640#ifdef HAS_SIGACTION
2641
abea2c45
HS		 2642#ifdef MACOS_TRADITIONAL
2643/* We don't want restart behavior on MacOS */
2644#undef SA_RESTART
2645#endif
2646
ff68c719 2647Sighandler_t
864dbfa3 2648Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2649{
27da23d5 2650 dVAR;
ff68c719 2651 struct sigaction act, oact;
2652
a10b1e10
JH		 2653#ifdef USE_ITHREADS
2654 /* only "parent" interpreter can diddle signals */
2655 if (PL_curinterp != aTHX)
8aad04aa 2656 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2657#endif
2658
8aad04aa 2659 act.sa_handler = (void(*)(int))handler;
ff68c719 2660 sigemptyset(&act.sa_mask);
2661 act.sa_flags = 0;
2662#ifdef SA_RESTART
4ffa73a3
JH		 2663 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2664 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2665#endif
358837b8 2666#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2667 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2668 act.sa_flags |= SA_NOCLDWAIT;
2669#endif
ff68c719 2670 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2671 return (Sighandler_t) SIG_ERR;
ff68c719 2672 else
8aad04aa 2673 return (Sighandler_t) oact.sa_handler;
ff68c719 2674}
2675
2676Sighandler_t
864dbfa3 2677Perl_rsignal_state(pTHX_ int signo)
ff68c719 2678{
2679 struct sigaction oact;
96a5add6 2680 PERL_UNUSED_CONTEXT;
ff68c719 2681
2682 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2683 return (Sighandler_t) SIG_ERR;
ff68c719 2684 else
8aad04aa 2685 return (Sighandler_t) oact.sa_handler;
ff68c719 2686}
2687
2688int
864dbfa3 2689Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2690{
27da23d5 2691 dVAR;
ff68c719 2692 struct sigaction act;
2693
a10b1e10
JH		 2694#ifdef USE_ITHREADS
2695 /* only "parent" interpreter can diddle signals */
2696 if (PL_curinterp != aTHX)
2697 return -1;
2698#endif
2699
8aad04aa 2700 act.sa_handler = (void(*)(int))handler;
ff68c719 2701 sigemptyset(&act.sa_mask);
2702 act.sa_flags = 0;
2703#ifdef SA_RESTART
4ffa73a3
JH		 2704 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2705 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2706#endif
36b5d377 2707#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2708 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2709 act.sa_flags |= SA_NOCLDWAIT;
2710#endif
ff68c719 2711 return sigaction(signo, &act, save);
2712}
2713
2714int
864dbfa3 2715Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2716{
27da23d5 2717 dVAR;
a10b1e10
JH		 2718#ifdef USE_ITHREADS
2719 /* only "parent" interpreter can diddle signals */
2720 if (PL_curinterp != aTHX)
2721 return -1;
2722#endif
2723
ff68c719 2724 return sigaction(signo, save, (struct sigaction *)NULL);
2725}
2726
2727#else /* !HAS_SIGACTION */
2728
2729Sighandler_t
864dbfa3 2730Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2731{
39f1703b 2732#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2733 /* only "parent" interpreter can diddle signals */
2734 if (PL_curinterp != aTHX)
8aad04aa 2735 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2736#endif
2737
6ad3d225 2738 return PerlProc_signal(signo, handler);
ff68c719 2739}
2740
fabdb6c0 2741static Signal_t
4e35701f 2742sig_trap(int signo)
ff68c719 2743{
27da23d5
JH		 2744 dVAR;
2745 PL_sig_trapped++;
ff68c719 2746}
2747
2748Sighandler_t
864dbfa3 2749Perl_rsignal_state(pTHX_ int signo)
ff68c719 2750{
27da23d5 2751 dVAR;
ff68c719 2752 Sighandler_t oldsig;
2753
39f1703b 2754#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2755 /* only "parent" interpreter can diddle signals */
2756 if (PL_curinterp != aTHX)
8aad04aa 2757 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2758#endif
2759
27da23d5 2760 PL_sig_trapped = 0;
6ad3d225
GS		 2761 oldsig = PerlProc_signal(signo, sig_trap);
2762 PerlProc_signal(signo, oldsig);
27da23d5 2763 if (PL_sig_trapped)
3aed30dc 2764 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2765 return oldsig;
2766}
2767
2768int
864dbfa3 2769Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2770{
39f1703b 2771#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2772 /* only "parent" interpreter can diddle signals */
2773 if (PL_curinterp != aTHX)
2774 return -1;
2775#endif
6ad3d225 2776 *save = PerlProc_signal(signo, handler);
8aad04aa 2777 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2778}
2779
2780int
864dbfa3 2781Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2782{
39f1703b 2783#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2784 /* only "parent" interpreter can diddle signals */
2785 if (PL_curinterp != aTHX)
2786 return -1;
2787#endif
8aad04aa 2788 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2789}
2790
2791#endif /* !HAS_SIGACTION */
64ca3a65 2792#endif /* !PERL_MICRO */
ff68c719 2793
5f05dabc 2794 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
cd39f2b6 2795#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
79072805 2796I32
864dbfa3 2797Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2798{
97aff369 2799 dVAR;
ff68c719 2800 Sigsave_t hstat, istat, qstat;
a687059c 2801 int status;
a0d0e21e 2802 SV **svp;
d8a83dd3
JH		 2803 Pid_t pid;
2804 Pid_t pid2;
03136e13 2805 bool close_failed;
b7953727 2806 int saved_errno = 0;
22fae026
TM		 2807#ifdef WIN32
2808 int saved_win32_errno;
2809#endif
a687059c 2810
4755096e 2811 LOCK_FDPID_MUTEX;
3280af22 2812 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2813 UNLOCK_FDPID_MUTEX;
25d92023 2814 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2815 SvREFCNT_dec(*svp);
3280af22 2816 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2817#ifdef OS2
2818 if (pid == -1) { /* Opened by popen. */
2819 return my_syspclose(ptr);
2820 }
a1d180c4 2821#endif
03136e13
CS		 2822 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2823 saved_errno = errno;
22fae026
TM		 2824#ifdef WIN32
2825 saved_win32_errno = GetLastError();
2826#endif
03136e13 2827 }
7c0587c8 2828#ifdef UTS
6ad3d225 2829 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2830#endif
64ca3a65 2831#ifndef PERL_MICRO
8aad04aa
JH		 2832 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2833 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2834 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
64ca3a65 2835#endif
748a9306 2836 do {
1d3434b8
GS		 2837 pid2 = wait4pid(pid, &status, 0);
2838 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2839#ifndef PERL_MICRO
ff68c719 2840 rsignal_restore(SIGHUP, &hstat);
2841 rsignal_restore(SIGINT, &istat);
2842 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2843#endif
03136e13 2844 if (close_failed) {
ce6e1103 2845 SETERRNO(saved_errno, 0);
03136e13
CS		 2846 return -1;
2847 }
1d3434b8 2848 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2849}
4633a7c4
LW		 2850#endif /* !DOSISH */
2851
2986a63f 2852#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
79072805 2853I32
d8a83dd3 2854Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2855{
97aff369 2856 dVAR;
27da23d5 2857 I32 result = 0;
b7953727
JH		 2858 if (!pid)
2859 return -1;
ca0c25f6 2860#ifdef PERL_USES_PL_PIDSTATUS
b7953727 2861 {
3aed30dc 2862 if (pid > 0) {
12072db5
NC		 2863 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2864 pid, rather than a string form. */
c4420975 2865 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS		 2866 if (svp && *svp != &PL_sv_undef) {
2867 *statusp = SvIVX(*svp);
12072db5
NC		 2868 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2869 G_DISCARD);
3aed30dc
HS		 2870 return pid;
2871 }
2872 }
2873 else {
2874 HE *entry;
2875
2876 hv_iterinit(PL_pidstatus);
2877 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 2878 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 2879 I32 len;
0bcc34c2 2880 const char * const spid = hv_iterkey(entry,&len);
27da23d5 2881
12072db5
NC		 2882 assert (len == sizeof(Pid_t));
2883 memcpy((char *)&pid, spid, len);
3aed30dc 2884 *statusp = SvIVX(sv);
7b9a3241
NC		 2885 /* The hash iterator is currently on this entry, so simply
2886 calling hv_delete would trigger the lazy delete, which on
2887 aggregate does more work, beacuse next call to hv_iterinit()
2888 would spot the flag, and have to call the delete routine,
2889 while in the meantime any new entries can't re-use that
2890 memory. */
2891 hv_iterinit(PL_pidstatus);
7ea75b61 2892 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS		 2893 return pid;
2894 }
20188a90
LW		 2895 }
2896 }
68a29c53 2897#endif
79072805 2898#ifdef HAS_WAITPID
367f3c24
IZ		 2899# ifdef HAS_WAITPID_RUNTIME
2900 if (!HAS_WAITPID_RUNTIME)
2901 goto hard_way;
2902# endif
cddd4526 2903 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2904 goto finish;
367f3c24
IZ		 2905#endif
2906#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
4608196e 2907 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
dfcfdb64 2908 goto finish;
367f3c24 2909#endif
ca0c25f6 2910#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 2911#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 2912 hard_way:
27da23d5 2913#endif
a0d0e21e 2914 {
a0d0e21e 2915 if (flags)
cea2e8a9 2916 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2917 else {
76e3520e 2918 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2919 pidgone(result,*statusp);
2920 if (result < 0)
2921 *statusp = -1;
2922 }
a687059c
LW		 2923 }
2924#endif
27da23d5 2925#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 2926 finish:
27da23d5 2927#endif
cddd4526
NIS		 2928 if (result < 0 && errno == EINTR) {
2929 PERL_ASYNC_CHECK();
2930 }
2931 return result;
a687059c 2932}
2986a63f 2933#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2934
ca0c25f6 2935#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 2936void
d8a83dd3 2937Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2938{
79072805 2939 register SV *sv;
a687059c 2940
12072db5 2941 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 2942 SvUPGRADE(sv,SVt_IV);
45977657 2943 SvIV_set(sv, status);
20188a90 2944 return;
a687059c 2945}
ca0c25f6 2946#endif
a687059c 2947
85ca448a 2948#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 2949int pclose();
ddcf38b7
IZ		 2950#ifdef HAS_FORK
2951int /* Cannot prototype with I32
2952 in os2ish.h. */
ba106d47 2953my_syspclose(PerlIO *ptr)
ddcf38b7 2954#else
79072805 2955I32
864dbfa3 2956Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2957#endif
a687059c 2958{
760ac839 2959 /* Needs work for PerlIO ! */
c4420975 2960 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 2961 const I32 result = pclose(f);
2b96b0a5
JH		 2962 PerlIO_releaseFILE(ptr,f);
2963 return result;
2964}
2965#endif
2966
933fea7f 2967#if defined(DJGPP)
2b96b0a5
JH		 2968int djgpp_pclose();
2969I32
2970Perl_my_pclose(pTHX_ PerlIO *ptr)
2971{
2972 /* Needs work for PerlIO ! */
c4420975 2973 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 2974 I32 result = djgpp_pclose(f);
933fea7f 2975 result = (result << 8) & 0xff00;
760ac839
LW		 2976 PerlIO_releaseFILE(ptr,f);
2977 return result;
a687059c 2978}
7c0587c8 2979#endif
9f68db38
LW		 2980
2981void
864dbfa3 2982Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 2983{
79072805 2984 register I32 todo;
c4420975 2985 register const char * const frombase = from;
96a5add6 2986 PERL_UNUSED_CONTEXT;
9f68db38
LW		 2987
2988 if (len == 1) {
08105a92 2989 register const char c = *from;
9f68db38 2990 while (count-- > 0)
5926133d 2991 *to++ = c;
9f68db38
LW		 2992 return;
2993 }
2994 while (count-- > 0) {
2995 for (todo = len; todo > 0; todo--) {
2996 *to++ = *from++;
2997 }
2998 from = frombase;
2999 }
3000}
0f85fab0 3001
fe14fcc3 3002#ifndef HAS_RENAME
79072805 3003I32
4373e329 3004Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3005{
93a17b20
LW		 3006 char *fa = strrchr(a,'/');
3007 char *fb = strrchr(b,'/');
c623ac67
GS		 3008 Stat_t tmpstatbuf1;
3009 Stat_t tmpstatbuf2;
c4420975 3010 SV * const tmpsv = sv_newmortal();
62b28dd9
LW		 3011
3012 if (fa)
3013 fa++;
3014 else
3015 fa = a;
3016 if (fb)
3017 fb++;
3018 else
3019 fb = b;
3020 if (strNE(a,b))
3021 return FALSE;
3022 if (fa == a)
616d8c9c 3023 sv_setpvn(tmpsv, ".", 1);
62b28dd9 3024 else
46fc3d4c 3025 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3026 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 3027 return FALSE;
3028 if (fb == b)
616d8c9c 3029 sv_setpvn(tmpsv, ".", 1);
62b28dd9 3030 else
46fc3d4c 3031 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3032 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 3033 return FALSE;
3034 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3035 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3036}
fe14fcc3
LW		 3037#endif /* !HAS_RENAME */
3038
491527d0 3039char*
7f315aed
NC		 3040Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3041 const char *const *const search_ext, I32 flags)
491527d0 3042{
97aff369 3043 dVAR;
bd61b366
SS		 3044 const char *xfound = NULL;
3045 char *xfailed = NULL;
0f31cffe 3046 char tmpbuf[MAXPATHLEN];
491527d0 3047 register char *s;
5f74f29c 3048 I32 len = 0;
491527d0 3049 int retval;
39a02377 3050 char *bufend;
491527d0
GS		 3051#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3052# define SEARCH_EXTS ".bat", ".cmd", NULL
3053# define MAX_EXT_LEN 4
3054#endif
3055#ifdef OS2
3056# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3057# define MAX_EXT_LEN 4
3058#endif
3059#ifdef VMS
3060# define SEARCH_EXTS ".pl", ".com", NULL
3061# define MAX_EXT_LEN 4
3062#endif
3063 /* additional extensions to try in each dir if scriptname not found */
3064#ifdef SEARCH_EXTS
0bcc34c2 3065 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3066 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3067 int extidx = 0, i = 0;
bd61b366 3068 const char *curext = NULL;
491527d0 3069#else
53c1dcc0 3070 PERL_UNUSED_ARG(search_ext);
491527d0
GS		 3071# define MAX_EXT_LEN 0
3072#endif
3073
3074 /*
3075 * If dosearch is true and if scriptname does not contain path
3076 * delimiters, search the PATH for scriptname.
3077 *
3078 * If SEARCH_EXTS is also defined, will look for each
3079 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3080 * while searching the PATH.
3081 *
3082 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3083 * proceeds as follows:
3084 * If DOSISH or VMSISH:
3085 * + look for ./scriptname{,.foo,.bar}
3086 * + search the PATH for scriptname{,.foo,.bar}
3087 *
3088 * If !DOSISH:
3089 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3090 * this will not look in '.' if it's not in the PATH)
3091 */
84486fc6 3092 tmpbuf[0] = '\0';
491527d0
GS		 3093
3094#ifdef VMS
3095# ifdef ALWAYS_DEFTYPES
3096 len = strlen(scriptname);
3097 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3098 int idx = 0, deftypes = 1;
491527d0
GS		 3099 bool seen_dot = 1;
3100
bd61b366 3101 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3102# else
3103 if (dosearch) {
c4420975 3104 int idx = 0, deftypes = 1;
491527d0
GS		 3105 bool seen_dot = 1;
3106
bd61b366 3107 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3108# endif
3109 /* The first time through, just add SEARCH_EXTS to whatever we
3110 * already have, so we can check for default file types. */
3111 while (deftypes ||
84486fc6 3112 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 3113 {
3114 if (deftypes) {
3115 deftypes = 0;
84486fc6 3116 *tmpbuf = '\0';
491527d0 3117 }
84486fc6
GS		 3118 if ((strlen(tmpbuf) + strlen(scriptname)
3119 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3120 continue; /* don't search dir with too-long name */
6fca0082 3121 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS		 3122#else /* !VMS */
3123
3124#ifdef DOSISH
3125 if (strEQ(scriptname, "-"))
3126 dosearch = 0;
3127 if (dosearch) { /* Look in '.' first. */
fe2774ed 3128 const char *cur = scriptname;
491527d0
GS		 3129#ifdef SEARCH_EXTS
3130 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3131 while (ext[i])
3132 if (strEQ(ext[i++],curext)) {
3133 extidx = -1; /* already has an ext */
3134 break;
3135 }
3136 do {
3137#endif
3138 DEBUG_p(PerlIO_printf(Perl_debug_log,
3139 "Looking for %s\n",cur));
017f25f1
IZ		 3140 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3141 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 3142 dosearch = 0;
3143 scriptname = cur;
3144#ifdef SEARCH_EXTS
3145 break;
3146#endif
3147 }
3148#ifdef SEARCH_EXTS
3149 if (cur == scriptname) {
3150 len = strlen(scriptname);
84486fc6 3151 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3152 break;
9e4425f7
SH		 3153 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3154 cur = tmpbuf;
491527d0
GS		 3155 }
3156 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3157 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS		 3158#endif
3159 }
3160#endif
3161
cd39f2b6
JH		 3162#ifdef MACOS_TRADITIONAL
3163 if (dosearch && !strchr(scriptname, ':') &&
3164 (s = PerlEnv_getenv("Commands")))
3165#else
491527d0
GS		 3166 if (dosearch && !strchr(scriptname, '/')
3167#ifdef DOSISH
3168 && !strchr(scriptname, '\\')
3169#endif
cd39f2b6
JH		 3170 && (s = PerlEnv_getenv("PATH")))
3171#endif
3172 {
491527d0 3173 bool seen_dot = 0;
92f0c265 3174
39a02377
DM		 3175 bufend = s + strlen(s);
3176 while (s < bufend) {
cd39f2b6 3177#ifdef MACOS_TRADITIONAL
39a02377 3178 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
cd39f2b6
JH		 3179 ',',
3180 &len);
3181#else
491527d0
GS		 3182#if defined(atarist) || defined(DOSISH)
3183 for (len = 0; *s
3184# ifdef atarist
3185 && *s != ','
3186# endif
3187 && *s != ';'; len++, s++) {
84486fc6
GS		 3188 if (len < sizeof tmpbuf)
3189 tmpbuf[len] = *s;
491527d0 3190 }
84486fc6
GS		 3191 if (len < sizeof tmpbuf)
3192 tmpbuf[len] = '\0';
491527d0 3193#else /* ! (atarist || DOSISH) */
39a02377 3194 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS		 3195 ':',
3196 &len);
3197#endif /* ! (atarist || DOSISH) */
cd39f2b6 3198#endif /* MACOS_TRADITIONAL */
39a02377 3199 if (s < bufend)
491527d0 3200 s++;
84486fc6 3201 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 3202 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 3203#ifdef MACOS_TRADITIONAL
3204 if (len && tmpbuf[len - 1] != ':')
3205 tmpbuf[len++] = ':';
3206#else
491527d0 3207 if (len
490a0e98 3208# if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 3209 && tmpbuf[len - 1] != '/'
3210 && tmpbuf[len - 1] != '\\'
490a0e98 3211# endif
491527d0 3212 )
84486fc6
GS		 3213 tmpbuf[len++] = '/';
3214 if (len == 2 && tmpbuf[0] == '.')
491527d0 3215 seen_dot = 1;
cd39f2b6 3216#endif
28f0d0ec 3217 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS		 3218#endif /* !VMS */
3219
3220#ifdef SEARCH_EXTS
84486fc6 3221 len = strlen(tmpbuf);
491527d0
GS		 3222 if (extidx > 0) /* reset after previous loop */
3223 extidx = 0;
3224 do {
3225#endif
84486fc6 3226 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3227 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 3228 if (S_ISDIR(PL_statbuf.st_mode)) {
3229 retval = -1;
3230 }
491527d0
GS		 3231#ifdef SEARCH_EXTS
3232 } while ( retval < 0 /* not there */
3233 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3234 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS		 3235 );
3236#endif
3237 if (retval < 0)
3238 continue;
3280af22
NIS		 3239 if (S_ISREG(PL_statbuf.st_mode)
3240 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 3241#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 3242 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 3243#endif
3244 )
3245 {
3aed30dc 3246 xfound = tmpbuf; /* bingo! */
491527d0
GS		 3247 break;
3248 }
3249 if (!xfailed)
84486fc6 3250 xfailed = savepv(tmpbuf);
491527d0
GS		 3251 }
3252#ifndef DOSISH
017f25f1 3253 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3254 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3255 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 3256#endif
3257 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 3258 if (!xfound) {
3259 if (flags & 1) { /* do or die? */
3aed30dc 3260 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 3261 (xfailed ? "execute" : "find"),
3262 (xfailed ? xfailed : scriptname),
3263 (xfailed ? "" : " on PATH"),
3264 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3265 }
bd61b366 3266 scriptname = NULL;
9ccb31f9 3267 }
43c5f42d 3268 Safefree(xfailed);
491527d0
GS		 3269 scriptname = xfound;
3270 }
bd61b366 3271 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS		 3272}
3273
ba869deb
GS		 3274#ifndef PERL_GET_CONTEXT_DEFINED
3275
3276void *
3277Perl_get_context(void)
3278{
27da23d5 3279 dVAR;
3db8f154 3280#if defined(USE_ITHREADS)
ba869deb
GS		 3281# ifdef OLD_PTHREADS_API
3282 pthread_addr_t t;
3283 if (pthread_getspecific(PL_thr_key, &t))
3284 Perl_croak_nocontext("panic: pthread_getspecific");
3285 return (void*)t;
3286# else
bce813aa 3287# ifdef I_MACH_CTHREADS
8b8b35ab 3288 return (void*)cthread_data(cthread_self());
bce813aa 3289# else
8b8b35ab
JH		 3290 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3291# endif
c44d3fdb 3292# endif
ba869deb
GS		 3293#else
3294 return (void*)NULL;
3295#endif
3296}
3297
3298void
3299Perl_set_context(void *t)
3300{
8772537c 3301 dVAR;
3db8f154 3302#if defined(USE_ITHREADS)
c44d3fdb
GS		 3303# ifdef I_MACH_CTHREADS
3304 cthread_set_data(cthread_self(), t);
3305# else
ba869deb
GS		 3306 if (pthread_setspecific(PL_thr_key, t))
3307 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 3308# endif
b464bac0 3309#else
8772537c 3310 PERL_UNUSED_ARG(t);
ba869deb
GS		 3311#endif
3312}
3313
3314#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3315
27da23d5 3316#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3317struct perl_vars *
864dbfa3 3318Perl_GetVars(pTHX)
22239a37 3319{
533c011a 3320 return &PL_Vars;
22239a37 3321}
31fb1209
NIS		 3322#endif
3323
1cb0ed9b 3324char **
864dbfa3 3325Perl_get_op_names(pTHX)
31fb1209 3326{
96a5add6
AL		 3327 PERL_UNUSED_CONTEXT;
3328 return (char **)PL_op_name;
31fb1209
NIS		 3329}
3330
1cb0ed9b 3331char **
864dbfa3 3332Perl_get_op_descs(pTHX)
31fb1209 3333{
96a5add6
AL		 3334 PERL_UNUSED_CONTEXT;
3335 return (char **)PL_op_desc;
31fb1209 3336}
9e6b2b00 3337
e1ec3a88 3338const char *
864dbfa3 3339Perl_get_no_modify(pTHX)
9e6b2b00 3340{
96a5add6
AL		 3341 PERL_UNUSED_CONTEXT;
3342 return PL_no_modify;
9e6b2b00
GS		 3343}
3344
3345U32 *
864dbfa3 3346Perl_get_opargs(pTHX)
9e6b2b00 3347{
96a5add6
AL		 3348 PERL_UNUSED_CONTEXT;
3349 return (U32 *)PL_opargs;
9e6b2b00 3350}
51aa15f3 3351
0cb96387
GS		 3352PPADDR_t*
3353Perl_get_ppaddr(pTHX)
3354{
96a5add6
AL		 3355 dVAR;
3356 PERL_UNUSED_CONTEXT;
3357 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 3358}
3359
a6c40364
GS		 3360#ifndef HAS_GETENV_LEN
3361char *
bf4acbe4 3362Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3363{
8772537c 3364 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3365 PERL_UNUSED_CONTEXT;
a6c40364
GS		 3366 if (env_trans)
3367 *len = strlen(env_trans);
3368 return env_trans;
f675dbe5
CB		 3369}
3370#endif
3371
dc9e4912
GS		 3372
3373MGVTBL*
864dbfa3 3374Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3375{
7452cf6a 3376 const MGVTBL* result;
96a5add6 3377 PERL_UNUSED_CONTEXT;
dc9e4912
GS		 3378
3379 switch(vtbl_id) {
3380 case want_vtbl_sv:
3381 result = &PL_vtbl_sv;
3382 break;
3383 case want_vtbl_env:
3384 result = &PL_vtbl_env;
3385 break;
3386 case want_vtbl_envelem:
3387 result = &PL_vtbl_envelem;
3388 break;
3389 case want_vtbl_sig:
3390 result = &PL_vtbl_sig;
3391 break;
3392 case want_vtbl_sigelem:
3393 result = &PL_vtbl_sigelem;
3394 break;
3395 case want_vtbl_pack:
3396 result = &PL_vtbl_pack;
3397 break;
3398 case want_vtbl_packelem:
3399 result = &PL_vtbl_packelem;
3400 break;
3401 case want_vtbl_dbline:
3402 result = &PL_vtbl_dbline;
3403 break;
3404 case want_vtbl_isa:
3405 result = &PL_vtbl_isa;
3406 break;
3407 case want_vtbl_isaelem:
3408 result = &PL_vtbl_isaelem;
3409 break;
3410 case want_vtbl_arylen:
3411 result = &PL_vtbl_arylen;
3412 break;
dc9e4912
GS		 3413 case want_vtbl_mglob:
3414 result = &PL_vtbl_mglob;
3415 break;
3416 case want_vtbl_nkeys:
3417 result = &PL_vtbl_nkeys;
3418 break;
3419 case want_vtbl_taint:
3420 result = &PL_vtbl_taint;
3421 break;
3422 case want_vtbl_substr:
3423 result = &PL_vtbl_substr;
3424 break;
3425 case want_vtbl_vec:
3426 result = &PL_vtbl_vec;
3427 break;
3428 case want_vtbl_pos:
3429 result = &PL_vtbl_pos;
3430 break;
3431 case want_vtbl_bm:
3432 result = &PL_vtbl_bm;
3433 break;
3434 case want_vtbl_fm:
3435 result = &PL_vtbl_fm;
3436 break;
3437 case want_vtbl_uvar:
3438 result = &PL_vtbl_uvar;
3439 break;
dc9e4912
GS		 3440 case want_vtbl_defelem:
3441 result = &PL_vtbl_defelem;
3442 break;
3443 case want_vtbl_regexp:
3444 result = &PL_vtbl_regexp;
3445 break;
3446 case want_vtbl_regdata:
3447 result = &PL_vtbl_regdata;
3448 break;
3449 case want_vtbl_regdatum:
3450 result = &PL_vtbl_regdatum;
3451 break;
3c90161d 3452#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 3453 case want_vtbl_collxfrm:
3454 result = &PL_vtbl_collxfrm;
3455 break;
3c90161d 3456#endif
dc9e4912
GS		 3457 case want_vtbl_amagic:
3458 result = &PL_vtbl_amagic;
3459 break;
3460 case want_vtbl_amagicelem:
3461 result = &PL_vtbl_amagicelem;
3462 break;
810b8aa5
GS		 3463 case want_vtbl_backref:
3464 result = &PL_vtbl_backref;
3465 break;
7e8c5dac
HS		 3466 case want_vtbl_utf8:
3467 result = &PL_vtbl_utf8;
3468 break;
7452cf6a 3469 default:
4608196e 3470 result = NULL;
7452cf6a 3471 break;
dc9e4912 3472 }
27da23d5 3473 return (MGVTBL*)result;
dc9e4912
GS		 3474}
3475
767df6a1 3476I32
864dbfa3 3477Perl_my_fflush_all(pTHX)
767df6a1 3478{
f800e14d 3479#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 3480 return PerlIO_flush(NULL);
767df6a1 3481#else
8fbdfb7c 3482# if defined(HAS__FWALK)
f13a2bc0 3483 extern int fflush(FILE *);
74cac757
JH		 3484 /* undocumented, unprototyped, but very useful BSDism */
3485 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3486 _fwalk(&fflush);
74cac757 3487 return 0;
8fa7f367 3488# else
8fbdfb7c 3489# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3490 long open_max = -1;
8fbdfb7c 3491# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3492 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3493# else
8fa7f367 3494# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3495 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3496# else
3497# ifdef FOPEN_MAX
74cac757 3498 open_max = FOPEN_MAX;
8fa7f367
JH		 3499# else
3500# ifdef OPEN_MAX
74cac757 3501 open_max = OPEN_MAX;
8fa7f367
JH		 3502# else
3503# ifdef _NFILE
d2201af2 3504 open_max = _NFILE;
8fa7f367
JH		 3505# endif
3506# endif
74cac757 3507# endif
767df6a1
JH		 3508# endif
3509# endif
767df6a1
JH		 3510 if (open_max > 0) {
3511 long i;
3512 for (i = 0; i < open_max; i++)
d2201af2
AD		 3513 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3514 STDIO_STREAM_ARRAY[i]._file < open_max &&
3515 STDIO_STREAM_ARRAY[i]._flag)
3516 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3517 return 0;
3518 }
8fbdfb7c 3519# endif
93189314 3520 SETERRNO(EBADF,RMS_IFI);
767df6a1 3521 return EOF;
74cac757 3522# endif
767df6a1
JH		 3523#endif
3524}
097ee67d 3525
69282e91 3526void
e1ec3a88 3527Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
bc37a18f 3528{
b64e5050 3529 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
66fc2fa5 3530
4c80c0b2 3531 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3aed30dc 3532 if (ckWARN(WARN_IO)) {
10edeb5d
JH		 3533 const char * const direction =
3534 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3aed30dc
HS		 3535 if (name && *name)
3536 Perl_warner(aTHX_ packWARN(WARN_IO),
3537 "Filehandle %s opened only for %sput",
fd322ea4 3538 name, direction);
3aed30dc
HS		 3539 else
3540 Perl_warner(aTHX_ packWARN(WARN_IO),
fd322ea4 3541 "Filehandle opened only for %sput", direction);
3aed30dc 3542 }
2dd78f96
JH		 3543 }
3544 else {
e1ec3a88 3545 const char *vile;
3aed30dc
HS		 3546 I32 warn_type;
3547
3548 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3549 vile = "closed";
3550 warn_type = WARN_CLOSED;
3551 }
3552 else {
3553 vile = "unopened";
3554 warn_type = WARN_UNOPENED;
3555 }
3556
3557 if (ckWARN(warn_type)) {
10edeb5d
JH		 3558 const char * const pars =
3559 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
f0a09b71 3560 const char * const func =
10edeb5d
JH		 3561 (const char *)
3562 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3563 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3564 op < 0 ? "" : /* handle phoney cases */
3565 PL_op_desc[op]);
3566 const char * const type =
3567 (const char *)
3568 (OP_IS_SOCKET(op) ||
3569 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3570 "socket" : "filehandle");
3aed30dc
HS		 3571 if (name && *name) {
3572 Perl_warner(aTHX_ packWARN(warn_type),
3573 "%s%s on %s %s %s", func, pars, vile, type, name);
3574 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3575 Perl_warner(
3576 aTHX_ packWARN(warn_type),
3577 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3578 func, pars, name
3579 );
3580 }
3581 else {
3582 Perl_warner(aTHX_ packWARN(warn_type),
3583 "%s%s on %s %s", func, pars, vile, type);
3584 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3585 Perl_warner(
3586 aTHX_ packWARN(warn_type),
3587 "\t(Are you trying to call %s%s on dirhandle?)\n",
3588 func, pars
3589 );
3590 }
3591 }
bc37a18f 3592 }
69282e91 3593}
a926ef6b
JH		 3594
3595#ifdef EBCDIC
cbebf344
JH		 3596/* in ASCII order, not that it matters */
3597static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3598