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