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