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