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