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