This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
update the links to freenode
[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"
7dc86639 27#include "reentr.h"
62b28dd9 28
97cb92d6 29#if defined(USE_PERLIO)
2e0cfa16 30#include "perliol.h" /* For PerlIOUnix_refcnt */
6f408c34 31#endif
2e0cfa16 32
64ca3a65 33#ifndef PERL_MICRO
a687059c 34#include <signal.h>
36477c24
PP
35#ifndef SIG_ERR
36# define SIG_ERR ((Sighandler_t) -1)
37#endif
64ca3a65 38#endif
36477c24 39
3be8f094
TC
40#include <math.h>
41#include <stdlib.h>
42
172d2248
OS
43#ifdef __Lynx__
44/* Missing protos on LynxOS */
45int putenv(char *);
46#endif
47
40262ff4
AB
48#ifdef __amigaos__
49# include "amigaos4/amigaio.h"
50#endif
51
868439a2
JH
52#ifdef HAS_SELECT
53# ifdef I_SYS_SELECT
54# include <sys/select.h>
55# endif
56#endif
57
470dd224 58#ifdef USE_C_BACKTRACE
0762e42f
JH
59# ifdef I_BFD
60# define USE_BFD
61# ifdef PERL_DARWIN
62# undef USE_BFD /* BFD is useless in OS X. */
63# endif
64# ifdef USE_BFD
65# include <bfd.h>
66# endif
67# endif
470dd224
JH
68# ifdef I_DLFCN
69# include <dlfcn.h>
70# endif
71# ifdef I_EXECINFO
72# include <execinfo.h>
73# endif
74#endif
75
b001a0d1
FC
76#ifdef PERL_DEBUG_READONLY_COW
77# include <sys/mman.h>
78#endif
79
8d063cd8 80#define FLUSH
8d063cd8 81
a687059c
LW
82/* NOTE: Do not call the next three routines directly. Use the macros
83 * in handy.h, so that we can easily redefine everything to do tracking of
84 * allocated hunks back to the original New to track down any memory leaks.
20cec16a 85 * XXX This advice seems to be widely ignored :-( --AD August 1996.
a687059c
LW
86 */
87
79a92154 88#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
1f4d2d4e
NC
89# define ALWAYS_NEED_THX
90#endif
91
b001a0d1
FC
92#if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
93static void
94S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
95{
96 if (header->readonly
97 && mprotect(header, header->size, PROT_READ|PROT_WRITE))
98 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
99 header, header->size, errno);
100}
101
102static void
103S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
104{
105 if (header->readonly
106 && mprotect(header, header->size, PROT_READ))
107 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
108 header, header->size, errno);
109}
110# define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
111# define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
112#else
113# define maybe_protect_rw(foo) NOOP
114# define maybe_protect_ro(foo) NOOP
115#endif
116
3f07c2bc
FC
117#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
118 /* Use memory_debug_header */
119# define USE_MDH
120# if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
121 || defined(PERL_DEBUG_READONLY_COW)
122# define MDH_HAS_SIZE
123# endif
124#endif
125
340e5263
KW
126/*
127=for apidoc_section $memory
128=for apidoc safesysmalloc
129Paranoid version of system's malloc()
130
131=cut
132*/
26fa51c3 133
bd4080b3 134Malloc_t
4f63d024 135Perl_safesysmalloc(MEM_SIZE size)
8d063cd8 136{
1f4d2d4e 137#ifdef ALWAYS_NEED_THX
54aff467 138 dTHX;
0cb20dae 139#endif
bd4080b3 140 Malloc_t ptr;
9f300641 141 dSAVEDERRNO;
9efda33a
TC
142
143#ifdef USE_MDH
144 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
145 goto out_of_memory;
a78adc84 146 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
9efda33a 147#endif
34de22dd 148#ifdef DEBUGGING
03c5309f 149 if ((SSize_t)size < 0)
147e3846 150 Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
34de22dd 151#endif
b001a0d1 152 if (!size) size = 1; /* malloc(0) is NASTY on our system */
9f300641 153 SAVE_ERRNO;
b001a0d1
FC
154#ifdef PERL_DEBUG_READONLY_COW
155 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
156 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
157 perror("mmap failed");
158 abort();
159 }
160#else
1ae509d1 161 ptr = (Malloc_t)PerlMem_malloc(size);
b001a0d1 162#endif
da927450 163 PERL_ALLOC_CHECK(ptr);
bd61b366 164 if (ptr != NULL) {
3f07c2bc 165#ifdef USE_MDH
7cb608b5
NC
166 struct perl_memory_debug_header *const header
167 = (struct perl_memory_debug_header *)ptr;
9a083ecf
NC
168#endif
169
170#ifdef PERL_POISON
7e337ee0 171 PoisonNew(((char *)ptr), size, char);
9a083ecf 172#endif
7cb608b5 173
9a083ecf 174#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC
175 header->interpreter = aTHX;
176 /* Link us into the list. */
177 header->prev = &PL_memory_debug_header;
178 header->next = PL_memory_debug_header.next;
179 PL_memory_debug_header.next = header;
b001a0d1 180 maybe_protect_rw(header->next);
7cb608b5 181 header->next->prev = header;
b001a0d1
FC
182 maybe_protect_ro(header->next);
183# ifdef PERL_DEBUG_READONLY_COW
184 header->readonly = 0;
cd1541b2 185# endif
e8dda941 186#endif
3f07c2bc 187#ifdef MDH_HAS_SIZE
b001a0d1
FC
188 header->size = size;
189#endif
b033d668 190 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
147e3846 191 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
b033d668 192
9f300641
TC
193 /* malloc() can modify errno() even on success, but since someone
194 writing perl code doesn't have any control over when perl calls
195 malloc() we need to hide that.
196 */
197 RESTORE_ERRNO;
b033d668 198 }
8d063cd8 199 else {
296f0d56 200#ifdef USE_MDH
9efda33a 201 out_of_memory:
296f0d56
TC
202#endif
203 {
204#ifndef ALWAYS_NEED_THX
205 dTHX;
206#endif
207 if (PL_nomemok)
208 ptr = NULL;
209 else
210 croak_no_mem();
211 }
8d063cd8 212 }
b033d668 213 return ptr;
8d063cd8
LW
214}
215
340e5263
KW
216/*
217=for apidoc safesysrealloc
218Paranoid version of system's realloc()
219
220=cut
221*/
8d063cd8 222
bd4080b3 223Malloc_t
4f63d024 224Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
8d063cd8 225{
1f4d2d4e 226#ifdef ALWAYS_NEED_THX
54aff467 227 dTHX;
0cb20dae 228#endif
bd4080b3 229 Malloc_t ptr;
b001a0d1
FC
230#ifdef PERL_DEBUG_READONLY_COW
231 const MEM_SIZE oldsize = where
a78adc84 232 ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
b001a0d1
FC
233 : 0;
234#endif
8d063cd8 235
7614df0c 236 if (!size) {
f2517201 237 safesysfree(where);
b033d668 238 ptr = NULL;
7614df0c 239 }
b033d668
DD
240 else if (!where) {
241 ptr = safesysmalloc(size);
242 }
243 else {
9f300641 244 dSAVE_ERRNO;
3f07c2bc 245#ifdef USE_MDH
b033d668 246 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
9efda33a
TC
247 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
248 goto out_of_memory;
b033d668
DD
249 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
250 {
251 struct perl_memory_debug_header *const header
252 = (struct perl_memory_debug_header *)where;
7cb608b5 253
b001a0d1 254# ifdef PERL_TRACK_MEMPOOL
b033d668
DD
255 if (header->interpreter != aTHX) {
256 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
257 header->interpreter, aTHX);
258 }
259 assert(header->next->prev == header);
260 assert(header->prev->next == header);
cd1541b2 261# ifdef PERL_POISON
b033d668
DD
262 if (header->size > size) {
263 const MEM_SIZE freed_up = header->size - size;
264 char *start_of_freed = ((char *)where) + size;
265 PoisonFree(start_of_freed, freed_up, char);
266 }
cd1541b2 267# endif
b001a0d1 268# endif
3f07c2bc 269# ifdef MDH_HAS_SIZE
b033d668 270 header->size = size;
b001a0d1 271# endif
b033d668 272 }
e8dda941 273#endif
34de22dd 274#ifdef DEBUGGING
b033d668 275 if ((SSize_t)size < 0)
147e3846 276 Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);
34de22dd 277#endif
b001a0d1 278#ifdef PERL_DEBUG_READONLY_COW
b033d668
DD
279 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
280 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
281 perror("mmap failed");
282 abort();
283 }
284 Copy(where,ptr,oldsize < size ? oldsize : size,char);
285 if (munmap(where, oldsize)) {
286 perror("munmap failed");
287 abort();
288 }
b001a0d1 289#else
b033d668 290 ptr = (Malloc_t)PerlMem_realloc(where,size);
b001a0d1 291#endif
b033d668 292 PERL_ALLOC_CHECK(ptr);
a1d180c4 293
4fd0a9b8
NC
294 /* MUST do this fixup first, before doing ANYTHING else, as anything else
295 might allocate memory/free/move memory, and until we do the fixup, it
296 may well be chasing (and writing to) free memory. */
b033d668 297 if (ptr != NULL) {
b001a0d1 298#ifdef PERL_TRACK_MEMPOOL
b033d668
DD
299 struct perl_memory_debug_header *const header
300 = (struct perl_memory_debug_header *)ptr;
7cb608b5 301
9a083ecf 302# ifdef PERL_POISON
b033d668
DD
303 if (header->size < size) {
304 const MEM_SIZE fresh = size - header->size;
305 char *start_of_fresh = ((char *)ptr) + size;
306 PoisonNew(start_of_fresh, fresh, char);
307 }
9a083ecf
NC
308# endif
309
b033d668
DD
310 maybe_protect_rw(header->next);
311 header->next->prev = header;
312 maybe_protect_ro(header->next);
313 maybe_protect_rw(header->prev);
314 header->prev->next = header;
315 maybe_protect_ro(header->prev);
b001a0d1 316#endif
b033d668 317 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
9f300641
TC
318
319 /* realloc() can modify errno() even on success, but since someone
320 writing perl code doesn't have any control over when perl calls
321 realloc() we need to hide that.
322 */
323 RESTORE_ERRNO;
b033d668 324 }
4fd0a9b8
NC
325
326 /* In particular, must do that fixup above before logging anything via
327 *printf(), as it can reallocate memory, which can cause SEGVs. */
328
147e3846
KW
329 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
330 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
4fd0a9b8 331
b033d668 332 if (ptr == NULL) {
296f0d56 333#ifdef USE_MDH
9efda33a 334 out_of_memory:
296f0d56
TC
335#endif
336 {
337#ifndef ALWAYS_NEED_THX
338 dTHX;
339#endif
340 if (PL_nomemok)
341 ptr = NULL;
342 else
343 croak_no_mem();
344 }
0cb20dae 345 }
8d063cd8 346 }
b033d668 347 return ptr;
8d063cd8
LW
348}
349
340e5263
KW
350/*
351=for apidoc safesysfree
352Safe version of system's free()
353
354=cut
355*/
8d063cd8 356
54310121 357Free_t
4f63d024 358Perl_safesysfree(Malloc_t where)
8d063cd8 359{
79a92154 360#ifdef ALWAYS_NEED_THX
54aff467 361 dTHX;
155aba94 362#endif
147e3846 363 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
378cc40b 364 if (where) {
3f07c2bc 365#ifdef USE_MDH
6edcbed6 366 Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
cd1541b2 367 {
7cb608b5 368 struct perl_memory_debug_header *const header
6edcbed6 369 = (struct perl_memory_debug_header *)where_intrn;
7cb608b5 370
3f07c2bc 371# ifdef MDH_HAS_SIZE
b001a0d1
FC
372 const MEM_SIZE size = header->size;
373# endif
374# ifdef PERL_TRACK_MEMPOOL
7cb608b5 375 if (header->interpreter != aTHX) {
5637ef5b
NC
376 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
377 header->interpreter, aTHX);
7cb608b5
NC
378 }
379 if (!header->prev) {
cd1541b2
NC
380 Perl_croak_nocontext("panic: duplicate free");
381 }
5637ef5b
NC
382 if (!(header->next))
383 Perl_croak_nocontext("panic: bad free, header->next==NULL");
384 if (header->next->prev != header || header->prev->next != header) {
385 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
386 "header=%p, ->prev->next=%p",
387 header->next->prev, header,
388 header->prev->next);
cd1541b2 389 }
7cb608b5 390 /* Unlink us from the chain. */
b001a0d1 391 maybe_protect_rw(header->next);
7cb608b5 392 header->next->prev = header->prev;
b001a0d1
FC
393 maybe_protect_ro(header->next);
394 maybe_protect_rw(header->prev);
7cb608b5 395 header->prev->next = header->next;
b001a0d1
FC
396 maybe_protect_ro(header->prev);
397 maybe_protect_rw(header);
7cb608b5 398# ifdef PERL_POISON
6edcbed6 399 PoisonNew(where_intrn, size, char);
cd1541b2 400# endif
7cb608b5
NC
401 /* Trigger the duplicate free warning. */
402 header->next = NULL;
b001a0d1
FC
403# endif
404# ifdef PERL_DEBUG_READONLY_COW
6edcbed6 405 if (munmap(where_intrn, size)) {
b001a0d1
FC
406 perror("munmap failed");
407 abort();
408 }
409# endif
7cb608b5 410 }
6edcbed6
DD
411#else
412 Malloc_t where_intrn = where;
413#endif /* USE_MDH */
b001a0d1 414#ifndef PERL_DEBUG_READONLY_COW
6edcbed6 415 PerlMem_free(where_intrn);
b001a0d1 416#endif
378cc40b 417 }
8d063cd8
LW
418}
419
340e5263
KW
420/*
421=for apidoc safesyscalloc
422Safe version of system's calloc()
423
424=cut
425*/
1050c9ca 426
bd4080b3 427Malloc_t
4f63d024 428Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
1050c9ca 429{
1f4d2d4e 430#ifdef ALWAYS_NEED_THX
54aff467 431 dTHX;
0cb20dae 432#endif
bd4080b3 433 Malloc_t ptr;
3f07c2bc 434#if defined(USE_MDH) || defined(DEBUGGING)
ad7244db 435 MEM_SIZE total_size = 0;
4b1123b9 436#endif
1050c9ca 437
ad7244db 438 /* Even though calloc() for zero bytes is strange, be robust. */
4b1123b9 439 if (size && (count <= MEM_SIZE_MAX / size)) {
3f07c2bc 440#if defined(USE_MDH) || defined(DEBUGGING)
ad7244db 441 total_size = size * count;
4b1123b9
NC
442#endif
443 }
ad7244db 444 else
d1decf2b 445 croak_memory_wrap();
3f07c2bc 446#ifdef USE_MDH
a78adc84
DM
447 if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
448 total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
ad7244db 449 else
d1decf2b 450 croak_memory_wrap();
ad7244db 451#endif
1050c9ca 452#ifdef DEBUGGING
03c5309f 453 if ((SSize_t)size < 0 || (SSize_t)count < 0)
147e3846 454 Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
5637ef5b 455 (UV)size, (UV)count);
1050c9ca 456#endif
b001a0d1
FC
457#ifdef PERL_DEBUG_READONLY_COW
458 if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
459 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
460 perror("mmap failed");
461 abort();
462 }
463#elif defined(PERL_TRACK_MEMPOOL)
e1a95402
NC
464 /* Have to use malloc() because we've added some space for our tracking
465 header. */
ad7244db
JH
466 /* malloc(0) is non-portable. */
467 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
e1a95402
NC
468#else
469 /* Use calloc() because it might save a memset() if the memory is fresh
470 and clean from the OS. */
ad7244db
JH
471 if (count && size)
472 ptr = (Malloc_t)PerlMem_calloc(count, size);
473 else /* calloc(0) is non-portable. */
474 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
e8dda941 475#endif
da927450 476 PERL_ALLOC_CHECK(ptr);
22730398 477 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %zu x %zu = %zu bytes\n",PTR2UV(ptr),(long)PL_an++, count, size, total_size));
bd61b366 478 if (ptr != NULL) {
3f07c2bc 479#ifdef USE_MDH
7cb608b5
NC
480 {
481 struct perl_memory_debug_header *const header
482 = (struct perl_memory_debug_header *)ptr;
483
b001a0d1 484# ifndef PERL_DEBUG_READONLY_COW
e1a95402 485 memset((void*)ptr, 0, total_size);
b001a0d1
FC
486# endif
487# ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC
488 header->interpreter = aTHX;
489 /* Link us into the list. */
490 header->prev = &PL_memory_debug_header;
491 header->next = PL_memory_debug_header.next;
492 PL_memory_debug_header.next = header;
b001a0d1 493 maybe_protect_rw(header->next);
7cb608b5 494 header->next->prev = header;
b001a0d1
FC
495 maybe_protect_ro(header->next);
496# ifdef PERL_DEBUG_READONLY_COW
497 header->readonly = 0;
498# endif
499# endif
3f07c2bc 500# ifdef MDH_HAS_SIZE
e1a95402 501 header->size = total_size;
cd1541b2 502# endif
a78adc84 503 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
7cb608b5 504 }
e8dda941 505#endif
1050c9ca
PP
506 return ptr;
507 }
0cb20dae 508 else {
1f4d2d4e 509#ifndef ALWAYS_NEED_THX
0cb20dae
NC
510 dTHX;
511#endif
512 if (PL_nomemok)
513 return NULL;
4cbe3a7d 514 croak_no_mem();
0cb20dae 515 }
1050c9ca
PP
516}
517
cae6d0e5
GS
518/* These must be defined when not using Perl's malloc for binary
519 * compatibility */
520
521#ifndef MYMALLOC
522
523Malloc_t Perl_malloc (MEM_SIZE nbytes)
524{
20b7effb
JH
525#ifdef PERL_IMPLICIT_SYS
526 dTHX;
527#endif
077a72a9 528 return (Malloc_t)PerlMem_malloc(nbytes);
cae6d0e5
GS
529}
530
531Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
532{
20b7effb
JH
533#ifdef PERL_IMPLICIT_SYS
534 dTHX;
535#endif
077a72a9 536 return (Malloc_t)PerlMem_calloc(elements, size);
cae6d0e5
GS
537}
538
539Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
540{
20b7effb
JH
541#ifdef PERL_IMPLICIT_SYS
542 dTHX;
543#endif
077a72a9 544 return (Malloc_t)PerlMem_realloc(where, nbytes);
cae6d0e5
GS
545}
546
547Free_t Perl_mfree (Malloc_t where)
548{
20b7effb
JH
549#ifdef PERL_IMPLICIT_SYS
550 dTHX;
551#endif
cae6d0e5
GS
552 PerlMem_free(where);
553}
554
555#endif
556
cc448cea
KW
557/* This is the value stored in *retlen in the two delimcpy routines below when
558 * there wasn't enough room in the destination to store everything it was asked
559 * to. The value is deliberately very large so that hopefully if code uses it
560 * unquestioninly to access memory, it will likely segfault. And it is small
561 * enough that if the caller does some arithmetic on it before accessing, it
562 * won't overflow into a small legal number. */
563#define DELIMCPY_OUT_OF_BOUNDS_RET I32_MAX
ab017425
KW
564
565/*
3f620621 566=for apidoc_section $string
ab017425
KW
567=for apidoc delimcpy_no_escape
568
569Copy a source buffer to a destination buffer, stopping at (but not including)
430f723e
KW
570the first occurrence in the source of the delimiter byte, C<delim>. The source
571is the bytes between S<C<from> and C<from_end> - 1>. Similarly, the dest is
572C<to> up to C<to_end>.
ab017425 573
430f723e 574The number of bytes copied is written to C<*retlen>.
ab017425 575
430f723e
KW
576Returns the position of C<delim> in the C<from> buffer, but if there is no
577such occurrence before C<from_end>, then C<from_end> is returned, and the entire
578buffer S<C<from> .. C<from_end> - 1> is copied.
ab017425
KW
579
580If there is room in the destination available after the copy, an extra
430f723e
KW
581terminating safety C<NUL> byte is appended (not included in the returned
582length).
583
584The error case is if the destination buffer is not large enough to accommodate
585everything that should be copied. In this situation, a value larger than
586S<C<to_end> - C<to>> is written to C<*retlen>, and as much of the source as
587fits will be written to the destination. Not having room for the safety C<NUL>
588is not considered an error.
ab017425
KW
589
590=cut
591*/
ba0a4150 592char *
430f723e
KW
593Perl_delimcpy_no_escape(char *to, const char *to_end,
594 const char *from, const char *from_end,
595 const int delim, I32 *retlen)
ba0a4150 596{
ab017425 597 const char * delim_pos;
430f723e
KW
598 Ptrdiff_t from_len = from_end - from;
599 Ptrdiff_t to_len = to_end - to;
600 SSize_t copy_len;
ab017425 601
ad9dfdb7 602 PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
ba0a4150 603
430f723e
KW
604 assert(from_len >= 0);
605 assert(to_len >= 0);
ab017425 606
430f723e
KW
607 /* Look for the first delimiter in the source */
608 delim_pos = (const char *) memchr(from, delim, from_len);
ab017425 609
430f723e
KW
610 /* Copy up to where the delimiter was found, or the entire buffer if not
611 * found */
612 copy_len = (delim_pos) ? delim_pos - from : from_len;
ab017425 613
430f723e
KW
614 /* If not enough room, copy as much as can fit, and set error return */
615 if (copy_len > to_len) {
616 Copy(from, to, to_len, char);
617 *retlen = DELIMCPY_OUT_OF_BOUNDS_RET;
ab017425 618 }
430f723e
KW
619 else {
620 Copy(from, to, copy_len, char);
ab017425 621
430f723e
KW
622 /* If there is extra space available, add a trailing NUL */
623 if (copy_len < to_len) {
624 to[copy_len] = '\0';
625 }
626
627 *retlen = copy_len;
ab017425
KW
628 }
629
630 return (char *) from + copy_len;
ba0a4150
FC
631}
632
cc448cea
KW
633/*
634=for apidoc delimcpy
635
636Copy a source buffer to a destination buffer, stopping at (but not including)
637the first occurrence in the source of an unescaped (defined below) delimiter
638byte, C<delim>. The source is the bytes between S<C<from> and C<from_end> -
6391>. Similarly, the dest is C<to> up to C<to_end>.
640
641The number of bytes copied is written to C<*retlen>.
642
643Returns the position of the first uncopied C<delim> in the C<from> buffer, but
644if there is no such occurrence before C<from_end>, then C<from_end> is returned,
645and the entire buffer S<C<from> .. C<from_end> - 1> is copied.
646
647If there is room in the destination available after the copy, an extra
648terminating safety C<NUL> byte is appended (not included in the returned
649length).
650
651The error case is if the destination buffer is not large enough to accommodate
652everything that should be copied. In this situation, a value larger than
653S<C<to_end> - C<to>> is written to C<*retlen>, and as much of the source as
654fits will be written to the destination. Not having room for the safety C<NUL>
655is not considered an error.
656
657In the following examples, let C<x> be the delimiter, and C<0> represent a C<NUL>
658byte (B<NOT> the digit C<0>). Then we would have
659
660 Source Destination
661 abcxdef abc0
662
663provided the destination buffer is at least 4 bytes long.
664
665An escaped delimiter is one which is immediately preceded by a single
666backslash. Escaped delimiters are copied, and the copy continues past the
667delimiter; the backslash is not copied:
668
669 Source Destination
670 abc\xdef abcxdef0
671
672(provided the destination buffer is at least 8 bytes long).
673
674It's actually somewhat more complicated than that. A sequence of any odd number
675of backslashes escapes the following delimiter, and the copy continues with
676exactly one of the backslashes stripped.
677
678 Source Destination
679 abc\xdef abcxdef0
680 abc\\\xdef abc\\xdef0
681 abc\\\\\xdef abc\\\\xdef0
682
683(as always, if the destination is large enough)
684
685An even number of preceding backslashes does not escape the delimiter, so that
686the copy stops just before it, and includes all the backslashes (no stripping;
687zero is considered even):
688
689 Source Destination
690 abcxdef abc0
691 abc\\xdef abc\\0
692 abc\\\\xdef abc\\\\0
693
694=cut
695*/
696
ba0a4150 697char *
cc448cea
KW
698Perl_delimcpy(char *to, const char *to_end,
699 const char *from, const char *from_end,
700 const int delim, I32 *retlen)
ba0a4150 701{
cc448cea
KW
702 const char * const orig_to = to;
703 Ptrdiff_t copy_len = 0;
704 bool stopped_early = FALSE; /* Ran out of room to copy to */
705
ad9dfdb7 706 PERL_ARGS_ASSERT_DELIMCPY;
cc448cea
KW
707 assert(from_end >= from);
708 assert(to_end >= to);
709
710 /* Don't use the loop for the trivial case of the first character being the
711 * delimiter; otherwise would have to worry inside the loop about backing
712 * up before the start of 'from' */
713 if (LIKELY(from_end > from && *from != delim)) {
714 while ((copy_len = from_end - from) > 0) {
715 const char * backslash_pos;
716 const char * delim_pos;
717
718 /* Look for the next delimiter in the remaining portion of the
719 * source. A loop invariant is that we already know that the copy
720 * should include *from; this comes from the conditional before the
721 * loop, and how we set things up at the end of each iteration */
722 delim_pos = (const char *) memchr(from + 1, delim, copy_len - 1);
723
724 /* If didn't find it, done looking; set up so copies all of the
725 * source */
726 if (! delim_pos) {
727 copy_len = from_end - from;
728 break;
729 }
730
731 /* Look for a backslash immediately before the delimiter */
732 backslash_pos = delim_pos - 1;
ba0a4150 733
cc448cea
KW
734 /* If the delimiter is not escaped, this ends the copy */
735 if (*backslash_pos != '\\') {
736 copy_len = delim_pos - from;
737 break;
738 }
739
740 /* Here there is a backslash just before the delimiter, but it
741 * could be the final backslash in a sequence of them. Backup to
742 * find the first one in it. */
743 do {
744 backslash_pos--;
745 }
746 while (backslash_pos >= from && *backslash_pos == '\\');
747
748 /* If the number of backslashes is even, they just escape one
749 * another, leaving the delimiter unescaped, and stopping the copy.
750 * */
751 if (! ((delim_pos - (backslash_pos + 1)) & 1)) {
752 copy_len = delim_pos - from; /* even, copy up to delimiter */
753 break;
754 }
755
756 /* Here is odd, so the delimiter is escaped. We will try to copy
757 * all but the final backslash in the sequence */
758 copy_len = delim_pos - 1 - from;
759
760 /* Do the copy, but not beyond the end of the destination */
761 if (copy_len >= to_end - to) {
762 Copy(from, to, to_end - to, char);
763 stopped_early = TRUE;
764 to = (char *) to_end;
765 }
766 else {
767 Copy(from, to, copy_len, char);
768 to += copy_len;
769 }
770
771 /* Set up so next iteration will include the delimiter */
772 from = delim_pos;
773 }
774 }
775
776 /* Here, have found the final segment to copy. Copy that, but not beyond
777 * the size of the destination. If not enough room, copy as much as can
778 * fit, and set error return */
779 if (stopped_early || copy_len > to_end - to) {
780 Copy(from, to, to_end - to, char);
781 *retlen = DELIMCPY_OUT_OF_BOUNDS_RET;
782 }
783 else {
784 Copy(from, to, copy_len, char);
785
786 to += copy_len;
787
788 /* If there is extra space available, add a trailing NUL */
789 if (to < to_end) {
790 *to = '\0';
791 }
792
793 *retlen = to - orig_to;
794 }
795
796 return (char *) from + copy_len;
ba0a4150
FC
797}
798
fcfc5a27 799/*
44170c9a 800=for apidoc ninstr
fcfc5a27
KW
801
802Find the first (leftmost) occurrence of a sequence of bytes within another
803sequence. This is the Perl version of C<strstr()>, extended to handle
804arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL>
805is what the initial C<n> in the function name stands for; some systems have an
806equivalent, C<memmem()>, but with a somewhat different API).
807
808Another way of thinking about this function is finding a needle in a haystack.
809C<big> points to the first byte in the haystack. C<big_end> points to one byte
810beyond the final byte in the haystack. C<little> points to the first byte in
811the needle. C<little_end> points to one byte beyond the final byte in the
812needle. All the parameters must be non-C<NULL>.
813
814The function returns C<NULL> if there is no occurrence of C<little> within
815C<big>. If C<little> is the empty string, C<big> is returned.
816
817Because this function operates at the byte level, and because of the inherent
818characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the
819needle and the haystack are strings with the same UTF-8ness, but not if the
820UTF-8ness differs.
821
822=cut
823
824*/
a687059c
LW
825
826char *
04c9e624 827Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
8d063cd8 828{
7918f24d 829 PERL_ARGS_ASSERT_NINSTR;
b8070b07
KW
830
831#ifdef HAS_MEMMEM
832 return ninstr(big, bigend, little, lend);
833#else
834
66256797
KW
835 if (little >= lend) {
836 return (char*) big;
837 }
838 else {
839 const U8 first = *little;
840 Size_t lsize;
841
842 /* No match can start closer to the end of the haystack than the length
843 * of the needle. */
844 bigend -= lend - little;
845 little++; /* Look for 'first', then the remainder is in here */
846 lsize = lend - little;
847
4c8626be 848 while (big <= bigend) {
66256797
KW
849 big = (char *) memchr((U8 *) big, first, bigend - big + 1);
850 if (big == NULL || big > bigend) {
851 return NULL;
4c8626be 852 }
66256797
KW
853
854 if (memEQ(big + 1, little, lsize)) {
855 return (char*) big;
856 }
857 big++;
4c8626be 858 }
378cc40b 859 }
66256797 860
bd61b366 861 return NULL;
b8070b07
KW
862
863#endif
864
a687059c
LW
865}
866
fcfc5a27 867/*
44170c9a 868=for apidoc rninstr
fcfc5a27
KW
869
870Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
871sequence of bytes within another sequence, returning C<NULL> if there is no
872such occurrence.
873
874=cut
875
876*/
a687059c
LW
877
878char *
5aaab254 879Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
a687059c 880{
2e8a5b76
KW
881 const Ptrdiff_t little_len = lend - little;
882 const Ptrdiff_t big_len = bigend - big;
a687059c 883
7918f24d
NC
884 PERL_ARGS_ASSERT_RNINSTR;
885
2e8a5b76
KW
886 /* A non-existent needle trivially matches the rightmost possible position
887 * in the haystack */
888 if (UNLIKELY(little_len <= 0)) {
08105a92 889 return (char*)bigend;
378cc40b 890 }
2e8a5b76 891
3aa316c2
KW
892 /* If the needle is larger than the haystack, the needle can't possibly fit
893 * inside the haystack. */
2e8a5b76
KW
894 if (UNLIKELY(little_len > big_len)) {
895 return NULL;
896 }
897
898 /* Special case length 1 needles. It's trivial if we have memrchr();
899 * and otherwise we just do a per-byte search backwards.
900 *
3aa316c2 901 * XXX When we don't have memrchr, we could use something like
2e8a5b76
KW
902 * S_find_next_masked( or S_find_span_end() to do per-word searches */
903 if (little_len == 1) {
904 const char final = *little;
905
906#ifdef HAS_MEMRCHR
907
908 return (char *) memrchr(big, final, big_len);
909#else
910 const char * cur = bigend - 1;
911
912 do {
913 if (*cur == final) {
914 return (char *) cur;
915 }
916 } while (--cur >= big);
917
918 return NULL;
919#endif
920
921 }
922 else { /* Below, the needle is longer than a single byte */
923
924 /* We search backwards in the haystack for the final character of the
925 * needle. Each time one is found, we see if the characters just
926 * before it in the haystack match the rest of the needle. */
927 const char final = *(lend - 1);
928
929 /* What matches consists of 'little_len'-1 characters, then the final
930 * one */
931 const Size_t prefix_len = little_len - 1;
932
933 /* If the final character in the needle is any closer than this to the
934 * left edge, there wouldn't be enough room for all of it to fit in the
935 * haystack */
936 const char * const left_fence = big + prefix_len;
937
938 /* Start at the right edge */
939 char * cur = (char *) bigend;
940
941 /* memrchr() makes the search easy (and fast); otherwise, look
942 * backwards byte-by-byte. */
943 do {
944
945#ifdef HAS_MEMRCHR
946
947 cur = (char *) memrchr(left_fence, final, cur - left_fence);
948 if (cur == NULL) {
949 return NULL;
950 }
951#else
952 do {
953 cur--;
954 if (cur < left_fence) {
955 return NULL;
956 }
957 }
958 while (*cur != final);
959#endif
960
961 /* Here, we know that *cur is 'final'; see if the preceding bytes
962 * of the needle also match the corresponding haystack bytes */
963 if memEQ(cur - prefix_len, little, prefix_len) {
964 return cur - prefix_len;
965 }
966 } while (cur > left_fence);
967
968 return NULL;
969 }
378cc40b 970}
a687059c 971
cf93c79d
IZ
972/* As a space optimization, we do not compile tables for strings of length
973 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
974 special-cased in fbm_instr().
975
976 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
977
954c1994 978/*
ccfc67b7 979
954c1994
GS
980=for apidoc fbm_compile
981
41715441 982Analyzes the string in order to make fast searches on it using C<fbm_instr()>
954c1994
GS
983-- the Boyer-Moore algorithm.
984
985=cut
986*/
987
378cc40b 988void
7506f9c3 989Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
378cc40b 990{
eb578fdb 991 const U8 *s;
ea725ce6 992 STRLEN i;
0b71040e 993 STRLEN len;
2bda37ba 994 MAGIC *mg;
79072805 995
7918f24d
NC
996 PERL_ARGS_ASSERT_FBM_COMPILE;
997
948d2370 998 if (isGV_with_GP(sv) || SvROK(sv))
4265b45d
NC
999 return;
1000
9402563a
NC
1001 if (SvVALID(sv))
1002 return;
1003
c517dc2b 1004 if (flags & FBMcf_TAIL) {
890ce7af 1005 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
396482e1 1006 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
c517dc2b
JH
1007 if (mg && mg->mg_len >= 0)
1008 mg->mg_len++;
1009 }
11609d9c 1010 if (!SvPOK(sv) || SvNIOKp(sv))
66379c06
FC
1011 s = (U8*)SvPV_force_mutable(sv, len);
1012 else s = (U8 *)SvPV_mutable(sv, len);
d1be9408 1013 if (len == 0) /* TAIL might be on a zero-length string. */
cf93c79d 1014 return;
c13a5c80 1015 SvUPGRADE(sv, SVt_PVMG);
78d0cf80 1016 SvIOK_off(sv);
8eeaf79a 1017 SvNOK_off(sv);
2bda37ba 1018
a5c7cb08 1019 /* add PERL_MAGIC_bm magic holding the FBM lookup table */
2bda37ba
NC
1020
1021 assert(!mg_find(sv, PERL_MAGIC_bm));
1022 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
1023 assert(mg);
1024
02128f11 1025 if (len > 2) {
21aeb718
NC
1026 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
1027 the BM table. */
66a1b24b 1028 const U8 mlen = (len>255) ? 255 : (U8)len;
2bda37ba 1029 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
eb578fdb 1030 U8 *table;
cf93c79d 1031
2bda37ba 1032 Newx(table, 256, U8);
7506f9c3 1033 memset((void*)table, mlen, 256);
2bda37ba
NC
1034 mg->mg_ptr = (char *)table;
1035 mg->mg_len = 256;
1036
1037 s += len - 1; /* last char */
02128f11 1038 i = 0;
cf93c79d
IZ
1039 while (s >= sb) {
1040 if (table[*s] == mlen)
7506f9c3 1041 table[*s] = (U8)i;
cf93c79d
IZ
1042 s--, i++;
1043 }
378cc40b 1044 }
378cc40b 1045
cf93c79d 1046 BmUSEFUL(sv) = 100; /* Initial value */
b4204fb6 1047 ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL);
378cc40b
LW
1048}
1049
cf93c79d 1050
954c1994
GS
1051/*
1052=for apidoc fbm_instr
1053
3f4963df 1054Returns the location of the SV in the string delimited by C<big> and
41c8d07a
DM
1055C<bigend> (C<bigend>) is the char following the last char).
1056It returns C<NULL> if the string can't be found. The C<sv>
796b6530 1057does not have to be C<fbm_compiled>, but the search will not be as fast
954c1994
GS
1058then.
1059
1060=cut
41c8d07a 1061
a3815e44 1062If SvTAIL(littlestr) is true, a fake "\n" was appended to the string
41c8d07a
DM
1063during FBM compilation due to FBMcf_TAIL in flags. It indicates that
1064the littlestr must be anchored to the end of bigstr (or to any \n if
1065FBMrf_MULTILINE).
1066
1067E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
1068while /abc$/ compiles to "abc\n" with SvTAIL() true.
1069
1070A littlestr of "abc", !SvTAIL matches as /abc/;
1071a littlestr of "ab\n", SvTAIL matches as:
1072 without FBMrf_MULTILINE: /ab\n?\z/
1073 with FBMrf_MULTILINE: /ab\n/ || /ab\z/;
1074
1075(According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
1076 "If SvTAIL is actually due to \Z or \z, this gives false positives
1077 if multiline".
954c1994
GS
1078*/
1079
41c8d07a 1080
378cc40b 1081char *
5aaab254 1082Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
378cc40b 1083{
eb578fdb 1084 unsigned char *s;
cf93c79d 1085 STRLEN l;
eb578fdb
KW
1086 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
1087 STRLEN littlelen = l;
1088 const I32 multiline = flags & FBMrf_MULTILINE;
4e8879f3
DM
1089 bool valid = SvVALID(littlestr);
1090 bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE;
cf93c79d 1091
7918f24d
NC
1092 PERL_ARGS_ASSERT_FBM_INSTR;
1093
bb152a4b
DM
1094 assert(bigend >= big);
1095
eb160463 1096 if ((STRLEN)(bigend - big) < littlelen) {
e08d24ff 1097 if ( tail
eb160463 1098 && ((STRLEN)(bigend - big) == littlelen - 1)
a1d180c4 1099 && (littlelen == 1
12ae5dfc 1100 || (*big == *little &&
27da23d5 1101 memEQ((char *)big, (char *)little, littlelen - 1))))
cf93c79d 1102 return (char*)big;
bd61b366 1103 return NULL;
cf93c79d 1104 }
378cc40b 1105
21aeb718
NC
1106 switch (littlelen) { /* Special cases for 0, 1 and 2 */
1107 case 0:
1108 return (char*)big; /* Cannot be SvTAIL! */
41c8d07a 1109
21aeb718 1110 case 1:
e08d24ff 1111 if (tail && !multiline) /* Anchor only! */
147f21b5
DM
1112 /* [-1] is safe because we know that bigend != big. */
1113 return (char *) (bigend - (bigend[-1] == '\n'));
1114
1115 s = (unsigned char *)memchr((void*)big, *little, bigend-big);
1116 if (s)
1117 return (char *)s;
e08d24ff 1118 if (tail)
cf93c79d 1119 return (char *) bigend;
bd61b366 1120 return NULL;
41c8d07a 1121
21aeb718 1122 case 2:
e08d24ff 1123 if (tail && !multiline) {
147f21b5
DM
1124 /* a littlestr with SvTAIL must be of the form "X\n" (where X
1125 * is a single char). It is anchored, and can only match
1126 * "....X\n" or "....X" */
1127 if (bigend[-2] == *little && bigend[-1] == '\n')
cf93c79d
IZ
1128 return (char*)bigend - 2;
1129 if (bigend[-1] == *little)
1130 return (char*)bigend - 1;
bd61b366 1131 return NULL;
cf93c79d 1132 }
147f21b5 1133
cf93c79d 1134 {
147f21b5
DM
1135 /* memchr() is likely to be very fast, possibly using whatever
1136 * hardware support is available, such as checking a whole
1137 * cache line in one instruction.
1138 * So for a 2 char pattern, calling memchr() is likely to be
1139 * faster than running FBM, or rolling our own. The previous
1140 * version of this code was roll-your-own which typically
1141 * only needed to read every 2nd char, which was good back in
1142 * the day, but no longer.
1143 */
1144 unsigned char c1 = little[0];
1145 unsigned char c2 = little[1];
1146
1147 /* *** for all this case, bigend points to the last char,
1148 * not the trailing \0: this makes the conditions slightly
1149 * simpler */
1150 bigend--;
1151 s = big;
1152 if (c1 != c2) {
1153 while (s < bigend) {
1154 /* do a quick test for c1 before calling memchr();
1155 * this avoids the expensive fn call overhead when
1156 * there are lots of c1's */
1157 if (LIKELY(*s != c1)) {
1158 s++;
1159 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
1160 if (!s)
1161 break;
1162 }
1163 if (s[1] == c2)
1164 return (char*)s;
1165
1166 /* failed; try searching for c2 this time; that way
1167 * we don't go pathologically slow when the string
1168 * consists mostly of c1's or vice versa.
1169 */
1170 s += 2;
1171 if (s > bigend)
1172 break;
1173 s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
1174 if (!s)
1175 break;
1176 if (s[-1] == c1)
1177 return (char*)s - 1;
1178 }
1179 }
1180 else {
1181 /* c1, c2 the same */
1182 while (s < bigend) {
1183 if (s[0] == c1) {
1184 got_1char:
1185 if (s[1] == c1)
1186 return (char*)s;
1187 s += 2;
1188 }
1189 else {
1190 s++;
1191 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
1192 if (!s || s >= bigend)
1193 break;
1194 goto got_1char;
1195 }
1196 }
1197 }
1198
1199 /* failed to find 2 chars; try anchored match at end without
1200 * the \n */
e08d24ff 1201 if (tail && bigend[0] == little[0])
147f21b5
DM
1202 return (char *)bigend;
1203 return NULL;
1204 }
41c8d07a 1205
21aeb718
NC
1206 default:
1207 break; /* Only lengths 0 1 and 2 have special-case code. */
d48672a2 1208 }
21aeb718 1209
e08d24ff 1210 if (tail && !multiline) { /* tail anchored? */
bbce6d69 1211 s = bigend - littlelen;
a1d180c4 1212 if (s >= big && bigend[-1] == '\n' && *s == *little
cf93c79d
IZ
1213 /* Automatically of length > 2 */
1214 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
7506f9c3 1215 {
bbce6d69 1216 return (char*)s; /* how sweet it is */
7506f9c3
GS
1217 }
1218 if (s[1] == *little
1219 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
1220 {
cf93c79d 1221 return (char*)s + 1; /* how sweet it is */
7506f9c3 1222 }
bd61b366 1223 return NULL;
02128f11 1224 }
41c8d07a 1225
4e8879f3 1226 if (!valid) {
147f21b5 1227 /* not compiled; use Perl_ninstr() instead */
c4420975 1228 char * const b = ninstr((char*)big,(char*)bigend,
cf93c79d
IZ
1229 (char*)little, (char*)little + littlelen);
1230
add424da 1231 assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
cf93c79d 1232 return b;
a687059c 1233 }
a1d180c4 1234
3566a07d
NC
1235 /* Do actual FBM. */
1236 if (littlelen > (STRLEN)(bigend - big))
1237 return NULL;
1238
1239 {
2bda37ba 1240 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
eb578fdb 1241 const unsigned char *oldlittle;
cf93c79d 1242
316ebaf2
JH
1243 assert(mg);
1244
cf93c79d
IZ
1245 --littlelen; /* Last char found by table lookup */
1246
1247 s = big + littlelen;
1248 little += littlelen; /* last char */
1249 oldlittle = little;
1250 if (s < bigend) {
316ebaf2 1251 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
147f21b5 1252 const unsigned char lastc = *little;
eb578fdb 1253 I32 tmp;
cf93c79d
IZ
1254
1255 top2:
7506f9c3 1256 if ((tmp = table[*s])) {
147f21b5
DM
1257 /* *s != lastc; earliest position it could match now is
1258 * tmp slots further on */
1259 if ((s += tmp) >= bigend)
1260 goto check_end;
1261 if (LIKELY(*s != lastc)) {
1262 s++;
1263 s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
1264 if (!s) {
1265 s = bigend;
1266 goto check_end;
1267 }
1268 goto top2;
1269 }
cf93c79d 1270 }
147f21b5
DM
1271
1272
1273 /* hand-rolled strncmp(): less expensive than calling the
1274 * real function (maybe???) */
1275 {
eb578fdb 1276 unsigned char * const olds = s;
cf93c79d
IZ
1277
1278 tmp = littlelen;
1279
1280 while (tmp--) {
1281 if (*--s == *--little)
1282 continue;
cf93c79d
IZ
1283 s = olds + 1; /* here we pay the price for failure */
1284 little = oldlittle;
1285 if (s < bigend) /* fake up continue to outer loop */
1286 goto top2;
1287 goto check_end;
1288 }
1289 return (char *)s;
a687059c 1290 }
378cc40b 1291 }
cf93c79d 1292 check_end:
c8029a41 1293 if ( s == bigend
e08d24ff 1294 && tail
12ae5dfc
JH
1295 && memEQ((char *)(bigend - littlelen),
1296 (char *)(oldlittle - littlelen), littlelen) )
cf93c79d 1297 return (char*)bigend - littlelen;
bd61b366 1298 return NULL;
378cc40b 1299 }
378cc40b
LW
1300}
1301
5e6ebb12
KW
1302const char *
1303Perl_cntrl_to_mnemonic(const U8 c)
1304{
1305 /* Returns the mnemonic string that represents character 'c', if one
1306 * exists; NULL otherwise. The only ones that exist for the purposes of
1307 * this routine are a few control characters */
1308
1309 switch (c) {
1310 case '\a': return "\\a";
1311 case '\b': return "\\b";
1312 case ESC_NATIVE: return "\\e";
1313 case '\f': return "\\f";
1314 case '\n': return "\\n";
1315 case '\r': return "\\r";
1316 case '\t': return "\\t";
1317 }
1318
1319 return NULL;
1320}
1321
8d063cd8
LW
1322/* copy a string to a safe spot */
1323
954c1994 1324/*
3f620621 1325=for apidoc_section $string
954c1994
GS
1326=for apidoc savepv
1327
72d33970
FC
1328Perl's version of C<strdup()>. Returns a pointer to a newly allocated
1329string which is a duplicate of C<pv>. The size of the string is
30a15352 1330determined by C<strlen()>, which means it may not contain embedded C<NUL>
3e66cf74
KW
1331characters and must have a trailing C<NUL>. To prevent memory leaks, the
1332memory allocated for the new string needs to be freed when no longer needed.
3d12c238 1333This can be done with the C<L</Safefree>> function, or
2f07b2fb 1334L<C<SAVEFREEPV>|perlguts/SAVEFREEPV(p)>.
954c1994 1335
0358c255
KW
1336On some platforms, Windows for example, all allocated memory owned by a thread
1337is deallocated when that thread ends. So if you need that not to happen, you
1338need to use the shared memory functions, such as C<L</savesharedpv>>.
1339
954c1994
GS
1340=cut
1341*/
1342
8d063cd8 1343char *
efdfce31 1344Perl_savepv(pTHX_ const char *pv)
8d063cd8 1345{
96a5add6 1346 PERL_UNUSED_CONTEXT;
e90e2364 1347 if (!pv)
bd61b366 1348 return NULL;
66a1b24b
AL
1349 else {
1350 char *newaddr;
1351 const STRLEN pvlen = strlen(pv)+1;
10edeb5d
JH
1352 Newx(newaddr, pvlen, char);
1353 return (char*)memcpy(newaddr, pv, pvlen);
66a1b24b 1354 }
8d063cd8
LW
1355}
1356
a687059c
LW
1357/* same thing but with a known length */
1358
954c1994
GS
1359/*
1360=for apidoc savepvn
1361
72d33970 1362Perl's version of what C<strndup()> would be if it existed. Returns a
61a925ed 1363pointer to a newly allocated string which is a duplicate of the first
72d33970 1364C<len> bytes from C<pv>, plus a trailing
6602b933 1365C<NUL> byte. The memory allocated for
cbf82dd0 1366the new string can be freed with the C<Safefree()> function.
954c1994 1367
0358c255
KW
1368On some platforms, Windows for example, all allocated memory owned by a thread
1369is deallocated when that thread ends. So if you need that not to happen, you
1370need to use the shared memory functions, such as C<L</savesharedpvn>>.
1371
954c1994
GS
1372=cut
1373*/
1374
a687059c 1375char *
052d9143 1376Perl_savepvn(pTHX_ const char *pv, Size_t len)
a687059c 1377{
eb578fdb 1378 char *newaddr;
96a5add6 1379 PERL_UNUSED_CONTEXT;
a687059c 1380
a02a5408 1381 Newx(newaddr,len+1,char);
92110913 1382 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
efdfce31 1383 if (pv) {
e90e2364
NC
1384 /* might not be null terminated */
1385 newaddr[len] = '\0';
07409e01 1386 return (char *) CopyD(pv,newaddr,len,char);
92110913
NIS
1387 }
1388 else {
07409e01 1389 return (char *) ZeroD(newaddr,len+1,char);
92110913 1390 }
a687059c
LW
1391}
1392
05ec9bb3
NIS
1393/*
1394=for apidoc savesharedpv
1395
61a925ed
AMS
1396A version of C<savepv()> which allocates the duplicate string in memory
1397which is shared between threads.
05ec9bb3
NIS
1398
1399=cut
1400*/
1401char *
efdfce31 1402Perl_savesharedpv(pTHX_ const char *pv)
05ec9bb3 1403{
eb578fdb 1404 char *newaddr;
490a0e98 1405 STRLEN pvlen;
dc3bf405
BF
1406
1407 PERL_UNUSED_CONTEXT;
1408
e90e2364 1409 if (!pv)
bd61b366 1410 return NULL;
e90e2364 1411
490a0e98
NC
1412 pvlen = strlen(pv)+1;
1413 newaddr = (char*)PerlMemShared_malloc(pvlen);
e90e2364 1414 if (!newaddr) {
4cbe3a7d 1415 croak_no_mem();
05ec9bb3 1416 }
10edeb5d 1417 return (char*)memcpy(newaddr, pv, pvlen);
05ec9bb3
NIS
1418}
1419
2e0de35c 1420/*
d9095cec
NC
1421=for apidoc savesharedpvn
1422
1423A version of C<savepvn()> which allocates the duplicate string in memory
796b6530 1424which is shared between threads. (With the specific difference that a C<NULL>
d9095cec
NC
1425pointer is not acceptable)
1426
1427=cut
1428*/
1429char *
1430Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1431{
1432 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
7918f24d 1433
dc3bf405 1434 PERL_UNUSED_CONTEXT;
6379d4a9 1435 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
7918f24d 1436
d9095cec 1437 if (!newaddr) {
4cbe3a7d 1438 croak_no_mem();
d9095cec
NC
1439 }
1440 newaddr[len] = '\0';
1441 return (char*)memcpy(newaddr, pv, len);
1442}
1443
1444/*
2e0de35c
NC
1445=for apidoc savesvpv
1446
6832267f 1447A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
2e0de35c
NC
1448the passed in SV using C<SvPV()>
1449
0358c255
KW
1450On some platforms, Windows for example, all allocated memory owned by a thread
1451is deallocated when that thread ends. So if you need that not to happen, you
1452need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1453
2e0de35c
NC
1454=cut
1455*/
1456
1457char *
1458Perl_savesvpv(pTHX_ SV *sv)
1459{
1460 STRLEN len;
7452cf6a 1461 const char * const pv = SvPV_const(sv, len);
eb578fdb 1462 char *newaddr;
2e0de35c 1463
7918f24d
NC
1464 PERL_ARGS_ASSERT_SAVESVPV;
1465
26866f99 1466 ++len;
a02a5408 1467 Newx(newaddr,len,char);
07409e01 1468 return (char *) CopyD(pv,newaddr,len,char);
2e0de35c 1469}
05ec9bb3 1470
9dcc53ea
Z
1471/*
1472=for apidoc savesharedsvpv
1473
1474A version of C<savesharedpv()> which allocates the duplicate string in
1475memory which is shared between threads.
1476
1477=cut
1478*/
1479
1480char *
1481Perl_savesharedsvpv(pTHX_ SV *sv)
1482{
1483 STRLEN len;
1484 const char * const pv = SvPV_const(sv, len);
1485
1486 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1487
1488 return savesharedpvn(pv, len);
1489}
05ec9bb3 1490
cea2e8a9 1491/* the SV for Perl_form() and mess() is not kept in an arena */
fc36a67e 1492
76e3520e 1493STATIC SV *
cea2e8a9 1494S_mess_alloc(pTHX)
fc36a67e
PP
1495{
1496 SV *sv;
1497 XPVMG *any;
1498
627364f1 1499 if (PL_phase != PERL_PHASE_DESTRUCT)
84bafc02 1500 return newSVpvs_flags("", SVs_TEMP);
e72dc28c 1501
0372dbb6
GS
1502 if (PL_mess_sv)
1503 return PL_mess_sv;
1504
fc36a67e 1505 /* Create as PVMG now, to avoid any upgrading later */
a02a5408
JC
1506 Newx(sv, 1, SV);
1507 Newxz(any, 1, XPVMG);
fc36a67e
PP
1508 SvFLAGS(sv) = SVt_PVMG;
1509 SvANY(sv) = (void*)any;
6136c704 1510 SvPV_set(sv, NULL);
fc36a67e 1511 SvREFCNT(sv) = 1 << 30; /* practically infinite */
e72dc28c 1512 PL_mess_sv = sv;
fc36a67e
PP
1513 return sv;
1514}
1515
c5be433b 1516#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1517char *
1518Perl_form_nocontext(const char* pat, ...)
1519{
1520 dTHX;
c5be433b 1521 char *retval;
cea2e8a9 1522 va_list args;
7918f24d 1523 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
cea2e8a9 1524 va_start(args, pat);
c5be433b 1525 retval = vform(pat, &args);
cea2e8a9 1526 va_end(args);
c5be433b 1527 return retval;
cea2e8a9 1528}
c5be433b 1529#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1530
7c9e965c 1531/*
d1b9805e 1532=for apidoc_section $display
7c9e965c 1533=for apidoc form
8de16cf6 1534=for apidoc_item form_nocontext
7c9e965c 1535
8de16cf6
KW
1536These take a sprintf-style format pattern and conventional
1537(non-SV) arguments and return the formatted string.
7c9e965c
JP
1538
1539 (char *) Perl_form(pTHX_ const char* pat, ...)
1540
1541can be used any place a string (char *) is required:
1542
1543 char * s = Perl_form("%d.%d",major,minor);
1544
8de16cf6 1545They use a single private buffer so if you want to format several strings you
7c9e965c
JP
1546must explicitly copy the earlier strings away (and free the copies when you
1547are done).
1548
8de16cf6
KW
1549The two forms differ only in that C<form_nocontext> does not take a thread
1550context (C<aTHX>) parameter, so is used in situations where the caller doesn't
1551already have the thread context.
3d12c238 1552
2385767d
KW
1553=for apidoc vform
1554Like C<L</form>> but but the arguments are an encapsulated argument list.
1555
7c9e965c
JP
1556=cut
1557*/
1558
8990e307 1559char *
864dbfa3 1560Perl_form(pTHX_ const char* pat, ...)
8990e307 1561{
c5be433b 1562 char *retval;
46fc3d4c 1563 va_list args;
7918f24d 1564 PERL_ARGS_ASSERT_FORM;
46fc3d4c 1565 va_start(args, pat);
c5be433b 1566 retval = vform(pat, &args);
46fc3d4c 1567 va_end(args);
c5be433b
GS
1568 return retval;
1569}
1570
1571char *
1572Perl_vform(pTHX_ const char *pat, va_list *args)
1573{
2d03de9c 1574 SV * const sv = mess_alloc();
7918f24d 1575 PERL_ARGS_ASSERT_VFORM;
4608196e 1576 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
e72dc28c 1577 return SvPVX(sv);
46fc3d4c 1578}
a687059c 1579
c5df3096 1580/*
44170c9a 1581=for apidoc mess
8de16cf6 1582=for apidoc_item mess_nocontext
c5df3096 1583
8de16cf6
KW
1584These take a sprintf-style format pattern and argument list, which are used to
1585generate a string message. If the message does not end with a newline, then it
1586will be extended with some indication of the current location in the code, as
1587described for C<L</mess_sv>>.
c5df3096
Z
1588
1589Normally, the resulting message is returned in a new mortal SV.
8de16cf6 1590But during global destruction a single SV may be shared between uses of
c5df3096
Z
1591this function.
1592
8de16cf6
KW
1593The two forms differ only in that C<mess_nocontext> does not take a thread
1594context (C<aTHX>) parameter, so is used in situations where the caller doesn't
1595already have the thread context.
3d12c238 1596
c5df3096
Z
1597=cut
1598*/
1599
5a844595
GS
1600#if defined(PERL_IMPLICIT_CONTEXT)
1601SV *
1602Perl_mess_nocontext(const char *pat, ...)
1603{
1604 dTHX;
1605 SV *retval;
1606 va_list args;
7918f24d 1607 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
5a844595
GS
1608 va_start(args, pat);
1609 retval = vmess(pat, &args);
1610 va_end(args);
1611 return retval;
1612}
1613#endif /* PERL_IMPLICIT_CONTEXT */
1614
06bf62c7 1615SV *
5a844595
GS
1616Perl_mess(pTHX_ const char *pat, ...)
1617{
1618 SV *retval;
1619 va_list args;
7918f24d 1620 PERL_ARGS_ASSERT_MESS;
5a844595
GS
1621 va_start(args, pat);
1622 retval = vmess(pat, &args);
1623 va_end(args);
1624 return retval;
1625}
1626
25502127
FC
1627const COP*
1628Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1629 bool opnext)
ae7d165c 1630{
25502127
FC
1631 /* Look for curop starting from o. cop is the last COP we've seen. */
1632 /* opnext means that curop is actually the ->op_next of the op we are
1633 seeking. */
ae7d165c 1634
7918f24d
NC
1635 PERL_ARGS_ASSERT_CLOSEST_COP;
1636
25502127
FC
1637 if (!o || !curop || (
1638 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1639 ))
fabdb6c0 1640 return cop;
ae7d165c
PJ
1641
1642 if (o->op_flags & OPf_KIDS) {
5f66b61c 1643 const OP *kid;
e6dae479 1644 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
5f66b61c 1645 const COP *new_cop;
ae7d165c
PJ
1646
1647 /* If the OP_NEXTSTATE has been optimised away we can still use it
1648 * the get the file and line number. */
1649
1650 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
5f66b61c 1651 cop = (const COP *)kid;
ae7d165c
PJ
1652
1653 /* Keep searching, and return when we've found something. */
1654
25502127 1655 new_cop = closest_cop(cop, kid, curop, opnext);
fabdb6c0
AL
1656 if (new_cop)
1657 return new_cop;
ae7d165c
PJ
1658 }
1659 }
1660
1661 /* Nothing found. */
1662
5f66b61c 1663 return NULL;
ae7d165c
PJ
1664}
1665
c5df3096 1666/*
44170c9a 1667=for apidoc mess_sv
c5df3096
Z
1668
1669Expands a message, intended for the user, to include an indication of
1670the current location in the code, if the message does not already appear
1671to be complete.
1672
1673C<basemsg> is the initial message or object. If it is a reference, it
1674will be used as-is and will be the result of this function. Otherwise it
1675is used as a string, and if it already ends with a newline, it is taken
1676to be complete, and the result of this function will be the same string.
1677If the message does not end with a newline, then a segment such as C<at
1678foo.pl line 37> will be appended, and possibly other clauses indicating
1679the current state of execution. The resulting message will end with a
1680dot and a newline.
1681
1682Normally, the resulting message is returned in a new mortal SV.
1683During global destruction a single SV may be shared between uses of this
1684function. If C<consume> is true, then the function is permitted (but not
1685required) to modify and return C<basemsg> instead of allocating a new SV.
1686
1687=cut
1688*/
1689
5a844595 1690SV *
c5df3096 1691Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
46fc3d4c 1692{
c5df3096 1693 SV *sv;
46fc3d4c 1694
0762e42f 1695#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
470dd224
JH
1696 {
1697 char *ws;
22ff3130 1698 UV wi;
470dd224 1699 /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
22ff3130
HS
1700 if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
1701 && grok_atoUV(ws, &wi, NULL)
1702 && wi <= PERL_INT_MAX
1703 ) {
1704 Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
470dd224
JH
1705 }
1706 }
1707#endif
1708
c5df3096
Z
1709 PERL_ARGS_ASSERT_MESS_SV;
1710
1711 if (SvROK(basemsg)) {
1712 if (consume) {
1713 sv = basemsg;
1714 }
1715 else {
1716 sv = mess_alloc();
1717 sv_setsv(sv, basemsg);
1718 }
1719 return sv;
1720 }
1721
1722 if (SvPOK(basemsg) && consume) {
1723 sv = basemsg;
1724 }
1725 else {
1726 sv = mess_alloc();
1727 sv_copypv(sv, basemsg);
1728 }
7918f24d 1729
46fc3d4c 1730 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
ae7d165c
PJ
1731 /*
1732 * Try and find the file and line for PL_op. This will usually be
1733 * PL_curcop, but it might be a cop that has been optimised away. We
1734 * can try to find such a cop by searching through the optree starting
1735 * from the sibling of PL_curcop.
1736 */
1737
f4c61774
DM
1738 if (PL_curcop) {
1739 const COP *cop =
1740 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
1741 if (!cop)
1742 cop = PL_curcop;
1743
1744 if (CopLINE(cop))
1745 Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
1746 OutCopFILE(cop), (IV)CopLINE(cop));
1747 }
1748
191f87d5
DH
1749 /* Seems that GvIO() can be untrustworthy during global destruction. */
1750 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1751 && IoLINES(GvIOp(PL_last_in_gv)))
1752 {
2748e602 1753 STRLEN l;
e1ec3a88 1754 const bool line_mode = (RsSIMPLE(PL_rs) &&
2748e602 1755 *SvPV_const(PL_rs,l) == '\n' && l == 1);
147e3846 1756 Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,
3b46b707
BF
1757 SVfARG(PL_last_in_gv == PL_argvgv
1758 ? &PL_sv_no
1759 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
edc2eac3
JH
1760 line_mode ? "line" : "chunk",
1761 (IV)IoLINES(GvIOp(PL_last_in_gv)));
a687059c 1762 }
627364f1 1763 if (PL_phase == PERL_PHASE_DESTRUCT)
5f66b61c
AL
1764 sv_catpvs(sv, " during global destruction");
1765 sv_catpvs(sv, ".\n");
a687059c 1766 }
06bf62c7 1767 return sv;
a687059c
LW
1768}
1769
c5df3096 1770/*
44170c9a 1771=for apidoc vmess
c5df3096
Z
1772
1773C<pat> and C<args> are a sprintf-style format pattern and encapsulated
801caa78
KW
1774argument list, respectively. These are used to generate a string message. If
1775the
c5df3096
Z
1776message does not end with a newline, then it will be extended with
1777some indication of the current location in the code, as described for
1778L</mess_sv>.
1779
1780Normally, the resulting message is returned in a new mortal SV.
1781During global destruction a single SV may be shared between uses of
1782this function.
1783
1784=cut
1785*/
1786
1787SV *
1788Perl_vmess(pTHX_ const char *pat, va_list *args)
1789{
c5df3096
Z
1790 SV * const sv = mess_alloc();
1791
1792 PERL_ARGS_ASSERT_VMESS;
1793
1794 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1795 return mess_sv(sv, 1);
1796}
1797
7ff03255 1798void
7d0994e0 1799Perl_write_to_stderr(pTHX_ SV* msv)
7ff03255
SG
1800{
1801 IO *io;
1802 MAGIC *mg;
1803
7918f24d
NC
1804 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1805
7ff03255
SG
1806 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1807 && (io = GvIO(PL_stderrgv))
daba3364 1808 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
36925d9e 1809 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
d1d7a15d 1810 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
7ff03255 1811 else {
53c1dcc0 1812 PerlIO * const serr = Perl_error_log;
7ff03255 1813
83c55556 1814 do_print(msv, serr);
7ff03255 1815 (void)PerlIO_flush(serr);
7ff03255
SG
1816 }
1817}
1818
c5df3096 1819/*
3f620621 1820=for apidoc_section $warning
c5df3096
Z
1821*/
1822
1823/* Common code used in dieing and warning */
1824
1825STATIC SV *
1826S_with_queued_errors(pTHX_ SV *ex)
1827{
1828 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1829 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1830 sv_catsv(PL_errors, ex);
1831 ex = sv_mortalcopy(PL_errors);
1832 SvCUR_set(PL_errors, 0);
1833 }
1834 return ex;
1835}
3ab1ac99 1836
46d9c920 1837STATIC bool
c5df3096 1838S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
63315e18
NC
1839{
1840 HV *stash;
1841 GV *gv;
1842 CV *cv;
46d9c920
NC
1843 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1844 /* sv_2cv might call Perl_croak() or Perl_warner() */
1845 SV * const oldhook = *hook;
1846
2460a496 1847 if (!oldhook || oldhook == PERL_WARNHOOK_FATAL)
c5df3096 1848 return FALSE;
63315e18 1849
63315e18 1850 ENTER;
46d9c920
NC
1851 SAVESPTR(*hook);
1852 *hook = NULL;
1853 cv = sv_2cv(oldhook, &stash, &gv, 0);
63315e18
NC
1854 LEAVE;
1855 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1856 dSP;
c5df3096 1857 SV *exarg;
63315e18
NC
1858
1859 ENTER;
2782061f 1860 save_re_context();
46d9c920
NC
1861 if (warn) {
1862 SAVESPTR(*hook);
1863 *hook = NULL;
1864 }
c5df3096
Z
1865 exarg = newSVsv(ex);
1866 SvREADONLY_on(exarg);
1867 SAVEFREESV(exarg);
63315e18 1868
46d9c920 1869 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
63315e18 1870 PUSHMARK(SP);
c5df3096 1871 XPUSHs(exarg);
63315e18 1872 PUTBACK;
daba3364 1873 call_sv(MUTABLE_SV(cv), G_DISCARD);
63315e18
NC
1874 POPSTACK;
1875 LEAVE;
46d9c920 1876 return TRUE;
63315e18 1877 }
46d9c920 1878 return FALSE;
63315e18
NC
1879}
1880
c5df3096 1881/*
44170c9a 1882=for apidoc die_sv
8de16cf6 1883=for apidoc_item die_nocontext
e07360fa 1884
8de16cf6 1885These ehave the same as L</croak_sv>, except for the return type.
c5df3096 1886It should be used only where the C<OP *> return type is required.
8de16cf6 1887The functions never actually return.
e07360fa 1888
8de16cf6
KW
1889The two forms differ only in that C<die_nocontext> does not take a thread
1890context (C<aTHX>) parameter, so is used in situations where the caller doesn't
1891already have the thread context.
3d12c238 1892
c5df3096
Z
1893=cut
1894*/
e07360fa 1895
6879a07b
TK
1896/* silence __declspec(noreturn) warnings */
1897MSVC_DIAG_IGNORE(4646 4645)
c5df3096
Z
1898OP *
1899Perl_die_sv(pTHX_ SV *baseex)
36477c24 1900{
c5df3096
Z
1901 PERL_ARGS_ASSERT_DIE_SV;
1902 croak_sv(baseex);
e5964223 1903 /* NOTREACHED */
117af67d 1904 NORETURN_FUNCTION_END;
36477c24 1905}
6879a07b 1906MSVC_DIAG_RESTORE
36477c24 1907
c5df3096 1908/*
44170c9a 1909=for apidoc die
c5df3096
Z
1910
1911Behaves the same as L</croak>, except for the return type.
1912It should be used only where the C<OP *> return type is required.
1913The function never actually returns.
1914
1915=cut
1916*/
1917
c5be433b 1918#if defined(PERL_IMPLICIT_CONTEXT)
6879a07b
TK
1919
1920/* silence __declspec(noreturn) warnings */
1921MSVC_DIAG_IGNORE(4646 4645)
cea2e8a9
GS
1922OP *
1923Perl_die_nocontext(const char* pat, ...)
a687059c 1924{
cea2e8a9 1925 dTHX;
a687059c 1926 va_list args;
cea2e8a9 1927 va_start(args, pat);
c5df3096 1928 vcroak(pat, &args);
e5964223 1929 NOT_REACHED; /* NOTREACHED */
cea2e8a9 1930 va_end(args);
117af67d 1931 NORETURN_FUNCTION_END;
cea2e8a9 1932}
6879a07b
TK
1933MSVC_DIAG_RESTORE
1934
c5be433b 1935#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1936
6879a07b
TK
1937/* silence __declspec(noreturn) warnings */
1938MSVC_DIAG_IGNORE(4646 4645)
cea2e8a9
GS
1939OP *
1940Perl_die(pTHX_ const char* pat, ...)
1941{
cea2e8a9
GS
1942 va_list args;
1943 va_start(args, pat);
c5df3096 1944 vcroak(pat, &args);
e5964223 1945 NOT_REACHED; /* NOTREACHED */
cea2e8a9 1946 va_end(args);
117af67d 1947 NORETURN_FUNCTION_END;
cea2e8a9 1948}
6879a07b 1949MSVC_DIAG_RESTORE
cea2e8a9 1950
c5df3096 1951/*
44170c9a 1952=for apidoc croak_sv
c5df3096
Z
1953
1954This is an XS interface to Perl's C<die> function.
1955
1956C<baseex> is the error message or object. If it is a reference, it
1957will be used as-is. Otherwise it is used as a string, and if it does
1958not end with a newline then it will be extended with some indication of
1959the current location in the code, as described for L</mess_sv>.
1960
1961The error message or object will be used as an exception, by default
1962returning control to the nearest enclosing C<eval>, but subject to
1963modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1964function never returns normally.
1965
1966To die with a simple string message, the L</croak> function may be
1967more convenient.
1968
1969=cut
1970*/
1971
c5be433b 1972void
c5df3096 1973Perl_croak_sv(pTHX_ SV *baseex)
cea2e8a9 1974{
c5df3096
Z
1975 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1976 PERL_ARGS_ASSERT_CROAK_SV;
1977 invoke_exception_hook(ex, FALSE);
1978 die_unwind(ex);
1979}
1980
1981/*
44170c9a 1982=for apidoc vcroak
c5df3096
Z
1983
1984This is an XS interface to Perl's C<die> function.
1985
1986C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1987argument list. These are used to generate a string message. If the
1988message does not end with a newline, then it will be extended with
1989some indication of the current location in the code, as described for
1990L</mess_sv>.
1991
1992The error message will be used as an exception, by default
1993returning control to the nearest enclosing C<eval>, but subject to
1994modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1995function never returns normally.
a687059c 1996
c5df3096
Z
1997For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1998(C<$@>) will be used as an error message or object instead of building an
1999error message from arguments. If you want to throw a non-string object,
2000or build an error message in an SV yourself, it is preferable to use
2001the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
5a844595 2002
c5df3096
Z
2003=cut
2004*/
2005
2006void
2007Perl_vcroak(pTHX_ const char* pat, va_list *args)
2008{
2009 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
2010 invoke_exception_hook(ex, FALSE);
2011 die_unwind(ex);
a687059c
LW
2012}
2013
c5df3096 2014/*
44170c9a 2015=for apidoc croak
8de16cf6 2016=for apidoc_item croak_nocontext
c5df3096 2017
8de16cf6 2018These are XS interfaces to Perl's C<die> function.
c5df3096 2019
8de16cf6
KW
2020They take a sprintf-style format pattern and argument list, which are used to
2021generate a string message. If the message does not end with a newline, then it
2022will be extended with some indication of the current location in the code, as
2023described for C<L</mess_sv>>.
c5df3096
Z
2024
2025The error message will be used as an exception, by default
2026returning control to the nearest enclosing C<eval>, but subject to
8de16cf6
KW
2027modification by a C<$SIG{__DIE__}> handler. In any case, these croak
2028functions never return normally.
c5df3096
Z
2029
2030For historical reasons, if C<pat> is null then the contents of C<ERRSV>
2031(C<$@>) will be used as an error message or object instead of building an
2032error message from arguments. If you want to throw a non-string object,
2033or build an error message in an SV yourself, it is preferable to use
8de16cf6
KW
2034the C<L</croak_sv>> function, which does not involve clobbering C<ERRSV>.
2035
2036The two forms differ only in that C<croak_nocontext> does not take a thread
4559f7e6
KW
2037context (C<aTHX>) parameter. It is usually preferred as it takes up fewer
2038bytes of code than plain C<Perl_croak>, and time is rarely a critical resource
2039when you are about to throw an exception.
c5df3096
Z
2040
2041=cut
2042*/
2043
c5be433b 2044#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 2045void
cea2e8a9 2046Perl_croak_nocontext(const char *pat, ...)
a687059c 2047{
cea2e8a9 2048 dTHX;
a687059c 2049 va_list args;
cea2e8a9 2050 va_start(args, pat);
c5be433b 2051 vcroak(pat, &args);
e5964223 2052 NOT_REACHED; /* NOTREACHED */
cea2e8a9
GS
2053 va_end(args);
2054}
2055#endif /* PERL_IMPLICIT_CONTEXT */
2056
d68c938a
KW
2057/* saves machine code for a common noreturn idiom typically used in Newx*() */
2058GCC_DIAG_IGNORE_DECL(-Wunused-function);
2059void
2060Perl_croak_memory_wrap(void)
2061{
2062 Perl_croak_nocontext("%s",PL_memory_wrap);
2063}
2064GCC_DIAG_RESTORE_DECL;
2065
c5df3096
Z
2066void
2067Perl_croak(pTHX_ const char *pat, ...)
2068{
2069 va_list args;
2070 va_start(args, pat);
2071 vcroak(pat, &args);
e5964223 2072 NOT_REACHED; /* NOTREACHED */
c5df3096
Z
2073 va_end(args);
2074}
2075
954c1994 2076/*
44170c9a 2077=for apidoc croak_no_modify
6ad8f254 2078
4f7dafea
KW
2079This encapsulates a common reason for dying, generating terser object code than
2080using the generic C<Perl_croak>. It is exactly equivalent to
2081C<Perl_croak(aTHX_ "%s", PL_no_modify)> (which expands to something like
2082"Modification of a read-only value attempted").
2083
2084Less code used on exception code paths reduces CPU cache pressure.
6ad8f254 2085
d8e47b5c 2086=cut
6ad8f254
NC
2087*/
2088
2089void
88772978 2090Perl_croak_no_modify(void)
6ad8f254 2091{
cb077ed2 2092 Perl_croak_nocontext( "%s", PL_no_modify);
6ad8f254
NC
2093}
2094
4cbe3a7d
DD
2095/* does not return, used in util.c perlio.c and win32.c
2096 This is typically called when malloc returns NULL.
2097*/
2098void
88772978 2099Perl_croak_no_mem(void)
4cbe3a7d
DD
2100{
2101 dTHX;
77c1c05b 2102
375ed12a
JH
2103 int fd = PerlIO_fileno(Perl_error_log);
2104 if (fd < 0)
2105 SETERRNO(EBADF,RMS_IFI);
2106 else {
2107 /* Can't use PerlIO to write as it allocates memory */
b469f1e0 2108 PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
375ed12a 2109 }
4cbe3a7d
DD
2110 my_exit(1);
2111}
2112
3d04513d
DD
2113/* does not return, used only in POPSTACK */
2114void
2115Perl_croak_popstack(void)
2116{
2117 dTHX;
2118 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
2119 my_exit(1);
2120}
2121
6ad8f254 2122/*
44170c9a 2123=for apidoc warn_sv
ccfc67b7 2124
c5df3096 2125This is an XS interface to Perl's C<warn> function.
954c1994 2126
c5df3096
Z
2127C<baseex> is the error message or object. If it is a reference, it
2128will be used as-is. Otherwise it is used as a string, and if it does
2129not end with a newline then it will be extended with some indication of
2130the current location in the code, as described for L</mess_sv>.
9983fa3c 2131
c5df3096
Z
2132The error message or object will by default be written to standard error,
2133but this is subject to modification by a C<$SIG{__WARN__}> handler.
9983fa3c 2134
c5df3096
Z
2135To warn with a simple string message, the L</warn> function may be
2136more convenient.
954c1994
GS
2137
2138=cut
2139*/
2140
cea2e8a9 2141void
c5df3096 2142Perl_warn_sv(pTHX_ SV *baseex)
cea2e8a9 2143{
c5df3096
Z
2144 SV *ex = mess_sv(baseex, 0);
2145 PERL_ARGS_ASSERT_WARN_SV;
2146 if (!invoke_exception_hook(ex, TRUE))
2147 write_to_stderr(ex);
cea2e8a9
GS
2148}
2149
c5df3096 2150/*
44170c9a 2151=for apidoc vwarn
c5df3096
Z
2152
2153This is an XS interface to Perl's C<warn> function.
2154
3d12c238 2155This is like C<L</warn>>, but C<args> are an encapsulated
4d4f193c 2156argument list.
c5df3096
Z
2157
2158Unlike with L</vcroak>, C<pat> is not permitted to be null.
2159
2160=cut
2161*/
2162
c5be433b
GS
2163void
2164Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 2165{
c5df3096 2166 SV *ex = vmess(pat, args);
7918f24d 2167 PERL_ARGS_ASSERT_VWARN;
c5df3096
Z
2168 if (!invoke_exception_hook(ex, TRUE))
2169 write_to_stderr(ex);
2170}
7918f24d 2171
c5df3096 2172/*
44170c9a 2173=for apidoc warn
3b4eef1c 2174=for apidoc_item warn_nocontext
87582a92 2175
3b4eef1c 2176These are XS interfaces to Perl's C<warn> function.
c5df3096 2177
3b4eef1c
KW
2178They take a sprintf-style format pattern and argument list, which are used to
2179generate a string message. If the message does not end with a newline, then it
2180will be extended with some indication of the current location in the code, as
2181described for C<L</mess_sv>>.
c5df3096
Z
2182
2183The error message or object will by default be written to standard error,
2184but this is subject to modification by a C<$SIG{__WARN__}> handler.
2185
3b4eef1c 2186Unlike with C<L</croak>>, C<pat> is not permitted to be null.
c5df3096 2187
3b4eef1c
KW
2188The two forms differ only in that C<warn_nocontext> does not take a thread
2189context (C<aTHX>) parameter, so is used in situations where the caller doesn't
2190already have the thread context.
3d12c238 2191
c5df3096
Z
2192=cut
2193*/
8d063cd8 2194
c5be433b 2195#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
2196void
2197Perl_warn_nocontext(const char *pat, ...)
2198{
2199 dTHX;
2200 va_list args;
7918f24d 2201 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
cea2e8a9 2202 va_start(args, pat);
c5be433b 2203 vwarn(pat, &args);
cea2e8a9
GS
2204 va_end(args);
2205}
2206#endif /* PERL_IMPLICIT_CONTEXT */
2207
2208void
2209Perl_warn(pTHX_ const char *pat, ...)
2210{
2211 va_list args;
7918f24d 2212 PERL_ARGS_ASSERT_WARN;
cea2e8a9 2213 va_start(args, pat);
c5be433b 2214 vwarn(pat, &args);
cea2e8a9
GS
2215 va_end(args);
2216}
2217
3b4eef1c
KW
2218/*
2219=for apidoc warner
2220=for apidoc_item warner_nocontext
2221
2222These output a warning of the specified category (or categories) given by
2223C<err>, using the sprintf-style format pattern C<pat>, and argument list.
2224
2225C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
2226C<packWARN4> macros populated with the appropriate number of warning
2227categories. If any of the warning categories they specify is fatal, a fatal
2228exception is thrown.
2229
2230In any event a message is generated by the pattern and arguments. If the
2231message does not end with a newline, then it will be extended with some
2232indication of the current location in the code, as described for L</mess_sv>.
2233
2234The error message or object will by default be written to standard error,
2235but this is subject to modification by a C<$SIG{__WARN__}> handler.
2236
2237C<pat> is not permitted to be null.
2238
2239The two forms differ only in that C<warner_nocontext> does not take a thread
2240context (C<aTHX>) parameter, so is used in situations where the caller doesn't
2241already have the thread context.
2242
2243These functions differ from the similarly named C<L</warn>> functions, in that
2244the latter are for XS code to unconditionally display a warning, whereas these
2245are for code that may be compiling a perl program, and does extra checking to
2246see if the warning should be fatal.
2247
2248=for apidoc ck_warner
2249=for apidoc_item ck_warner_d
2250If none of the warning categories given by C<err> are enabled, do nothing;
2251otherwise call C<L</warner>> or C<L</warner_nocontext>> with the passed-in
2252parameters;.
2253
2254C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
2255C<packWARN4> macros populated with the appropriate number of warning
2256categories.
2257
2258The two forms differ only in that C<ck_warner_d> should be used if warnings for
2259any of the categories are by default enabled.
2260
2261=for apidoc vwarner
2262This is like C<L</warner>>, but C<args> are an encapsulated argument list.
2263
2264=cut
2265*/
2266
c5be433b
GS
2267#if defined(PERL_IMPLICIT_CONTEXT)
2268void
2269Perl_warner_nocontext(U32 err, const char *pat, ...)
2270{
27da23d5 2271 dTHX;
c5be433b 2272 va_list args;
7918f24d 2273 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
c5be433b
GS
2274 va_start(args, pat);
2275 vwarner(err, pat, &args);
2276 va_end(args);
2277}
2278#endif /* PERL_IMPLICIT_CONTEXT */
2279
599cee73 2280void
9b387841
NC
2281Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
2282{
2283 PERL_ARGS_ASSERT_CK_WARNER_D;
2284
2285 if (Perl_ckwarn_d(aTHX_ err)) {
2286 va_list args;
2287 va_start(args, pat);
2288 vwarner(err, pat, &args);
2289 va_end(args);
2290 }
2291}
2292
2293void
a2a5de95
NC
2294Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
2295{
2296 PERL_ARGS_ASSERT_CK_WARNER;
2297
2298 if (Perl_ckwarn(aTHX_ err)) {
2299 va_list args;
2300 va_start(args, pat);
2301 vwarner(err, pat, &args);
2302 va_end(args);
2303 }
2304}
2305
2306void
864dbfa3 2307Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM
2308{
2309 va_list args;
7918f24d 2310 PERL_ARGS_ASSERT_WARNER;
c5be433b
GS
2311 va_start(args, pat);
2312 vwarner(err, pat, &args);
2313 va_end(args);
2314}
2315
2316void
2317Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
2318{
7918f24d 2319 PERL_ARGS_ASSERT_VWARNER;
46b27d2f
LM
2320 if (
2321 (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
2322 !(PL_in_eval & EVAL_KEEPERR)
2323 ) {
a3b680e6 2324 SV * const msv = vmess(pat, args);
599cee73 2325
594b6fac
LM
2326 if (PL_parser && PL_parser->error_count) {
2327 qerror(msv);
2328 }
2329 else {
2330 invoke_exception_hook(msv, FALSE);
2331 die_unwind(msv);
2332 }
599cee73
PM
2333 }
2334 else {
d13b0d77 2335 Perl_vwarn(aTHX_ pat, args);
599cee73
PM
2336 }
2337}
2338
f54ba1c2
DM
2339/* implements the ckWARN? macros */
2340
2341bool
2342Perl_ckwarn(pTHX_ U32 w)
2343{
ad287e37 2344 /* If lexical warnings have not been set, use $^W. */
3c3f8cd6
AB
2345 if (isLEXWARN_off)
2346 return PL_dowarn & G_WARN_ON;
ad287e37 2347
26c7b074 2348 return ckwarn_common(w);
f54ba1c2
DM
2349}
2350
2351/* implements the ckWARN?_d macro */
2352
2353bool
2354Perl_ckwarn_d(pTHX_ U32 w)
2355{
ad287e37 2356 /* If lexical warnings have not been set then default classes warn. */
3c3f8cd6
AB
2357 if (isLEXWARN_off)
2358 return TRUE;
ad287e37 2359
26c7b074
NC
2360 return ckwarn_common(w);
2361}
2362
2363static bool
2364S_ckwarn_common(pTHX_ U32 w)
2365{
3c3f8cd6
AB
2366 if (PL_curcop->cop_warnings == pWARN_ALL)
2367 return TRUE;
ad287e37
NC
2368
2369 if (PL_curcop->cop_warnings == pWARN_NONE)
2370 return FALSE;
2371
98fe6610
NC
2372 /* Check the assumption that at least the first slot is non-zero. */
2373 assert(unpackWARN1(w));
2374
2375 /* Check the assumption that it is valid to stop as soon as a zero slot is
2376 seen. */
2377 if (!unpackWARN2(w)) {
2378 assert(!unpackWARN3(w));
2379 assert(!unpackWARN4(w));
2380 } else if (!unpackWARN3(w)) {
2381 assert(!unpackWARN4(w));
2382 }
2383
26c7b074
NC
2384 /* Right, dealt with all the special cases, which are implemented as non-
2385 pointers, so there is a pointer to a real warnings mask. */
98fe6610
NC
2386 do {
2387 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2388 return TRUE;
2389 } while (w >>= WARNshift);
2390
2391 return FALSE;
f54ba1c2
DM
2392}
2393
72dc9ed5
NC
2394/* Set buffer=NULL to get a new one. */
2395STRLEN *
8ee4cf24 2396Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
72dc9ed5 2397 STRLEN size) {
5af88345
FC
2398 const MEM_SIZE len_wanted =
2399 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
35da51f7 2400 PERL_UNUSED_CONTEXT;
7918f24d 2401 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
72dc9ed5 2402
10edeb5d
JH
2403 buffer = (STRLEN*)
2404 (specialWARN(buffer) ?
2405 PerlMemShared_malloc(len_wanted) :
2406 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC
2407 buffer[0] = size;
2408 Copy(bits, (buffer + 1), size, char);
5af88345
FC
2409 if (size < WARNsize)
2410 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
72dc9ed5
NC
2411 return buffer;
2412}
f54ba1c2 2413
e6587932
DM
2414/* since we've already done strlen() for both nam and val
2415 * we can use that info to make things faster than
2416 * sprintf(s, "%s=%s", nam, val)
2417 */
2418#define my_setenv_format(s, nam, nlen, val, vlen) \
2419 Copy(nam, s, nlen, char); \
2420 *(s+nlen) = '='; \
2421 Copy(val, s+(nlen+1), vlen, char); \
2422 *(s+(nlen+1+vlen)) = '\0'
2423
adebb90d
DM
2424
2425
c5d12488 2426#ifdef USE_ENVIRON_ARRAY
de5576aa 2427/* NB: VMS' my_setenv() is in vms.c */
34716e2a 2428
3d50648c
DM
2429/* Configure doesn't test for HAS_SETENV yet, so decide based on platform.
2430 * For Solaris, setenv() and unsetenv() were introduced in Solaris 9, so
2431 * testing for HAS UNSETENV is sufficient.
2432 */
822c8b4d 2433# if defined(__CYGWIN__)|| defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
3d50648c
DM
2434# define MY_HAS_SETENV
2435# endif
2436
34716e2a
DM
2437/* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if
2438 * 'current' is non-null, with up to three sizes that are added together.
2439 * It handles integer overflow.
2440 */
3d50648c 2441# ifndef MY_HAS_SETENV
34716e2a
DM
2442static char *
2443S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size)
2444{
2445 void *p;
2446 Size_t sl, l = l1 + l2;
2447
2448 if (l < l2)
2449 goto panic;
2450 l += l3;
2451 if (l < l3)
2452 goto panic;
2453 sl = l * size;
2454 if (sl < l)
2455 goto panic;
2456
2457 p = current
2458 ? safesysrealloc(current, sl)
2459 : safesysmalloc(sl);
2460 if (p)
2461 return (char*)p;
2462
2463 panic:
2464 croak_memory_wrap();
2465}
3d50648c 2466# endif
34716e2a
DM
2467
2468
adebb90d 2469# if !defined(WIN32) && !defined(NETWARE)
34716e2a 2470
df641d45 2471/*
3f620621 2472=for apidoc_section $utility
df641d45
KW
2473=for apidoc my_setenv
2474
2475A wrapper for the C library L<setenv(3)>. Don't use the latter, as the perl
2476version has desirable safeguards
2477
2478=cut
2479*/
2480
8d063cd8 2481void
e1ec3a88 2482Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 2483{
adebb90d 2484# ifdef __amigaos4__
6e3136a6 2485 amigaos4_obtain_environ(__FUNCTION__);
adebb90d
DM
2486# endif
2487
2488# ifdef USE_ITHREADS
24f3e849
KW
2489 /* only parent thread can modify process environment, so no need to use a
2490 * mutex */
4efc5df6 2491 if (PL_curinterp == aTHX)
adebb90d 2492# endif
4efc5df6 2493 {
adebb90d
DM
2494
2495# ifndef PERL_USE_SAFE_PUTENV
50acdf95 2496 if (!PL_use_safe_putenv) {
b7d87861 2497 /* most putenv()s leak, so we manipulate environ directly */
34716e2a
DM
2498 UV i;
2499 Size_t vlen, nlen = strlen(nam);
b7d87861
JH
2500
2501 /* where does it go? */
2502 for (i = 0; environ[i]; i++) {
34716e2a 2503 if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=')
b7d87861
JH
2504 break;
2505 }
c5d12488 2506
b7d87861 2507 if (environ == PL_origenviron) { /* need we copy environment? */
34716e2a 2508 UV j, max;
b7d87861
JH
2509 char **tmpenv;
2510
2511 max = i;
2512 while (environ[max])
2513 max++;
adebb90d 2514
34716e2a
DM
2515 /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */
2516 tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*));
adebb90d 2517
b7d87861 2518 for (j=0; j<max; j++) { /* copy environment */
34716e2a
DM
2519 const Size_t len = strlen(environ[j]);
2520 tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1);
b7d87861
JH
2521 Copy(environ[j], tmpenv[j], len+1, char);
2522 }
adebb90d 2523
b7d87861
JH
2524 tmpenv[max] = NULL;
2525 environ = tmpenv; /* tell exec where it is now */
2526 }
adebb90d 2527
b7d87861
JH
2528 if (!val) {
2529 safesysfree(environ[i]);
2530 while (environ[i]) {
2531 environ[i] = environ[i+1];
2532 i++;
2533 }
adebb90d 2534# ifdef __amigaos4__
6e3136a6 2535 goto my_setenv_out;
adebb90d 2536# else
b7d87861 2537 return;
adebb90d 2538# endif
b7d87861 2539 }
adebb90d 2540
b7d87861 2541 if (!environ[i]) { /* does not exist yet */
34716e2a 2542 environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*));
b7d87861
JH
2543 environ[i+1] = NULL; /* make sure it's null terminated */
2544 }
2545 else
2546 safesysfree(environ[i]);
34716e2a 2547
b7d87861
JH
2548 vlen = strlen(val);
2549
34716e2a 2550 environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1);
b7d87861
JH
2551 /* all that work just for this */
2552 my_setenv_format(environ[i], nam, nlen, val, vlen);
adebb90d
DM
2553 }
2554 else {
2555
2556# endif /* !PERL_USE_SAFE_PUTENV */
2557
3d50648c 2558# ifdef MY_HAS_SETENV
adebb90d 2559# if defined(HAS_UNSETENV)
88f5bc07
AB
2560 if (val == NULL) {
2561 (void)unsetenv(nam);
2562 } else {
2563 (void)setenv(nam, val, 1);
2564 }
adebb90d 2565# else /* ! HAS_UNSETENV */
88f5bc07 2566 (void)setenv(nam, val, 1);
adebb90d
DM
2567# endif /* HAS_UNSETENV */
2568
2569# elif defined(HAS_UNSETENV)
2570
88f5bc07 2571 if (val == NULL) {
ba88ff58
MJ
2572 if (environ) /* old glibc can crash with null environ */
2573 (void)unsetenv(nam);
88f5bc07 2574 } else {
34716e2a
DM
2575 const Size_t nlen = strlen(nam);
2576 const Size_t vlen = strlen(val);
2577 char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
88f5bc07
AB
2578 my_setenv_format(new_env, nam, nlen, val, vlen);
2579 (void)putenv(new_env);
2580 }
adebb90d
DM
2581
2582# else /* ! HAS_UNSETENV */
2583
88f5bc07 2584 char *new_env;
34716e2a
DM
2585 const Size_t nlen = strlen(nam);
2586 Size_t vlen;
88f5bc07
AB
2587 if (!val) {
2588 val = "";
2589 }
2590 vlen = strlen(val);
34716e2a 2591 new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
88f5bc07
AB
2592 /* all that work just for this */
2593 my_setenv_format(new_env, nam, nlen, val, vlen);
2594 (void)putenv(new_env);
adebb90d 2595
3d50648c 2596# endif /* MY_HAS_SETENV */
adebb90d
DM
2597
2598# ifndef PERL_USE_SAFE_PUTENV
50acdf95 2599 }
adebb90d 2600# endif
4efc5df6 2601 }
adebb90d
DM
2602
2603# ifdef __amigaos4__
6e3136a6
AB
2604my_setenv_out:
2605 amigaos4_release_environ(__FUNCTION__);
adebb90d 2606# endif
8d063cd8
LW
2607}
2608
adebb90d 2609# else /* WIN32 || NETWARE */
68dc0745
PP
2610
2611void
72229eff 2612Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 2613{
eb578fdb 2614 char *envstr;
34716e2a
DM
2615 const Size_t nlen = strlen(nam);
2616 Size_t vlen;
e6587932 2617
c5d12488
JH
2618 if (!val) {
2619 val = "";
ac5c734f 2620 }
c5d12488 2621 vlen = strlen(val);
34716e2a 2622 envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
c5d12488
JH
2623 my_setenv_format(envstr, nam, nlen, val, vlen);
2624 (void)PerlEnv_putenv(envstr);
ff69e883 2625 safesysfree(envstr);
3e3baf6d
TB
2626}
2627
adebb90d
DM
2628# endif /* WIN32 || NETWARE */
2629
2630#endif /* USE_ENVIRON_ARRAY */
2631
2632
3e3baf6d 2633
378cc40b 2634
16d20bd9 2635#ifdef UNLINK_ALL_VERSIONS
79072805 2636I32
6e732051 2637Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 2638{
35da51f7 2639 I32 retries = 0;
378cc40b 2640
7918f24d
NC
2641 PERL_ARGS_ASSERT_UNLNK;
2642
35da51f7
AL
2643 while (PerlLIO_unlink(f) >= 0)
2644 retries++;
2645 return retries ? 0 : -1;
378cc40b
LW
2646}
2647#endif
2648
4a7d1889 2649PerlIO *
c9289b7b 2650Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
4a7d1889 2651{
f6fb4e44 2652#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
1f852d0d 2653 int p[2];
eb578fdb
KW
2654 I32 This, that;
2655 Pid_t pid;
1f852d0d
NIS
2656 SV *sv;
2657 I32 did_pipes = 0;
2658 int pp[2];
2659
7918f24d
NC
2660 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2661
1f852d0d
NIS
2662 PERL_FLUSHALL_FOR_CHILD;
2663 This = (*mode == 'w');
2664 that = !This;
284167a5 2665 if (TAINTING_get) {
1f852d0d
NIS
2666 taint_env();
2667 taint_proper("Insecure %s%s", "EXEC");
2668 }
884fc2d3 2669 if (PerlProc_pipe_cloexec(p) < 0)
4608196e 2670 return NULL;
1f852d0d 2671 /* Try for another pipe pair for error return */
74df577f 2672 if (PerlProc_pipe_cloexec(pp) >= 0)
1f852d0d 2673 did_pipes = 1;
52e18b1f 2674 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS
2675 if (errno != EAGAIN) {
2676 PerlLIO_close(p[This]);
4e6dfe71 2677 PerlLIO_close(p[that]);
1f852d0d
NIS
2678 if (did_pipes) {
2679 PerlLIO_close(pp[0]);
2680 PerlLIO_close(pp[1]);
2681 }
4608196e 2682 return NULL;
1f852d0d 2683 }
a2a5de95 2684 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
1f852d0d
NIS
2685 sleep(5);
2686 }
2687 if (pid == 0) {
2688 /* Child */
1f852d0d
NIS
2689#undef THIS
2690#undef THAT
2691#define THIS that
2692#define THAT This
1f852d0d 2693 /* Close parent's end of error status pipe (if any) */
74df577f 2694 if (did_pipes)
1f852d0d 2695 PerlLIO_close(pp[0]);
1f852d0d
NIS
2696 /* Now dup our end of _the_ pipe to right position */
2697 if (p[THIS] != (*mode == 'r')) {
2698 PerlLIO_dup2(p[THIS], *mode == 'r');
2699 PerlLIO_close(p[THIS]);
4e6dfe71
GS
2700 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2701 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2702 }
30c869b8
LT
2703 else {
2704 setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
4e6dfe71 2705 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
30c869b8 2706 }
1f852d0d
NIS
2707#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2708 /* No automatic close - do it by hand */
b7953727
JH
2709# ifndef NOFILE
2710# define NOFILE 20
2711# endif
a080fe3d
NIS
2712 {
2713 int fd;
2714
2715 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2716 if (fd != pp[1])
a080fe3d
NIS
2717 PerlLIO_close(fd);
2718 }
1f852d0d
NIS
2719 }
2720#endif
a0714e2c 2721 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS
2722 PerlProc__exit(1);
2723#undef THIS
2724#undef THAT
2725 }
2726 /* Parent */
1f852d0d
NIS
2727 if (did_pipes)
2728 PerlLIO_close(pp[1]);
2729 /* Keep the lower of the two fd numbers */
2730 if (p[that] < p[This]) {
884fc2d3 2731 PerlLIO_dup2_cloexec(p[This], p[that]);
1f852d0d
NIS
2732 PerlLIO_close(p[This]);
2733 p[This] = p[that];
2734 }
4e6dfe71
GS
2735 else
2736 PerlLIO_close(p[that]); /* close child's end of pipe */
2737
1f852d0d 2738 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2739 SvUPGRADE(sv,SVt_IV);
45977657 2740 SvIV_set(sv, pid);
1f852d0d
NIS
2741 PL_forkprocess = pid;
2742 /* If we managed to get status pipe check for exec fail */
2743 if (did_pipes && pid > 0) {
2744 int errkid;
35bc1e35 2745 unsigned read_total = 0;
1f852d0d 2746
35bc1e35 2747 while (read_total < sizeof(int)) {
19742f39 2748 const SSize_t n1 = PerlLIO_read(pp[0],
35bc1e35
JK
2749 (void*)(((char*)&errkid)+read_total),
2750 (sizeof(int)) - read_total);
1f852d0d
NIS
2751 if (n1 <= 0)
2752 break;
35bc1e35 2753 read_total += n1;
1f852d0d
NIS
2754 }
2755 PerlLIO_close(pp[0]);
2756 did_pipes = 0;
35bc1e35 2757 if (read_total) { /* Error */
1f852d0d 2758 int pid2, status;
8c51524e 2759 PerlLIO_close(p[This]);
35bc1e35
JK
2760 if (read_total != sizeof(int))
2761 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", read_total);
1f852d0d
NIS
2762 do {
2763 pid2 = wait4pid(pid, &status, 0);
2764 } while (pid2 == -1 && errno == EINTR);
2765 errno = errkid; /* Propagate errno from kid */
4608196e 2766 return NULL;
1f852d0d
NIS
2767 }
2768 }
2769 if (did_pipes)
2770 PerlLIO_close(pp[0]);
2771 return PerlIO_fdopen(p[This], mode);
2772#else
8492b23f 2773# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
4e205ed6 2774 return my_syspopen4(aTHX_ NULL, mode, n, args);
8492b23f
TC
2775# elif defined(WIN32)
2776 return win32_popenlist(mode, n, args);
9d419b5f 2777# else
4a7d1889
NIS
2778 Perl_croak(aTHX_ "List form of piped open not implemented");
2779 return (PerlIO *) NULL;
9d419b5f 2780# endif
1f852d0d 2781#endif
4a7d1889
NIS
2782}
2783
4dd5370d
AB
2784 /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2785#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
760ac839 2786PerlIO *
3dd43144 2787Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c
LW
2788{
2789 int p[2];
eb578fdb
KW
2790 I32 This, that;
2791 Pid_t pid;
79072805 2792 SV *sv;
bfce84ec 2793 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ
2794 I32 did_pipes = 0;
2795 int pp[2];
a687059c 2796
7918f24d
NC
2797 PERL_ARGS_ASSERT_MY_POPEN;
2798
45bc9206 2799 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ
2800#ifdef OS2
2801 if (doexec) {
23da6c43 2802 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2803 }
a1d180c4 2804#endif
8ac85365
NIS
2805 This = (*mode == 'w');
2806 that = !This;
284167a5 2807 if (doexec && TAINTING_get) {
bbce6d69
PP
2808 taint_env();
2809 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2810 }
884fc2d3 2811 if (PerlProc_pipe_cloexec(p) < 0)
4608196e 2812 return NULL;
74df577f 2813 if (doexec && PerlProc_pipe_cloexec(pp) >= 0)
e446cec8 2814 did_pipes = 1;
52e18b1f 2815 while ((pid = PerlProc_fork()) < 0) {
a687059c 2816 if (errno != EAGAIN) {
6ad3d225 2817 PerlLIO_close(p[This]);
b5ac89c3 2818 PerlLIO_close(p[that]);
e446cec8
IZ
2819 if (did_pipes) {
2820 PerlLIO_close(pp[0]);
2821 PerlLIO_close(pp[1]);
2822 }
a687059c 2823 if (!doexec)
b3647a36 2824 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2825 return NULL;
a687059c 2826 }
a2a5de95 2827 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW
2828 sleep(5);
2829 }
2830 if (pid == 0) {
79072805 2831
30ac6d9b
GS
2832#undef THIS
2833#undef THAT
a687059c 2834#define THIS that
8ac85365 2835#define THAT This
74df577f 2836 if (did_pipes)
e446cec8 2837 PerlLIO_close(pp[0]);
a687059c 2838 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS
2839 PerlLIO_dup2(p[THIS], *mode == 'r');
2840 PerlLIO_close(p[THIS]);
b5ac89c3
NIS
2841 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2842 PerlLIO_close(p[THAT]);
a687059c 2843 }
c6fe5b98
LT
2844 else {
2845 setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
b5ac89c3 2846 PerlLIO_close(p[THAT]);
c6fe5b98 2847 }
4435c477 2848#ifndef OS2
a687059c 2849 if (doexec) {
a0d0e21e 2850#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
2851#ifndef NOFILE
2852#define NOFILE 20
2853#endif
a080fe3d 2854 {
3aed30dc 2855 int fd;
a080fe3d
NIS
2856
2857 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2858 if (fd != pp[1])
3aed30dc 2859 PerlLIO_close(fd);
a080fe3d 2860 }
ae986130 2861#endif
a080fe3d
NIS
2862 /* may or may not use the shell */
2863 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2864 PerlProc__exit(1);
a687059c 2865 }
4435c477 2866#endif /* defined OS2 */
713cef20
IZ
2867
2868#ifdef PERLIO_USING_CRLF
2869 /* Since we circumvent IO layers when we manipulate low-level
2870 filedescriptors directly, need to manually switch to the
2871 default, binary, low-level mode; see PerlIOBuf_open(). */
2872 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2873#endif
3280af22 2874 PL_forkprocess = 0;
ca0c25f6 2875#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2876 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2877#endif
4608196e 2878 return NULL;
a687059c
LW
2879#undef THIS
2880#undef THAT
2881 }
e446cec8
IZ
2882 if (did_pipes)
2883 PerlLIO_close(pp[1]);
8ac85365 2884 if (p[that] < p[This]) {
884fc2d3 2885 PerlLIO_dup2_cloexec(p[This], p[that]);
6ad3d225 2886 PerlLIO_close(p[This]);
8ac85365 2887 p[This] = p[that];
62b28dd9 2888 }
b5ac89c3
NIS
2889 else
2890 PerlLIO_close(p[that]);
2891
3280af22 2892 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2893 SvUPGRADE(sv,SVt_IV);
45977657 2894 SvIV_set(sv, pid);
3280af22 2895 PL_forkprocess = pid;
e446cec8
IZ
2896 if (did_pipes && pid > 0) {
2897 int errkid;
bb7a0f54 2898 unsigned n = 0;
e446cec8
IZ
2899
2900 while (n < sizeof(int)) {
19742f39 2901 const SSize_t n1 = PerlLIO_read(pp[0],
e446cec8
IZ
2902 (void*)(((char*)&errkid)+n),
2903 (sizeof(int)) - n);
2904 if (n1 <= 0)
2905 break;
2906 n += n1;
2907 }
2f96c702
IZ
2908 PerlLIO_close(pp[0]);
2909 did_pipes = 0;
e446cec8 2910 if (n) { /* Error */
faa466a7 2911 int pid2, status;
8c51524e 2912 PerlLIO_close(p[This]);
e446cec8 2913 if (n != sizeof(int))
5637ef5b 2914 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
faa466a7
RG
2915 do {
2916 pid2 = wait4pid(pid, &status, 0);
2917 } while (pid2 == -1 && errno == EINTR);
e446cec8 2918 errno = errkid; /* Propagate errno from kid */
4608196e 2919 return NULL;
e446cec8
IZ
2920 }
2921 }
2922 if (did_pipes)
2923 PerlLIO_close(pp[0]);
8ac85365 2924 return PerlIO_fdopen(p[This], mode);
a687059c 2925}
8ad758c7 2926#elif defined(DJGPP)
2b96b0a5
JH
2927FILE *djgpp_popen();
2928PerlIO *
cef6ea9d 2929Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH
2930{
2931 PERL_FLUSHALL_FOR_CHILD;
2932 /* Call system's popen() to get a FILE *, then import it.
2933 used 0 for 2nd parameter to PerlIO_importFILE;
2934 apparently not used
2935 */
2936 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2937}
8ad758c7 2938#elif defined(__LIBCATAMOUNT__)
9c12f1e5
RGS
2939PerlIO *
2940Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2941{
2942 return NULL;
2943}
7c0587c8
LW
2944
2945#endif /* !DOSISH */
a687059c 2946
52e18b1f
GS
2947/* this is called in parent before the fork() */
2948void
2949Perl_atfork_lock(void)
80b94025
JH
2950#if defined(USE_ITHREADS)
2951# ifdef USE_PERLIO
2952 PERL_TSA_ACQUIRE(PL_perlio_mutex)
2953# endif
2954# ifdef MYMALLOC
2955 PERL_TSA_ACQUIRE(PL_malloc_mutex)
2956# endif
2957 PERL_TSA_ACQUIRE(PL_op_mutex)
2958#endif
52e18b1f 2959{
3db8f154 2960#if defined(USE_ITHREADS)
52e18b1f 2961 /* locks must be held in locking order (if any) */
4da80956
P
2962# ifdef USE_PERLIO
2963 MUTEX_LOCK(&PL_perlio_mutex);
2964# endif
52e18b1f
GS
2965# ifdef MYMALLOC
2966 MUTEX_LOCK(&PL_malloc_mutex);
2967# endif
2968 OP_REFCNT_LOCK;
2969#endif
2970}
2971
2972/* this is called in both parent and child after the fork() */
2973void
2974Perl_atfork_unlock(void)
80b94025
JH
2975#if defined(USE_ITHREADS)
2976# ifdef USE_PERLIO
2977 PERL_TSA_RELEASE(PL_perlio_mutex)
2978# endif
2979# ifdef MYMALLOC
2980 PERL_TSA_RELEASE(PL_malloc_mutex)
2981# endif
2982 PERL_TSA_RELEASE(PL_op_mutex)
2983#endif
52e18b1f 2984{
3db8f154 2985#if defined(USE_ITHREADS)
52e18b1f 2986 /* locks must be released in same order as in atfork_lock() */
4da80956
P
2987# ifdef USE_PERLIO
2988 MUTEX_UNLOCK(&PL_perlio_mutex);
2989# endif
52e18b1f
GS
2990# ifdef MYMALLOC
2991 MUTEX_UNLOCK(&PL_malloc_mutex);
2992# endif
2993 OP_REFCNT_UNLOCK;
2994#endif
2995}
2996
2997Pid_t
2998Perl_my_fork(void)
2999{
3000#if defined(HAS_FORK)
3001 Pid_t pid;
3db8f154 3002#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS
3003 atfork_lock();
3004 pid = fork();
3005 atfork_unlock();
3006#else
3007 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
3008 * handlers elsewhere in the code */
3009 pid = fork();
3010#endif
3011 return pid;
40262ff4
AB
3012#elif defined(__amigaos4__)
3013 return amigaos_fork();
52e18b1f
GS
3014#else
3015 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
3016 Perl_croak_nocontext("fork() not available");
b961a566 3017 return 0;
52e18b1f
GS
3018#endif /* HAS_FORK */
3019}
3020
fe14fcc3 3021#ifndef HAS_DUP2
fec02dd3 3022int
ba106d47 3023dup2(int oldfd, int newfd)
a687059c 3024{
a0d0e21e 3025#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
3026 if (oldfd == newfd)
3027 return oldfd;
6ad3d225 3028 PerlLIO_close(newfd);
fec02dd3 3029 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 3030#else
fc36a67e
PP
3031#define DUP2_MAX_FDS 256
3032 int fdtmp[DUP2_MAX_FDS];
79072805 3033 I32 fdx = 0;
ae986130
LW
3034 int fd;
3035
fe14fcc3 3036 if (oldfd == newfd)
fec02dd3 3037 return oldfd;
6ad3d225 3038 PerlLIO_close(newfd);
fc36a67e 3039 /* good enough for low fd's... */
6ad3d225 3040 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 3041 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 3042 PerlLIO_close(fd);
fc36a67e
PP
3043 fd = -1;
3044 break;
3045 }
ae986130 3046 fdtmp[fdx++] = fd;
fc36a67e 3047 }
ae986130 3048 while (fdx > 0)
6ad3d225 3049 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 3050 return fd;
62b28dd9 3051#endif
a687059c
LW
3052}
3053#endif
3054
64ca3a65 3055#ifndef PERL_MICRO
ff68c719
PP
3056#ifdef HAS_SIGACTION
3057
962fce0f 3058/*
3f620621 3059=for apidoc_section $signals
962fce0f
KW
3060=for apidoc rsignal
3061
3062A wrapper for the C library L<signal(2)>. Don't use the latter, as the Perl
3063version knows things that interact with the rest of the perl interpreter.
3064
3065=cut
3066*/
3067
ff68c719 3068Sighandler_t
864dbfa3 3069Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719
PP
3070{
3071 struct sigaction act, oact;
3072
a10b1e10
JH
3073#ifdef USE_ITHREADS
3074 /* only "parent" interpreter can diddle signals */
3075 if (PL_curinterp != aTHX)
8aad04aa 3076 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
3077#endif
3078
8d61efc5 3079 act.sa_handler = handler;
ff68c719
PP
3080 sigemptyset(&act.sa_mask);
3081 act.sa_flags = 0;
3082#ifdef SA_RESTART
4ffa73a3
JH
3083 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3084 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 3085#endif
358837b8 3086#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 3087 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
3088 act.sa_flags |= SA_NOCLDWAIT;
3089#endif
ff68c719 3090 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 3091 return (Sighandler_t) SIG_ERR;
ff68c719 3092 else
8aad04aa 3093 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
3094}
3095
3096Sighandler_t
864dbfa3 3097Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
3098{
3099 struct sigaction oact;
96a5add6 3100 PERL_UNUSED_CONTEXT;
ff68c719
PP
3101
3102 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 3103 return (Sighandler_t) SIG_ERR;
ff68c719 3104 else
8aad04aa 3105 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
3106}
3107
3108int
864dbfa3 3109Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719
PP
3110{
3111 struct sigaction act;
3112
7918f24d
NC
3113 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
3114
a10b1e10
JH
3115#ifdef USE_ITHREADS
3116 /* only "parent" interpreter can diddle signals */
3117 if (PL_curinterp != aTHX)
3118 return -1;
3119#endif
3120
8d61efc5 3121 act.sa_handler = handler;
ff68c719
PP
3122 sigemptyset(&act.sa_mask);
3123 act.sa_flags = 0;
3124#ifdef SA_RESTART
4ffa73a3
JH
3125 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3126 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 3127#endif
36b5d377 3128#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 3129 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
3130 act.sa_flags |= SA_NOCLDWAIT;
3131#endif
ff68c719
PP
3132 return sigaction(signo, &act, save);
3133}
3134
3135int
864dbfa3 3136Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 3137{
20b7effb 3138 PERL_UNUSED_CONTEXT;
a10b1e10
JH
3139#ifdef USE_ITHREADS
3140 /* only "parent" interpreter can diddle signals */
3141 if (PL_curinterp != aTHX)
3142 return -1;
3143#endif
3144
ff68c719
PP
3145 return sigaction(signo, save, (struct sigaction *)NULL);
3146}
3147
3148#else /* !HAS_SIGACTION */
3149
3150Sighandler_t
864dbfa3 3151Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 3152{
39f1703b 3153#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3154 /* only "parent" interpreter can diddle signals */
3155 if (PL_curinterp != aTHX)
8aad04aa 3156 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
3157#endif
3158
6ad3d225 3159 return PerlProc_signal(signo, handler);
ff68c719
PP
3160}
3161
fabdb6c0 3162static Signal_t
4e35701f 3163sig_trap(int signo)
ff68c719 3164{
27da23d5 3165 PL_sig_trapped++;
ff68c719
PP
3166}
3167
3168Sighandler_t
864dbfa3 3169Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
3170{
3171 Sighandler_t oldsig;
3172
39f1703b 3173#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3174 /* only "parent" interpreter can diddle signals */
3175 if (PL_curinterp != aTHX)
8aad04aa 3176 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
3177#endif
3178
27da23d5 3179 PL_sig_trapped = 0;
6ad3d225
GS
3180 oldsig = PerlProc_signal(signo, sig_trap);
3181 PerlProc_signal(signo, oldsig);
27da23d5 3182 if (PL_sig_trapped)
3aed30dc 3183 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719
PP
3184 return oldsig;
3185}
3186
3187int
864dbfa3 3188Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 3189{
39f1703b 3190#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3191 /* only "parent" interpreter can diddle signals */
3192 if (PL_curinterp != aTHX)
3193 return -1;
3194#endif
6ad3d225 3195 *save = PerlProc_signal(signo, handler);
8aad04aa 3196 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3197}
3198
3199int
864dbfa3 3200Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 3201{
39f1703b 3202#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3203 /* only "parent" interpreter can diddle signals */
3204 if (PL_curinterp != aTHX)
3205 return -1;
3206#endif
8aad04aa 3207 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3208}
3209
3210#endif /* !HAS_SIGACTION */
64ca3a65 3211#endif /* !PERL_MICRO */
ff68c719 3212
5f05dabc 3213 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
53f73940 3214#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
79072805 3215I32
864dbfa3 3216Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 3217{
a687059c 3218 int status;
a0d0e21e 3219 SV **svp;
d8a83dd3 3220 Pid_t pid;
2e0cfa16 3221 Pid_t pid2 = 0;
03136e13 3222 bool close_failed;
4ee39169 3223 dSAVEDERRNO;
2e0cfa16 3224 const int fd = PerlIO_fileno(ptr);
e9d373c4
TC
3225 bool should_wait;
3226
3227 svp = av_fetch(PL_fdpid,fd,TRUE);
3228 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3229 SvREFCNT_dec(*svp);
3230 *svp = NULL;
2e0cfa16 3231
97cb92d6 3232#if defined(USE_PERLIO)
2e0cfa16
FC
3233 /* Find out whether the refcount is low enough for us to wait for the
3234 child proc without blocking. */
e9d373c4 3235 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
b6ae43b7 3236#else
e9d373c4 3237 should_wait = pid > 0;
b6ae43b7 3238#endif
a687059c 3239
ddcf38b7
IZ
3240#ifdef OS2
3241 if (pid == -1) { /* Opened by popen. */
3242 return my_syspclose(ptr);
3243 }
a1d180c4 3244#endif
f1618b10
CS
3245 close_failed = (PerlIO_close(ptr) == EOF);
3246 SAVE_ERRNO;
2e0cfa16 3247 if (should_wait) do {
1d3434b8
GS
3248 pid2 = wait4pid(pid, &status, 0);
3249 } while (pid2 == -1 && errno == EINTR);
03136e13 3250 if (close_failed) {
4ee39169 3251 RESTORE_ERRNO;
03136e13
CS
3252 return -1;
3253 }
2e0cfa16
FC
3254 return(
3255 should_wait
3256 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3257 : 0
3258 );
20188a90 3259}
8ad758c7 3260#elif defined(__LIBCATAMOUNT__)
9c12f1e5
RGS
3261I32
3262Perl_my_pclose(pTHX_ PerlIO *ptr)
3263{
3264 return -1;
3265}
4633a7c4
LW
3266#endif /* !DOSISH */
3267
e37778c2 3268#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 3269I32
d8a83dd3 3270Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 3271{
27da23d5 3272 I32 result = 0;
7918f24d 3273 PERL_ARGS_ASSERT_WAIT4PID;
ca0c25f6 3274#ifdef PERL_USES_PL_PIDSTATUS
d4c02743
TC
3275 if (!pid) {
3276 /* PERL_USES_PL_PIDSTATUS is only defined when neither
3277 waitpid() nor wait4() is available, or on OS/2, which
3278 doesn't appear to support waiting for a progress group
3279 member, so we can only treat a 0 pid as an unknown child.
3280 */
3281 errno = ECHILD;
3282 return -1;
3283 }
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
f6bab5f6 3310 aggregate does more work, because next call to hv_iterinit()
7b9a3241
NC
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)
d4c02743 3330 result = wait4(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{
eb578fdb 3363 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
6de23f80 3372#if defined(OS2)
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
5aaab254 3407Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
9f68db38 3408{
7918f24d
NC
3409 PERL_ARGS_ASSERT_REPEATCPY;
3410
223f01db
KW
3411 assert(len >= 0);
3412
2709980d 3413 if (count < 0)
d1decf2b 3414 croak_memory_wrap();
2709980d 3415
16fa5c11
VP
3416 if (len == 1)
3417 memset(to, *from, count);
3418 else if (count) {
eb578fdb 3419 char *p = to;
26e1303d 3420 IV items, linear, half;
16fa5c11
VP
3421
3422 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3423 for (items = 0; items < linear; ++items) {
eb578fdb 3424 const char *q = from;
26e1303d 3425 IV todo;
16fa5c11
VP
3426 for (todo = len; todo > 0; todo--)
3427 *p++ = *q++;
3428 }
3429
3430 half = count / 2;
3431 while (items <= half) {
26e1303d 3432 IV size = items * len;
16fa5c11
VP
3433 memcpy(p, to, size);
3434 p += size;
3435 items *= 2;
9f68db38 3436 }
16fa5c11
VP
3437
3438 if (count > items)
3439 memcpy(p, to, (count - items) * len);
9f68db38
LW
3440 }
3441}
0f85fab0 3442
fe14fcc3 3443#ifndef HAS_RENAME
79072805 3444I32
4373e329 3445Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3446{
93a17b20
LW
3447 char *fa = strrchr(a,'/');
3448 char *fb = strrchr(b,'/');
c623ac67
GS
3449 Stat_t tmpstatbuf1;
3450 Stat_t tmpstatbuf2;
c4420975 3451 SV * const tmpsv = sv_newmortal();
62b28dd9 3452
7918f24d
NC
3453 PERL_ARGS_ASSERT_SAME_DIRENT;
3454
62b28dd9
LW
3455 if (fa)
3456 fa++;
3457 else
3458 fa = a;
3459 if (fb)
3460 fb++;
3461 else
3462 fb = b;
3463 if (strNE(a,b))
3464 return FALSE;
3465 if (fa == a)
76f68e9b 3466 sv_setpvs(tmpsv, ".");
62b28dd9 3467 else
46fc3d4c 3468 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3469 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
3470 return FALSE;
3471 if (fb == b)
76f68e9b 3472 sv_setpvs(tmpsv, ".");
62b28dd9 3473 else
46fc3d4c 3474 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3475 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
3476 return FALSE;
3477 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3478 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3479}
fe14fcc3
LW
3480#endif /* !HAS_RENAME */
3481
491527d0 3482char*
7f315aed
NC
3483Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3484 const char *const *const search_ext, I32 flags)
491527d0 3485{
bd61b366
SS
3486 const char *xfound = NULL;
3487 char *xfailed = NULL;
0f31cffe 3488 char tmpbuf[MAXPATHLEN];
eb578fdb 3489 char *s;
5f74f29c 3490 I32 len = 0;
491527d0 3491 int retval;
39a02377 3492 char *bufend;
7c458fae 3493#if defined(DOSISH) && !defined(OS2)
491527d0
GS
3494# define SEARCH_EXTS ".bat", ".cmd", NULL
3495# define MAX_EXT_LEN 4
3496#endif
3497#ifdef OS2
3498# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3499# define MAX_EXT_LEN 4
3500#endif
3501#ifdef VMS
3502# define SEARCH_EXTS ".pl", ".com", NULL
3503# define MAX_EXT_LEN 4
3504#endif
3505 /* additional extensions to try in each dir if scriptname not found */
3506#ifdef SEARCH_EXTS
0bcc34c2 3507 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3508 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3509 int extidx = 0, i = 0;
bd61b366 3510 const char *curext = NULL;
491527d0 3511#else
53c1dcc0 3512 PERL_UNUSED_ARG(search_ext);
491527d0
GS
3513# define MAX_EXT_LEN 0
3514#endif
3515
7918f24d
NC
3516 PERL_ARGS_ASSERT_FIND_SCRIPT;
3517
491527d0
GS
3518 /*
3519 * If dosearch is true and if scriptname does not contain path
3520 * delimiters, search the PATH for scriptname.
3521 *
3522 * If SEARCH_EXTS is also defined, will look for each
3523 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3524 * while searching the PATH.
3525 *
3526 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3527 * proceeds as follows:
3528 * If DOSISH or VMSISH:
3529 * + look for ./scriptname{,.foo,.bar}
3530 * + search the PATH for scriptname{,.foo,.bar}
3531 *
3532 * If !DOSISH:
3533 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3534 * this will not look in '.' if it's not in the PATH)
3535 */
84486fc6 3536 tmpbuf[0] = '\0';
491527d0
GS
3537
3538#ifdef VMS
3539# ifdef ALWAYS_DEFTYPES
3540 len = strlen(scriptname);
3541 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3542 int idx = 0, deftypes = 1;
491527d0
GS
3543 bool seen_dot = 1;
3544
bd61b366 3545 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3546# else
3547 if (dosearch) {
c4420975 3548 int idx = 0, deftypes = 1;
491527d0
GS
3549 bool seen_dot = 1;
3550
bd61b366 3551 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3552# endif
3553 /* The first time through, just add SEARCH_EXTS to whatever we
3554 * already have, so we can check for default file types. */
3555 while (deftypes ||
84486fc6 3556 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0 3557 {
2aa28b86 3558 Stat_t statbuf;
491527d0
GS
3559 if (deftypes) {
3560 deftypes = 0;
84486fc6 3561 *tmpbuf = '\0';
491527d0 3562 }
84486fc6
GS
3563 if ((strlen(tmpbuf) + strlen(scriptname)
3564 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3565 continue; /* don't search dir with too-long name */
6fca0082 3566 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS
3567#else /* !VMS */
3568
3569#ifdef DOSISH
3570 if (strEQ(scriptname, "-"))
3571 dosearch = 0;
3572 if (dosearch) { /* Look in '.' first. */
fe2774ed 3573 const char *cur = scriptname;
491527d0
GS
3574#ifdef SEARCH_EXTS
3575 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3576 while (ext[i])
3577 if (strEQ(ext[i++],curext)) {
3578 extidx = -1; /* already has an ext */
3579 break;
3580 }
3581 do {
3582#endif
3583 DEBUG_p(PerlIO_printf(Perl_debug_log,
3584 "Looking for %s\n",cur));
45a23732 3585 {
0cc19a43 3586 Stat_t statbuf;
45a23732
DD
3587 if (PerlLIO_stat(cur,&statbuf) >= 0
3588 && !S_ISDIR(statbuf.st_mode)) {
3589 dosearch = 0;
3590 scriptname = cur;
491527d0 3591#ifdef SEARCH_EXTS
45a23732 3592 break;
491527d0 3593#endif
45a23732 3594 }
491527d0
GS
3595 }
3596#ifdef SEARCH_EXTS
3597 if (cur == scriptname) {
3598 len = strlen(scriptname);
84486fc6 3599 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3600 break;
9e4425f7
SH
3601 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3602 cur = tmpbuf;
491527d0
GS
3603 }
3604 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3605 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS
3606#endif
3607 }
3608#endif
3609
3610 if (dosearch && !strchr(scriptname, '/')