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