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