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