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