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