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