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