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