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