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