This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #112316] Make strict vars respect assignment to null pkg
[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 2004 STRLEN size) {
5af88345
FC
2005 const MEM_SIZE len_wanted =
2006 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
35da51f7 2007 PERL_UNUSED_CONTEXT;
7918f24d 2008 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
72dc9ed5 2009
10edeb5d
JH
2010 buffer = (STRLEN*)
2011 (specialWARN(buffer) ?
2012 PerlMemShared_malloc(len_wanted) :
2013 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC
2014 buffer[0] = size;
2015 Copy(bits, (buffer + 1), size, char);
5af88345
FC
2016 if (size < WARNsize)
2017 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
72dc9ed5
NC
2018 return buffer;
2019}
f54ba1c2 2020
e6587932
DM
2021/* since we've already done strlen() for both nam and val
2022 * we can use that info to make things faster than
2023 * sprintf(s, "%s=%s", nam, val)
2024 */
2025#define my_setenv_format(s, nam, nlen, val, vlen) \
2026 Copy(nam, s, nlen, char); \
2027 *(s+nlen) = '='; \
2028 Copy(val, s+(nlen+1), vlen, char); \
2029 *(s+(nlen+1+vlen)) = '\0'
2030
c5d12488
JH
2031#ifdef USE_ENVIRON_ARRAY
2032 /* VMS' my_setenv() is in vms.c */
2033#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 2034void
e1ec3a88 2035Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 2036{
27da23d5 2037 dVAR;
4efc5df6
GS
2038#ifdef USE_ITHREADS
2039 /* only parent thread can modify process environment */
2040 if (PL_curinterp == aTHX)
2041#endif
2042 {
f2517201 2043#ifndef PERL_USE_SAFE_PUTENV
50acdf95 2044 if (!PL_use_safe_putenv) {
c5d12488 2045 /* most putenv()s leak, so we manipulate environ directly */
3a9222be
JH
2046 register I32 i;
2047 register const I32 len = strlen(nam);
c5d12488
JH
2048 int nlen, vlen;
2049
3a9222be
JH
2050 /* where does it go? */
2051 for (i = 0; environ[i]; i++) {
2052 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2053 break;
2054 }
2055
c5d12488
JH
2056 if (environ == PL_origenviron) { /* need we copy environment? */
2057 I32 j;
2058 I32 max;
2059 char **tmpenv;
2060
2061 max = i;
2062 while (environ[max])
2063 max++;
2064 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2065 for (j=0; j<max; j++) { /* copy environment */
2066 const int len = strlen(environ[j]);
2067 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2068 Copy(environ[j], tmpenv[j], len+1, char);
2069 }
2070 tmpenv[max] = NULL;
2071 environ = tmpenv; /* tell exec where it is now */
2072 }
2073 if (!val) {
2074 safesysfree(environ[i]);
2075 while (environ[i]) {
2076 environ[i] = environ[i+1];
2077 i++;
a687059c 2078 }
c5d12488
JH
2079 return;
2080 }
2081 if (!environ[i]) { /* does not exist yet */
2082 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2083 environ[i+1] = NULL; /* make sure it's null terminated */
2084 }
2085 else
2086 safesysfree(environ[i]);
2087 nlen = strlen(nam);
2088 vlen = strlen(val);
2089
2090 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2091 /* all that work just for this */
2092 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95 2093 } else {
c5d12488 2094# endif
7ee146b1 2095# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
88f5bc07
AB
2096# if defined(HAS_UNSETENV)
2097 if (val == NULL) {
2098 (void)unsetenv(nam);
2099 } else {
2100 (void)setenv(nam, val, 1);
2101 }
2102# else /* ! HAS_UNSETENV */
2103 (void)setenv(nam, val, 1);
2104# endif /* HAS_UNSETENV */
47dafe4d 2105# else
88f5bc07
AB
2106# if defined(HAS_UNSETENV)
2107 if (val == NULL) {
2108 (void)unsetenv(nam);
2109 } else {
c4420975
AL
2110 const int nlen = strlen(nam);
2111 const int vlen = strlen(val);
2112 char * const new_env =
88f5bc07
AB
2113 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2114 my_setenv_format(new_env, nam, nlen, val, vlen);
2115 (void)putenv(new_env);
2116 }
2117# else /* ! HAS_UNSETENV */
2118 char *new_env;
c4420975
AL
2119 const int nlen = strlen(nam);
2120 int vlen;
88f5bc07
AB
2121 if (!val) {
2122 val = "";
2123 }
2124 vlen = strlen(val);
2125 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2126 /* all that work just for this */
2127 my_setenv_format(new_env, nam, nlen, val, vlen);
2128 (void)putenv(new_env);
2129# endif /* HAS_UNSETENV */
47dafe4d 2130# endif /* __CYGWIN__ */
50acdf95
MS
2131#ifndef PERL_USE_SAFE_PUTENV
2132 }
2133#endif
4efc5df6 2134 }
8d063cd8
LW
2135}
2136
c5d12488 2137#else /* WIN32 || NETWARE */
68dc0745
PP
2138
2139void
72229eff 2140Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 2141{
27da23d5 2142 dVAR;
c5d12488
JH
2143 register char *envstr;
2144 const int nlen = strlen(nam);
2145 int vlen;
e6587932 2146
c5d12488
JH
2147 if (!val) {
2148 val = "";
ac5c734f 2149 }
c5d12488
JH
2150 vlen = strlen(val);
2151 Newx(envstr, nlen+vlen+2, char);
2152 my_setenv_format(envstr, nam, nlen, val, vlen);
2153 (void)PerlEnv_putenv(envstr);
2154 Safefree(envstr);
3e3baf6d
TB
2155}
2156
c5d12488 2157#endif /* WIN32 || NETWARE */
3e3baf6d 2158
c5d12488 2159#endif /* !VMS && !EPOC*/
378cc40b 2160
16d20bd9 2161#ifdef UNLINK_ALL_VERSIONS
79072805 2162I32
6e732051 2163Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 2164{
35da51f7 2165 I32 retries = 0;
378cc40b 2166
7918f24d
NC
2167 PERL_ARGS_ASSERT_UNLNK;
2168
35da51f7
AL
2169 while (PerlLIO_unlink(f) >= 0)
2170 retries++;
2171 return retries ? 0 : -1;
378cc40b
LW
2172}
2173#endif
2174
7a3f2258 2175/* this is a drop-in replacement for bcopy() */
2253333f 2176#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 2177char *
7a3f2258 2178Perl_my_bcopy(register const char *from,register char *to,register I32 len)
378cc40b 2179{
2d03de9c 2180 char * const retval = to;
378cc40b 2181
7918f24d
NC
2182 PERL_ARGS_ASSERT_MY_BCOPY;
2183
7c0587c8
LW
2184 if (from - to >= 0) {
2185 while (len--)
2186 *to++ = *from++;
2187 }
2188 else {
2189 to += len;
2190 from += len;
2191 while (len--)
faf8582f 2192 *(--to) = *(--from);
7c0587c8 2193 }
378cc40b
LW
2194 return retval;
2195}
ffed7fef 2196#endif
378cc40b 2197
7a3f2258 2198/* this is a drop-in replacement for memset() */
fc36a67e
PP
2199#ifndef HAS_MEMSET
2200void *
7a3f2258 2201Perl_my_memset(register char *loc, register I32 ch, register I32 len)
fc36a67e 2202{
2d03de9c 2203 char * const retval = loc;
fc36a67e 2204
7918f24d
NC
2205 PERL_ARGS_ASSERT_MY_MEMSET;
2206
fc36a67e
PP
2207 while (len--)
2208 *loc++ = ch;
2209 return retval;
2210}
2211#endif
2212
7a3f2258 2213/* this is a drop-in replacement for bzero() */
7c0587c8 2214#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 2215char *
7a3f2258 2216Perl_my_bzero(register char *loc, register I32 len)
378cc40b 2217{
2d03de9c 2218 char * const retval = loc;
378cc40b 2219
7918f24d
NC
2220 PERL_ARGS_ASSERT_MY_BZERO;
2221
378cc40b
LW
2222 while (len--)
2223 *loc++ = 0;
2224 return retval;
2225}
2226#endif
7c0587c8 2227
7a3f2258 2228/* this is a drop-in replacement for memcmp() */
36477c24 2229#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 2230I32
7a3f2258 2231Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
7c0587c8 2232{
e1ec3a88
AL
2233 register const U8 *a = (const U8 *)s1;
2234 register const U8 *b = (const U8 *)s2;
79072805 2235 register I32 tmp;
7c0587c8 2236
7918f24d
NC
2237 PERL_ARGS_ASSERT_MY_MEMCMP;
2238
7c0587c8 2239 while (len--) {
27da23d5 2240 if ((tmp = *a++ - *b++))
7c0587c8
LW
2241 return tmp;
2242 }
2243 return 0;
2244}
36477c24 2245#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 2246
fe14fcc3 2247#ifndef HAS_VPRINTF
d05d9be5
AD
2248/* This vsprintf replacement should generally never get used, since
2249 vsprintf was available in both System V and BSD 2.11. (There may
2250 be some cross-compilation or embedded set-ups where it is needed,
2251 however.)
2252
2253 If you encounter a problem in this function, it's probably a symptom
2254 that Configure failed to detect your system's vprintf() function.
2255 See the section on "item vsprintf" in the INSTALL file.
2256
2257 This version may compile on systems with BSD-ish <stdio.h>,
2258 but probably won't on others.
2259*/
a687059c 2260
85e6fe83 2261#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2262char *
2263#else
2264int
2265#endif
d05d9be5 2266vsprintf(char *dest, const char *pat, void *args)
a687059c
LW
2267{
2268 FILE fakebuf;
2269
d05d9be5
AD
2270#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2271 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2272 FILE_cnt(&fakebuf) = 32767;
2273#else
2274 /* These probably won't compile -- If you really need
2275 this, you'll have to figure out some other method. */
a687059c
LW
2276 fakebuf._ptr = dest;
2277 fakebuf._cnt = 32767;
d05d9be5 2278#endif
35c8bce7
LW
2279#ifndef _IOSTRG
2280#define _IOSTRG 0
2281#endif
a687059c
LW
2282 fakebuf._flag = _IOWRT|_IOSTRG;
2283 _doprnt(pat, args, &fakebuf); /* what a kludge */
d05d9be5
AD
2284#if defined(STDIO_PTR_LVALUE)
2285 *(FILE_ptr(&fakebuf)++) = '\0';
2286#else
2287 /* PerlIO has probably #defined away fputc, but we want it here. */
2288# ifdef fputc
2289# undef fputc /* XXX Should really restore it later */
2290# endif
2291 (void)fputc('\0', &fakebuf);
2292#endif
85e6fe83 2293#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2294 return(dest);
2295#else
2296 return 0; /* perl doesn't use return value */
2297#endif
2298}
2299
fe14fcc3 2300#endif /* HAS_VPRINTF */
a687059c
LW
2301
2302#ifdef MYSWAP
ffed7fef 2303#if BYTEORDER != 0x4321
a687059c 2304short
864dbfa3 2305Perl_my_swap(pTHX_ short s)
a687059c
LW
2306{
2307#if (BYTEORDER & 1) == 0
2308 short result;
2309
2310 result = ((s & 255) << 8) + ((s >> 8) & 255);
2311 return result;
2312#else
2313 return s;
2314#endif
2315}
2316
2317long
864dbfa3 2318Perl_my_htonl(pTHX_ long l)
a687059c
LW
2319{
2320 union {
2321 long result;
ffed7fef 2322 char c[sizeof(long)];
a687059c
LW
2323 } u;
2324
cef6ea9d
JH
2325#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2326#if BYTEORDER == 0x12345678
2327 u.result = 0;
2328#endif
a687059c
LW
2329 u.c[0] = (l >> 24) & 255;
2330 u.c[1] = (l >> 16) & 255;
2331 u.c[2] = (l >> 8) & 255;
2332 u.c[3] = l & 255;
2333 return u.result;
2334#else
ffed7fef 2335#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 2336 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 2337#else
79072805
LW
2338 register I32 o;
2339 register I32 s;
a687059c 2340
ffed7fef
LW
2341 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2342 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW
2343 }
2344 return u.result;
2345#endif
2346#endif
2347}
2348
2349long
864dbfa3 2350Perl_my_ntohl(pTHX_ long l)
a687059c
LW
2351{
2352 union {
2353 long l;
ffed7fef 2354 char c[sizeof(long)];
a687059c
LW
2355 } u;
2356
ffed7fef 2357#if BYTEORDER == 0x1234
a687059c
LW
2358 u.c[0] = (l >> 24) & 255;
2359 u.c[1] = (l >> 16) & 255;
2360 u.c[2] = (l >> 8) & 255;
2361 u.c[3] = l & 255;
2362 return u.l;
2363#else
ffed7fef 2364#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 2365 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 2366#else
79072805
LW
2367 register I32 o;
2368 register I32 s;
a687059c
LW
2369
2370 u.l = l;
2371 l = 0;
ffed7fef
LW
2372 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2373 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW
2374 }
2375 return l;
2376#endif
2377#endif
2378}
2379
ffed7fef 2380#endif /* BYTEORDER != 0x4321 */
988174c1
LW
2381#endif /* MYSWAP */
2382
2383/*
2384 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2385 * If these functions are defined,
2386 * the BYTEORDER is neither 0x1234 nor 0x4321.
2387 * However, this is not assumed.
2388 * -DWS
2389 */
2390
1109a392 2391#define HTOLE(name,type) \
988174c1 2392 type \
ba106d47 2393 name (register type n) \
988174c1
LW
2394 { \
2395 union { \
2396 type value; \
2397 char c[sizeof(type)]; \
2398 } u; \
bb7a0f54
MHM
2399 register U32 i; \
2400 register U32 s = 0; \
1109a392 2401 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
988174c1
LW
2402 u.c[i] = (n >> s) & 0xFF; \
2403 } \
2404 return u.value; \
2405 }
2406
1109a392 2407#define LETOH(name,type) \
988174c1 2408 type \
ba106d47 2409 name (register type n) \
988174c1
LW
2410 { \
2411 union { \
2412 type value; \
2413 char c[sizeof(type)]; \
2414 } u; \
bb7a0f54
MHM
2415 register U32 i; \
2416 register U32 s = 0; \
988174c1
LW
2417 u.value = n; \
2418 n = 0; \
1109a392
MHM
2419 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2420 n |= ((type)(u.c[i] & 0xFF)) << s; \
988174c1
LW
2421 } \
2422 return n; \
2423 }
2424
1109a392
MHM
2425/*
2426 * Big-endian byte order functions.
2427 */
2428
2429#define HTOBE(name,type) \
2430 type \
2431 name (register type n) \
2432 { \
2433 union { \
2434 type value; \
2435 char c[sizeof(type)]; \
2436 } u; \
bb7a0f54
MHM
2437 register U32 i; \
2438 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM
2439 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2440 u.c[i] = (n >> s) & 0xFF; \
2441 } \
2442 return u.value; \
2443 }
2444
2445#define BETOH(name,type) \
2446 type \
2447 name (register type n) \
2448 { \
2449 union { \
2450 type value; \
2451 char c[sizeof(type)]; \
2452 } u; \
bb7a0f54
MHM
2453 register U32 i; \
2454 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM
2455 u.value = n; \
2456 n = 0; \
2457 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2458 n |= ((type)(u.c[i] & 0xFF)) << s; \
2459 } \
2460 return n; \
2461 }
2462
2463/*
2464 * If we just can't do it...
2465 */
2466
2467#define NOT_AVAIL(name,type) \
2468 type \
2469 name (register type n) \
2470 { \
2471 Perl_croak_nocontext(#name "() not available"); \
2472 return n; /* not reached */ \
2473 }
2474
2475
988174c1 2476#if defined(HAS_HTOVS) && !defined(htovs)
1109a392 2477HTOLE(htovs,short)
988174c1
LW
2478#endif
2479#if defined(HAS_HTOVL) && !defined(htovl)
1109a392 2480HTOLE(htovl,long)
988174c1
LW
2481#endif
2482#if defined(HAS_VTOHS) && !defined(vtohs)
1109a392 2483LETOH(vtohs,short)
988174c1
LW
2484#endif
2485#if defined(HAS_VTOHL) && !defined(vtohl)
1109a392
MHM
2486LETOH(vtohl,long)
2487#endif
2488
2489#ifdef PERL_NEED_MY_HTOLE16
2490# if U16SIZE == 2
2491HTOLE(Perl_my_htole16,U16)
2492# else
2493NOT_AVAIL(Perl_my_htole16,U16)
2494# endif
2495#endif
2496#ifdef PERL_NEED_MY_LETOH16
2497# if U16SIZE == 2
2498LETOH(Perl_my_letoh16,U16)
2499# else
2500NOT_AVAIL(Perl_my_letoh16,U16)
2501# endif
2502#endif
2503#ifdef PERL_NEED_MY_HTOBE16
2504# if U16SIZE == 2
2505HTOBE(Perl_my_htobe16,U16)
2506# else
2507NOT_AVAIL(Perl_my_htobe16,U16)
2508# endif
2509#endif
2510#ifdef PERL_NEED_MY_BETOH16
2511# if U16SIZE == 2
2512BETOH(Perl_my_betoh16,U16)
2513# else
2514NOT_AVAIL(Perl_my_betoh16,U16)
2515# endif
2516#endif
2517
2518#ifdef PERL_NEED_MY_HTOLE32
2519# if U32SIZE == 4
2520HTOLE(Perl_my_htole32,U32)
2521# else
2522NOT_AVAIL(Perl_my_htole32,U32)
2523# endif
2524#endif
2525#ifdef PERL_NEED_MY_LETOH32
2526# if U32SIZE == 4
2527LETOH(Perl_my_letoh32,U32)
2528# else
2529NOT_AVAIL(Perl_my_letoh32,U32)
2530# endif
2531#endif
2532#ifdef PERL_NEED_MY_HTOBE32
2533# if U32SIZE == 4
2534HTOBE(Perl_my_htobe32,U32)
2535# else
2536NOT_AVAIL(Perl_my_htobe32,U32)
2537# endif
2538#endif
2539#ifdef PERL_NEED_MY_BETOH32
2540# if U32SIZE == 4
2541BETOH(Perl_my_betoh32,U32)
2542# else
2543NOT_AVAIL(Perl_my_betoh32,U32)
2544# endif
2545#endif
2546
2547#ifdef PERL_NEED_MY_HTOLE64
2548# if U64SIZE == 8
2549HTOLE(Perl_my_htole64,U64)
2550# else
2551NOT_AVAIL(Perl_my_htole64,U64)
2552# endif
2553#endif
2554#ifdef PERL_NEED_MY_LETOH64
2555# if U64SIZE == 8
2556LETOH(Perl_my_letoh64,U64)
2557# else
2558NOT_AVAIL(Perl_my_letoh64,U64)
2559# endif
2560#endif
2561#ifdef PERL_NEED_MY_HTOBE64
2562# if U64SIZE == 8
2563HTOBE(Perl_my_htobe64,U64)
2564# else
2565NOT_AVAIL(Perl_my_htobe64,U64)
2566# endif
2567#endif
2568#ifdef PERL_NEED_MY_BETOH64
2569# if U64SIZE == 8
2570BETOH(Perl_my_betoh64,U64)
2571# else
2572NOT_AVAIL(Perl_my_betoh64,U64)
2573# endif
988174c1 2574#endif
a687059c 2575
1109a392
MHM
2576#ifdef PERL_NEED_MY_HTOLES
2577HTOLE(Perl_my_htoles,short)
2578#endif
2579#ifdef PERL_NEED_MY_LETOHS
2580LETOH(Perl_my_letohs,short)
2581#endif
2582#ifdef PERL_NEED_MY_HTOBES
2583HTOBE(Perl_my_htobes,short)
2584#endif
2585#ifdef PERL_NEED_MY_BETOHS
2586BETOH(Perl_my_betohs,short)
2587#endif
2588
2589#ifdef PERL_NEED_MY_HTOLEI
2590HTOLE(Perl_my_htolei,int)
2591#endif
2592#ifdef PERL_NEED_MY_LETOHI
2593LETOH(Perl_my_letohi,int)
2594#endif
2595#ifdef PERL_NEED_MY_HTOBEI
2596HTOBE(Perl_my_htobei,int)
2597#endif
2598#ifdef PERL_NEED_MY_BETOHI
2599BETOH(Perl_my_betohi,int)
2600#endif
2601
2602#ifdef PERL_NEED_MY_HTOLEL
2603HTOLE(Perl_my_htolel,long)
2604#endif
2605#ifdef PERL_NEED_MY_LETOHL
2606LETOH(Perl_my_letohl,long)
2607#endif
2608#ifdef PERL_NEED_MY_HTOBEL
2609HTOBE(Perl_my_htobel,long)
2610#endif
2611#ifdef PERL_NEED_MY_BETOHL
2612BETOH(Perl_my_betohl,long)
2613#endif
2614
2615void
2616Perl_my_swabn(void *ptr, int n)
2617{
2618 register char *s = (char *)ptr;
2619 register char *e = s + (n-1);
2620 register char tc;
2621
7918f24d
NC
2622 PERL_ARGS_ASSERT_MY_SWABN;
2623
1109a392
MHM
2624 for (n /= 2; n > 0; s++, e--, n--) {
2625 tc = *s;
2626 *s = *e;
2627 *e = tc;
2628 }
2629}
2630
4a7d1889 2631PerlIO *
c9289b7b 2632Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
4a7d1889 2633{
e37778c2 2634#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
97aff369 2635 dVAR;
1f852d0d
NIS
2636 int p[2];
2637 register I32 This, that;
2638 register Pid_t pid;
2639 SV *sv;
2640 I32 did_pipes = 0;
2641 int pp[2];
2642
7918f24d
NC
2643 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2644
1f852d0d
NIS
2645 PERL_FLUSHALL_FOR_CHILD;
2646 This = (*mode == 'w');
2647 that = !This;
2648 if (PL_tainting) {
2649 taint_env();
2650 taint_proper("Insecure %s%s", "EXEC");
2651 }
2652 if (PerlProc_pipe(p) < 0)
4608196e 2653 return NULL;
1f852d0d
NIS
2654 /* Try for another pipe pair for error return */
2655 if (PerlProc_pipe(pp) >= 0)
2656 did_pipes = 1;
52e18b1f 2657 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS
2658 if (errno != EAGAIN) {
2659 PerlLIO_close(p[This]);
4e6dfe71 2660 PerlLIO_close(p[that]);
1f852d0d
NIS
2661 if (did_pipes) {
2662 PerlLIO_close(pp[0]);
2663 PerlLIO_close(pp[1]);
2664 }
4608196e 2665 return NULL;
1f852d0d 2666 }
a2a5de95 2667 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
1f852d0d
NIS
2668 sleep(5);
2669 }
2670 if (pid == 0) {
2671 /* Child */
1f852d0d
NIS
2672#undef THIS
2673#undef THAT
2674#define THIS that
2675#define THAT This
1f852d0d
NIS
2676 /* Close parent's end of error status pipe (if any) */
2677 if (did_pipes) {
2678 PerlLIO_close(pp[0]);
2679#if defined(HAS_FCNTL) && defined(F_SETFD)
2680 /* Close error pipe automatically if exec works */
2681 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2682#endif
2683 }
2684 /* Now dup our end of _the_ pipe to right position */
2685 if (p[THIS] != (*mode == 'r')) {
2686 PerlLIO_dup2(p[THIS], *mode == 'r');
2687 PerlLIO_close(p[THIS]);
4e6dfe71
GS
2688 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2689 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2690 }
4e6dfe71
GS
2691 else
2692 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS
2693#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2694 /* No automatic close - do it by hand */
b7953727
JH
2695# ifndef NOFILE
2696# define NOFILE 20
2697# endif
a080fe3d
NIS
2698 {
2699 int fd;
2700
2701 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2702 if (fd != pp[1])
a080fe3d
NIS
2703 PerlLIO_close(fd);
2704 }
1f852d0d
NIS
2705 }
2706#endif
a0714e2c 2707 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS
2708 PerlProc__exit(1);
2709#undef THIS
2710#undef THAT
2711 }
2712 /* Parent */
52e18b1f 2713 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS
2714 if (did_pipes)
2715 PerlLIO_close(pp[1]);
2716 /* Keep the lower of the two fd numbers */
2717 if (p[that] < p[This]) {
2718 PerlLIO_dup2(p[This], p[that]);
2719 PerlLIO_close(p[This]);
2720 p[This] = p[that];
2721 }
4e6dfe71
GS
2722 else
2723 PerlLIO_close(p[that]); /* close child's end of pipe */
2724
1f852d0d 2725 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2726 SvUPGRADE(sv,SVt_IV);
45977657 2727 SvIV_set(sv, pid);
1f852d0d
NIS
2728 PL_forkprocess = pid;
2729 /* If we managed to get status pipe check for exec fail */
2730 if (did_pipes && pid > 0) {
2731 int errkid;
bb7a0f54
MHM
2732 unsigned n = 0;
2733 SSize_t n1;
1f852d0d
NIS
2734
2735 while (n < sizeof(int)) {
2736 n1 = PerlLIO_read(pp[0],
2737 (void*)(((char*)&errkid)+n),
2738 (sizeof(int)) - n);
2739 if (n1 <= 0)
2740 break;
2741 n += n1;
2742 }
2743 PerlLIO_close(pp[0]);
2744 did_pipes = 0;
2745 if (n) { /* Error */
2746 int pid2, status;
8c51524e 2747 PerlLIO_close(p[This]);
1f852d0d 2748 if (n != sizeof(int))
5637ef5b 2749 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
1f852d0d
NIS
2750 do {
2751 pid2 = wait4pid(pid, &status, 0);
2752 } while (pid2 == -1 && errno == EINTR);
2753 errno = errkid; /* Propagate errno from kid */
4608196e 2754 return NULL;
1f852d0d
NIS
2755 }
2756 }
2757 if (did_pipes)
2758 PerlLIO_close(pp[0]);
2759 return PerlIO_fdopen(p[This], mode);
2760#else
9d419b5f 2761# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
4e205ed6 2762 return my_syspopen4(aTHX_ NULL, mode, n, args);
9d419b5f 2763# else
4a7d1889
NIS
2764 Perl_croak(aTHX_ "List form of piped open not implemented");
2765 return (PerlIO *) NULL;
9d419b5f 2766# endif
1f852d0d 2767#endif
4a7d1889
NIS
2768}
2769
5f05dabc 2770 /* VMS' my_popen() is in VMS.c, same with OS/2. */
e37778c2 2771#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
760ac839 2772PerlIO *
3dd43144 2773Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c 2774{
97aff369 2775 dVAR;
a687059c 2776 int p[2];
8ac85365 2777 register I32 This, that;
d8a83dd3 2778 register Pid_t pid;
79072805 2779 SV *sv;
bfce84ec 2780 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ
2781 I32 did_pipes = 0;
2782 int pp[2];
a687059c 2783
7918f24d
NC
2784 PERL_ARGS_ASSERT_MY_POPEN;
2785
45bc9206 2786 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ
2787#ifdef OS2
2788 if (doexec) {
23da6c43 2789 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2790 }
a1d180c4 2791#endif
8ac85365
NIS
2792 This = (*mode == 'w');
2793 that = !This;
3280af22 2794 if (doexec && PL_tainting) {
bbce6d69
PP
2795 taint_env();
2796 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2797 }
c2267164 2798 if (PerlProc_pipe(p) < 0)
4608196e 2799 return NULL;
e446cec8
IZ
2800 if (doexec && PerlProc_pipe(pp) >= 0)
2801 did_pipes = 1;
52e18b1f 2802 while ((pid = PerlProc_fork()) < 0) {
a687059c 2803 if (errno != EAGAIN) {
6ad3d225 2804 PerlLIO_close(p[This]);
b5ac89c3 2805 PerlLIO_close(p[that]);
e446cec8
IZ
2806 if (did_pipes) {
2807 PerlLIO_close(pp[0]);
2808 PerlLIO_close(pp[1]);
2809 }
a687059c 2810 if (!doexec)
b3647a36 2811 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2812 return NULL;
a687059c 2813 }
a2a5de95 2814 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW
2815 sleep(5);
2816 }
2817 if (pid == 0) {
79072805 2818
30ac6d9b
GS
2819#undef THIS
2820#undef THAT
a687059c 2821#define THIS that
8ac85365 2822#define THAT This
e446cec8
IZ
2823 if (did_pipes) {
2824 PerlLIO_close(pp[0]);
2825#if defined(HAS_FCNTL) && defined(F_SETFD)
2826 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2827#endif
2828 }
a687059c 2829 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS
2830 PerlLIO_dup2(p[THIS], *mode == 'r');
2831 PerlLIO_close(p[THIS]);
b5ac89c3
NIS
2832 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2833 PerlLIO_close(p[THAT]);
a687059c 2834 }
b5ac89c3
NIS
2835 else
2836 PerlLIO_close(p[THAT]);
4435c477 2837#ifndef OS2
a687059c 2838 if (doexec) {
a0d0e21e 2839#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
2840#ifndef NOFILE
2841#define NOFILE 20
2842#endif
a080fe3d 2843 {
3aed30dc 2844 int fd;
a080fe3d
NIS
2845
2846 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2847 if (fd != pp[1])
3aed30dc 2848 PerlLIO_close(fd);
a080fe3d 2849 }
ae986130 2850#endif
a080fe3d
NIS
2851 /* may or may not use the shell */
2852 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2853 PerlProc__exit(1);
a687059c 2854 }
4435c477 2855#endif /* defined OS2 */
713cef20
IZ
2856
2857#ifdef PERLIO_USING_CRLF
2858 /* Since we circumvent IO layers when we manipulate low-level
2859 filedescriptors directly, need to manually switch to the
2860 default, binary, low-level mode; see PerlIOBuf_open(). */
2861 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2862#endif
3280af22 2863 PL_forkprocess = 0;
ca0c25f6 2864#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2865 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2866#endif
4608196e 2867 return NULL;
a687059c
LW
2868#undef THIS
2869#undef THAT
2870 }
b5ac89c3 2871 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ
2872 if (did_pipes)
2873 PerlLIO_close(pp[1]);
8ac85365 2874 if (p[that] < p[This]) {
6ad3d225
GS
2875 PerlLIO_dup2(p[This], p[that]);
2876 PerlLIO_close(p[This]);
8ac85365 2877 p[This] = p[that];
62b28dd9 2878 }
b5ac89c3
NIS
2879 else
2880 PerlLIO_close(p[that]);
2881
3280af22 2882 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2883 SvUPGRADE(sv,SVt_IV);
45977657 2884 SvIV_set(sv, pid);
3280af22 2885 PL_forkprocess = pid;
e446cec8
IZ
2886 if (did_pipes && pid > 0) {
2887 int errkid;
bb7a0f54
MHM
2888 unsigned n = 0;
2889 SSize_t n1;
e446cec8
IZ
2890
2891 while (n < sizeof(int)) {
2892 n1 = PerlLIO_read(pp[0],
2893 (void*)(((char*)&errkid)+n),
2894 (sizeof(int)) - n);
2895 if (n1 <= 0)
2896 break;
2897 n += n1;
2898 }
2f96c702
IZ
2899 PerlLIO_close(pp[0]);
2900 did_pipes = 0;
e446cec8 2901 if (n) { /* Error */
faa466a7 2902 int pid2, status;
8c51524e 2903 PerlLIO_close(p[This]);
e446cec8 2904 if (n != sizeof(int))
5637ef5b 2905 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
faa466a7
RG
2906 do {
2907 pid2 = wait4pid(pid, &status, 0);
2908 } while (pid2 == -1 && errno == EINTR);
e446cec8 2909 errno = errkid; /* Propagate errno from kid */
4608196e 2910 return NULL;
e446cec8
IZ
2911 }
2912 }
2913 if (did_pipes)
2914 PerlLIO_close(pp[0]);
8ac85365 2915 return PerlIO_fdopen(p[This], mode);
a687059c 2916}
7c0587c8 2917#else
85ca448a 2918#if defined(atarist) || defined(EPOC)
7c0587c8 2919FILE *popen();
760ac839 2920PerlIO *
cef6ea9d 2921Perl_my_popen(pTHX_ const char *cmd, const char *mode)
7c0587c8 2922{
7918f24d 2923 PERL_ARGS_ASSERT_MY_POPEN;
45bc9206 2924 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS
2925 /* Call system's popen() to get a FILE *, then import it.
2926 used 0 for 2nd parameter to PerlIO_importFILE;
2927 apparently not used
2928 */
2929 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2930}
2b96b0a5
JH
2931#else
2932#if defined(DJGPP)
2933FILE *djgpp_popen();
2934PerlIO *
cef6ea9d 2935Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH
2936{
2937 PERL_FLUSHALL_FOR_CHILD;
2938 /* Call system's popen() to get a FILE *, then import it.
2939 used 0 for 2nd parameter to PerlIO_importFILE;
2940 apparently not used
2941 */
2942 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2943}
9c12f1e5
RGS
2944#else
2945#if defined(__LIBCATAMOUNT__)
2946PerlIO *
2947Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2948{
2949 return NULL;
2950}
2951#endif
2b96b0a5 2952#endif
7c0587c8
LW
2953#endif
2954
2955#endif /* !DOSISH */
a687059c 2956
52e18b1f
GS
2957/* this is called in parent before the fork() */
2958void
2959Perl_atfork_lock(void)
2960{
27da23d5 2961 dVAR;
3db8f154 2962#if defined(USE_ITHREADS)
52e18b1f
GS
2963 /* locks must be held in locking order (if any) */
2964# ifdef MYMALLOC
2965 MUTEX_LOCK(&PL_malloc_mutex);
2966# endif
2967 OP_REFCNT_LOCK;
2968#endif
2969}
2970
2971/* this is called in both parent and child after the fork() */
2972void
2973Perl_atfork_unlock(void)
2974{
27da23d5 2975 dVAR;
3db8f154 2976#if defined(USE_ITHREADS)
52e18b1f
GS
2977 /* locks must be released in same order as in atfork_lock() */
2978# ifdef MYMALLOC
2979 MUTEX_UNLOCK(&PL_malloc_mutex);
2980# endif
2981 OP_REFCNT_UNLOCK;
2982#endif
2983}
2984
2985Pid_t
2986Perl_my_fork(void)
2987{
2988#if defined(HAS_FORK)
2989 Pid_t pid;
3db8f154 2990#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS
2991 atfork_lock();
2992 pid = fork();
2993 atfork_unlock();
2994#else
2995 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2996 * handlers elsewhere in the code */
2997 pid = fork();
2998#endif
2999 return pid;
3000#else
3001 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
3002 Perl_croak_nocontext("fork() not available");
b961a566 3003 return 0;
52e18b1f
GS
3004#endif /* HAS_FORK */
3005}
3006
748a9306 3007#ifdef DUMP_FDS
35ff7856 3008void
c9289b7b 3009Perl_dump_fds(pTHX_ const char *const s)
ae986130
LW
3010{
3011 int fd;
c623ac67 3012 Stat_t tmpstatbuf;
ae986130 3013
7918f24d
NC
3014 PERL_ARGS_ASSERT_DUMP_FDS;
3015
bf49b057 3016 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 3017 for (fd = 0; fd < 32; fd++) {
6ad3d225 3018 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 3019 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 3020 }
bf49b057 3021 PerlIO_printf(Perl_debug_log,"\n");
27da23d5 3022 return;
ae986130 3023}
35ff7856 3024#endif /* DUMP_FDS */
ae986130 3025
fe14fcc3 3026#ifndef HAS_DUP2
fec02dd3 3027int
ba106d47 3028dup2(int oldfd, int newfd)
a687059c 3029{
a0d0e21e 3030#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
3031 if (oldfd == newfd)
3032 return oldfd;
6ad3d225 3033 PerlLIO_close(newfd);
fec02dd3 3034 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 3035#else
fc36a67e
PP
3036#define DUP2_MAX_FDS 256
3037 int fdtmp[DUP2_MAX_FDS];
79072805 3038 I32 fdx = 0;
ae986130
LW
3039 int fd;
3040
fe14fcc3 3041 if (oldfd == newfd)
fec02dd3 3042 return oldfd;
6ad3d225 3043 PerlLIO_close(newfd);
fc36a67e 3044 /* good enough for low fd's... */
6ad3d225 3045 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 3046 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 3047 PerlLIO_close(fd);
fc36a67e
PP
3048 fd = -1;
3049 break;
3050 }
ae986130 3051 fdtmp[fdx++] = fd;
fc36a67e 3052 }
ae986130 3053 while (fdx > 0)
6ad3d225 3054 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 3055 return fd;
62b28dd9 3056#endif
a687059c
LW
3057}
3058#endif
3059
64ca3a65 3060#ifndef PERL_MICRO
ff68c719
PP
3061#ifdef HAS_SIGACTION
3062
3063Sighandler_t
864dbfa3 3064Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 3065{
27da23d5 3066 dVAR;
ff68c719
PP
3067 struct sigaction act, oact;
3068
a10b1e10
JH
3069#ifdef USE_ITHREADS
3070 /* only "parent" interpreter can diddle signals */
3071 if (PL_curinterp != aTHX)
8aad04aa 3072 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
3073#endif
3074
8aad04aa 3075 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
3076 sigemptyset(&act.sa_mask);
3077 act.sa_flags = 0;
3078#ifdef SA_RESTART
4ffa73a3
JH
3079 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3080 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 3081#endif
358837b8 3082#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 3083 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
3084 act.sa_flags |= SA_NOCLDWAIT;
3085#endif
ff68c719 3086 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 3087 return (Sighandler_t) SIG_ERR;
ff68c719 3088 else
8aad04aa 3089 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
3090}
3091
3092Sighandler_t
864dbfa3 3093Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
3094{
3095 struct sigaction oact;
96a5add6 3096 PERL_UNUSED_CONTEXT;
ff68c719
PP
3097
3098 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 3099 return (Sighandler_t) SIG_ERR;
ff68c719 3100 else
8aad04aa 3101 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
3102}
3103
3104int
864dbfa3 3105Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 3106{
27da23d5 3107 dVAR;
ff68c719
PP
3108 struct sigaction act;
3109
7918f24d
NC
3110 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
3111
a10b1e10
JH
3112#ifdef USE_ITHREADS
3113 /* only "parent" interpreter can diddle signals */
3114 if (PL_curinterp != aTHX)
3115 return -1;
3116#endif
3117
8aad04aa 3118 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
3119 sigemptyset(&act.sa_mask);
3120 act.sa_flags = 0;
3121#ifdef SA_RESTART
4ffa73a3
JH
3122 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3123 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 3124#endif
36b5d377 3125#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 3126 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
3127 act.sa_flags |= SA_NOCLDWAIT;
3128#endif
ff68c719
PP
3129 return sigaction(signo, &act, save);
3130}
3131
3132int
864dbfa3 3133Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 3134{
27da23d5 3135 dVAR;
a10b1e10
JH
3136#ifdef USE_ITHREADS
3137 /* only "parent" interpreter can diddle signals */
3138 if (PL_curinterp != aTHX)
3139 return -1;
3140#endif
3141
ff68c719
PP
3142 return sigaction(signo, save, (struct sigaction *)NULL);
3143}
3144
3145#else /* !HAS_SIGACTION */
3146
3147Sighandler_t
864dbfa3 3148Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 3149{
39f1703b 3150#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3151 /* only "parent" interpreter can diddle signals */
3152 if (PL_curinterp != aTHX)
8aad04aa 3153 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
3154#endif
3155
6ad3d225 3156 return PerlProc_signal(signo, handler);
ff68c719
PP
3157}
3158
fabdb6c0 3159static Signal_t
4e35701f 3160sig_trap(int signo)
ff68c719 3161{
27da23d5
JH
3162 dVAR;
3163 PL_sig_trapped++;
ff68c719
PP
3164}
3165
3166Sighandler_t
864dbfa3 3167Perl_rsignal_state(pTHX_ int signo)
ff68c719 3168{
27da23d5 3169 dVAR;
ff68c719
PP
3170 Sighandler_t oldsig;
3171
39f1703b 3172#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3173 /* only "parent" interpreter can diddle signals */
3174 if (PL_curinterp != aTHX)
8aad04aa 3175 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
3176#endif
3177
27da23d5 3178 PL_sig_trapped = 0;
6ad3d225
GS
3179 oldsig = PerlProc_signal(signo, sig_trap);
3180 PerlProc_signal(signo, oldsig);
27da23d5 3181 if (PL_sig_trapped)
3aed30dc 3182 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719
PP
3183 return oldsig;
3184}
3185
3186int
864dbfa3 3187Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 3188{
39f1703b 3189#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3190 /* only "parent" interpreter can diddle signals */
3191 if (PL_curinterp != aTHX)
3192 return -1;
3193#endif
6ad3d225 3194 *save = PerlProc_signal(signo, handler);
8aad04aa 3195 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3196}
3197
3198int
864dbfa3 3199Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 3200{
39f1703b 3201#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3202 /* only "parent" interpreter can diddle signals */
3203 if (PL_curinterp != aTHX)
3204 return -1;
3205#endif
8aad04aa 3206 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3207}
3208
3209#endif /* !HAS_SIGACTION */
64ca3a65 3210#endif /* !PERL_MICRO */
ff68c719 3211
5f05dabc 3212 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
e37778c2 3213#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
79072805 3214I32
864dbfa3 3215Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 3216{
97aff369 3217 dVAR;
ff68c719 3218 Sigsave_t hstat, istat, qstat;
a687059c 3219 int status;
a0d0e21e 3220 SV **svp;
d8a83dd3 3221 Pid_t pid;
2e0cfa16 3222 Pid_t pid2 = 0;
03136e13 3223 bool close_failed;
4ee39169 3224 dSAVEDERRNO;
2e0cfa16
FC
3225 const int fd = PerlIO_fileno(ptr);
3226
b6ae43b7 3227#ifdef USE_PERLIO
2e0cfa16
FC
3228 /* Find out whether the refcount is low enough for us to wait for the
3229 child proc without blocking. */
3230 const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
b6ae43b7
NC
3231#else
3232 const bool should_wait = 1;
3233#endif
a687059c 3234
2e0cfa16 3235 svp = av_fetch(PL_fdpid,fd,TRUE);
25d92023 3236 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 3237 SvREFCNT_dec(*svp);
3280af22 3238 *svp = &PL_sv_undef;
ddcf38b7
IZ
3239#ifdef OS2
3240 if (pid == -1) { /* Opened by popen. */
3241 return my_syspclose(ptr);
3242 }
a1d180c4 3243#endif
f1618b10
CS
3244 close_failed = (PerlIO_close(ptr) == EOF);
3245 SAVE_ERRNO;
7c0587c8 3246#ifdef UTS
6ad3d225 3247 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 3248#endif
64ca3a65 3249#ifndef PERL_MICRO
8aad04aa
JH
3250 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
3251 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
3252 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
64ca3a65 3253#endif
2e0cfa16 3254 if (should_wait) do {
1d3434b8
GS
3255 pid2 = wait4pid(pid, &status, 0);
3256 } while (pid2 == -1 && errno == EINTR);
64ca3a65 3257#ifndef PERL_MICRO
ff68c719
PP
3258 rsignal_restore(SIGHUP, &hstat);
3259 rsignal_restore(SIGINT, &istat);
3260 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 3261#endif
03136e13 3262 if (close_failed) {
4ee39169 3263 RESTORE_ERRNO;
03136e13
CS
3264 return -1;
3265 }
2e0cfa16
FC
3266 return(
3267 should_wait
3268 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3269 : 0
3270 );
20188a90 3271}
9c12f1e5
RGS
3272#else
3273#if defined(__LIBCATAMOUNT__)
3274I32
3275Perl_my_pclose(pTHX_ PerlIO *ptr)
3276{
3277 return -1;
3278}
3279#endif
4633a7c4
LW
3280#endif /* !DOSISH */
3281
e37778c2 3282#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 3283I32
d8a83dd3 3284Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 3285{
97aff369 3286 dVAR;
27da23d5 3287 I32 result = 0;
7918f24d 3288 PERL_ARGS_ASSERT_WAIT4PID;
b7953727
JH
3289 if (!pid)
3290 return -1;
ca0c25f6 3291#ifdef PERL_USES_PL_PIDSTATUS
b7953727 3292 {
3aed30dc 3293 if (pid > 0) {
12072db5
NC
3294 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3295 pid, rather than a string form. */
c4420975 3296 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS
3297 if (svp && *svp != &PL_sv_undef) {
3298 *statusp = SvIVX(*svp);
12072db5
NC
3299 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3300 G_DISCARD);
3aed30dc
HS
3301 return pid;
3302 }
3303 }
3304 else {
3305 HE *entry;
3306
3307 hv_iterinit(PL_pidstatus);
3308 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 3309 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 3310 I32 len;
0bcc34c2 3311 const char * const spid = hv_iterkey(entry,&len);
27da23d5 3312
12072db5
NC
3313 assert (len == sizeof(Pid_t));
3314 memcpy((char *)&pid, spid, len);
3aed30dc 3315 *statusp = SvIVX(sv);
7b9a3241
NC
3316 /* The hash iterator is currently on this entry, so simply
3317 calling hv_delete would trigger the lazy delete, which on
3318 aggregate does more work, beacuse next call to hv_iterinit()
3319 would spot the flag, and have to call the delete routine,
3320 while in the meantime any new entries can't re-use that
3321 memory. */
3322 hv_iterinit(PL_pidstatus);
7ea75b61 3323 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS
3324 return pid;
3325 }
20188a90
LW
3326 }
3327 }
68a29c53 3328#endif
79072805 3329#ifdef HAS_WAITPID
367f3c24
IZ
3330# ifdef HAS_WAITPID_RUNTIME
3331 if (!HAS_WAITPID_RUNTIME)
3332 goto hard_way;
3333# endif
cddd4526 3334 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 3335 goto finish;
367f3c24
IZ
3336#endif
3337#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
4608196e 3338 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
dfcfdb64 3339 goto finish;
367f3c24 3340#endif
ca0c25f6 3341#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 3342#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 3343 hard_way:
27da23d5 3344#endif
a0d0e21e 3345 {
a0d0e21e 3346 if (flags)
cea2e8a9 3347 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 3348 else {
76e3520e 3349 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW
3350 pidgone(result,*statusp);
3351 if (result < 0)
3352 *statusp = -1;
3353 }
a687059c
LW
3354 }
3355#endif
27da23d5 3356#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 3357 finish:
27da23d5 3358#endif
cddd4526
NIS
3359 if (result < 0 && errno == EINTR) {
3360 PERL_ASYNC_CHECK();
48dbb59e 3361 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS
3362 }
3363 return result;
a687059c 3364}
2986a63f 3365#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 3366
ca0c25f6 3367#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 3368void
ed4173ef 3369S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 3370{
79072805 3371 register SV *sv;
a687059c 3372
12072db5 3373 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 3374 SvUPGRADE(sv,SVt_IV);
45977657 3375 SvIV_set(sv, status);
20188a90 3376 return;
a687059c 3377}
ca0c25f6 3378#endif
a687059c 3379
85ca448a 3380#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 3381int pclose();
ddcf38b7
IZ
3382#ifdef HAS_FORK
3383int /* Cannot prototype with I32
3384 in os2ish.h. */
ba106d47 3385my_syspclose(PerlIO *ptr)
ddcf38b7 3386#else
79072805 3387I32
864dbfa3 3388Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 3389#endif
a687059c 3390{
760ac839 3391 /* Needs work for PerlIO ! */
c4420975 3392 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 3393 const I32 result = pclose(f);
2b96b0a5
JH
3394 PerlIO_releaseFILE(ptr,f);
3395 return result;
3396}
3397#endif
3398
933fea7f 3399#if defined(DJGPP)
2b96b0a5
JH
3400int djgpp_pclose();
3401I32
3402Perl_my_pclose(pTHX_ PerlIO *ptr)
3403{
3404 /* Needs work for PerlIO ! */
c4420975 3405 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 3406 I32 result = djgpp_pclose(f);
933fea7f 3407 result = (result << 8) & 0xff00;
760ac839
LW
3408 PerlIO_releaseFILE(ptr,f);
3409 return result;
a687059c 3410}
7c0587c8 3411#endif
9f68db38 3412
16fa5c11 3413#define PERL_REPEATCPY_LINEAR 4
9f68db38 3414void
26e1303d 3415Perl_repeatcpy(register char *to, register const char *from, I32 len, register IV count)
9f68db38 3416{
7918f24d
NC
3417 PERL_ARGS_ASSERT_REPEATCPY;
3418
16fa5c11
VP
3419 if (len == 1)
3420 memset(to, *from, count);
3421 else if (count) {
3422 register char *p = to;
26e1303d 3423 IV items, linear, half;
16fa5c11
VP
3424
3425 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3426 for (items = 0; items < linear; ++items) {
3427 register const char *q = from;
26e1303d 3428 IV todo;
16fa5c11
VP
3429 for (todo = len; todo > 0; todo--)
3430 *p++ = *q++;
3431 }
3432
3433 half = count / 2;
3434 while (items <= half) {
26e1303d 3435 IV size = items * len;
16fa5c11
VP
3436 memcpy(p, to, size);
3437 p += size;
3438 items *= 2;
9f68db38 3439 }
16fa5c11
VP
3440
3441 if (count > items)
3442 memcpy(p, to, (count - items) * len);
9f68db38
LW
3443 }
3444}
0f85fab0 3445
fe14fcc3 3446#ifndef HAS_RENAME
79072805 3447I32
4373e329 3448Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3449{
93a17b20
LW
3450 char *fa = strrchr(a,'/');
3451 char *fb = strrchr(b,'/');
c623ac67
GS
3452 Stat_t tmpstatbuf1;
3453 Stat_t tmpstatbuf2;
c4420975 3454 SV * const tmpsv = sv_newmortal();
62b28dd9 3455
7918f24d
NC
3456 PERL_ARGS_ASSERT_SAME_DIRENT;
3457
62b28dd9
LW
3458 if (fa)
3459 fa++;
3460 else
3461 fa = a;
3462 if (fb)
3463 fb++;
3464 else
3465 fb = b;
3466 if (strNE(a,b))
3467 return FALSE;
3468 if (fa == a)
76f68e9b 3469 sv_setpvs(tmpsv, ".");
62b28dd9 3470 else
46fc3d4c 3471 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3472 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
3473 return FALSE;
3474 if (fb == b)
76f68e9b 3475 sv_setpvs(tmpsv, ".");
62b28dd9 3476 else
46fc3d4c 3477 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3478 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
3479 return FALSE;
3480 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3481 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3482}
fe14fcc3
LW
3483#endif /* !HAS_RENAME */
3484
491527d0 3485char*
7f315aed
NC
3486Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3487 const char *const *const search_ext, I32 flags)
491527d0 3488{
97aff369 3489 dVAR;
bd61b366
SS
3490 const char *xfound = NULL;
3491 char *xfailed = NULL;
0f31cffe 3492 char tmpbuf[MAXPATHLEN];
491527d0 3493 register char *s;
5f74f29c 3494 I32 len = 0;
491527d0 3495 int retval;
39a02377 3496 char *bufend;
491527d0
GS
3497#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3498# define SEARCH_EXTS ".bat", ".cmd", NULL
3499# define MAX_EXT_LEN 4
3500#endif
3501#ifdef OS2
3502# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3503# define MAX_EXT_LEN 4
3504#endif
3505#ifdef VMS
3506# define SEARCH_EXTS ".pl", ".com", NULL
3507# define MAX_EXT_LEN 4
3508#endif
3509 /* additional extensions to try in each dir if scriptname not found */
3510#ifdef SEARCH_EXTS
0bcc34c2 3511 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3512 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3513 int extidx = 0, i = 0;
bd61b366 3514 const char *curext = NULL;
491527d0 3515#else
53c1dcc0 3516 PERL_UNUSED_ARG(search_ext);
491527d0
GS
3517# define MAX_EXT_LEN 0
3518#endif
3519
7918f24d
NC
3520 PERL_ARGS_ASSERT_FIND_SCRIPT;
3521
491527d0
GS
3522 /*
3523 * If dosearch is true and if scriptname does not contain path
3524 * delimiters, search the PATH for scriptname.
3525 *
3526 * If SEARCH_EXTS is also defined, will look for each
3527 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3528 * while searching the PATH.
3529 *
3530 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3531 * proceeds as follows:
3532 * If DOSISH or VMSISH:
3533 * + look for ./scriptname{,.foo,.bar}
3534 * + search the PATH for scriptname{,.foo,.bar}
3535 *
3536 * If !DOSISH:
3537 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3538 * this will not look in '.' if it's not in the PATH)
3539 */
84486fc6 3540 tmpbuf[0] = '\0';
491527d0
GS
3541
3542#ifdef VMS
3543# ifdef ALWAYS_DEFTYPES
3544 len = strlen(scriptname);
3545 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3546 int idx = 0, deftypes = 1;
491527d0
GS
3547 bool seen_dot = 1;
3548
bd61b366 3549 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3550# else
3551 if (dosearch) {
c4420975 3552 int idx = 0, deftypes = 1;
491527d0
GS
3553 bool seen_dot = 1;
3554
bd61b366 3555 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3556# endif
3557 /* The first time through, just add SEARCH_EXTS to whatever we
3558 * already have, so we can check for default file types. */
3559 while (deftypes ||
84486fc6 3560 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS
3561 {
3562 if (deftypes) {
3563 deftypes = 0;
84486fc6 3564 *tmpbuf = '\0';
491527d0 3565 }
84486fc6
GS
3566 if ((strlen(tmpbuf) + strlen(scriptname)
3567 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3568 continue; /* don't search dir with too-long name */
6fca0082 3569 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS
3570#else /* !VMS */
3571
3572#ifdef DOSISH
3573 if (strEQ(scriptname, "-"))
3574 dosearch = 0;
3575 if (dosearch) { /* Look in '.' first. */
fe2774ed 3576 const char *cur = scriptname;
491527d0
GS
3577#ifdef SEARCH_EXTS
3578 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3579 while (ext[i])
3580 if (strEQ(ext[i++],curext)) {
3581 extidx = -1; /* already has an ext */
3582 break;
3583 }
3584 do {
3585#endif
3586 DEBUG_p(PerlIO_printf(Perl_debug_log,
3587 "Looking for %s\n",cur));
017f25f1
IZ
3588 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3589 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS
3590 dosearch = 0;
3591 scriptname = cur;
3592#ifdef SEARCH_EXTS
3593 break;
3594#endif
3595 }
3596#ifdef SEARCH_EXTS
3597 if (cur == scriptname) {
3598 len = strlen(scriptname);
84486fc6 3599 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3600 break;
9e4425f7
SH
3601 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3602 cur = tmpbuf;
491527d0
GS
3603 }
3604 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3605 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS
3606#endif
3607 }
3608#endif
3609
3610 if (dosearch && !strchr(scriptname, '/')
3611#ifdef DOSISH
3612 && !strchr(scriptname, '\\')
3613#endif
cd39f2b6 3614 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3615 {
491527d0 3616 bool seen_dot = 0;
92f0c265 3617
39a02377
DM
3618 bufend = s + strlen(s);
3619 while (s < bufend) {
491527d0
GS
3620#if defined(atarist) || defined(DOSISH)
3621 for (len = 0; *s
3622# ifdef atarist
3623 && *s != ','
3624# endif
3625 && *s != ';'; len++, s++) {
84486fc6
GS
3626 if (len < sizeof tmpbuf)
3627 tmpbuf[len] = *s;
491527d0 3628 }
84486fc6
GS
3629 if (len < sizeof tmpbuf)
3630 tmpbuf[len] = '\0';
491527d0 3631#else /* ! (atarist || DOSISH) */
39a02377 3632 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS
3633 ':',
3634 &len);
3635#endif /* ! (atarist || DOSISH) */
39a02377 3636 if (s < bufend)
491527d0 3637 s++;
84486fc6 3638 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS
3639 continue; /* don't search dir with too-long name */