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