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
Pod typos
[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 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)
147e3846 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);
147e3846 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 259 if ((SSize_t)size < 0)
147e3846 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
147e3846
KW		 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
147e3846 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)
147e3846 422 Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
5637ef5b 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);
147e3846 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 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 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 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 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);
147e3846 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 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 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 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 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))
147e3846 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);
147e3846 1536 Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,
3b46b707
BF		 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 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 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 2352 while (len--)
2353 *loc++ = ch;
99fff99d 2354 return vloc;
fc36a67e 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 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 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 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 2871#ifdef HAS_SIGACTION
2872
2873Sighandler_t
864dbfa3 2874Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 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 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 2900}
2901
2902Sighandler_t
864dbfa3 2903Perl_rsignal_state(pTHX_ int signo)
ff68c719 2904{
2905 struct sigaction oact;
96a5add6 2906 PERL_UNUSED_CONTEXT;
ff68c719 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 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 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 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 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 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 2972}
2973
fabdb6c0 2974static Signal_t
4e35701f 2975sig_trap(int signo)
ff68c719 2976{
27da23d5
JH		 2977 dVAR;
2978 PL_sig_trapped++;
ff68c719 2979}
2980
2981Sighandler_t
864dbfa3 2982Perl_rsignal_state(pTHX_ int signo)
ff68c719 2983{
27da23d5 2984 dVAR;
ff68c719 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 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 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 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;
3580 return &PL_Vars;
22239a37 3581}
31fb1209
NIS		 3582#endif
3583
1cb0ed9b 3584char **
864dbfa3 3585Perl_get_op_names(pTHX)
31fb1209 3586{
96a5add6
AL		 3587 PERL_UNUSED_CONTEXT;
3588 return (char **)PL_op_name;
31fb1209
NIS		 3589}
3590
1cb0ed9b 3591char **
864dbfa3 3592Perl_get_op_descs(pTHX)
31fb1209 3593{
96a5add6
AL		 3594 PERL_UNUSED_CONTEXT;
3595 return (char **)PL_op_desc;
31fb1209 3596}
9e6b2b00 3597
e1ec3a88 3598const char *
864dbfa3 3599Perl_get_no_modify(pTHX)
9e6b2b00 3600{
96a5add6
AL		 3601 PERL_UNUSED_CONTEXT;
3602 return PL_no_modify;
9e6b2b00
GS		 3603}
3604
3605U32 *
864dbfa3 3606Perl_get_opargs(pTHX)
9e6b2b00 3607{
96a5add6
AL		 3608 PERL_UNUSED_CONTEXT;
3609 return (U32 *)PL_opargs;
9e6b2b00 3610}
51aa15f3 3611
0cb96387
GS		 3612PPADDR_t*
3613Perl_get_ppaddr(pTHX)
3614{
96a5add6
AL		 3615 dVAR;
3616 PERL_UNUSED_CONTEXT;
3617 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 3618}
3619
a6c40364
GS		 3620#ifndef HAS_GETENV_LEN
3621char *
bf4acbe4 3622Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3623{
8772537c 3624 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3625 PERL_UNUSED_CONTEXT;
7918f24d 3626 PERL_ARGS_ASSERT_GETENV_LEN;
a6c40364
GS		 3627 if (env_trans)
3628 *len = strlen(env_trans);
3629 return env_trans;
f675dbe5
CB		 3630}
3631#endif
3632
dc9e4912
GS		 3633
3634MGVTBL*
864dbfa3 3635Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3636{
96a5add6 3637 PERL_UNUSED_CONTEXT;
dc9e4912 3638
c7fdacb9 3639 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
31114fe9 3640 ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
dc9e4912
GS		 3641}
3642
767df6a1 3643I32
864dbfa3 3644Perl_my_fflush_all(pTHX)
767df6a1 3645{
97cb92d6 3646#if defined(USE_PERLIO) || defined(FFLUSH_NULL)
ce720889 3647 return PerlIO_flush(NULL);
767df6a1 3648#else
8fbdfb7c 3649# if defined(HAS__FWALK)
f13a2bc0 3650 extern int fflush(FILE *);
74cac757
JH		 3651 /* undocumented, unprototyped, but very useful BSDism */
3652 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3653 _fwalk(&fflush);
74cac757 3654 return 0;
8fa7f367 3655# else
8fbdfb7c 3656# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3657 long open_max = -1;
8fbdfb7c 3658# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3659 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3660# else
8fa7f367 3661# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3662 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3663# else
3664# ifdef FOPEN_MAX
74cac757 3665 open_max = FOPEN_MAX;
8fa7f367
JH		 3666# else
3667# ifdef OPEN_MAX
74cac757 3668 open_max = OPEN_MAX;
8fa7f367
JH		 3669# else
3670# ifdef _NFILE
d2201af2 3671 open_max = _NFILE;
8fa7f367
JH		 3672# endif
3673# endif
74cac757 3674# endif
767df6a1
JH		 3675# endif
3676# endif
767df6a1
JH		 3677 if (open_max > 0) {
3678 long i;
3679 for (i = 0; i < open_max; i++)
d2201af2
AD		 3680 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3681 STDIO_STREAM_ARRAY[i]._file < open_max &&
3682 STDIO_STREAM_ARRAY[i]._flag)
3683 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3684 return 0;
3685 }
8fbdfb7c 3686# endif
93189314 3687 SETERRNO(EBADF,RMS_IFI);
767df6a1 3688 return EOF;
74cac757 3689# endif
767df6a1
JH		 3690#endif
3691}
097ee67d 3692
69282e91 3693void
45219de6 3694Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
a5390457
NC		 3695{
3696 if (ckWARN(WARN_IO)) {
0223a801 3697 HEK * const name
c6e4ff34 3698 = gv && (isGV_with_GP(gv))
0223a801 3699 ? GvENAME_HEK((gv))
3b46b707 3700 : NULL;
a5390457
NC		 3701 const char * const direction = have == '>' ? "out" : "in";
3702
b3c81598 3703 if (name && HEK_LEN(name))
a5390457 3704 Perl_warner(aTHX_ packWARN(WARN_IO),
147e3846 3705 "Filehandle %" HEKf " opened only for %sput",
10bafe90 3706 HEKfARG(name), direction);
a5390457
NC		 3707 else
3708 Perl_warner(aTHX_ packWARN(WARN_IO),
3709 "Filehandle opened only for %sput", direction);
3710 }
3711}
3712
3713void
831e4cc3 3714Perl_report_evil_fh(pTHX_ const GV *gv)
bc37a18f 3715{
65820a28 3716 const IO *io = gv ? GvIO(gv) : NULL;
831e4cc3 3717 const PERL_BITFIELD16 op = PL_op->op_type;
a5390457
NC		 3718 const char *vile;
3719 I32 warn_type;
3720
65820a28 3721 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
a5390457
NC		 3722 vile = "closed";
3723 warn_type = WARN_CLOSED;
2dd78f96
JH		 3724 }
3725 else {
a5390457
NC		 3726 vile = "unopened";
3727 warn_type = WARN_UNOPENED;
3728 }
3729
3730 if (ckWARN(warn_type)) {
3b46b707 3731 SV * const name
5c5c5f45 3732 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3b46b707 3733 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
a5390457
NC		 3734 const char * const pars =
3735 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3736 const char * const func =
3737 (const char *)
d955f84c
FC		 3738 (op == OP_READLINE || op == OP_RCATLINE
3739 ? "readline" : /* "<HANDLE>" not nice */
a5390457 3740 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
a5390457
NC		 3741 PL_op_desc[op]);
3742 const char * const type =
3743 (const char *)
65820a28 3744 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
a5390457 3745 ? "socket" : "filehandle");
1e00d6e9 3746 const bool have_name = name && SvCUR(name);
65d99836 3747 Perl_warner(aTHX_ packWARN(warn_type),
147e3846 3748 "%s%s on %s %s%s%" SVf, func, pars, vile, type,
65d99836
FC		 3749 have_name ? " " : "",
3750 SVfARG(have_name ? name : &PL_sv_no));
3751 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
a5390457
NC		 3752 Perl_warner(
3753 aTHX_ packWARN(warn_type),
147e3846 3754 "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",
65d99836
FC		 3755 func, pars, have_name ? " " : "",
3756 SVfARG(have_name ? name : &PL_sv_no)
a5390457 3757 );
bc37a18f 3758 }
69282e91 3759}
a926ef6b 3760
f6adc668 3761/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH		 3762 * system to give us a reasonable struct to copy. This fix means that
3763 * strftime uses the tm_zone and tm_gmtoff values returned by
3764 * localtime(time()). That should give the desired result most of the
3765 * time. But probably not always!
3766 *
f6adc668
JH		 3767 * This does not address tzname aspects of NETaa14816.
3768 *
e72cf795 3769 */
f6adc668 3770
61b27c87 3771#ifdef __GLIBC__
e72cf795
JH		 3772# ifndef STRUCT_TM_HASZONE
3773# define STRUCT_TM_HASZONE
3774# endif
3775#endif
3776
f6adc668
JH		 3777#ifdef STRUCT_TM_HASZONE /* Backward compat */
3778# ifndef HAS_TM_TM_ZONE
3779# define HAS_TM_TM_ZONE
3780# endif
3781#endif
3782
e72cf795 3783void
f1208910 3784Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3785{
f6adc668 3786#ifdef HAS_TM_TM_ZONE
e72cf795 3787 Time_t now;
1b6737cc 3788 const struct tm* my_tm;
dc3bf405 3789 PERL_UNUSED_CONTEXT;
7918f24d 3790 PERL_ARGS_ASSERT_INIT_TM;
e72cf795 3791 (void)time(&now);
82c57498 3792 my_tm = localtime(&now);
ca46b8ee
SP		 3793 if (my_tm)
3794 Copy(my_tm, ptm, 1, struct tm);
1b6737cc 3795#else
dc3bf405 3796 PERL_UNUSED_CONTEXT;
7918f24d 3797 PERL_ARGS_ASSERT_INIT_TM;
1b6737cc 3798 PERL_UNUSED_ARG(ptm);
e72cf795
JH		 3799#endif
3800}
3801
3802/*
3803 * mini_mktime - normalise struct tm values without the localtime()
3804 * semantics (and overhead) of mktime().
3805 */
3806void
ddeaf645 3807Perl_mini_mktime(struct tm *ptm)
e72cf795
JH		 3808{
3809 int yearday;
3810 int secs;
3811 int month, mday, year, jday;
3812 int odd_cent, odd_year;
3813
7918f24d
NC		 3814 PERL_ARGS_ASSERT_MINI_MKTIME;
3815
e72cf795
JH		 3816#define DAYS_PER_YEAR 365
3817#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3818#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3819#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3820#define SECS_PER_HOUR (60*60)
3821#define SECS_PER_DAY (24*SECS_PER_HOUR)
3822/* parentheses deliberately absent on these two, otherwise they don't work */
3823#define MONTH_TO_DAYS 153/5
3824#define DAYS_TO_MONTH 5/153
3825/* offset to bias by March (month 4) 1st between month/mday & year finding */
3826#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3827/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3828#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3829
3830/*
3831 * Year/day algorithm notes:
3832 *
3833 * With a suitable offset for numeric value of the month, one can find
3834 * an offset into the year by considering months to have 30.6 (153/5) days,
3835 * using integer arithmetic (i.e., with truncation). To avoid too much
3836 * messing about with leap days, we consider January and February to be
3837 * the 13th and 14th month of the previous year. After that transformation,
3838 * we need the month index we use to be high by 1 from 'normal human' usage,
3839 * so the month index values we use run from 4 through 15.
3840 *
3841 * Given that, and the rules for the Gregorian calendar (leap years are those
3842 * divisible by 4 unless also divisible by 100, when they must be divisible
3843 * by 400 instead), we can simply calculate the number of days since some
3844 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3845 * the days we derive from our month index, and adding in the day of the
3846 * month. The value used here is not adjusted for the actual origin which
3847 * it normally would use (1 January A.D. 1), since we're not exposing it.
3848 * We're only building the value so we can turn around and get the
3849 * normalised values for the year, month, day-of-month, and day-of-year.
3850 *
3851 * For going backward, we need to bias the value we're using so that we find
3852 * the right year value. (Basically, we don't want the contribution of
3853 * March 1st to the number to apply while deriving the year). Having done
3854 * that, we 'count up' the contribution to the year number by accounting for
3855 * full quadracenturies (400-year periods) with their extra leap days, plus
3856 * the contribution from full centuries (to avoid counting in the lost leap
3857 * days), plus the contribution from full quad-years (to count in the normal
3858 * leap days), plus the leftover contribution from any non-leap years.
3859 * At this point, if we were working with an actual leap day, we'll have 0
3860 * days left over. This is also true for March 1st, however. So, we have
3861 * to special-case that result, and (earlier) keep track of the 'odd'
3862 * century and year contributions. If we got 4 extra centuries in a qcent,
3863 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3864 * Otherwise, we add back in the earlier bias we removed (the 123 from
3865 * figuring in March 1st), find the month index (integer division by 30.6),
3866 * and the remainder is the day-of-month. We then have to convert back to
3867 * 'real' months (including fixing January and February from being 14/15 in
3868 * the previous year to being in the proper year). After that, to get
3869 * tm_yday, we work with the normalised year and get a new yearday value for
3870 * January 1st, which we subtract from the yearday value we had earlier,
3871 * representing the date we've re-built. This is done from January 1
3872 * because tm_yday is 0-origin.
3873 *
3874 * Since POSIX time routines are only guaranteed to work for times since the
3875 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3876 * applies Gregorian calendar rules even to dates before the 16th century
3877 * doesn't bother me. Besides, you'd need cultural context for a given
3878 * date to know whether it was Julian or Gregorian calendar, and that's
3879 * outside the scope for this routine. Since we convert back based on the
3880 * same rules we used to build the yearday, you'll only get strange results
3881 * for input which needed normalising, or for the 'odd' century years which
486ec47a 3882 * were leap years in the Julian calendar but not in the Gregorian one.
e72cf795
JH		 3883 * I can live with that.
3884 *
3885 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3886 * that's still outside the scope for POSIX time manipulation, so I don't
3887 * care.
3888 */
3889
3890 year = 1900 + ptm->tm_year;
3891 month = ptm->tm_mon;
3892 mday = ptm->tm_mday;
a64f08cb 3893 jday = 0;
e72cf795
JH		 3894 if (month >= 2)
3895 month+=2;
3896 else
3897 month+=14, year--;
3898 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3899 yearday += month*MONTH_TO_DAYS + mday + jday;
3900 /*
3901 * Note that we don't know when leap-seconds were or will be,
3902 * so we have to trust the user if we get something which looks
3903 * like a sensible leap-second. Wild values for seconds will
3904 * be rationalised, however.
3905 */
3906 if ((unsigned) ptm->tm_sec <= 60) {
3907 secs = 0;
3908 }
3909 else {
3910 secs = ptm->tm_sec;
3911 ptm->tm_sec = 0;
3912 }
3913 secs += 60 * ptm->tm_min;
3914 secs += SECS_PER_HOUR * ptm->tm_hour;
3915 if (secs < 0) {
3916 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3917 /* got negative remainder, but need positive time */
3918 /* back off an extra day to compensate */
3919 yearday += (secs/SECS_PER_DAY)-1;
3920 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3921 }
3922 else {
3923 yearday += (secs/SECS_PER_DAY);
3924 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3925 }
3926 }
3927 else if (secs >= SECS_PER_DAY) {
3928 yearday += (secs/SECS_PER_DAY);
3929 secs %= SECS_PER_DAY;
3930 }
3931 ptm->tm_hour = secs/SECS_PER_HOUR;
3932 secs %= SECS_PER_HOUR;
3933 ptm->tm_min = secs/60;
3934 secs %= 60;
3935 ptm->tm_sec += secs;
3936 /* done with time of day effects */
3937 /*
3938 * The algorithm for yearday has (so far) left it high by 428.
3939 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3940 * bias it by 123 while trying to figure out what year it
3941 * really represents. Even with this tweak, the reverse
3942 * translation fails for years before A.D. 0001.
3943 * It would still fail for Feb 29, but we catch that one below.
3944 */
3945 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3946 yearday -= YEAR_ADJUST;
3947 year = (yearday / DAYS_PER_QCENT) * 400;
3948 yearday %= DAYS_PER_QCENT;
3949 odd_cent = yearday / DAYS_PER_CENT;
3950 year += odd_cent * 100;
3951 yearday %= DAYS_PER_CENT;
3952 year += (yearday / DAYS_PER_QYEAR) * 4;
3953 yearday %= DAYS_PER_QYEAR;
3954 odd_year = yearday / DAYS_PER_YEAR;
3955 year += odd_year;
3956 yearday %= DAYS_PER_YEAR;
3957 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3958 month = 1;
3959 yearday = 29;
3960 }
3961 else {
3962 yearday += YEAR_ADJUST; /* recover March 1st crock */
3963 month = yearday*DAYS_TO_MONTH;
3964 yearday -= month*MONTH_TO_DAYS;
3965 /* recover other leap-year adjustment */
3966 if (month > 13) {
3967 month-=14;
3968 year++;
3969 }
3970 else {
3971 month-=2;
3972 }
3973 }
3974 ptm->tm_year = year - 1900;
3975 if (yearday) {
3976 ptm->tm_mday = yearday;
3977 ptm->tm_mon = month;
3978 }
3979 else {
3980 ptm->tm_mday = 31;
3981 ptm->tm_mon = month - 1;
3982 }
3983 /* re-build yearday based on Jan 1 to get tm_yday */
3984 year--;
3985 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3986 yearday += 14*MONTH_TO_DAYS + 1;
3987 ptm->tm_yday = jday - yearday;
a64f08cb 3988 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
e72cf795 3989}
b3c85772
JH		 3990
3991char *
e1ec3a88 3992Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
b3c85772
JH		 3993{
3994#ifdef HAS_STRFTIME
4c17e999
KW		 3995
3996 /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */
3997
b3c85772
JH		 3998 char *buf;
3999 int buflen;
4000 struct tm mytm;
4001 int len;
4002
7918f24d
NC		 4003 PERL_ARGS_ASSERT_MY_STRFTIME;
4004
b3c85772
JH		 4005 init_tm(&mytm); /* XXX workaround - see init_tm() above */
4006 mytm.tm_sec = sec;
4007 mytm.tm_min = min;
4008 mytm.tm_hour = hour;
4009 mytm.tm_mday = mday;
4010 mytm.tm_mon = mon;
4011 mytm.tm_year = year;
4012 mytm.tm_wday = wday;
4013 mytm.tm_yday = yday;
4014 mytm.tm_isdst = isdst;
4015 mini_mktime(&mytm);
c473feec
SR		 4016 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4017#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4018 STMT_START {
4019 struct tm mytm2;
4020 mytm2 = mytm;
4021 mktime(&mytm2);
4022#ifdef HAS_TM_TM_GMTOFF
4023 mytm.tm_gmtoff = mytm2.tm_gmtoff;
4024#endif
4025#ifdef HAS_TM_TM_ZONE
4026 mytm.tm_zone = mytm2.tm_zone;
4027#endif
4028 } STMT_END;
4029#endif
b3c85772 4030 buflen = 64;
a02a5408 4031 Newx(buf, buflen, char);
5d37acd6
DM		 4032
4033 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
b3c85772 4034 len = strftime(buf, buflen, fmt, &mytm);
5d37acd6
DM		 4035 GCC_DIAG_RESTORE;
4036
b3c85772 4037 /*
877f6a72 4038 ** The following is needed to handle to the situation where
b3c85772
JH		 4039 ** tmpbuf overflows. Basically we want to allocate a buffer
4040 ** and try repeatedly. The reason why it is so complicated
4041 ** is that getting a return value of 0 from strftime can indicate
4042 ** one of the following:
4043 ** 1. buffer overflowed,
4044 ** 2. illegal conversion specifier, or
4045 ** 3. the format string specifies nothing to be returned(not
4046 ** an error). This could be because format is an empty string
4047 ** or it specifies %p that yields an empty string in some locale.
4048 ** If there is a better way to make it portable, go ahead by
4049 ** all means.
4050 */
4051 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4052 return buf;
4053 else {
4054 /* Possibly buf overflowed - try again with a bigger buf */
e1ec3a88 4055 const int fmtlen = strlen(fmt);
7743c307 4056 int bufsize = fmtlen + buflen;
877f6a72 4057
c4bc4aaa 4058 Renew(buf, bufsize, char);
b3c85772 4059 while (buf) {
5d37acd6
DM		 4060
4061 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
b3c85772 4062 buflen = strftime(buf, bufsize, fmt, &mytm);
5d37acd6
DM		 4063 GCC_DIAG_RESTORE;
4064
b3c85772
JH		 4065 if (buflen > 0 && buflen < bufsize)
4066 break;
4067 /* heuristic to prevent out-of-memory errors */
4068 if (bufsize > 100*fmtlen) {
4069 Safefree(buf);
4070 buf = NULL;
4071 break;
4072 }
7743c307
SH		 4073 bufsize *= 2;
4074 Renew(buf, bufsize, char);
b3c85772
JH		 4075 }
4076 return buf;
4077 }
4078#else
4079 Perl_croak(aTHX_ "panic: no strftime");
27da23d5 4080 return NULL;
b3c85772
JH		 4081#endif
4082}
4083
877f6a72
NIS		 4084
4085#define SV_CWD_RETURN_UNDEF \
e03e82a0
DM		 4086 sv_set_undef(sv); \
4087 return FALSE
877f6a72
NIS		 4088
4089#define SV_CWD_ISDOT(dp) \
4090 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3aed30dc 4091 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
877f6a72
NIS		 4092
4093/*
ccfc67b7
JH		 4094=head1 Miscellaneous Functions
4095
89423764 4096=for apidoc getcwd_sv
877f6a72 4097
796b6530 4098Fill C<sv> with current working directory
877f6a72
NIS		 4099
4100=cut
4101*/
4102
4103/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4104 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4105 * getcwd(3) if available
f6bab5f6 4106 * Comments from the original:
877f6a72
NIS		 4107 * This is a faster version of getcwd. It's also more dangerous
4108 * because you might chdir out of a directory that you can't chdir
4109 * back into. */
4110
877f6a72 4111int
5aaab254 4112Perl_getcwd_sv(pTHX_ SV *sv)
877f6a72
NIS		 4113{
4114#ifndef PERL_MICRO
ea715489 4115 SvTAINTED_on(sv);
ea715489 4116
7918f24d
NC		 4117 PERL_ARGS_ASSERT_GETCWD_SV;
4118
8f95b30d
JH		 4119#ifdef HAS_GETCWD
4120 {
60e110a8
DM		 4121 char buf[MAXPATHLEN];
4122
3aed30dc 4123 /* Some getcwd()s automatically allocate a buffer of the given
60e110a8
DM		 4124 * size from the heap if they are given a NULL buffer pointer.
4125 * The problem is that this behaviour is not portable. */
3aed30dc 4126 if (getcwd(buf, sizeof(buf) - 1)) {
42d9b98d 4127 sv_setpv(sv, buf);
3aed30dc
HS		 4128 return TRUE;
4129 }
4130 else {
e03e82a0 4131 SV_CWD_RETURN_UNDEF;
3aed30dc 4132 }
8f95b30d
JH		 4133 }
4134
4135#else
4136
c623ac67 4137 Stat_t statbuf;
877f6a72 4138 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4373e329 4139 int pathlen=0;
877f6a72 4140 Direntry_t *dp;
877f6a72 4141
862a34c6 4142 SvUPGRADE(sv, SVt_PV);
877f6a72 4143
877f6a72 4144 if (PerlLIO_lstat(".", &statbuf) < 0) {
3aed30dc 4145 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 4146 }
4147
4148 orig_cdev = statbuf.st_dev;
4149 orig_cino = statbuf.st_ino;
4150 cdev = orig_cdev;
4151 cino = orig_cino;
4152
4153 for (;;) {
4373e329 4154 DIR *dir;
f56ed502 4155 int namelen;
3aed30dc
HS		 4156 odev = cdev;
4157 oino = cino;
4158
4159 if (PerlDir_chdir("..") < 0) {
4160 SV_CWD_RETURN_UNDEF;
4161 }
4162 if (PerlLIO_stat(".", &statbuf) < 0) {
4163 SV_CWD_RETURN_UNDEF;
4164 }
4165
4166 cdev = statbuf.st_dev;
4167 cino = statbuf.st_ino;
4168
4169 if (odev == cdev && oino == cino) {
4170 break;
4171 }
4172 if (!(dir = PerlDir_open("."))) {
4173 SV_CWD_RETURN_UNDEF;
4174 }
4175
4176 while ((dp = PerlDir_read(dir)) != NULL) {
877f6a72 4177#ifdef DIRNAMLEN
f56ed502 4178 namelen = dp->d_namlen;
877f6a72 4179#else
f56ed502 4180 namelen = strlen(dp->d_name);
877f6a72 4181#endif
3aed30dc
HS		 4182 /* skip . and .. */
4183 if (SV_CWD_ISDOT(dp)) {
4184 continue;
4185 }
4186
4187 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4188 SV_CWD_RETURN_UNDEF;
4189 }
4190
4191 tdev = statbuf.st_dev;
4192 tino = statbuf.st_ino;
4193 if (tino == oino && tdev == odev) {
4194 break;
4195 }
cb5953d6
JH		 4196 }
4197
3aed30dc
HS		 4198 if (!dp) {
4199 SV_CWD_RETURN_UNDEF;
4200 }
4201
4202 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4203 SV_CWD_RETURN_UNDEF;
4204 }
877f6a72 4205
3aed30dc
HS		 4206 SvGROW(sv, pathlen + namelen + 1);
4207
4208 if (pathlen) {
4209 /* shift down */
95a20fc0 4210 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3aed30dc 4211 }
877f6a72 4212
3aed30dc
HS		 4213 /* prepend current directory to the front */
4214 *SvPVX(sv) = '/';
4215 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4216 pathlen += (namelen + 1);
877f6a72
NIS		 4217
4218#ifdef VOID_CLOSEDIR
3aed30dc 4219 PerlDir_close(dir);
877f6a72 4220#else
3aed30dc
HS		 4221 if (PerlDir_close(dir) < 0) {
4222 SV_CWD_RETURN_UNDEF;
4223 }
877f6a72
NIS		 4224#endif
4225 }
4226
60e110a8 4227 if (pathlen) {
3aed30dc
HS		 4228 SvCUR_set(sv, pathlen);
4229 *SvEND(sv) = '\0';
4230 SvPOK_only(sv);
877f6a72 4231
95a20fc0 4232 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3aed30dc
HS		 4233 SV_CWD_RETURN_UNDEF;
4234 }
877f6a72
NIS		 4235 }
4236 if (PerlLIO_stat(".", &statbuf) < 0) {
3aed30dc 4237 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 4238 }
4239
4240 cdev = statbuf.st_dev;
4241 cino = statbuf.st_ino;
4242
4243 if (cdev != orig_cdev || cino != orig_cino) {
3aed30dc
HS		 4244 Perl_croak(aTHX_ "Unstable directory path, "
4245 "current directory changed unexpectedly");
877f6a72 4246 }
877f6a72
NIS		 4247
4248 return TRUE;
793b8d8e
JH		 4249#endif
4250
877f6a72
NIS		 4251#else
4252 return FALSE;
4253#endif
4254}
4255
abc6d738 4256#include "vutil.c"
ad63d80f 4257
c95c94b1 4258#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
2bc69dc4
NIS		 4259# define EMULATE_SOCKETPAIR_UDP
4260#endif
4261
4262#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee
NC		 4263static int
4264S_socketpair_udp (int fd[2]) {
e10bb1e9 4265 dTHX;
02fc2eee
NC		 4266 /* Fake a datagram socketpair using UDP to localhost. */
4267 int sockets[2] = {-1, -1};
4268 struct sockaddr_in addresses[2];
4269 int i;
3aed30dc 4270 Sock_size_t size = sizeof(struct sockaddr_in);
ae92b34e 4271 unsigned short port;
02fc2eee
NC		 4272 int got;
4273
3aed30dc 4274 memset(&addresses, 0, sizeof(addresses));
02fc2eee
NC		 4275 i = 1;
4276 do {
3aed30dc
HS		 4277 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4278 if (sockets[i] == -1)
4279 goto tidy_up_and_fail;
4280
4281 addresses[i].sin_family = AF_INET;
4282 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4283 addresses[i].sin_port = 0; /* kernel choses port. */
4284 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4285 sizeof(struct sockaddr_in)) == -1)
4286 goto tidy_up_and_fail;
02fc2eee
NC		 4287 } while (i--);
4288
4289 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4290 for each connect the other socket to it. */
4291 i = 1;
4292 do {
3aed30dc
HS		 4293 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4294 &size) == -1)
4295 goto tidy_up_and_fail;
4296 if (size != sizeof(struct sockaddr_in))
4297 goto abort_tidy_up_and_fail;
4298 /* !1 is 0, !0 is 1 */
4299 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4300 sizeof(struct sockaddr_in)) == -1)
4301 goto tidy_up_and_fail;
02fc2eee
NC		 4302 } while (i--);
4303
4304 /* Now we have 2 sockets connected to each other. I don't trust some other
4305 process not to have already sent a packet to us (by random) so send
4306 a packet from each to the other. */
4307 i = 1;
4308 do {
3aed30dc
HS		 4309 /* I'm going to send my own port number. As a short.
4310 (Who knows if someone somewhere has sin_port as a bitfield and needs
4311 this routine. (I'm assuming crays have socketpair)) */
4312 port = addresses[i].sin_port;
4313 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4314 if (got != sizeof(port)) {
4315 if (got == -1)
4316 goto tidy_up_and_fail;
4317 goto abort_tidy_up_and_fail;
4318 }
02fc2eee
NC		 4319 } while (i--);
4320
4321 /* Packets sent. I don't trust them to have arrived though.
4322 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4323 connect to localhost will use a second kernel thread. In 2.6 the
4324 first thread running the connect() returns before the second completes,
4325 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4326 returns 0. Poor programs have tripped up. One poor program's authors'
4327 had a 50-1 reverse stock split. Not sure how connected these were.)
4328 So I don't trust someone not to have an unpredictable UDP stack.
4329 */
4330
4331 {
3aed30dc
HS		 4332 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4333 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4334 fd_set rset;
4335
4336 FD_ZERO(&rset);
ea407a0c
NC		 4337 FD_SET((unsigned int)sockets[0], &rset);
4338 FD_SET((unsigned int)sockets[1], &rset);
3aed30dc
HS		 4339
4340 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4341 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4342 || !FD_ISSET(sockets[1], &rset)) {
4343 /* I hope this is portable and appropriate. */
4344 if (got == -1)
4345 goto tidy_up_and_fail;
4346 goto abort_tidy_up_and_fail;
4347 }
02fc2eee 4348 }
f4758303 4349
02fc2eee
NC		 4350 /* And the paranoia department even now doesn't trust it to have arrive
4351 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4352 {
3aed30dc
HS		 4353 struct sockaddr_in readfrom;
4354 unsigned short buffer[2];
02fc2eee 4355
3aed30dc
HS		 4356 i = 1;
4357 do {
02fc2eee 4358#ifdef MSG_DONTWAIT
3aed30dc
HS		 4359 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4360 sizeof(buffer), MSG_DONTWAIT,
4361 (struct sockaddr *) &readfrom, &size);
02fc2eee 4362#else
3aed30dc
HS		 4363 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4364 sizeof(buffer), 0,
4365 (struct sockaddr *) &readfrom, &size);
e10bb1e9 4366#endif
02fc2eee 4367
3aed30dc
HS		 4368 if (got == -1)
4369 goto tidy_up_and_fail;
4370 if (got != sizeof(port)
4371 || size != sizeof(struct sockaddr_in)
4372 /* Check other socket sent us its port. */
4373 || buffer[0] != (unsigned short) addresses[!i].sin_port
4374 /* Check kernel says we got the datagram from that socket */
4375 || readfrom.sin_family != addresses[!i].sin_family
4376 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4377 || readfrom.sin_port != addresses[!i].sin_port)
4378 goto abort_tidy_up_and_fail;
4379 } while (i--);
02fc2eee
NC		 4380 }
4381 /* My caller (my_socketpair) has validated that this is non-NULL */
4382 fd[0] = sockets[0];
4383 fd[1] = sockets[1];
4384 /* I hereby declare this connection open. May God bless all who cross
4385 her. */
4386 return 0;
4387
4388 abort_tidy_up_and_fail:
4389 errno = ECONNABORTED;
4390 tidy_up_and_fail:
4391 {
4ee39169 4392 dSAVE_ERRNO;
3aed30dc
HS		 4393 if (sockets[0] != -1)
4394 PerlLIO_close(sockets[0]);
4395 if (sockets[1] != -1)
4396 PerlLIO_close(sockets[1]);
4ee39169 4397 RESTORE_ERRNO;
3aed30dc 4398 return -1;
02fc2eee
NC		 4399 }
4400}
85ca448a 4401#endif /* EMULATE_SOCKETPAIR_UDP */
02fc2eee 4402
b5ac89c3 4403#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
02fc2eee
NC		 4404int
4405Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4406 /* Stevens says that family must be AF_LOCAL, protocol 0.
2948e0bd 4407 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
2bcd6579 4408 dTHXa(NULL);
02fc2eee
NC		 4409 int listener = -1;
4410 int connector = -1;
4411 int acceptor = -1;
4412 struct sockaddr_in listen_addr;
4413 struct sockaddr_in connect_addr;
4414 Sock_size_t size;
4415
50458334
JH		 4416 if (protocol
4417#ifdef AF_UNIX
4418 || family != AF_UNIX
4419#endif
3aed30dc
HS		 4420 ) {
4421 errno = EAFNOSUPPORT;
4422 return -1;
02fc2eee 4423 }
2948e0bd 4424 if (!fd) {
3aed30dc
HS		 4425 errno = EINVAL;
4426 return -1;
2948e0bd 4427 }
02fc2eee 4428
2bc69dc4 4429#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee 4430 if (type == SOCK_DGRAM)
3aed30dc 4431 return S_socketpair_udp(fd);
2bc69dc4 4432#endif
02fc2eee 4433
2bcd6579 4434 aTHXa(PERL_GET_THX);
3aed30dc 4435 listener = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4436 if (listener == -1)
3aed30dc
HS		 4437 return -1;
4438 memset(&listen_addr, 0, sizeof(listen_addr));
02fc2eee 4439 listen_addr.sin_family = AF_INET;
3aed30dc 4440 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
02fc2eee 4441 listen_addr.sin_port = 0; /* kernel choses port. */
3aed30dc
HS		 4442 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4443 sizeof(listen_addr)) == -1)
4444 goto tidy_up_and_fail;
e10bb1e9 4445 if (PerlSock_listen(listener, 1) == -1)
3aed30dc 4446 goto tidy_up_and_fail;
02fc2eee 4447
3aed30dc 4448 connector = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4449 if (connector == -1)
3aed30dc 4450 goto tidy_up_and_fail;
02fc2eee 4451 /* We want to find out the port number to connect to. */
3aed30dc
HS		 4452 size = sizeof(connect_addr);
4453 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4454 &size) == -1)
4455 goto tidy_up_and_fail;
4456 if (size != sizeof(connect_addr))
4457 goto abort_tidy_up_and_fail;
e10bb1e9 4458 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
3aed30dc
HS		 4459 sizeof(connect_addr)) == -1)
4460 goto tidy_up_and_fail;
02fc2eee 4461
3aed30dc
HS		 4462 size = sizeof(listen_addr);
4463 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4464 &size);
02fc2eee 4465 if (acceptor == -1)
3aed30dc
HS		 4466 goto tidy_up_and_fail;
4467 if (size != sizeof(listen_addr))
4468 goto abort_tidy_up_and_fail;
4469 PerlLIO_close(listener);
02fc2eee
NC		 4470 /* Now check we are talking to ourself by matching port and host on the
4471 two sockets. */
3aed30dc
HS		 4472 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4473 &size) == -1)
4474 goto tidy_up_and_fail;
4475 if (size != sizeof(connect_addr)
4476 || listen_addr.sin_family != connect_addr.sin_family
4477 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4478 || listen_addr.sin_port != connect_addr.sin_port) {
4479 goto abort_tidy_up_and_fail;
02fc2eee
NC		 4480 }
4481 fd[0] = connector;
4482 fd[1] = acceptor;
4483 return 0;
4484
4485 abort_tidy_up_and_fail:
27da23d5
JH		 4486#ifdef ECONNABORTED
4487 errno = ECONNABORTED; /* This would be the standard thing to do. */
4488#else
4489# ifdef ECONNREFUSED
4490 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4491# else
4492 errno = ETIMEDOUT; /* Desperation time. */
4493# endif
4494#endif
02fc2eee
NC		 4495 tidy_up_and_fail:
4496 {
4ee39169 4497 dSAVE_ERRNO;
3aed30dc
HS		 4498 if (listener != -1)
4499 PerlLIO_close(listener);
4500 if (connector != -1)
4501 PerlLIO_close(connector);
4502 if (acceptor != -1)
4503 PerlLIO_close(acceptor);
4ee39169 4504 RESTORE_ERRNO;
3aed30dc 4505 return -1;
02fc2eee
NC		 4506 }
4507}
85ca448a 4508#else
48ea76d1 4509/* In any case have a stub so that there's code corresponding
d500e60d 4510 * to the my_socketpair in embed.fnc. */
48ea76d1
JH		 4511int
4512Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
daf16542 4513#ifdef HAS_SOCKETPAIR
48ea76d1 4514 return socketpair(family, type, protocol, fd);
daf16542
JH		 4515#else
4516 return -1;
4517#endif
48ea76d1
JH		 4518}
4519#endif
4520
68795e93
NIS		 4521/*
4522
4523=for apidoc sv_nosharing
4524
4525Dummy routine which "shares" an SV when there is no sharing module present.
72d33970
FC		 4526Or "locks" it. Or "unlocks" it. In other
4527words, ignores its single SV argument.
796b6530 4528Exists to avoid test for a C<NULL> function pointer and because it could
d5b2b27b 4529potentially warn under some level of strict-ness.
68795e93
NIS		 4530
4531=cut
4532*/
4533
4534void
4535Perl_sv_nosharing(pTHX_ SV *sv)
4536{
96a5add6 4537 PERL_UNUSED_CONTEXT;
53c1dcc0 4538 PERL_UNUSED_ARG(sv);
68795e93
NIS		 4539}
4540
eba16661
JH		 4541/*
4542
4543=for apidoc sv_destroyable
4544
4545Dummy routine which reports that object can be destroyed when there is no
4546sharing module present. It ignores its single SV argument, and returns
796b6530 4547'true'. Exists to avoid test for a C<NULL> function pointer and because it
eba16661
JH		 4548could potentially warn under some level of strict-ness.
4549
4550=cut
4551*/
4552
4553bool
4554Perl_sv_destroyable(pTHX_ SV *sv)
4555{
4556 PERL_UNUSED_CONTEXT;
4557 PERL_UNUSED_ARG(sv);
4558 return TRUE;
4559}
4560
a05d7ebb 4561U32
e1ec3a88 4562Perl_parse_unicode_opts(pTHX_ const char **popt)
a05d7ebb 4563{
e1ec3a88 4564 const char *p = *popt;
a05d7ebb
JH		 4565 U32 opt = 0;
4566
7918f24d
NC		 4567 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4568
a05d7ebb
JH		 4569 if (*p) {
4570 if (isDIGIT(*p)) {
96e440d2 4571 const char* endptr;
22ff3130 4572 UV uv;
89d84ff9 4573 if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
22ff3130 4574 opt = (U32)uv;
89d84ff9
HS		 4575 p = endptr;
4576 if (p && *p && *p != '\n' && *p != '\r') {
4577 if (isSPACE(*p))
4578 goto the_end_of_the_opts_parser;
4579 else
4580 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4581 }
22ff3130 4582 }
817e3e2c
TC		 4583 else {
4584 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
4585 }
22ff3130
HS		 4586 }
4587 else {
a05d7ebb
JH		 4588 for (; *p; p++) {
4589 switch (*p) {
4590 case PERL_UNICODE_STDIN:
4591 opt |= PERL_UNICODE_STDIN_FLAG; break;
4592 case PERL_UNICODE_STDOUT:
4593 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4594 case PERL_UNICODE_STDERR:
4595 opt |= PERL_UNICODE_STDERR_FLAG; break;
4596 case PERL_UNICODE_STD:
4597 opt |= PERL_UNICODE_STD_FLAG; break;
4598 case PERL_UNICODE_IN:
4599 opt |= PERL_UNICODE_IN_FLAG; break;
4600 case PERL_UNICODE_OUT:
4601 opt |= PERL_UNICODE_OUT_FLAG; break;
4602 case PERL_UNICODE_INOUT:
4603 opt |= PERL_UNICODE_INOUT_FLAG; break;
4604 case PERL_UNICODE_LOCALE:
4605 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4606 case PERL_UNICODE_ARGV:
4607 opt |= PERL_UNICODE_ARGV_FLAG; break;
5a22a2bb
NC		 4608 case PERL_UNICODE_UTF8CACHEASSERT:
4609 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
a05d7ebb 4610 default:
d4a59e54
FC		 4611 if (*p != '\n' && *p != '\r') {
4612 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4613 else
7c91f477
JH		 4614 Perl_croak(aTHX_
4615 "Unknown Unicode option letter '%c'", *p);
d4a59e54 4616 }
a05d7ebb
JH		 4617 }
4618 }
4619 }
4620 }
4621 else
4622 opt = PERL_UNICODE_DEFAULT_FLAGS;
4623
d4a59e54
FC		 4624 the_end_of_the_opts_parser:
4625
a05d7ebb 4626 if (opt & ~PERL_UNICODE_ALL_FLAGS)
147e3846 4627 Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
a05d7ebb
JH		 4628 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4629
4630 *popt = p;
4631
4632 return opt;
4633}
4634
25bbd826
CB		 4635#ifdef VMS
4636# include <starlet.h>
4637#endif
4638
132efe8b
JH		 4639U32
4640Perl_seed(pTHX)
4641{
4642 /*
4643 * This is really just a quick hack which grabs various garbage
4644 * values. It really should be a real hash algorithm which
4645 * spreads the effect of every input bit onto every output bit,
4646 * if someone who knows about such things would bother to write it.
4647 * Might be a good idea to add that function to CORE as well.
4648 * No numbers below come from careful analysis or anything here,
4649 * except they are primes and SEED_C1 > 1E6 to get a full-width
4650 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4651 * probably be bigger too.
4652 */
4653#if RANDBITS > 16
4654# define SEED_C1 1000003
4655#define SEED_C4 73819
4656#else
4657# define SEED_C1 25747
4658#define SEED_C4 20639
4659#endif
4660#define SEED_C2 3
4661#define SEED_C3 269
4662#define SEED_C5 26107
4663
4664#ifndef PERL_NO_DEV_RANDOM
4665 int fd;
4666#endif
4667 U32 u;
95a8bf05 4668#ifdef HAS_GETTIMEOFDAY
132efe8b 4669 struct timeval when;
95a8bf05 4670#else
132efe8b 4671 Time_t when;
132efe8b
JH		 4672#endif
4673
4674/* This test is an escape hatch, this symbol isn't set by Configure. */
4675#ifndef PERL_NO_DEV_RANDOM
4676#ifndef PERL_RANDOM_DEVICE
4677 /* /dev/random isn't used by default because reads from it will block
4678 * if there isn't enough entropy available. You can compile with
4679 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4680 * is enough real entropy to fill the seed. */
afa49a03
AB		 4681# ifdef __amigaos4__
4682# define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4683# else
4684# define PERL_RANDOM_DEVICE "/dev/urandom"
4685# endif
132efe8b
JH		 4686#endif
4687 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4688 if (fd != -1) {
27da23d5 4689 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
132efe8b
JH		 4690 u = 0;
4691 PerlLIO_close(fd);
4692 if (u)
4693 return u;
4694 }
4695#endif
4696
95a8bf05 4697#ifdef HAS_GETTIMEOFDAY
132efe8b
JH		 4698 PerlProc_gettimeofday(&when,NULL);
4699 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
95a8bf05 4700#else
132efe8b
JH		 4701 (void)time(&when);
4702 u = (U32)SEED_C1 * when;
132efe8b
JH		 4703#endif
4704 u += SEED_C3 * (U32)PerlProc_getpid();
4705 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4706#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4707 u += SEED_C5 * (U32)PTR2UV(&when);
4708#endif
4709 return u;
4710}
4711
7dc86639 4712void
a2098e20 4713Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
bed60192 4714{
a2098e20
YO		 4715 const char *env_pv;
4716 unsigned long i;
7dc86639
YO		 4717
4718 PERL_ARGS_ASSERT_GET_HASH_SEED;
bed60192 4719
a2098e20 4720 env_pv= PerlEnv_getenv("PERL_HASH_SEED");
7dc86639 4721
a2098e20 4722 if ( env_pv )
7dc86639
YO		 4723#ifndef USE_HASH_SEED_EXPLICIT
4724 {
a2098e20
YO		 4725 /* ignore leading spaces */
4726 while (isSPACE(*env_pv))
4727 env_pv++;
6a5b4183 4728#ifdef USE_PERL_PERTURB_KEYS
a2098e20
YO		 4729 /* if they set it to "0" we disable key traversal randomization completely */
4730 if (strEQ(env_pv,"0")) {
6a5b4183
YO		 4731 PL_hash_rand_bits_enabled= 0;
4732 } else {
a2098e20 4733 /* otherwise switch to deterministic mode */
6a5b4183
YO		 4734 PL_hash_rand_bits_enabled= 2;
4735 }
4736#endif
a2098e20
YO		 4737 /* ignore a leading 0x... if it is there */
4738 if (env_pv[0] == '0' && env_pv[1] == 'x')
4739 env_pv += 2;
bed60192 4740
a2098e20
YO		 4741 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4742 seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4743 if ( isXDIGIT(*env_pv)) {
4744 seed_buffer[i] |= READ_XDIGIT(env_pv);
7dc86639 4745 }
7dc86639 4746 }
a2098e20
YO		 4747 while (isSPACE(*env_pv))
4748 env_pv++;
4749
4750 if (*env_pv && !isXDIGIT(*env_pv)) {
aac486f1 4751 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
73cf895c 4752 }
7dc86639 4753 /* should we check for unparsed crap? */
a2098e20
YO		 4754 /* should we warn about unused hex? */
4755 /* should we warn about insufficient hex? */
7dc86639
YO		 4756 }
4757 else
4758#endif
4759 {
4760 (void)seedDrand01((Rand_seed_t)seed());
4761
a2098e20
YO		 4762 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4763 seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
7dc86639 4764 }
0e0ab621 4765 }
6a5b4183 4766#ifdef USE_PERL_PERTURB_KEYS
0e0ab621
YO		 4767 { /* initialize PL_hash_rand_bits from the hash seed.
4768 * This value is highly volatile, it is updated every
4769 * hash insert, and is used as part of hash bucket chain
4770 * randomization and hash iterator randomization. */
a2098e20 4771 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
0e0ab621 4772 for( i = 0; i < sizeof(UV) ; i++ ) {
6a5b4183
YO		 4773 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4774 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
0e0ab621
YO		 4775 }
4776 }
a2098e20
YO		 4777 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4778 if (env_pv) {
4779 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
6a5b4183 4780 PL_hash_rand_bits_enabled= 0;
a2098e20 4781 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
6a5b4183 4782 PL_hash_rand_bits_enabled= 1;
a2098e20 4783 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
6a5b4183
YO		 4784 PL_hash_rand_bits_enabled= 2;
4785 } else {
a2098e20 4786 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
6a5b4183
YO		 4787 }
4788 }
4789#endif
bed60192 4790}
27da23d5
JH		 4791
4792#ifdef PERL_GLOBAL_STRUCT
4793
bae1192d
JH		 4794#define PERL_GLOBAL_STRUCT_INIT
4795#include "opcode.h" /* the ppaddr and check */
4796
27da23d5
JH		 4797struct perl_vars *
4798Perl_init_global_struct(pTHX)
4799{
4800 struct perl_vars *plvarsp = NULL;
bae1192d 4801# ifdef PERL_GLOBAL_STRUCT
c3caa5c3
JH		 4802 const IV nppaddr = C_ARRAY_LENGTH(Gppaddr);
4803 const IV ncheck = C_ARRAY_LENGTH(Gcheck);
23491f1d 4804 PERL_UNUSED_CONTEXT;
27da23d5
JH		 4805# ifdef PERL_GLOBAL_STRUCT_PRIVATE
4806 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4807 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4808 if (!plvarsp)
4809 exit(1);
4810# else
4811 plvarsp = PL_VarsPtr;
4812# endif /* PERL_GLOBAL_STRUCT_PRIVATE */
aadb217d
JH		 4813# undef PERLVAR
4814# undef PERLVARA
4815# undef PERLVARI
4816# undef PERLVARIC
115ff745
NC		 4817# define PERLVAR(prefix,var,type) /**/
4818# define PERLVARA(prefix,var,n,type) /**/
4819# define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
4820# define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
27da23d5
JH		 4821# include "perlvars.h"
4822# undef PERLVAR
4823# undef PERLVARA
4824# undef PERLVARI
4825# undef PERLVARIC
27da23d5 4826# ifdef PERL_GLOBAL_STRUCT
bae1192d
JH		 4827 plvarsp->Gppaddr =
4828 (Perl_ppaddr_t*)
4829 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
27da23d5
JH		 4830 if (!plvarsp->Gppaddr)
4831 exit(1);
bae1192d
JH		 4832 plvarsp->Gcheck =
4833 (Perl_check_t*)
4834 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
27da23d5
JH		 4835 if (!plvarsp->Gcheck)
4836 exit(1);
4837 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4838 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4839# endif
4840# ifdef PERL_SET_VARS
4841 PERL_SET_VARS(plvarsp);
4842# endif
5c64bffd
NC		 4843# ifdef PERL_GLOBAL_STRUCT_PRIVATE
4844 plvarsp->Gsv_placeholder.sv_flags = 0;
4845 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
4846# endif
bae1192d
JH		 4847# undef PERL_GLOBAL_STRUCT_INIT
4848# endif
27da23d5
JH		 4849 return plvarsp;
4850}
4851
4852#endif /* PERL_GLOBAL_STRUCT */
4853
4854#ifdef PERL_GLOBAL_STRUCT
4855
4856void
4857Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4858{
c1181d2b
DM		 4859 int veto = plvarsp->Gveto_cleanup;
4860
7918f24d 4861 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
23491f1d 4862 PERL_UNUSED_CONTEXT;
bae1192d 4863# ifdef PERL_GLOBAL_STRUCT
27da23d5
JH		 4864# ifdef PERL_UNSET_VARS
4865 PERL_UNSET_VARS(plvarsp);
4866# endif
c1181d2b
DM		 4867 if (veto)
4868 return;
27da23d5
JH		 4869 free(plvarsp->Gppaddr);
4870 free(plvarsp->Gcheck);
bae1192d 4871# ifdef PERL_GLOBAL_STRUCT_PRIVATE
27da23d5 4872 free(plvarsp);
bae1192d
JH		 4873# endif
4874# endif
27da23d5
JH		 4875}
4876
4877#endif /* PERL_GLOBAL_STRUCT */
4878
fe4f188c
JH		 4879#ifdef PERL_MEM_LOG
4880
22ff3130 4881/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
73d1d973
JC		 4882 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4883 * given, and you supply your own implementation.
65ceff02 4884 *
2e5b5004 4885 * The default implementation reads a single env var, PERL_MEM_LOG,
1cd8acb5
JC		 4886 * expecting one or more of the following:
4887 *
22ff3130 4888 * \d+ - fd fd to write to : must be 1st (grok_atoUV)
2e5b5004 4889 * 'm' - memlog was PERL_MEM_LOG=1
1cd8acb5
JC		 4890 * 's' - svlog was PERL_SV_LOG=1
4891 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
0b0ab801 4892 *
1cd8acb5
JC		 4893 * This makes the logger controllable enough that it can reasonably be
4894 * added to the system perl.
65ceff02
JH		 4895 */
4896
1cd8acb5 4897/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
65ceff02
JH		 4898 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4899 */
e352bcff
JH		 4900#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4901
1cd8acb5
JC		 4902/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4903 * writes to. In the default logger, this is settable at runtime.
65ceff02
JH		 4904 */
4905#ifndef PERL_MEM_LOG_FD
4906# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4907#endif
4908
73d1d973 4909#ifndef PERL_MEM_LOG_NOIMPL
d7a2c63c
MHM		 4910
4911# ifdef DEBUG_LEAKING_SCALARS
4912# define SV_LOG_SERIAL_FMT " [%lu]"
4913# define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
4914# else
4915# define SV_LOG_SERIAL_FMT
4916# define _SV_LOG_SERIAL_ARG(sv)
4917# endif
4918
0b0ab801 4919static void
73d1d973
JC		 4920S_mem_log_common(enum mem_log_type mlt, const UV n,
4921 const UV typesize, const char *type_name, const SV *sv,
4922 Malloc_t oldalloc, Malloc_t newalloc,
4923 const char *filename, const int linenumber,
4924 const char *funcname)
0b0ab801 4925{
1cd8acb5 4926 const char *pmlenv;
4ca7bcef 4927
1cd8acb5 4928 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
4ca7bcef 4929
1cd8acb5
JC		 4930 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
4931 if (!pmlenv)
4932 return;
4933 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
65ceff02
JH		 4934 {
4935 /* We can't use SVs or PerlIO for obvious reasons,
4936 * so we'll use stdio and low-level IO instead. */
4937 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
1cd8acb5 4938
5b692037 4939# ifdef HAS_GETTIMEOFDAY
0b0ab801
MHM		 4940# define MEM_LOG_TIME_FMT "%10d.%06d: "
4941# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
4942 struct timeval tv;
65ceff02 4943 gettimeofday(&tv, 0);
0b0ab801
MHM		 4944# else
4945# define MEM_LOG_TIME_FMT "%10d: "
4946# define MEM_LOG_TIME_ARG (int)when
4947 Time_t when;
4948 (void)time(&when);
5b692037
JH		 4949# endif
4950 /* If there are other OS specific ways of hires time than
d0b0e707 4951 * gettimeofday() (see dist/Time-HiRes), the easiest way is
5b692037
JH		 4952 * probably that they would be used to fill in the struct
4953 * timeval. */
65ceff02 4954 {
0b0ab801 4955 STRLEN len;
96e440d2 4956 const char* endptr;
22ff3130
HS		 4957 int fd;
4958 UV uv;
4959 if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
4960 && uv && uv <= PERL_INT_MAX
4961 ) {
4962 fd = (int)uv;
4963 } else {
1cd8acb5 4964 fd = PERL_MEM_LOG_FD;
22ff3130 4965 }
0b0ab801 4966
1cd8acb5 4967 if (strchr(pmlenv, 't')) {
0b0ab801
MHM		 4968 len = my_snprintf(buf, sizeof(buf),
4969 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
acfd4d8e 4970 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
0b0ab801 4971 }
0b0ab801
MHM		 4972 switch (mlt) {
4973 case MLT_ALLOC:
4974 len = my_snprintf(buf, sizeof(buf),
147e3846
KW		 4975 "alloc: %s:%d:%s: %" IVdf " %" UVuf
4976 " %s = %" IVdf ": %" UVxf "\n",
0b0ab801 4977 filename, linenumber, funcname, n, typesize,
bef8a128 4978 type_name, n * typesize, PTR2UV(newalloc));
0b0ab801
MHM		 4979 break;
4980 case MLT_REALLOC:
4981 len = my_snprintf(buf, sizeof(buf),
147e3846
KW		 4982 "realloc: %s:%d:%s: %" IVdf " %" UVuf
4983 " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",
0b0ab801 4984 filename, linenumber, funcname, n, typesize,
bef8a128 4985 type_name, n * typesize, PTR2UV(oldalloc),
0b0ab801
MHM		 4986 PTR2UV(newalloc));
4987 break;
4988 case MLT_FREE:
4989 len = my_snprintf(buf, sizeof(buf),
147e3846 4990 "free: %s:%d:%s: %" UVxf "\n",
0b0ab801
MHM		 4991 filename, linenumber, funcname,
4992 PTR2UV(oldalloc));
4993 break;
d7a2c63c
MHM		 4994 case MLT_NEW_SV:
4995 case MLT_DEL_SV:
4996 len = my_snprintf(buf, sizeof(buf),
147e3846 4997 "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",
d7a2c63c
MHM		 4998 mlt == MLT_NEW_SV ? "new" : "del",
4999 filename, linenumber, funcname,
5000 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5001 break;
73d1d973
JC		 5002 default:
5003 len = 0;
0b0ab801 5004 }
acfd4d8e 5005 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
65ceff02
JH		 5006 }
5007 }
0b0ab801 5008}
73d1d973
JC		 5009#endif /* !PERL_MEM_LOG_NOIMPL */
5010
5011#ifndef PERL_MEM_LOG_NOIMPL
5012# define \
5013 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5014 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5015#else
5016/* this is suboptimal, but bug compatible. User is providing their
486ec47a 5017 own implementation, but is getting these functions anyway, and they
73d1d973
JC		 5018 do nothing. But _NOIMPL users should be able to cope or fix */
5019# define \
5020 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5021 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
0b0ab801
MHM		 5022#endif
5023
5024Malloc_t
73d1d973
JC		 5025Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5026 Malloc_t newalloc,
5027 const char *filename, const int linenumber,
5028 const char *funcname)
5029{
6fb87544
MH		 5030 PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
5031
73d1d973
JC		 5032 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5033 NULL, NULL, newalloc,
5034 filename, linenumber, funcname);
fe4f188c
JH		 5035 return newalloc;
5036}
5037
5038Malloc_t
73d1d973
JC		 5039Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5040 Malloc_t oldalloc, Malloc_t newalloc,
5041 const char *filename, const int linenumber,
5042 const char *funcname)
5043{
6fb87544
MH		 5044 PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
5045
73d1d973
JC		 5046 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5047 NULL, oldalloc, newalloc,
5048 filename, linenumber, funcname);
fe4f188c
JH		 5049 return newalloc;
5050}
5051
5052Malloc_t
73d1d973
JC		 5053Perl_mem_log_free(Malloc_t oldalloc,
5054 const char *filename, const int linenumber,
5055 const char *funcname)
fe4f188c 5056{
6fb87544
MH		 5057 PERL_ARGS_ASSERT_MEM_LOG_FREE;
5058
73d1d973
JC		 5059 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5060 filename, linenumber, funcname);
fe4f188c
JH		 5061 return oldalloc;
5062}
5063
d7a2c63c 5064void
73d1d973
JC		 5065Perl_mem_log_new_sv(const SV *sv,
5066 const char *filename, const int linenumber,
5067 const char *funcname)
d7a2c63c 5068{
73d1d973
JC		 5069 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5070 filename, linenumber, funcname);
d7a2c63c
MHM		 5071}
5072
5073void
73d1d973
JC		 5074Perl_mem_log_del_sv(const SV *sv,
5075 const char *filename, const int linenumber,
5076 const char *funcname)
d7a2c63c 5077{
73d1d973
JC		 5078 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5079 filename, linenumber, funcname);
d7a2c63c
MHM		 5080}
5081
fe4f188c
JH		 5082#endif /* PERL_MEM_LOG */
5083
66610fdd 5084/*
ce582cee
NC		 5085=for apidoc my_sprintf
5086
5087The C library C<sprintf>, wrapped if necessary, to ensure that it will return
72d33970 5088the length of the string written to the buffer. Only rare pre-ANSI systems
ce582cee
NC		 5089need the wrapper function - usually this is a direct call to C<sprintf>.
5090
5091=cut
5092*/
5093#ifndef SPRINTF_RETURNS_STRLEN
5094int
5095Perl_my_sprintf(char *buffer, const char* pat, ...)
5096{
5097 va_list args;
7918f24d 5098 PERL_ARGS_ASSERT_MY_SPRINTF;
ce582cee
NC		 5099 va_start(args, pat);
5100 vsprintf(buffer, pat, args);
5101 va_end(args);
5102 return strlen(buffer);
5103}
5104#endif
5105
d9fad198 5106/*
a4eca1d4
JH		 5107=for apidoc quadmath_format_single
5108
796b6530 5109C<quadmath_snprintf()> is very strict about its C<format> string and will
801caa78 5110fail, returning -1, if the format is invalid. It accepts exactly
a4eca1d4
JH		 5111one format spec.
5112
796b6530 5113C<quadmath_format_single()> checks that the intended single spec looks
a4eca1d4
JH		 5114sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
5115and has C<Q> before it. This is not a full "printf syntax check",
5116just the basics.
5117
5118Returns the format if it is valid, NULL if not.
5119
796b6530 5120C<quadmath_format_single()> can and will actually patch in the missing
a4eca1d4
JH		 5121C<Q>, if necessary. In this case it will return the modified copy of
5122the format, B<which the caller will need to free.>
5123
5124See also L</quadmath_format_needed>.
5125
5126=cut
5127*/
5128#ifdef USE_QUADMATH
5129const char*
5130Perl_quadmath_format_single(const char* format)
5131{
5132 STRLEN len;
5133
5134 PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE;
5135
5136 if (format[0] != '%' || strchr(format + 1, '%'))
5137 return NULL;
5138 len = strlen(format);
5139 /* minimum length three: %Qg */
5140 if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL)
5141 return NULL;
5142 if (format[len - 2] != 'Q') {
5143 char* fixed;
5144 Newx(fixed, len + 1, char);
5145 memcpy(fixed, format, len - 1);
5146 fixed[len - 1] = 'Q';
5147 fixed[len ] = format[len - 1];
5148 fixed[len + 1] = 0;
5149 return (const char*)fixed;
5150 }
5151 return format;
5152}
5153#endif
5154
5155/*
5156=for apidoc quadmath_format_needed
5157
796b6530
KW		 5158C<quadmath_format_needed()> returns true if the C<format> string seems to
5159contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
a4eca1d4
JH		 5160or returns false otherwise.
5161
5162The format specifier detection is not complete printf-syntax detection,
5163but it should catch most common cases.
5164
5165If true is returned, those arguments B<should> in theory be processed
796b6530 5166with C<quadmath_snprintf()>, but in case there is more than one such
a4eca1d4
JH		 5167format specifier (see L</quadmath_format_single>), and if there is
5168anything else beyond that one (even just a single byte), they
796b6530 5169B<cannot> be processed because C<quadmath_snprintf()> is very strict,
a4eca1d4
JH		 5170accepting only one format spec, and nothing else.
5171In this case, the code should probably fail.
5172
5173=cut
5174*/
5175#ifdef USE_QUADMATH
5176bool
5177Perl_quadmath_format_needed(const char* format)
5178{
5179 const char *p = format;
5180 const char *q;
5181
5182 PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
5183
5184 while ((q = strchr(p, '%'))) {
5185 q++;
5186 if (*q == '+') /* plus */
5187 q++;
5188 if (*q == '#') /* alt */
5189 q++;
5190 if (*q == '*') /* width */
5191 q++;
5192 else {
5193 if (isDIGIT(*q)) {
5194 while (isDIGIT(*q)) q++;
5195 }
5196 }
5197 if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
5198 q++;
5199 if (*q == '*')
5200 q++;
5201 else
5202 while (isDIGIT(*q)) q++;
5203 }
5204 if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
5205 return TRUE;
5206 p = q + 1;
5207 }
5208 return FALSE;
5209}
5210#endif
5211
5212/*
d9fad198
JH		 5213=for apidoc my_snprintf
5214
5215The C library C<snprintf> functionality, if available and
5b692037 5216standards-compliant (uses C<vsnprintf>, actually). However, if the
d9fad198 5217C<vsnprintf> is not available, will unfortunately use the unsafe
5b692037
JH		 5218C<vsprintf> which can overrun the buffer (there is an overrun check,
5219but that may be too late). Consider using C<sv_vcatpvf> instead, or
5220getting C<vsnprintf>.
d9fad198
JH		 5221
5222=cut
5223*/
5224int
5225Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
d9fad198 5226{
a4eca1d4 5227 int retval = -1;
d9fad198 5228 va_list ap;
7918f24d 5229 PERL_ARGS_ASSERT_MY_SNPRINTF;
f9adac4b
JH		 5230#ifndef HAS_VSNPRINTF
5231 PERL_UNUSED_VAR(len);
5232#endif
d9fad198 5233 va_start(ap, format);
a4eca1d4
JH		 5234#ifdef USE_QUADMATH
5235 {
5236 const char* qfmt = quadmath_format_single(format);
5237 bool quadmath_valid = FALSE;
5238 if (qfmt) {
5239 /* If the format looked promising, use it as quadmath. */
5240 retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
5241 if (retval == -1)
5242 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
5243 quadmath_valid = TRUE;
5244 if (qfmt != format)
5245 Safefree(qfmt);
5246 qfmt = NULL;
5247 }
5248 assert(qfmt == NULL);
5249 /* quadmath_format_single() will return false for example for
5250 * "foo = %g", or simply "%g". We could handle the %g by
5251 * using quadmath for the NV args. More complex cases of
5252 * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
5253 * quadmath-valid but has stuff in front).
5254 *
5255 * Handling the "Q-less" cases right would require walking
5256 * through the va_list and rewriting the format, calling
5257 * quadmath for the NVs, building a new va_list, and then
5258 * letting vsnprintf/vsprintf to take care of the other
5259 * arguments. This may be doable.
5260 *
5261 * We do not attempt that now. But for paranoia, we here try
5262 * to detect some common (but not all) cases where the
5263 * "Q-less" %[efgaEFGA] formats are present, and die if
5264 * detected. This doesn't fix the problem, but it stops the
5265 * vsnprintf/vsprintf pulling doubles off the va_list when
5266 * __float128 NVs should be pulled off instead.
5267 *
5268 * If quadmath_format_needed() returns false, we are reasonably
5269 * certain that we can call vnsprintf() or vsprintf() safely. */
5270 if (!quadmath_valid && quadmath_format_needed(format))
5271 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
5272
5273 }
5274#endif
5275 if (retval == -1)
5b692037 5276#ifdef HAS_VSNPRINTF
a4eca1d4 5277 retval = vsnprintf(buffer, len, format, ap);
d9fad198 5278#else
a4eca1d4 5279 retval = vsprintf(buffer, format, ap);
d9fad198
JH		 5280#endif
5281 va_end(ap);
7dac5c64
RB		 5282 /* vsprintf() shows failure with < 0 */
5283 if (retval < 0
5284#ifdef HAS_VSNPRINTF
5285 /* vsnprintf() shows failure with >= len */
5286 ||
5287 (len > 0 && (Size_t)retval >= len)
5288#endif
5289 )
dbf7dff6 5290 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
d9fad198
JH		 5291 return retval;
5292}
5293
5294/*
5295=for apidoc my_vsnprintf
5296
5b692037
JH		 5297The C library C<vsnprintf> if available and standards-compliant.
5298However, if if the C<vsnprintf> is not available, will unfortunately
5299use the unsafe C<vsprintf> which can overrun the buffer (there is an
5300overrun check, but that may be too late). Consider using
5301C<sv_vcatpvf> instead, or getting C<vsnprintf>.
d9fad198
JH		 5302
5303=cut
5304*/
5305int
5306Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
d9fad198 5307{
a4eca1d4
JH		 5308#ifdef USE_QUADMATH
5309 PERL_UNUSED_ARG(buffer);
5310 PERL_UNUSED_ARG(len);
5311 PERL_UNUSED_ARG(format);
bf49eae4
DM		 5312 /* the cast is to avoid gcc -Wsizeof-array-argument complaining */
5313 PERL_UNUSED_ARG((void*)ap);
a4eca1d4
JH		 5314 Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
5315 return 0;
5316#else
d9fad198 5317 int retval;
d9fad198
JH		 5318#ifdef NEED_VA_COPY
5319 va_list apc;
7918f24d
NC		 5320
5321 PERL_ARGS_ASSERT_MY_VSNPRINTF;
239fec62 5322 Perl_va_copy(ap, apc);
5b692037 5323# ifdef HAS_VSNPRINTF
d9fad198
JH		 5324 retval = vsnprintf(buffer, len, format, apc);
5325# else
52039d8f 5326 PERL_UNUSED_ARG(len);
d9fad198
JH		 5327 retval = vsprintf(buffer, format, apc);
5328# endif
d4825b27 5329 va_end(apc);
d9fad198 5330#else
5b692037 5331# ifdef HAS_VSNPRINTF
d9fad198
JH		 5332 retval = vsnprintf(buffer, len, format, ap);
5333# else
52039d8f 5334 PERL_UNUSED_ARG(len);
d9fad198
JH		 5335 retval = vsprintf(buffer, format, ap);
5336# endif
5b692037 5337#endif /* #ifdef NEED_VA_COPY */
7dac5c64
RB		 5338 /* vsprintf() shows failure with < 0 */
5339 if (retval < 0
5340#ifdef HAS_VSNPRINTF
5341 /* vsnprintf() shows failure with >= len */
5342 ||
5343 (len > 0 && (Size_t)retval >= len)
5344#endif
5345 )
dbf7dff6 5346 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
d9fad198 5347 return retval;
a4eca1d4 5348#endif
d9fad198
JH		 5349}
5350
b0269e46
AB		 5351void
5352Perl_my_clearenv(pTHX)
5353{
5354 dVAR;
5355#if ! defined(PERL_MICRO)
5356# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5357 PerlEnv_clearenv();
5358# else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5359# if defined(USE_ENVIRON_ARRAY)
5360# if defined(USE_ITHREADS)
5361 /* only the parent thread can clobber the process environment */
5362 if (PL_curinterp == aTHX)
5363# endif /* USE_ITHREADS */
5364 {
5365# if ! defined(PERL_USE_SAFE_PUTENV)
5366 if ( !PL_use_safe_putenv) {
5367 I32 i;
5368 if (environ == PL_origenviron)
5369 environ = (char**)safesysmalloc(sizeof(char*));
5370 else
5371 for (i = 0; environ[i]; i++)
5372 (void)safesysfree(environ[i]);
5373 }
5374 environ[0] = NULL;
5375# else /* PERL_USE_SAFE_PUTENV */
5376# if defined(HAS_CLEARENV)
5377 (void)clearenv();
5378# elif defined(HAS_UNSETENV)
5379 int bsiz = 80; /* Most envvar names will be shorter than this. */
a96bc635 5380 char *buf = (char*)safesysmalloc(bsiz);
b0269e46
AB		 5381 while (*environ != NULL) {
5382 char *e = strchr(*environ, '=');
b57a0404 5383 int l = e ? e - *environ : (int)strlen(*environ);
b0269e46
AB		 5384 if (bsiz < l + 1) {
5385 (void)safesysfree(buf);
1bdfa2de 5386 bsiz = l + 1; /* + 1 for the \0. */
a96bc635 5387 buf = (char*)safesysmalloc(bsiz);
b0269e46 5388 }
82d8bb49
NC		 5389 memcpy(buf, *environ, l);
5390 buf[l] = '\0';
b0269e46
AB		 5391 (void)unsetenv(buf);
5392 }
5393 (void)safesysfree(buf);
5394# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5395 /* Just null environ and accept the leakage. */
5396 *environ = NULL;
5397# endif /* HAS_CLEARENV || HAS_UNSETENV */
5398# endif /* ! PERL_USE_SAFE_PUTENV */
5399 }
5400# endif /* USE_ENVIRON_ARRAY */
5401# endif /* PERL_IMPLICIT_SYS || WIN32 */
5402#endif /* PERL_MICRO */
5403}
5404
f16dd614
DM		 5405#ifdef PERL_IMPLICIT_CONTEXT
5406
53d44271 5407/* Implements the MY_CXT_INIT macro. The first time a module is loaded,
f16dd614
DM		 5408the global PL_my_cxt_index is incremented, and that value is assigned to
5409that module's static my_cxt_index (who's address is passed as an arg).
5410Then, for each interpreter this function is called for, it makes sure a
5411void* slot is available to hang the static data off, by allocating or
5412extending the interpreter's PL_my_cxt_list array */
5413
53d44271 5414#ifndef PERL_GLOBAL_STRUCT_PRIVATE
f16dd614
DM		 5415void *
5416Perl_my_cxt_init(pTHX_ int *index, size_t size)
5417{
97aff369 5418 dVAR;
f16dd614 5419 void *p;
7918f24d 5420 PERL_ARGS_ASSERT_MY_CXT_INIT;
f16dd614
DM		 5421 if (*index == -1) {
5422 /* this module hasn't been allocated an index yet */
8703a9a4 5423#if defined(USE_ITHREADS)
f16dd614 5424 MUTEX_LOCK(&PL_my_ctx_mutex);
8703a9a4 5425#endif
f16dd614 5426 *index = PL_my_cxt_index++;
8703a9a4 5427#if defined(USE_ITHREADS)
f16dd614 5428 MUTEX_UNLOCK(&PL_my_ctx_mutex);
8703a9a4 5429#endif
f16dd614
DM		 5430 }
5431
5432 /* make sure the array is big enough */
4c901e72
DM		 5433 if (PL_my_cxt_size <= *index) {
5434 if (PL_my_cxt_size) {
5435 while (PL_my_cxt_size <= *index)
f16dd614
DM		 5436 PL_my_cxt_size *= 2;
5437 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5438 }
5439 else {
5440 PL_my_cxt_size = 16;
5441 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5442 }
5443 }
5444 /* newSV() allocates one more than needed */
5445 p = (void*)SvPVX(newSV(size-1));
5446 PL_my_cxt_list[*index] = p;
5447 Zero(p, size, char);
5448 return p;
5449}
53d44271
JH		 5450
5451#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5452
5453int
5454Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5455{
5456 dVAR;
5457 int index;
5458
7918f24d
NC		 5459 PERL_ARGS_ASSERT_MY_CXT_INDEX;
5460
53d44271
JH		 5461 for (index = 0; index < PL_my_cxt_index; index++) {
5462 const char *key = PL_my_cxt_keys[index];
5463 /* try direct pointer compare first - there are chances to success,
5464 * and it's much faster.
5465 */
5466 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5467 return index;
5468 }
5469 return -1;
5470}
5471
5472void *
5473Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5474{
5475 dVAR;
5476 void *p;
5477 int index;
5478
7918f24d
NC		 5479 PERL_ARGS_ASSERT_MY_CXT_INIT;
5480
53d44271
JH		 5481 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5482 if (index == -1) {
5483 /* this module hasn't been allocated an index yet */
8703a9a4 5484#if defined(USE_ITHREADS)
53d44271 5485 MUTEX_LOCK(&PL_my_ctx_mutex);
8703a9a4 5486#endif
53d44271 5487 index = PL_my_cxt_index++;
8703a9a4 5488#if defined(USE_ITHREADS)
53d44271 5489 MUTEX_UNLOCK(&PL_my_ctx_mutex);
8703a9a4 5490#endif
53d44271
JH		 5491 }
5492
5493 /* make sure the array is big enough */
5494 if (PL_my_cxt_size <= index) {
5495 int old_size = PL_my_cxt_size;
5496 int i;
5497 if (PL_my_cxt_size) {
5498 while (PL_my_cxt_size <= index)
5499 PL_my_cxt_size *= 2;
5500 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5501 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5502 }
5503 else {
5504 PL_my_cxt_size = 16;
5505 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5506 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5507 }
5508 for (i = old_size; i < PL_my_cxt_size; i++) {
5509 PL_my_cxt_keys[i] = 0;
5510 PL_my_cxt_list[i] = 0;
5511 }
5512 }
5513 PL_my_cxt_keys[index] = my_cxt_key;
5514 /* newSV() allocates one more than needed */
5515 p = (void*)SvPVX(newSV(size-1));
5516 PL_my_cxt_list[index] = p;
5517 Zero(p, size, char);
5518 return p;
5519}
5520#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5521#endif /* PERL_IMPLICIT_CONTEXT */
f16dd614 5522
db6e00bd 5523
5ec05c96
DM		 5524/* Perl_xs_handshake():
5525 implement the various XS_*_BOOTCHECK macros, which are added to .c
5526 files by ExtUtils::ParseXS, to check that the perl the module was built
5527 with is binary compatible with the running perl.
5528
5529 usage:
5530 Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
5531 [U32 items, U32 ax], [char * api_version], [char * xs_version])
5532
5533 The meaning of the varargs is determined the U32 key arg (which is not
5534 a format string). The fields of key are assembled by using HS_KEY().
5535
5536 Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type
5537 "PerlInterpreter *" and represents the callers context; otherwise it is
5538 of type "CV *", and is the boot xsub's CV.
5539
5540 v_my_perl will catch where a threaded future perl526.dll calling IO.dll
5541 for example, and IO.dll was linked with threaded perl524.dll, and both
5542 perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader
5543 successfully can load IO.dll into the process but simultaneously it
5544 loaded an interpreter of a different version into the process, and XS
5545 code will naturally pass SV*s created by perl524.dll for perl526.dll to
5546 use through perl526.dll's my_perl->Istack_base.
5547
5548 v_my_perl cannot be the first arg, since then 'key' will be out of
5549 place in a threaded vs non-threaded mixup; and analyzing the key
5550 number's bitfields won't reveal the problem, since it will be a valid
5551 key (unthreaded perl) on interp side, but croak will report the XS mod's
5552 key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if
5553 it's a threaded perl and an unthreaded XS module, threaded perl will
5554 look at an uninit C stack or an uninit register to get 'key'
5555 (remember that it assumes that the 1st arg is the interp cxt).
5556
5557 'file' is the source filename of the caller.
5558*/
5559
db6e00bd 5560I32
9a189793 5561Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
db6e00bd
DD		 5562{
5563 va_list args;
5564 U32 items, ax;
9a189793
DD		 5565 void * got;
5566 void * need;
db6e00bd
DD		 5567#ifdef PERL_IMPLICIT_CONTEXT
5568 dTHX;
9a189793
DD		 5569 tTHX xs_interp;
5570#else
5571 CV* cv;
5572 SV *** xs_spp;
db6e00bd
DD		 5573#endif
5574 PERL_ARGS_ASSERT_XS_HANDSHAKE;
9a189793 5575 va_start(args, file);
db6e00bd 5576
3ef6b8e9 5577 got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
9a189793 5578 need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
3ef6b8e9 5579 if (UNLIKELY(got != need))
9a189793 5580 goto bad_handshake;
db6e00bd
DD		 5581/* try to catch where a 2nd threaded perl interp DLL is loaded into a process
5582 by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
5583 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
5584 dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
5585 passed to the XS DLL */
db6e00bd 5586#ifdef PERL_IMPLICIT_CONTEXT
9a189793
DD		 5587 xs_interp = (tTHX)v_my_perl;
5588 got = xs_interp;
5589 need = my_perl;
db6e00bd
DD		 5590#else
5591/* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
5592 loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
5593 but the DynaLoder/Perl that started the process and loaded the XS DLL is
5594 unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *)
5595 through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
5596 location in the unthreaded perl binary) stored in CV * to figure out if this
5597 Perl_xs_handshake was called by the same pp_entersub */
9a189793
DD		 5598 cv = (CV*)v_my_perl;
5599 xs_spp = (SV***)CvHSCXT(cv);
5600 got = xs_spp;
5601 need = &PL_stack_sp;
5602#endif
5603 if(UNLIKELY(got != need)) {
5604 bad_handshake:/* recycle branch and string from above */
5605 if(got != (void *)HSf_NOCHK)
fe60b4f6
DM		 5606 noperl_die("%s: loadable library and perl binaries are mismatched"
5607 " (got handshake key %p, needed %p)\n",
9a189793
DD		 5608 file, got, need);
5609 }
5610
5611 if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */
5612 SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
5613 PL_xsubfilename = file; /* so the old name must be restored for
5614 additional XSUBs to register themselves */
9b669ea1
DD		 5615 /* XSUBs can't be perl lang/perl5db.pl debugged
5616 if (PERLDB_LINE_OR_SAVESRC)
5617 (void)gv_fetchfile(file); */
db6e00bd
DD		 5618 }
5619
5620 if(key & HSf_POPMARK) {
5621 ax = POPMARK;
5622 { SV **mark = PL_stack_base + ax++;
5623 { dSP;
5624 items = (I32)(SP - MARK);
5625 }
5626 }
5627 } else {
5628 items = va_arg(args, U32);
5629 ax = va_arg(args, U32);
5630 }
5631 {
5632 U32 apiverlen;
5633 assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX);
ea91b243 5634 if((apiverlen = HS_GETAPIVERLEN(key))) {
db6e00bd
DD		 5635 char * api_p = va_arg(args, char*);
5636 if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
5637 || memNE(api_p, "v" PERL_API_VERSION_STRING,
5638 sizeof("v" PERL_API_VERSION_STRING)-1))
147e3846 5639 Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s",
db6e00bd
DD		 5640 api_p, SVfARG(PL_stack_base[ax + 0]),
5641 "v" PERL_API_VERSION_STRING);
5642 }
5643 }
5644 {
5645 U32 xsverlen;
5646 assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
ea91b243 5647 if((xsverlen = HS_GETXSVERLEN(key)))
672cbd15 5648 S_xs_version_bootcheck(aTHX_
db6e00bd
DD		 5649 items, ax, va_arg(args, char*), xsverlen);
5650 }
5651 va_end(args);
5652 return ax;
5653}
5654
5ec05c96 5655
672cbd15
DD		 5656STATIC void
5657S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
e9b067d9
NC		 5658 STRLEN xs_len)
5659{
5660 SV *sv;
5661 const char *vn = NULL;
a2f871a2 5662 SV *const module = PL_stack_base[ax];
e9b067d9
NC		 5663
5664 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5665
5666 if (items >= 2) /* version supplied as bootstrap arg */
5667 sv = PL_stack_base[ax + 1];
5668 else {
5669 /* XXX GV_ADDWARN */
a2f871a2 5670 vn = "XS_VERSION";
147e3846 5671 sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
a2f871a2
NC		 5672 if (!sv || !SvOK(sv)) {
5673 vn = "VERSION";
147e3846 5674 sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
a2f871a2 5675 }
e9b067d9
NC		 5676 }
5677 if (sv) {
f9cc56fa 5678 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
573a19fb 5679 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
f9cc56fa 5680 ? sv : sv_2mortal(new_version(sv));
e9b067d9
NC		 5681 xssv = upg_version(xssv, 0);
5682 if ( vcmp(pmsv,xssv) ) {
a2f871a2 5683 SV *string = vstringify(xssv);
147e3846 5684 SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf
c1f6cd39 5685 " does not match ", SVfARG(module), SVfARG(string));
a2f871a2
NC		 5686
5687 SvREFCNT_dec(string);
5688 string = vstringify(pmsv);
5689
5690 if (vn) {
147e3846 5691 Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn,
c1f6cd39 5692 SVfARG(string));
a2f871a2 5693 } else {
147e3846 5694 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string));
a2f871a2
NC		 5695 }
5696 SvREFCNT_dec(string);
5697
e9b067d9 5698 Perl_sv_2mortal(aTHX_ xpt);
e9b067d9 5699 Perl_croak_sv(aTHX_ xpt);
f9cc56fa 5700 }
e9b067d9
NC		 5701 }
5702}
5703
f46a3253
KW		 5704/*
5705=for apidoc my_strlcat
5706
5707The C library C<strlcat> if available, or a Perl implementation of it.
6602b933 5708This operates on C C<NUL>-terminated strings.
f46a3253
KW		 5709
5710C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
6602b933 5711most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate,
f46a3253
KW		 5712unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
5713practice this should not happen as it means that either C<size> is incorrect or
6602b933 5714that C<dst> is not a proper C<NUL>-terminated string).
f46a3253
KW		 5715
5716Note that C<size> is the full size of the destination buffer and
6602b933
KW		 5717the result is guaranteed to be C<NUL>-terminated if there is room. Note that
5718room for the C<NUL> should be included in C<size>.
f46a3253 5719
6ade12da
KW		 5720The return value is the total length that C<dst> would have if C<size> is
5721sufficiently large. Thus it is the initial length of C<dst> plus the length of
5722C<src>. If C<size> is smaller than the return, the excess was not appended.
5723
f46a3253
KW		 5724=cut
5725
0baa827e 5726Description stolen from http://man.openbsd.org/strlcat.3
f46a3253 5727*/
a6cc4119
SP		 5728#ifndef HAS_STRLCAT
5729Size_t
5730Perl_my_strlcat(char *dst, const char *src, Size_t size)
5731{
5732 Size_t used, length, copy;
5733
5734 used = strlen(dst);
5735 length = strlen(src);
5736 if (size > 0 && used < size - 1) {
5737 copy = (length >= size - used) ? size - used - 1 : length;
5738 memcpy(dst + used, src, copy);
5739 dst[used + copy] = '\0';
5740 }
5741 return used + length;
5742}
5743#endif
5744
f46a3253
KW		 5745
5746/*
5747=for apidoc my_strlcpy
5748
5749The C library C<strlcpy> if available, or a Perl implementation of it.
6602b933 5750This operates on C C<NUL>-terminated strings.
f46a3253
KW		 5751
5752C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
6602b933 5753to C<dst>, C<NUL>-terminating the result if C<size> is not 0.
f46a3253 5754
6ade12da
KW		 5755The return value is the total length C<src> would be if the copy completely
5756succeeded. If it is larger than C<size>, the excess was not copied.
5757
f46a3253
KW		 5758=cut
5759
0baa827e 5760Description stolen from http://man.openbsd.org/strlcpy.3
f46a3253 5761*/
a6cc4119
SP		 5762#ifndef HAS_STRLCPY
5763Size_t
5764Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5765{
5766 Size_t length, copy;
5767
5768 length = strlen(src);
5769 if (size > 0) {
5770 copy = (length >= size) ? size - 1 : length;
5771 memcpy(dst, src, copy);
5772 dst[copy] = '\0';
5773 }
5774 return length;
5775}
5776#endif
5777
17dd9954
JH		 5778#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5779/* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5780long _ftol( double ); /* Defined by VC6 C libs. */
5781long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5782#endif
5783
a7999c08
FC		 5784PERL_STATIC_INLINE bool
5785S_gv_has_usable_name(pTHX_ GV *gv)
5786{
5787 GV **gvp;
5788 return GvSTASH(gv)
5789 && HvENAME(GvSTASH(gv))
edf4dbd2
FC		 5790 && (gvp = (GV **)hv_fetchhek(
5791 GvSTASH(gv), GvNAME_HEK(gv), 0
a7999c08
FC		 5792 ))
5793 && *gvp == gv;
5794}
5795
c51f309c
NC		 5796void
5797Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5798{
c51f309c 5799 SV * const dbsv = GvSVn(PL_DBsub);
9a9b5ec9 5800 const bool save_taint = TAINT_get;
07004ebb 5801
107c452c
FC		 5802 /* When we are called from pp_goto (svp is null),
5803 * we do not care about using dbsv to call CV;
c51f309c
NC		 5804 * it's for informational purposes only.
5805 */
5806
7918f24d
NC		 5807 PERL_ARGS_ASSERT_GET_DB_SUB;
5808
284167a5 5809 TAINT_set(FALSE);
c51f309c
NC		 5810 save_item(dbsv);
5811 if (!PERLDB_SUB_NN) {
be1cc451 5812 GV *gv = CvGV(cv);
c51f309c 5813
e0a18850 5814 if (!svp && !CvLEXICAL(cv)) {
7d8b4ed3
FC		 5815 gv_efullname3(dbsv, gv, NULL);
5816 }
e0a18850 5817 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv)
c51f309c 5818 || strEQ(GvNAME(gv), "END")
a7999c08
FC		 5819 || ( /* Could be imported, and old sub redefined. */
5820 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
5821 &&
159b6efe 5822 !( (SvTYPE(*svp) == SVt_PVGV)
be1cc451 5823 && (GvCV((const GV *)*svp) == cv)
a7999c08 5824 /* Use GV from the stack as a fallback. */
4aaab439 5825 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
be1cc451
FC		 5826 )
5827 )
7d8b4ed3 5828 ) {
c51f309c 5829 /* GV is potentially non-unique, or contain different CV. */
daba3364 5830 SV * const tmp = newRV(MUTABLE_SV(cv));
c51f309c
NC		 5831 sv_setsv(dbsv, tmp);
5832 SvREFCNT_dec(tmp);
5833 }
5834 else {
a7999c08
FC		 5835 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
5836 sv_catpvs(dbsv, "::");
f34d8cdd 5837 sv_cathek(dbsv, GvNAME_HEK(gv));
c51f309c
NC		 5838 }
5839 }
5840 else {
5841 const int type = SvTYPE(dbsv);
5842 if (type < SVt_PVIV && type != SVt_IV)
5843 sv_upgrade(dbsv, SVt_PVIV);
5844 (void)SvIOK_on(dbsv);
5845 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5846 }
90a04aed 5847 SvSETMAGIC(dbsv);
07004ebb 5848 TAINT_IF(save_taint);
9a9b5ec9
DM		 5849#ifdef NO_TAINT_SUPPORT
5850 PERL_UNUSED_VAR(save_taint);
5851#endif
c51f309c
NC		 5852}
5853
3497a01f 5854int
ddeaf645 5855Perl_my_dirfd(DIR * dir) {
3497a01f
SP		 5856
5857 /* Most dirfd implementations have problems when passed NULL. */
5858 if(!dir)
5859 return -1;
5860#ifdef HAS_DIRFD
5861 return dirfd(dir);
5862#elif defined(HAS_DIR_DD_FD)
5863 return dir->dd_fd;
5864#else
ddeaf645 5865 Perl_croak_nocontext(PL_no_func, "dirfd");
661d43c4 5866 NOT_REACHED; /* NOTREACHED */
3497a01f
SP		 5867 return 0;
5868#endif
5869}
5870
f7e71195
AB		 5871REGEXP *
5872Perl_get_re_arg(pTHX_ SV *sv) {
f7e71195
AB		 5873
5874 if (sv) {
5875 if (SvMAGICAL(sv))
5876 mg_get(sv);
df052ff8
BM		 5877 if (SvROK(sv))
5878 sv = MUTABLE_SV(SvRV(sv));
5879 if (SvTYPE(sv) == SVt_REGEXP)
5880 return (REGEXP*) sv;
f7e71195
AB		 5881 }
5882
5883 return NULL;
5884}
5885
ce582cee 5886/*
3be8f094
TC		 5887 * This code is derived from drand48() implementation from FreeBSD,
5888 * found in lib/libc/gen/_rand48.c.
5889 *
5890 * The U64 implementation is original, based on the POSIX
5891 * specification for drand48().
5892 */
5893
5894/*
5895* Copyright (c) 1993 Martin Birgmeier
5896* All rights reserved.
5897*
5898* You may redistribute unmodified or modified versions of this source
5899* code provided that the above copyright notice and this and the
5900* following conditions are retained.
5901*
5902* This software is provided ``as is'', and comes with no warranties
5903* of any kind. I shall in no event be liable for anything that happens
5904* to anyone/anything when using this software.
5905*/
5906
5907#define FREEBSD_DRAND48_SEED_0 (0x330e)
5908
5909#ifdef PERL_DRAND48_QUAD
5910
7ace1b59 5911#define DRAND48_MULT U64_CONST(0x5deece66d)
3be8f094 5912#define DRAND48_ADD 0xb
7ace1b59 5913#define DRAND48_MASK U64_CONST(0xffffffffffff)
3be8f094
TC		 5914
5915#else
5916
5917#define FREEBSD_DRAND48_SEED_1 (0xabcd)
5918#define FREEBSD_DRAND48_SEED_2 (0x1234)
5919#define FREEBSD_DRAND48_MULT_0 (0xe66d)
5920#define FREEBSD_DRAND48_MULT_1 (0xdeec)
5921#define FREEBSD_DRAND48_MULT_2 (0x0005)
5922#define FREEBSD_DRAND48_ADD (0x000b)
5923
5924const unsigned short _rand48_mult[3] = {
5925 FREEBSD_DRAND48_MULT_0,
5926 FREEBSD_DRAND48_MULT_1,
5927 FREEBSD_DRAND48_MULT_2
5928};
5929const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
5930
5931#endif
5932
5933void
5934Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
5935{
5936 PERL_ARGS_ASSERT_DRAND48_INIT_R;
5937
5938#ifdef PERL_DRAND48_QUAD
702c92eb 5939 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16);
3be8f094
TC		 5940#else
5941 random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
5942 random_state->seed[1] = (U16) seed;
5943 random_state->seed[2] = (U16) (seed >> 16);
5944#endif
5945}
5946
5947double
5948Perl_drand48_r(perl_drand48_t *random_state)
5949{
5950 PERL_ARGS_ASSERT_DRAND48_R;
5951
5952#ifdef PERL_DRAND48_QUAD
5953 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
5954 & DRAND48_MASK;
5955
0f246720 5956 return ldexp((double)*random_state, -48);
3be8f094 5957#else
63835f79 5958 {
3be8f094
TC		 5959 U32 accu;
5960 U16 temp[2];
5961
5962 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
5963 + (U32) _rand48_add;
5964 temp[0] = (U16) accu; /* lower 16 bits */
5965 accu >>= sizeof(U16) * 8;
5966 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
5967 + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
5968 temp[1] = (U16) accu; /* middle 16 bits */
5969 accu >>= sizeof(U16) * 8;
5970 accu += _rand48_mult[0] * random_state->seed[2]
5971 + _rand48_mult[1] * random_state->seed[1]
5972 + _rand48_mult[2] * random_state->seed[0];
5973 random_state->seed[0] = temp[0];
5974 random_state->seed[1] = temp[1];
5975 random_state->seed[2] = (U16) accu;
5976
5977 return ldexp((double) random_state->seed[0], -48) +
5978 ldexp((double) random_state->seed[1], -32) +
5979 ldexp((double) random_state->seed[2], -16);
63835f79 5980 }
3be8f094
TC		 5981#endif
5982}
2c6ee1a7 5983
470dd224
JH		 5984#ifdef USE_C_BACKTRACE
5985
5986/* Possibly move all this USE_C_BACKTRACE code into a new file. */
5987
5988#ifdef USE_BFD
5989
5990typedef struct {
0762e42f 5991 /* abfd is the BFD handle. */
470dd224 5992 bfd* abfd;
0762e42f 5993 /* bfd_syms is the BFD symbol table. */
470dd224 5994 asymbol** bfd_syms;
0762e42f 5995 /* bfd_text is handle to the the ".text" section of the object file. */
470dd224
JH		 5996 asection* bfd_text;
5997 /* Since opening the executable and scanning its symbols is quite
5998 * heavy operation, we remember the filename we used the last time,
5999 * and do the opening and scanning only if the filename changes.
6000 * This removes most (but not all) open+scan cycles. */
6001 const char* fname_prev;
6002} bfd_context;
6003
6004/* Given a dl_info, update the BFD context if necessary. */
6005static void bfd_update(bfd_context* ctx, Dl_info* dl_info)
6006{
6007 /* BFD open and scan only if the filename changed. */
6008 if (ctx->fname_prev == NULL ||
6009 strNE(dl_info->dli_fname, ctx->fname_prev)) {
a1684041
JH		 6010 if (ctx->abfd) {
6011 bfd_close(ctx->abfd);
6012 }
470dd224
JH		 6013 ctx->abfd = bfd_openr(dl_info->dli_fname, 0);
6014 if (ctx->abfd) {
6015 if (bfd_check_format(ctx->abfd, bfd_object)) {
6016 IV symbol_size = bfd_get_symtab_upper_bound(ctx->abfd);
6017 if (symbol_size > 0) {
6018 Safefree(ctx->bfd_syms);
6019 Newx(ctx->bfd_syms, symbol_size, asymbol*);
6020 ctx->bfd_text =
6021 bfd_get_section_by_name(ctx->abfd, ".text");
6022 }
6023 else
6024 ctx->abfd = NULL;
6025 }
6026 else
6027 ctx->abfd = NULL;
6028 }
6029 ctx->fname_prev = dl_info->dli_fname;
6030 }
6031}
6032
6033/* Given a raw frame, try to symbolize it and store
6034 * symbol information (source file, line number) away. */
6035static void bfd_symbolize(bfd_context* ctx,
6036 void* raw_frame,
6037 char** symbol_name,
6038 STRLEN* symbol_name_size,
6039 char** source_name,
6040 STRLEN* source_name_size,
6041 STRLEN* source_line)
6042{
6043 *symbol_name = NULL;
6044 *symbol_name_size = 0;
6045 if (ctx->abfd) {
6046 IV offset = PTR2IV(raw_frame) - PTR2IV(ctx->bfd_text->vma);
6047 if (offset > 0 &&
6048 bfd_canonicalize_symtab(ctx->abfd, ctx->bfd_syms) > 0) {
6049 const char *file;
6050 const char *func;
6051 unsigned int line = 0;
6052 if (bfd_find_nearest_line(ctx->abfd, ctx->bfd_text,
6053 ctx->bfd_syms, offset,
6054 &file, &func, &line) &&
6055 file && func && line > 0) {
6056 /* Size and copy the source file, use only
6057 * the basename of the source file.
6058 *
6059 * NOTE: the basenames are fine for the
6060 * Perl source files, but may not always
6061 * be the best idea for XS files. */
6062 const char *p, *b = NULL;
6063 /* Look for the last slash. */
6064 for (p = file; *p; p++) {
6065 if (*p == '/')
6066 b = p + 1;
6067 }
6068 if (b == NULL || *b == 0) {
6069 b = file;
6070 }
6071 *source_name_size = p - b + 1;
6072 Newx(*source_name, *source_name_size + 1, char);
6073 Copy(b, *source_name, *source_name_size + 1, char);
6074
6075 *symbol_name_size = strlen(func);
6076 Newx(*symbol_name, *symbol_name_size + 1, char);
6077 Copy(func, *symbol_name, *symbol_name_size + 1, char);
6078
6079 *source_line = line;
6080 }
6081 }
6082 }
6083}
6084
6085#endif /* #ifdef USE_BFD */
6086
6087#ifdef PERL_DARWIN
6088
6089/* OS X has no public API for for 'symbolicating' (Apple official term)
6090 * stack addresses to {function_name, source_file, line_number}.
6091 * Good news: there is command line utility atos(1) which does that.
6092 * Bad news 1: it's a command line utility.
6093 * Bad news 2: one needs to have the Developer Tools installed.
6094 * Bad news 3: in newer releases it needs to be run as 'xcrun atos'.
6095 *
6096 * To recap: we need to open a pipe for reading for a utility which
6097 * might not exist, or exists in different locations, and then parse
6098 * the output. And since this is all for a low-level API, we cannot
6099 * use high-level stuff. Thanks, Apple. */
6100
6101typedef struct {
0762e42f
JH		 6102 /* tool is set to the absolute pathname of the tool to use:
6103 * xcrun or atos. */
470dd224 6104 const char* tool;
0762e42f
JH		 6105 /* format is set to a printf format string used for building
6106 * the external command to run. */
470dd224 6107 const char* format;
0762e42f
JH		 6108 /* unavail is set if e.g. xcrun cannot be found, or something
6109 * else happens that makes getting the backtrace dubious. Note,
6110 * however, that the context isn't persistent, the next call to
6111 * get_c_backtrace() will start from scratch. */
470dd224 6112 bool unavail;
0762e42f 6113 /* fname is the current object file name. */
470dd224 6114 const char* fname;
0762e42f 6115 /* object_base_addr is the base address of the shared object. */
470dd224
JH		 6116 void* object_base_addr;
6117} atos_context;
6118
6119/* Given |dl_info|, updates the context. If the context has been
6120 * marked unavailable, return immediately. If not but the tool has
6121 * not been set, set it to either "xcrun atos" or "atos" (also set the
6122 * format to use for creating commands for piping), or if neither is
6123 * unavailable (one needs the Developer Tools installed), mark the context
6124 * an unavailable. Finally, update the filename (object name),
6125 * and its base address. */
6126
6127static void atos_update(atos_context* ctx,
6128 Dl_info* dl_info)
6129{
6130 if (ctx->unavail)
6131 return;
6132 if (ctx->tool == NULL) {
6133 const char* tools[] = {
6134 "/usr/bin/xcrun",
6135 "/usr/bin/atos"
6136 };
6137 const char* formats[] = {
6138 "/usr/bin/xcrun atos -o '%s' -l %08x %08x 2>&1",
6139 "/usr/bin/atos -d -o '%s' -l %08x %08x 2>&1"
6140 };
6141 struct stat st;
6142 UV i;
6143 for (i = 0; i < C_ARRAY_LENGTH(tools); i++) {
6144 if (stat(tools[i], &st) == 0 && S_ISREG(st.st_mode)) {
6145 ctx->tool = tools[i];
6146 ctx->format = formats[i];
6147 break;
6148 }
6149 }
6150 if (ctx->tool == NULL) {
6151 ctx->unavail = TRUE;
6152 return;
6153 }
6154 }
6155 if (ctx->fname == NULL ||
6156 strNE(dl_info->dli_fname, ctx->fname)) {
6157 ctx->fname = dl_info->dli_fname;
6158 ctx->object_base_addr = dl_info->dli_fbase;
6159 }
6160}
6161
6162/* Given an output buffer end |p| and its |start|, matches
6163 * for the atos output, extracting the source code location
96e440d2 6164 * and returning non-NULL if possible, returning NULL otherwise. */
470dd224
JH		 6165static const char* atos_parse(const char* p,
6166 const char* start,
6167 STRLEN* source_name_size,
6168 STRLEN* source_line) {
96e440d2 6169 /* atos() output is something like:
470dd224
JH		 6170 * perl_parse (in miniperl) (perl.c:2314)\n\n".
6171 * We cannot use Perl regular expressions, because we need to
6172 * stay low-level. Therefore here we have a rolled-out version
6173 * of a state machine which matches _backwards_from_the_end_ and
6174 * if there's a success, returns the starts of the filename,
6175 * also setting the filename size and the source line number.
6176 * The matched regular expression is roughly "\(.*:\d+\)\s*$" */
6177 const char* source_number_start;
6178 const char* source_name_end;
96e440d2
JH		 6179 const char* source_line_end;
6180 const char* close_paren;
22ff3130
HS		 6181 UV uv;
6182
470dd224
JH		 6183 /* Skip trailing whitespace. */
6184 while (p > start && isspace(*p)) p--;
6185 /* Now we should be at the close paren. */
6186 if (p == start || *p != ')')
6187 return NULL;
96e440d2 6188 close_paren = p;
470dd224
JH		 6189 p--;
6190 /* Now we should be in the line number. */
6191 if (p == start || !isdigit(*p))
6192 return NULL;
6193 /* Skip over the digits. */
6194 while (p > start && isdigit(*p))
6195 p--;
6196 /* Now we should be at the colon. */
6197 if (p == start || *p != ':')
6198 return NULL;
6199 source_number_start = p + 1;
6200 source_name_end = p; /* Just beyond the end. */
6201 p--;
6202 /* Look for the open paren. */
6203 while (p > start && *p != '(')
6204 p--;
6205 if (p == start)
6206 return NULL;
6207 p++;
6208 *source_name_size = source_name_end - p;
22ff3130
HS		 6209 if (grok_atoUV(source_number_start, &uv, &source_line_end)
6210 && source_line_end == close_paren
99315af8 6211 && uv <= PERL_INT_MAX
22ff3130
HS		 6212 ) {
6213 *source_line = (STRLEN)uv;
6214 return p;
6215 }
6216 return NULL;
470dd224
JH		 6217}
6218
6219/* Given a raw frame, read a pipe from the symbolicator (that's the
6220 * technical term) atos, reads the result, and parses the source code
6221 * location. We must stay low-level, so we use snprintf(), pipe(),
6222 * and fread(), and then also parse the output ourselves. */
6223static void atos_symbolize(atos_context* ctx,
6224 void* raw_frame,
6225 char** source_name,
6226 STRLEN* source_name_size,
6227 STRLEN* source_line)
6228{
6229 char cmd[1024];
6230 const char* p;
6231 Size_t cnt;
6232
6233 if (ctx->unavail)
6234 return;
6235 /* Simple security measure: if there's any funny business with
6236 * the object name (used as "-o '%s'" ), leave since at least
6237 * partially the user controls it. */
6238 for (p = ctx->fname; *p; p++) {
6239 if (*p == '\'' || iscntrl(*p)) {
6240 ctx->unavail = TRUE;
6241 return;
6242 }
6243 }
6244 cnt = snprintf(cmd, sizeof(cmd), ctx->format,
6245 ctx->fname, ctx->object_base_addr, raw_frame);
6246 if (cnt < sizeof(cmd)) {
6247 /* Undo nostdio.h #defines that disable stdio.
6248 * This is somewhat naughty, but is used elsewhere
6249 * in the core, and affects only OS X. */
6250#undef FILE
6251#undef popen
6252#undef fread
6253#undef pclose
6254 FILE* fp = popen(cmd, "r");
6255 /* At the moment we open a new pipe for each stack frame.
6256 * This is naturally somewhat slow, but hopefully generating
6257 * stack traces is never going to in a performance critical path.
6258 *
6259 * We could play tricks with atos by batching the stack
6260 * addresses to be resolved: atos can either take multiple
6261 * addresses from the command line, or read addresses from
470dd224
JH		 6262 * a file (though the mess of creating temporary files would
6263 * probably negate much of any possible speedup).
6264 *
6265 * Normally there are only two objects present in the backtrace:
6266 * perl itself, and the libdyld.dylib. (Note that the object
6267 * filenames contain the full pathname, so perl may not always
6268 * be in the same place.) Whenever the object in the
6269 * backtrace changes, the base address also changes.
6270 *
6271 * The problem with batching the addresses, though, would be
6272 * matching the results with the addresses: the parsing of
6273 * the results is already painful enough with a single address. */
6274 if (fp) {
6275 char out[1024];
6276 UV cnt = fread(out, 1, sizeof(out), fp);
6277 if (cnt < sizeof(out)) {
70ead873 6278 const char* p = atos_parse(out + cnt - 1, out,
470dd224
JH		 6279 source_name_size,
6280 source_line);
6281 if (p) {
6282 Newx(*source_name,
70ead873 6283 *source_name_size, char);
470dd224 6284 Copy(p, *source_name,
70ead873 6285 *source_name_size, char);
470dd224
JH		 6286 }
6287 }
6288 pclose(fp);
6289 }
6290 }
6291}
6292
6293#endif /* #ifdef PERL_DARWIN */
6294
6295/*
6296=for apidoc get_c_backtrace
6297
6298Collects the backtrace (aka "stacktrace") into a single linear
796b6530 6299malloced buffer, which the caller B<must> C<Perl_free_c_backtrace()>.
470dd224 6300
796b6530
KW		 6301Scans the frames back by S<C<depth + skip>>, then drops the C<skip> innermost,
6302returning at most C<depth> frames.
470dd224
JH		 6303
6304=cut
6305*/
6306
6307Perl_c_backtrace*
6308Perl_get_c_backtrace(pTHX_ int depth, int skip)
6309{
6310 /* Note that here we must stay as low-level as possible: Newx(),
6311 * Copy(), Safefree(); since we may be called from anywhere,
6312 * so we should avoid higher level constructs like SVs or AVs.
6313 *
6314 * Since we are using safesysmalloc() via Newx(), don't try
6315 * getting backtrace() there, unless you like deep recursion. */
6316
6317 /* Currently only implemented with backtrace() and dladdr(),
6318 * for other platforms NULL is returned. */
6319
6320#if defined(HAS_BACKTRACE) && defined(HAS_DLADDR)
6321 /* backtrace() is available via <execinfo.h> in glibc and in most
6322 * modern BSDs; dladdr() is available via <dlfcn.h>. */
6323
6324 /* We try fetching this many frames total, but then discard
6325 * the |skip| first ones. For the remaining ones we will try
6326 * retrieving more information with dladdr(). */
6327 int try_depth = skip + depth;
6328
6329 /* The addresses (program counters) returned by backtrace(). */
6330 void** raw_frames;
6331
6332 /* Retrieved with dladdr() from the addresses returned by backtrace(). */
6333 Dl_info* dl_infos;
6334
6335 /* Sizes _including_ the terminating \0 of the object name
6336 * and symbol name strings. */
6337 STRLEN* object_name_sizes;
6338 STRLEN* symbol_name_sizes;
6339
6340#ifdef USE_BFD
6341 /* The symbol names comes either from dli_sname,
6342 * or if using BFD, they can come from BFD. */
6343 char** symbol_names;
6344#endif
6345
6346 /* The source code location information. Dug out with e.g. BFD. */
6347 char** source_names;
6348 STRLEN* source_name_sizes;
6349 STRLEN* source_lines;
6350
6351 Perl_c_backtrace* bt = NULL; /* This is what will be returned. */
6352 int got_depth; /* How many frames were returned from backtrace(). */
6353 UV frame_count = 0; /* How many frames we return. */
6354 UV total_bytes = 0; /* The size of the whole returned backtrace. */
6355
6356#ifdef USE_BFD
6357 bfd_context bfd_ctx;
6358#endif
6359#ifdef PERL_DARWIN
6360 atos_context atos_ctx;
6361#endif
6362
6363 /* Here are probably possibilities for optimizing. We could for
6364 * example have a struct that contains most of these and then
6365 * allocate |try_depth| of them, saving a bunch of malloc calls.
6366 * Note, however, that |frames| could not be part of that struct
6367 * because backtrace() will want an array of just them. Also be
6368 * careful about the name strings. */
6369 Newx(raw_frames, try_depth, void*);
6370 Newx(dl_infos, try_depth, Dl_info);
6371 Newx(object_name_sizes, try_depth, STRLEN);
6372 Newx(symbol_name_sizes, try_depth, STRLEN);
6373 Newx(source_names, try_depth, char*);
6374 Newx(source_name_sizes, try_depth, STRLEN);
6375 Newx(source_lines, try_depth, STRLEN);
6376#ifdef USE_BFD
6377 Newx(symbol_names, try_depth, char*);
6378#endif
6379
6380 /* Get the raw frames. */
6381 got_depth = (int)backtrace(raw_frames, try_depth);
6382
6383 /* We use dladdr() instead of backtrace_symbols() because we want
6384 * the full details instead of opaque strings. This is useful for
6385 * two reasons: () the details are needed for further symbolic
0762e42f
JH		 6386 * digging, for example in OS X (2) by having the details we fully
6387 * control the output, which in turn is useful when more platforms
6388 * are added: we can keep out output "portable". */
470dd224
JH		 6389
6390 /* We want a single linear allocation, which can then be freed
6391 * with a single swoop. We will do the usual trick of first
6392 * walking over the structure and seeing how much we need to
6393 * allocate, then allocating, and then walking over the structure
6394 * the second time and populating it. */
6395
6396 /* First we must compute the total size of the buffer. */
6397 total_bytes = sizeof(Perl_c_backtrace_header);
6398 if (got_depth > skip) {
6399 int i;
6400#ifdef USE_BFD
6401 bfd_init(); /* Is this safe to call multiple times? */
6402 Zero(&bfd_ctx, 1, bfd_context);
6403#endif
6404#ifdef PERL_DARWIN
6405 Zero(&atos_ctx, 1, atos_context);
6406#endif
6407 for (i = skip; i < try_depth; i++) {
6408 Dl_info* dl_info = &dl_infos[i];
6409
4d00a319
JH		 6410 object_name_sizes[i] = 0;
6411 source_names[i] = NULL;
6412 source_name_sizes[i] = 0;
6413 source_lines[i] = 0;
6414
470dd224
JH		 6415 /* Yes, zero from dladdr() is failure. */
6416 if (dladdr(raw_frames[i], dl_info)) {
70ead873
VT		 6417 total_bytes += sizeof(Perl_c_backtrace_frame);
6418
470dd224
JH		 6419 object_name_sizes[i] =
6420 dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0;
6421 symbol_name_sizes[i] =
6422 dl_info->dli_sname ? strlen(dl_info->dli_sname) : 0;
6423#ifdef USE_BFD
6424 bfd_update(&bfd_ctx, dl_info);
6425 bfd_symbolize(&bfd_ctx, raw_frames[i],
6426 &symbol_names[i],
6427 &symbol_name_sizes[i],
6428 &source_names[i],
6429 &source_name_sizes[i],
6430 &source_lines[i]);
6431#endif
6432#if PERL_DARWIN
6433 atos_update(&atos_ctx, dl_info);
6434 atos_symbolize(&atos_ctx,
6435 raw_frames[i],
6436 &source_names[i],
6437 &source_name_sizes[i],
6438 &source_lines[i]);
6439#endif
6440
6441 /* Plus ones for the terminating \0. */
6442 total_bytes += object_name_sizes[i] + 1;
6443 total_bytes += symbol_name_sizes[i] + 1;
6444 total_bytes += source_name_sizes[i] + 1;
6445
6446 frame_count++;
6447 } else {
6448 break;
6449 }
6450 }
6451#ifdef USE_BFD
6452 Safefree(bfd_ctx.bfd_syms);
6453#endif
6454 }
6455
6456 /* Now we can allocate and populate the result buffer. */
6457 Newxc(bt, total_bytes, char, Perl_c_backtrace);
6458 Zero(bt, total_bytes, char);
6459 bt->header.frame_count = frame_count;
6460 bt->header.total_bytes = total_bytes;
6461 if (frame_count > 0) {
6462 Perl_c_backtrace_frame* frame = bt->frame_info;
6463 char* name_base = (char *)(frame + frame_count);
6464 char* name_curr = name_base; /* Outputting the name strings here. */
6465 UV i;
6466 for (i = skip; i < skip + frame_count; i++) {
6467 Dl_info* dl_info = &dl_infos[i];
6468
6469 frame->addr = raw_frames[i];
6470 frame->object_base_addr = dl_info->dli_fbase;
6471 frame->symbol_addr = dl_info->dli_saddr;
6472
6473 /* Copies a string, including the \0, and advances the name_curr.
6474 * Also copies the start and the size to the frame. */
6475#define PERL_C_BACKTRACE_STRCPY(frame, doffset, src, dsize, size) \
6476 if (size && src) \
6477 Copy(src, name_curr, size, char); \
6478 frame->doffset = name_curr - (char*)bt; \
6479 frame->dsize = size; \
6480 name_curr += size; \
6481 *name_curr++ = 0;
6482
6483 PERL_C_BACKTRACE_STRCPY(frame, object_name_offset,
6484 dl_info->dli_fname,
6485 object_name_size, object_name_sizes[i]);
6486
6487#ifdef USE_BFD
6488 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset,
6489 symbol_names[i],
6490 symbol_name_size, symbol_name_sizes[i]);
6491 Safefree(symbol_names[i]);
6492#else
6493 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset,
6494 dl_info->dli_sname,
6495 symbol_name_size, symbol_name_sizes[i]);
6496#endif
6497
6498 PERL_C_BACKTRACE_STRCPY(frame, source_name_offset,
6499 source_names[i],
6500 source_name_size, source_name_sizes[i]);
6501 Safefree(source_names[i]);
6502
6503#undef PERL_C_BACKTRACE_STRCPY
6504
6505 frame->source_line_number = source_lines[i];
6506
6507 frame++;
6508 }
6509 assert(total_bytes ==
6510 (UV)(sizeof(Perl_c_backtrace_header) +
6511 frame_count * sizeof(Perl_c_backtrace_frame) +
6512 name_curr - name_base));
6513 }
6514#ifdef USE_BFD
6515 Safefree(symbol_names);
a1684041
JH		 6516 if (bfd_ctx.abfd) {
6517 bfd_close(bfd_ctx.abfd);
6518 }
470dd224
JH		 6519#endif
6520 Safefree(source_lines);
6521 Safefree(source_name_sizes);
6522 Safefree(source_names);
6523 Safefree(symbol_name_sizes);
6524 Safefree(object_name_sizes);
6525 /* Assuming the strings returned by dladdr() are pointers
6526 * to read-only static memory (the object file), so that
6527 * they do not need freeing (and cannot be). */
6528 Safefree(dl_infos);
6529 Safefree(raw_frames);
6530 return bt;
6531#else
6532 PERL_UNUSED_ARGV(depth);
6533 PERL_UNUSED_ARGV(skip);
6534 return NULL;
6535#endif
6536}
6537
6538/*
6539=for apidoc free_c_backtrace
6540
6541Deallocates a backtrace received from get_c_bracktrace.
6542
6543=cut
6544*/
6545
6546/*
6547=for apidoc get_c_backtrace_dump
6548
796b6530
KW		 6549Returns a SV containing a dump of C<depth> frames of the call stack, skipping
6550the C<skip> innermost ones. C<depth> of 20 is usually enough.
470dd224
JH		 6551
6552The appended output looks like:
6553
6554...
65551 10e004812:0082 Perl_croak util.c:1716 /usr/bin/perl
65562 10df8d6d2:1d72 perl_parse perl.c:3975 /usr/bin/perl
6557...
6558
6559The fields are tab-separated. The first column is the depth (zero
6560being the innermost non-skipped frame). In the hex:offset, the hex is
796b6530
KW		 6561where the program counter was in C<S_parse_body>, and the :offset (might
6562be missing) tells how much inside the C<S_parse_body> the program counter was.
470dd224 6563
796b6530 6564The C<util.c:1716> is the source code file and line number.
470dd224 6565
75af9d73 6566The F</usr/bin/perl> is obvious (hopefully).
470dd224
JH		 6567
6568Unknowns are C<"-">. Unknowns can happen unfortunately quite easily:
6569if the platform doesn't support retrieving the information;
6570if the binary is missing the debug information;
6571if the optimizer has transformed the code by for example inlining.
6572
6573=cut
6574*/
6575
6576SV*
6577Perl_get_c_backtrace_dump(pTHX_ int depth, int skip)
6578{
6579 Perl_c_backtrace* bt;
6580
6581 bt = get_c_backtrace(depth, skip + 1 /* Hide ourselves. */);
6582 if (bt) {
6583 Perl_c_backtrace_frame* frame;
6584 SV* dsv = newSVpvs("");
6585 UV i;
6586 for (i = 0, frame = bt->frame_info;
6587 i < bt->header.frame_count; i++, frame++) {
6588 Perl_sv_catpvf(aTHX_ dsv, "%d", (int)i);
6589 Perl_sv_catpvf(aTHX_ dsv, "\t%p", frame->addr ? frame->addr : "-");
6590 /* Symbol (function) names might disappear without debug info.
6591 *
6592 * The source code location might disappear in case of the
6593 * optimizer inlining or otherwise rearranging the code. */
6594 if (frame->symbol_addr) {
6595 Perl_sv_catpvf(aTHX_ dsv, ":%04x",
6596 (int)
6597 ((char*)frame->addr - (char*)frame->symbol_addr));
6598 }
6599 Perl_sv_catpvf(aTHX_ dsv, "\t%s",
6600 frame->symbol_name_size &&
6601 frame->symbol_name_offset ?
6602 (char*)bt + frame->symbol_name_offset : "-");
6603 if (frame->source_name_size &&
6604 frame->source_name_offset &&
6605 frame->source_line_number) {
147e3846 6606 Perl_sv_catpvf(aTHX_ dsv, "\t%s:%" UVuf,
470dd224
JH		 6607 (char*)bt + frame->source_name_offset,
6608 (UV)frame->source_line_number);
6609 } else {
6610 Perl_sv_catpvf(aTHX_ dsv, "\t-");
6611 }
6612 Perl_sv_catpvf(aTHX_ dsv, "\t%s",
6613 frame->object_name_size &&
6614 frame->object_name_offset ?
6615 (char*)bt + frame->object_name_offset : "-");
6616 /* The frame->object_base_addr is not output,
6617 * but it is used for symbolizing/symbolicating. */
6618 sv_catpvs(dsv, "\n");
6619 }
6620
6621 Perl_free_c_backtrace(aTHX_ bt);
6622
6623 return dsv;
6624 }
6625
6626 return NULL;
6627}
6628
6629/*
6630=for apidoc dump_c_backtrace
6631
796b6530 6632Dumps the C backtrace to the given C<fp>.
470dd224
JH		 6633
6634Returns true if a backtrace could be retrieved, false if not.
6635
6636=cut
6637*/
6638
6639bool
6640Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip)
6641{
6642 SV* sv;
6643
6644 PERL_ARGS_ASSERT_DUMP_C_BACKTRACE;
6645
6646 sv = Perl_get_c_backtrace_dump(aTHX_ depth, skip);
6647 if (sv) {
6648 sv_2mortal(sv);
6649 PerlIO_printf(fp, "%s", SvPV_nolen(sv));
6650 return TRUE;
6651 }
6652 return FALSE;
6653}
6654
6655#endif /* #ifdef USE_C_BACKTRACE */
3be8f094 6656
3baee7cc
JH		 6657#ifdef PERL_TSA_ACTIVE
6658
6659/* pthread_mutex_t and perl_mutex are typedef equivalent
6660 * so casting the pointers is fine. */
6661
6662int perl_tsa_mutex_lock(perl_mutex* mutex)
6663{
6664 return pthread_mutex_lock((pthread_mutex_t *) mutex);
6665}
6666
6667int perl_tsa_mutex_unlock(perl_mutex* mutex)
6668{
6669 return pthread_mutex_unlock((pthread_mutex_t *) mutex);
6670}
6671
6672int perl_tsa_mutex_destroy(perl_mutex* mutex)
6673{
6674 return pthread_mutex_destroy((pthread_mutex_t *) mutex);
6675}
6676
6677#endif
6678
3f6bd23a
DM		 6679
6680#ifdef USE_DTRACE
6681
6682/* log a sub call or return */
6683
6684void
6685Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call)
6686{
6687 const char *func;
6688 const char *file;
6689 const char *stash;
6690 const COP *start;
6691 line_t line;
6692
6693 PERL_ARGS_ASSERT_DTRACE_PROBE_CALL;
6694
6695 if (CvNAMED(cv)) {
6696 HEK *hek = CvNAME_HEK(cv);
6697 func = HEK_KEY(hek);
6698 }
6699 else {
6700 GV *gv = CvGV(cv);
6701 func = GvENAME(gv);
6702 }
6703 start = (const COP *)CvSTART(cv);
6704 file = CopFILE(start);
6705 line = CopLINE(start);
6706 stash = CopSTASHPV(start);
6707
6708 if (is_call) {
6709 PERL_SUB_ENTRY(func, file, line, stash);
6710 }
6711 else {
6712 PERL_SUB_RETURN(func, file, line, stash);
6713 }
6714}
6715
6716
6717/* log a require file loading/loaded */
6718
6719void
6720Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading)
6721{
6722 PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD;
6723
6724 if (is_loading) {
6725 PERL_LOADING_FILE(name);
6726 }
6727 else {
6728 PERL_LOADED_FILE(name);
6729 }
6730}
6731
6732
6733/* log an op execution */
6734
6735void
6736Perl_dtrace_probe_op(pTHX_ const OP *op)
6737{
6738 PERL_ARGS_ASSERT_DTRACE_PROBE_OP;
6739
6740 PERL_OP_ENTRY(OP_NAME(op));
6741}
6742
6743
6744/* log a compile/run phase change */
6745
6746void
6747Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase)
6748{
6749 const char *ph_old = PL_phase_names[PL_phase];
6750 const char *ph_new = PL_phase_names[phase];
6751
6752 PERL_PHASE_CHANGE(ph_new, ph_old);
6753}
6754
6755#endif
6756
3be8f094 6757/*
14d04a33 6758 * ex: set ts=8 sts=4 sw=4 et:
37442d52 6759 */
Unnamed repository; edit this file 'description' to name the repository.