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