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