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