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