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