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