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