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