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