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