1 /* util.c 2 * 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 5 * 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. 8 * 9 */ 10 11 /* 12 * 'Very useful, no doubt, that was to Saruman; yet it seems that he was 13 * not content.' --Gandalf to Pippin 14 * 15 * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"] 16 */ 17 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 24 #include "EXTERN.h" 25 #define PERL_IN_UTIL_C 26 #include "perl.h" 27 #include "reentr.h" 28 29 #if defined(USE_PERLIO) 30 #include "perliol.h" /* For PerlIOUnix_refcnt */ 31 #endif 32 33 #ifndef PERL_MICRO 34 #include <signal.h> 35 #ifndef SIG_ERR 36 # define SIG_ERR ((Sighandler_t) -1) 37 #endif 38 #endif 39 40 #include <math.h> 41 #include <stdlib.h> 42 43 #ifdef __Lynx__ 44 /* Missing protos on LynxOS */ 45 int putenv(char *); 46 #endif 47 48 #ifdef __amigaos__ 49 # include "amigaos4/amigaio.h" 50 #endif 51 52 #ifdef HAS_SELECT 53 # ifdef I_SYS_SELECT 54 # include <sys/select.h> 55 # endif 56 #endif 57 58 #ifdef USE_C_BACKTRACE 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 68 # ifdef I_DLFCN 69 # include <dlfcn.h> 70 # endif 71 # ifdef I_EXECINFO 72 # include <execinfo.h> 73 # endif 74 #endif 75 76 #ifdef PERL_DEBUG_READONLY_COW 77 # include <sys/mman.h> 78 #endif 79 80 #define FLUSH 81 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. 85 * XXX This advice seems to be widely ignored :-( --AD August 1996. 86 */ 87 88 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL) 89 # define ALWAYS_NEED_THX 90 #endif 91 92 #if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW) 93 static void 94 S_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 102 static void 103 S_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 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 126 /* paranoid version of system's malloc() */ 127 128 Malloc_t 129 Perl_safesysmalloc(MEM_SIZE size) 130 { 131 #ifdef ALWAYS_NEED_THX 132 dTHX; 133 #endif 134 Malloc_t ptr; 135 136 #ifdef USE_MDH 137 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) 138 goto out_of_memory; 139 size += PERL_MEMORY_DEBUG_HEADER_SIZE; 140 #endif 141 #ifdef DEBUGGING 142 if ((SSize_t)size < 0) 143 Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size); 144 #endif 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 155 PERL_ALLOC_CHECK(ptr); 156 if (ptr != NULL) { 157 #ifdef USE_MDH 158 struct perl_memory_debug_header *const header 159 = (struct perl_memory_debug_header *)ptr; 160 #endif 161 162 #ifdef PERL_POISON 163 PoisonNew(((char *)ptr), size, char); 164 #endif 165 166 #ifdef PERL_TRACK_MEMPOOL 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; 172 maybe_protect_rw(header->next); 173 header->next->prev = header; 174 maybe_protect_ro(header->next); 175 # ifdef PERL_DEBUG_READONLY_COW 176 header->readonly = 0; 177 # endif 178 #endif 179 #ifdef MDH_HAS_SIZE 180 header->size = size; 181 #endif 182 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); 183 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 184 185 } 186 else { 187 #ifdef USE_MDH 188 out_of_memory: 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 } 199 } 200 return ptr; 201 } 202 203 /* paranoid version of system's realloc() */ 204 205 Malloc_t 206 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) 207 { 208 #ifdef ALWAYS_NEED_THX 209 dTHX; 210 #endif 211 Malloc_t ptr; 212 #ifdef PERL_DEBUG_READONLY_COW 213 const MEM_SIZE oldsize = where 214 ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size 215 : 0; 216 #endif 217 218 if (!size) { 219 safesysfree(where); 220 ptr = NULL; 221 } 222 else if (!where) { 223 ptr = safesysmalloc(size); 224 } 225 else { 226 #ifdef USE_MDH 227 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); 228 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) 229 goto out_of_memory; 230 size += PERL_MEMORY_DEBUG_HEADER_SIZE; 231 { 232 struct perl_memory_debug_header *const header 233 = (struct perl_memory_debug_header *)where; 234 235 # ifdef PERL_TRACK_MEMPOOL 236 if (header->interpreter != aTHX) { 237 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p", 238 header->interpreter, aTHX); 239 } 240 assert(header->next->prev == header); 241 assert(header->prev->next == header); 242 # ifdef PERL_POISON 243 if (header->size > size) { 244 const MEM_SIZE freed_up = header->size - size; 245 char *start_of_freed = ((char *)where) + size; 246 PoisonFree(start_of_freed, freed_up, char); 247 } 248 # endif 249 # endif 250 # ifdef MDH_HAS_SIZE 251 header->size = size; 252 # endif 253 } 254 #endif 255 #ifdef DEBUGGING 256 if ((SSize_t)size < 0) 257 Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size); 258 #endif 259 #ifdef PERL_DEBUG_READONLY_COW 260 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE, 261 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { 262 perror("mmap failed"); 263 abort(); 264 } 265 Copy(where,ptr,oldsize < size ? oldsize : size,char); 266 if (munmap(where, oldsize)) { 267 perror("munmap failed"); 268 abort(); 269 } 270 #else 271 ptr = (Malloc_t)PerlMem_realloc(where,size); 272 #endif 273 PERL_ALLOC_CHECK(ptr); 274 275 /* MUST do this fixup first, before doing ANYTHING else, as anything else 276 might allocate memory/free/move memory, and until we do the fixup, it 277 may well be chasing (and writing to) free memory. */ 278 if (ptr != NULL) { 279 #ifdef PERL_TRACK_MEMPOOL 280 struct perl_memory_debug_header *const header 281 = (struct perl_memory_debug_header *)ptr; 282 283 # ifdef PERL_POISON 284 if (header->size < size) { 285 const MEM_SIZE fresh = size - header->size; 286 char *start_of_fresh = ((char *)ptr) + size; 287 PoisonNew(start_of_fresh, fresh, char); 288 } 289 # endif 290 291 maybe_protect_rw(header->next); 292 header->next->prev = header; 293 maybe_protect_ro(header->next); 294 maybe_protect_rw(header->prev); 295 header->prev->next = header; 296 maybe_protect_ro(header->prev); 297 #endif 298 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); 299 } 300 301 /* In particular, must do that fixup above before logging anything via 302 *printf(), as it can reallocate memory, which can cause SEGVs. */ 303 304 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); 305 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 306 307 if (ptr == NULL) { 308 #ifdef USE_MDH 309 out_of_memory: 310 #endif 311 { 312 #ifndef ALWAYS_NEED_THX 313 dTHX; 314 #endif 315 if (PL_nomemok) 316 ptr = NULL; 317 else 318 croak_no_mem(); 319 } 320 } 321 } 322 return ptr; 323 } 324 325 /* safe version of system's free() */ 326 327 Free_t 328 Perl_safesysfree(Malloc_t where) 329 { 330 #ifdef ALWAYS_NEED_THX 331 dTHX; 332 #endif 333 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); 334 if (where) { 335 #ifdef USE_MDH 336 Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); 337 { 338 struct perl_memory_debug_header *const header 339 = (struct perl_memory_debug_header *)where_intrn; 340 341 # ifdef MDH_HAS_SIZE 342 const MEM_SIZE size = header->size; 343 # endif 344 # ifdef PERL_TRACK_MEMPOOL 345 if (header->interpreter != aTHX) { 346 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p", 347 header->interpreter, aTHX); 348 } 349 if (!header->prev) { 350 Perl_croak_nocontext("panic: duplicate free"); 351 } 352 if (!(header->next)) 353 Perl_croak_nocontext("panic: bad free, header->next==NULL"); 354 if (header->next->prev != header || header->prev->next != header) { 355 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, " 356 "header=%p, ->prev->next=%p", 357 header->next->prev, header, 358 header->prev->next); 359 } 360 /* Unlink us from the chain. */ 361 maybe_protect_rw(header->next); 362 header->next->prev = header->prev; 363 maybe_protect_ro(header->next); 364 maybe_protect_rw(header->prev); 365 header->prev->next = header->next; 366 maybe_protect_ro(header->prev); 367 maybe_protect_rw(header); 368 # ifdef PERL_POISON 369 PoisonNew(where_intrn, size, char); 370 # endif 371 /* Trigger the duplicate free warning. */ 372 header->next = NULL; 373 # endif 374 # ifdef PERL_DEBUG_READONLY_COW 375 if (munmap(where_intrn, size)) { 376 perror("munmap failed"); 377 abort(); 378 } 379 # endif 380 } 381 #else 382 Malloc_t where_intrn = where; 383 #endif /* USE_MDH */ 384 #ifndef PERL_DEBUG_READONLY_COW 385 PerlMem_free(where_intrn); 386 #endif 387 } 388 } 389 390 /* safe version of system's calloc() */ 391 392 Malloc_t 393 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) 394 { 395 #ifdef ALWAYS_NEED_THX 396 dTHX; 397 #endif 398 Malloc_t ptr; 399 #if defined(USE_MDH) || defined(DEBUGGING) 400 MEM_SIZE total_size = 0; 401 #endif 402 403 /* Even though calloc() for zero bytes is strange, be robust. */ 404 if (size && (count <= MEM_SIZE_MAX / size)) { 405 #if defined(USE_MDH) || defined(DEBUGGING) 406 total_size = size * count; 407 #endif 408 } 409 else 410 croak_memory_wrap(); 411 #ifdef USE_MDH 412 if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size) 413 total_size += PERL_MEMORY_DEBUG_HEADER_SIZE; 414 else 415 croak_memory_wrap(); 416 #endif 417 #ifdef DEBUGGING 418 if ((SSize_t)size < 0 || (SSize_t)count < 0) 419 Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf, 420 (UV)size, (UV)count); 421 #endif 422 #ifdef PERL_DEBUG_READONLY_COW 423 if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE, 424 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { 425 perror("mmap failed"); 426 abort(); 427 } 428 #elif defined(PERL_TRACK_MEMPOOL) 429 /* Have to use malloc() because we've added some space for our tracking 430 header. */ 431 /* malloc(0) is non-portable. */ 432 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1); 433 #else 434 /* Use calloc() because it might save a memset() if the memory is fresh 435 and clean from the OS. */ 436 if (count && size) 437 ptr = (Malloc_t)PerlMem_calloc(count, size); 438 else /* calloc(0) is non-portable. */ 439 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1); 440 #endif 441 PERL_ALLOC_CHECK(ptr); 442 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)); 443 if (ptr != NULL) { 444 #ifdef USE_MDH 445 { 446 struct perl_memory_debug_header *const header 447 = (struct perl_memory_debug_header *)ptr; 448 449 # ifndef PERL_DEBUG_READONLY_COW 450 memset((void*)ptr, 0, total_size); 451 # endif 452 # ifdef PERL_TRACK_MEMPOOL 453 header->interpreter = aTHX; 454 /* Link us into the list. */ 455 header->prev = &PL_memory_debug_header; 456 header->next = PL_memory_debug_header.next; 457 PL_memory_debug_header.next = header; 458 maybe_protect_rw(header->next); 459 header->next->prev = header; 460 maybe_protect_ro(header->next); 461 # ifdef PERL_DEBUG_READONLY_COW 462 header->readonly = 0; 463 # endif 464 # endif 465 # ifdef MDH_HAS_SIZE 466 header->size = total_size; 467 # endif 468 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); 469 } 470 #endif 471 return ptr; 472 } 473 else { 474 #ifndef ALWAYS_NEED_THX 475 dTHX; 476 #endif 477 if (PL_nomemok) 478 return NULL; 479 croak_no_mem(); 480 } 481 } 482 483 /* These must be defined when not using Perl's malloc for binary 484 * compatibility */ 485 486 #ifndef MYMALLOC 487 488 Malloc_t Perl_malloc (MEM_SIZE nbytes) 489 { 490 #ifdef PERL_IMPLICIT_SYS 491 dTHX; 492 #endif 493 return (Malloc_t)PerlMem_malloc(nbytes); 494 } 495 496 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) 497 { 498 #ifdef PERL_IMPLICIT_SYS 499 dTHX; 500 #endif 501 return (Malloc_t)PerlMem_calloc(elements, size); 502 } 503 504 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) 505 { 506 #ifdef PERL_IMPLICIT_SYS 507 dTHX; 508 #endif 509 return (Malloc_t)PerlMem_realloc(where, nbytes); 510 } 511 512 Free_t Perl_mfree (Malloc_t where) 513 { 514 #ifdef PERL_IMPLICIT_SYS 515 dTHX; 516 #endif 517 PerlMem_free(where); 518 } 519 520 #endif 521 522 /* copy a string up to some (non-backslashed) delimiter, if any. 523 * With allow_escape, converts \<delimiter> to <delimiter>, while leaves 524 * \<non-delimiter> as-is. 525 * Returns the position in the src string of the closing delimiter, if 526 * any, or returns fromend otherwise. 527 * This is the internal implementation for Perl_delimcpy and 528 * Perl_delimcpy_no_escape. 529 */ 530 531 static char * 532 S_delimcpy_intern(char *to, const char *toend, const char *from, 533 const char *fromend, int delim, I32 *retlen, 534 const bool allow_escape) 535 { 536 I32 tolen; 537 538 PERL_ARGS_ASSERT_DELIMCPY; 539 540 for (tolen = 0; from < fromend; from++, tolen++) { 541 if (allow_escape && *from == '\\' && from + 1 < fromend) { 542 if (from[1] != delim) { 543 if (to < toend) 544 *to++ = *from; 545 tolen++; 546 } 547 from++; 548 } 549 else if (*from == delim) 550 break; 551 if (to < toend) 552 *to++ = *from; 553 } 554 if (to < toend) 555 *to = '\0'; 556 *retlen = tolen; 557 return (char *)from; 558 } 559 560 char * 561 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen) 562 { 563 PERL_ARGS_ASSERT_DELIMCPY; 564 565 return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1); 566 } 567 568 char * 569 Perl_delimcpy_no_escape(char *to, const char *toend, const char *from, 570 const char *fromend, int delim, I32 *retlen) 571 { 572 PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE; 573 574 return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 0); 575 } 576 577 /* 578 =head1 Miscellaneous Functions 579 580 =for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end 581 582 Find the first (leftmost) occurrence of a sequence of bytes within another 583 sequence. This is the Perl version of C<strstr()>, extended to handle 584 arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL> 585 is what the initial C<n> in the function name stands for; some systems have an 586 equivalent, C<memmem()>, but with a somewhat different API). 587 588 Another way of thinking about this function is finding a needle in a haystack. 589 C<big> points to the first byte in the haystack. C<big_end> points to one byte 590 beyond the final byte in the haystack. C<little> points to the first byte in 591 the needle. C<little_end> points to one byte beyond the final byte in the 592 needle. All the parameters must be non-C<NULL>. 593 594 The function returns C<NULL> if there is no occurrence of C<little> within 595 C<big>. If C<little> is the empty string, C<big> is returned. 596 597 Because this function operates at the byte level, and because of the inherent 598 characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the 599 needle and the haystack are strings with the same UTF-8ness, but not if the 600 UTF-8ness differs. 601 602 =cut 603 604 */ 605 606 char * 607 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend) 608 { 609 PERL_ARGS_ASSERT_NINSTR; 610 611 #ifdef HAS_MEMMEM 612 return ninstr(big, bigend, little, lend); 613 #else 614 615 if (little >= lend) 616 return (char*)big; 617 { 618 const char first = *little; 619 bigend -= lend - little++; 620 OUTER: 621 while (big <= bigend) { 622 if (*big++ == first) { 623 const char *s, *x; 624 for (x=big,s=little; s < lend; x++,s++) { 625 if (*s != *x) 626 goto OUTER; 627 } 628 return (char*)(big-1); 629 } 630 } 631 } 632 return NULL; 633 634 #endif 635 636 } 637 638 /* 639 =head1 Miscellaneous Functions 640 641 =for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end 642 643 Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a 644 sequence of bytes within another sequence, returning C<NULL> if there is no 645 such occurrence. 646 647 =cut 648 649 */ 650 651 char * 652 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend) 653 { 654 const char *bigbeg; 655 const I32 first = *little; 656 const char * const littleend = lend; 657 658 PERL_ARGS_ASSERT_RNINSTR; 659 660 if (little >= littleend) 661 return (char*)bigend; 662 bigbeg = big; 663 big = bigend - (littleend - little++); 664 while (big >= bigbeg) { 665 const char *s, *x; 666 if (*big-- != first) 667 continue; 668 for (x=big+2,s=little; s < littleend; /**/ ) { 669 if (*s != *x) 670 break; 671 else { 672 x++; 673 s++; 674 } 675 } 676 if (s >= littleend) 677 return (char*)(big+1); 678 } 679 return NULL; 680 } 681 682 /* As a space optimization, we do not compile tables for strings of length 683 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are 684 special-cased in fbm_instr(). 685 686 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ 687 688 /* 689 =head1 Miscellaneous Functions 690 691 =for apidoc fbm_compile 692 693 Analyzes the string in order to make fast searches on it using C<fbm_instr()> 694 -- the Boyer-Moore algorithm. 695 696 =cut 697 */ 698 699 void 700 Perl_fbm_compile(pTHX_ SV *sv, U32 flags) 701 { 702 const U8 *s; 703 STRLEN i; 704 STRLEN len; 705 U32 frequency = 256; 706 MAGIC *mg; 707 PERL_DEB( STRLEN rarest = 0 ); 708 709 PERL_ARGS_ASSERT_FBM_COMPILE; 710 711 if (isGV_with_GP(sv) || SvROK(sv)) 712 return; 713 714 if (SvVALID(sv)) 715 return; 716 717 if (flags & FBMcf_TAIL) { 718 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; 719 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */ 720 if (mg && mg->mg_len >= 0) 721 mg->mg_len++; 722 } 723 if (!SvPOK(sv) || SvNIOKp(sv)) 724 s = (U8*)SvPV_force_mutable(sv, len); 725 else s = (U8 *)SvPV_mutable(sv, len); 726 if (len == 0) /* TAIL might be on a zero-length string. */ 727 return; 728 SvUPGRADE(sv, SVt_PVMG); 729 SvIOK_off(sv); 730 SvNOK_off(sv); 731 732 /* add PERL_MAGIC_bm magic holding the FBM lookup table */ 733 734 assert(!mg_find(sv, PERL_MAGIC_bm)); 735 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0); 736 assert(mg); 737 738 if (len > 2) { 739 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use 740 the BM table. */ 741 const U8 mlen = (len>255) ? 255 : (U8)len; 742 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */ 743 U8 *table; 744 745 Newx(table, 256, U8); 746 memset((void*)table, mlen, 256); 747 mg->mg_ptr = (char *)table; 748 mg->mg_len = 256; 749 750 s += len - 1; /* last char */ 751 i = 0; 752 while (s >= sb) { 753 if (table[*s] == mlen) 754 table[*s] = (U8)i; 755 s--, i++; 756 } 757 } 758 759 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ 760 for (i = 0; i < len; i++) { 761 if (PL_freq[s[i]] < frequency) { 762 PERL_DEB( rarest = i ); 763 frequency = PL_freq[s[i]]; 764 } 765 } 766 BmUSEFUL(sv) = 100; /* Initial value */ 767 ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL); 768 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %" UVuf "\n", 769 s[rarest], (UV)rarest)); 770 } 771 772 773 /* 774 =for apidoc fbm_instr 775 776 Returns the location of the SV in the string delimited by C<big> and 777 C<bigend> (C<bigend>) is the char following the last char). 778 It returns C<NULL> if the string can't be found. The C<sv> 779 does not have to be C<fbm_compiled>, but the search will not be as fast 780 then. 781 782 =cut 783 784 If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string 785 during FBM compilation due to FBMcf_TAIL in flags. It indicates that 786 the littlestr must be anchored to the end of bigstr (or to any \n if 787 FBMrf_MULTILINE). 788 789 E.g. The regex compiler would compile /abc/ to a littlestr of "abc", 790 while /abc$/ compiles to "abc\n" with SvTAIL() true. 791 792 A littlestr of "abc", !SvTAIL matches as /abc/; 793 a littlestr of "ab\n", SvTAIL matches as: 794 without FBMrf_MULTILINE: /ab\n?\z/ 795 with FBMrf_MULTILINE: /ab\n/ || /ab\z/; 796 797 (According to Ilya from 1999; I don't know if this is still true, DAPM 2015): 798 "If SvTAIL is actually due to \Z or \z, this gives false positives 799 if multiline". 800 */ 801 802 803 char * 804 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags) 805 { 806 unsigned char *s; 807 STRLEN l; 808 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l); 809 STRLEN littlelen = l; 810 const I32 multiline = flags & FBMrf_MULTILINE; 811 bool valid = SvVALID(littlestr); 812 bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE; 813 814 PERL_ARGS_ASSERT_FBM_INSTR; 815 816 assert(bigend >= big); 817 818 if ((STRLEN)(bigend - big) < littlelen) { 819 if ( tail 820 && ((STRLEN)(bigend - big) == littlelen - 1) 821 && (littlelen == 1 822 || (*big == *little && 823 memEQ((char *)big, (char *)little, littlelen - 1)))) 824 return (char*)big; 825 return NULL; 826 } 827 828 switch (littlelen) { /* Special cases for 0, 1 and 2 */ 829 case 0: 830 return (char*)big; /* Cannot be SvTAIL! */ 831 832 case 1: 833 if (tail && !multiline) /* Anchor only! */ 834 /* [-1] is safe because we know that bigend != big. */ 835 return (char *) (bigend - (bigend[-1] == '\n')); 836 837 s = (unsigned char *)memchr((void*)big, *little, bigend-big); 838 if (s) 839 return (char *)s; 840 if (tail) 841 return (char *) bigend; 842 return NULL; 843 844 case 2: 845 if (tail && !multiline) { 846 /* a littlestr with SvTAIL must be of the form "X\n" (where X 847 * is a single char). It is anchored, and can only match 848 * "....X\n" or "....X" */ 849 if (bigend[-2] == *little && bigend[-1] == '\n') 850 return (char*)bigend - 2; 851 if (bigend[-1] == *little) 852 return (char*)bigend - 1; 853 return NULL; 854 } 855 856 { 857 /* memchr() is likely to be very fast, possibly using whatever 858 * hardware support is available, such as checking a whole 859 * cache line in one instruction. 860 * So for a 2 char pattern, calling memchr() is likely to be 861 * faster than running FBM, or rolling our own. The previous 862 * version of this code was roll-your-own which typically 863 * only needed to read every 2nd char, which was good back in 864 * the day, but no longer. 865 */ 866 unsigned char c1 = little[0]; 867 unsigned char c2 = little[1]; 868 869 /* *** for all this case, bigend points to the last char, 870 * not the trailing \0: this makes the conditions slightly 871 * simpler */ 872 bigend--; 873 s = big; 874 if (c1 != c2) { 875 while (s < bigend) { 876 /* do a quick test for c1 before calling memchr(); 877 * this avoids the expensive fn call overhead when 878 * there are lots of c1's */ 879 if (LIKELY(*s != c1)) { 880 s++; 881 s = (unsigned char *)memchr((void*)s, c1, bigend - s); 882 if (!s) 883 break; 884 } 885 if (s[1] == c2) 886 return (char*)s; 887 888 /* failed; try searching for c2 this time; that way 889 * we don't go pathologically slow when the string 890 * consists mostly of c1's or vice versa. 891 */ 892 s += 2; 893 if (s > bigend) 894 break; 895 s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1); 896 if (!s) 897 break; 898 if (s[-1] == c1) 899 return (char*)s - 1; 900 } 901 } 902 else { 903 /* c1, c2 the same */ 904 while (s < bigend) { 905 if (s[0] == c1) { 906 got_1char: 907 if (s[1] == c1) 908 return (char*)s; 909 s += 2; 910 } 911 else { 912 s++; 913 s = (unsigned char *)memchr((void*)s, c1, bigend - s); 914 if (!s || s >= bigend) 915 break; 916 goto got_1char; 917 } 918 } 919 } 920 921 /* failed to find 2 chars; try anchored match at end without 922 * the \n */ 923 if (tail && bigend[0] == little[0]) 924 return (char *)bigend; 925 return NULL; 926 } 927 928 default: 929 break; /* Only lengths 0 1 and 2 have special-case code. */ 930 } 931 932 if (tail && !multiline) { /* tail anchored? */ 933 s = bigend - littlelen; 934 if (s >= big && bigend[-1] == '\n' && *s == *little 935 /* Automatically of length > 2 */ 936 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) 937 { 938 return (char*)s; /* how sweet it is */ 939 } 940 if (s[1] == *little 941 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) 942 { 943 return (char*)s + 1; /* how sweet it is */ 944 } 945 return NULL; 946 } 947 948 if (!valid) { 949 /* not compiled; use Perl_ninstr() instead */ 950 char * const b = ninstr((char*)big,(char*)bigend, 951 (char*)little, (char*)little + littlelen); 952 953 assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */ 954 return b; 955 } 956 957 /* Do actual FBM. */ 958 if (littlelen > (STRLEN)(bigend - big)) 959 return NULL; 960 961 { 962 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm); 963 const unsigned char *oldlittle; 964 965 assert(mg); 966 967 --littlelen; /* Last char found by table lookup */ 968 969 s = big + littlelen; 970 little += littlelen; /* last char */ 971 oldlittle = little; 972 if (s < bigend) { 973 const unsigned char * const table = (const unsigned char *) mg->mg_ptr; 974 const unsigned char lastc = *little; 975 I32 tmp; 976 977 top2: 978 if ((tmp = table[*s])) { 979 /* *s != lastc; earliest position it could match now is 980 * tmp slots further on */ 981 if ((s += tmp) >= bigend) 982 goto check_end; 983 if (LIKELY(*s != lastc)) { 984 s++; 985 s = (unsigned char *)memchr((void*)s, lastc, bigend - s); 986 if (!s) { 987 s = bigend; 988 goto check_end; 989 } 990 goto top2; 991 } 992 } 993 994 995 /* hand-rolled strncmp(): less expensive than calling the 996 * real function (maybe???) */ 997 { 998 unsigned char * const olds = s; 999 1000 tmp = littlelen; 1001 1002 while (tmp--) { 1003 if (*--s == *--little) 1004 continue; 1005 s = olds + 1; /* here we pay the price for failure */ 1006 little = oldlittle; 1007 if (s < bigend) /* fake up continue to outer loop */ 1008 goto top2; 1009 goto check_end; 1010 } 1011 return (char *)s; 1012 } 1013 } 1014 check_end: 1015 if ( s == bigend 1016 && tail 1017 && memEQ((char *)(bigend - littlelen), 1018 (char *)(oldlittle - littlelen), littlelen) ) 1019 return (char*)bigend - littlelen; 1020 return NULL; 1021 } 1022 } 1023 1024 /* copy a string to a safe spot */ 1025 1026 /* 1027 =head1 Memory Management 1028 1029 =for apidoc savepv 1030 1031 Perl's version of C<strdup()>. Returns a pointer to a newly allocated 1032 string which is a duplicate of C<pv>. The size of the string is 1033 determined by C<strlen()>, which means it may not contain embedded C<NUL> 1034 characters and must have a trailing C<NUL>. The memory allocated for the new 1035 string can be freed with the C<Safefree()> function. 1036 1037 On some platforms, Windows for example, all allocated memory owned by a thread 1038 is deallocated when that thread ends. So if you need that not to happen, you 1039 need to use the shared memory functions, such as C<L</savesharedpv>>. 1040 1041 =cut 1042 */ 1043 1044 char * 1045 Perl_savepv(pTHX_ const char *pv) 1046 { 1047 PERL_UNUSED_CONTEXT; 1048 if (!pv) 1049 return NULL; 1050 else { 1051 char *newaddr; 1052 const STRLEN pvlen = strlen(pv)+1; 1053 Newx(newaddr, pvlen, char); 1054 return (char*)memcpy(newaddr, pv, pvlen); 1055 } 1056 } 1057 1058 /* same thing but with a known length */ 1059 1060 /* 1061 =for apidoc savepvn 1062 1063 Perl's version of what C<strndup()> would be if it existed. Returns a 1064 pointer to a newly allocated string which is a duplicate of the first 1065 C<len> bytes from C<pv>, plus a trailing 1066 C<NUL> byte. The memory allocated for 1067 the new string can be freed with the C<Safefree()> function. 1068 1069 On some platforms, Windows for example, all allocated memory owned by a thread 1070 is deallocated when that thread ends. So if you need that not to happen, you 1071 need to use the shared memory functions, such as C<L</savesharedpvn>>. 1072 1073 =cut 1074 */ 1075 1076 char * 1077 Perl_savepvn(pTHX_ const char *pv, I32 len) 1078 { 1079 char *newaddr; 1080 PERL_UNUSED_CONTEXT; 1081 1082 assert(len >= 0); 1083 1084 Newx(newaddr,len+1,char); 1085 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ 1086 if (pv) { 1087 /* might not be null terminated */ 1088 newaddr[len] = '\0'; 1089 return (char *) CopyD(pv,newaddr,len,char); 1090 } 1091 else { 1092 return (char *) ZeroD(newaddr,len+1,char); 1093 } 1094 } 1095 1096 /* 1097 =for apidoc savesharedpv 1098 1099 A version of C<savepv()> which allocates the duplicate string in memory 1100 which is shared between threads. 1101 1102 =cut 1103 */ 1104 char * 1105 Perl_savesharedpv(pTHX_ const char *pv) 1106 { 1107 char *newaddr; 1108 STRLEN pvlen; 1109 1110 PERL_UNUSED_CONTEXT; 1111 1112 if (!pv) 1113 return NULL; 1114 1115 pvlen = strlen(pv)+1; 1116 newaddr = (char*)PerlMemShared_malloc(pvlen); 1117 if (!newaddr) { 1118 croak_no_mem(); 1119 } 1120 return (char*)memcpy(newaddr, pv, pvlen); 1121 } 1122 1123 /* 1124 =for apidoc savesharedpvn 1125 1126 A version of C<savepvn()> which allocates the duplicate string in memory 1127 which is shared between threads. (With the specific difference that a C<NULL> 1128 pointer is not acceptable) 1129 1130 =cut 1131 */ 1132 char * 1133 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) 1134 { 1135 char *const newaddr = (char*)PerlMemShared_malloc(len + 1); 1136 1137 PERL_UNUSED_CONTEXT; 1138 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */ 1139 1140 if (!newaddr) { 1141 croak_no_mem(); 1142 } 1143 newaddr[len] = '\0'; 1144 return (char*)memcpy(newaddr, pv, len); 1145 } 1146 1147 /* 1148 =for apidoc savesvpv 1149 1150 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from 1151 the passed in SV using C<SvPV()> 1152 1153 On some platforms, Windows for example, all allocated memory owned by a thread 1154 is deallocated when that thread ends. So if you need that not to happen, you 1155 need to use the shared memory functions, such as C<L</savesharedsvpv>>. 1156 1157 =cut 1158 */ 1159 1160 char * 1161 Perl_savesvpv(pTHX_ SV *sv) 1162 { 1163 STRLEN len; 1164 const char * const pv = SvPV_const(sv, len); 1165 char *newaddr; 1166 1167 PERL_ARGS_ASSERT_SAVESVPV; 1168 1169 ++len; 1170 Newx(newaddr,len,char); 1171 return (char *) CopyD(pv,newaddr,len,char); 1172 } 1173 1174 /* 1175 =for apidoc savesharedsvpv 1176 1177 A version of C<savesharedpv()> which allocates the duplicate string in 1178 memory which is shared between threads. 1179 1180 =cut 1181 */ 1182 1183 char * 1184 Perl_savesharedsvpv(pTHX_ SV *sv) 1185 { 1186 STRLEN len; 1187 const char * const pv = SvPV_const(sv, len); 1188 1189 PERL_ARGS_ASSERT_SAVESHAREDSVPV; 1190 1191 return savesharedpvn(pv, len); 1192 } 1193 1194 /* the SV for Perl_form() and mess() is not kept in an arena */ 1195 1196 STATIC SV * 1197 S_mess_alloc(pTHX) 1198 { 1199 SV *sv; 1200 XPVMG *any; 1201 1202 if (PL_phase != PERL_PHASE_DESTRUCT) 1203 return newSVpvs_flags("", SVs_TEMP); 1204 1205 if (PL_mess_sv) 1206 return PL_mess_sv; 1207 1208 /* Create as PVMG now, to avoid any upgrading later */ 1209 Newx(sv, 1, SV); 1210 Newxz(any, 1, XPVMG); 1211 SvFLAGS(sv) = SVt_PVMG; 1212 SvANY(sv) = (void*)any; 1213 SvPV_set(sv, NULL); 1214 SvREFCNT(sv) = 1 << 30; /* practically infinite */ 1215 PL_mess_sv = sv; 1216 return sv; 1217 } 1218 1219 #if defined(PERL_IMPLICIT_CONTEXT) 1220 char * 1221 Perl_form_nocontext(const char* pat, ...) 1222 { 1223 dTHX; 1224 char *retval; 1225 va_list args; 1226 PERL_ARGS_ASSERT_FORM_NOCONTEXT; 1227 va_start(args, pat); 1228 retval = vform(pat, &args); 1229 va_end(args); 1230 return retval; 1231 } 1232 #endif /* PERL_IMPLICIT_CONTEXT */ 1233 1234 /* 1235 =head1 Miscellaneous Functions 1236 =for apidoc form 1237 1238 Takes a sprintf-style format pattern and conventional 1239 (non-SV) arguments and returns the formatted string. 1240 1241 (char *) Perl_form(pTHX_ const char* pat, ...) 1242 1243 can be used any place a string (char *) is required: 1244 1245 char * s = Perl_form("%d.%d",major,minor); 1246 1247 Uses a single private buffer so if you want to format several strings you 1248 must explicitly copy the earlier strings away (and free the copies when you 1249 are done). 1250 1251 =cut 1252 */ 1253 1254 char * 1255 Perl_form(pTHX_ const char* pat, ...) 1256 { 1257 char *retval; 1258 va_list args; 1259 PERL_ARGS_ASSERT_FORM; 1260 va_start(args, pat); 1261 retval = vform(pat, &args); 1262 va_end(args); 1263 return retval; 1264 } 1265 1266 char * 1267 Perl_vform(pTHX_ const char *pat, va_list *args) 1268 { 1269 SV * const sv = mess_alloc(); 1270 PERL_ARGS_ASSERT_VFORM; 1271 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 1272 return SvPVX(sv); 1273 } 1274 1275 /* 1276 =for apidoc Am|SV *|mess|const char *pat|... 1277 1278 Take a sprintf-style format pattern and argument list. These are used to 1279 generate a string message. If the message does not end with a newline, 1280 then it will be extended with some indication of the current location 1281 in the code, as described for L</mess_sv>. 1282 1283 Normally, the resulting message is returned in a new mortal SV. 1284 During global destruction a single SV may be shared between uses of 1285 this function. 1286 1287 =cut 1288 */ 1289 1290 #if defined(PERL_IMPLICIT_CONTEXT) 1291 SV * 1292 Perl_mess_nocontext(const char *pat, ...) 1293 { 1294 dTHX; 1295 SV *retval; 1296 va_list args; 1297 PERL_ARGS_ASSERT_MESS_NOCONTEXT; 1298 va_start(args, pat); 1299 retval = vmess(pat, &args); 1300 va_end(args); 1301 return retval; 1302 } 1303 #endif /* PERL_IMPLICIT_CONTEXT */ 1304 1305 SV * 1306 Perl_mess(pTHX_ const char *pat, ...) 1307 { 1308 SV *retval; 1309 va_list args; 1310 PERL_ARGS_ASSERT_MESS; 1311 va_start(args, pat); 1312 retval = vmess(pat, &args); 1313 va_end(args); 1314 return retval; 1315 } 1316 1317 const COP* 1318 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, 1319 bool opnext) 1320 { 1321 /* Look for curop starting from o. cop is the last COP we've seen. */ 1322 /* opnext means that curop is actually the ->op_next of the op we are 1323 seeking. */ 1324 1325 PERL_ARGS_ASSERT_CLOSEST_COP; 1326 1327 if (!o || !curop || ( 1328 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop 1329 )) 1330 return cop; 1331 1332 if (o->op_flags & OPf_KIDS) { 1333 const OP *kid; 1334 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { 1335 const COP *new_cop; 1336 1337 /* If the OP_NEXTSTATE has been optimised away we can still use it 1338 * the get the file and line number. */ 1339 1340 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) 1341 cop = (const COP *)kid; 1342 1343 /* Keep searching, and return when we've found something. */ 1344 1345 new_cop = closest_cop(cop, kid, curop, opnext); 1346 if (new_cop) 1347 return new_cop; 1348 } 1349 } 1350 1351 /* Nothing found. */ 1352 1353 return NULL; 1354 } 1355 1356 /* 1357 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume 1358 1359 Expands a message, intended for the user, to include an indication of 1360 the current location in the code, if the message does not already appear 1361 to be complete. 1362 1363 C<basemsg> is the initial message or object. If it is a reference, it 1364 will be used as-is and will be the result of this function. Otherwise it 1365 is used as a string, and if it already ends with a newline, it is taken 1366 to be complete, and the result of this function will be the same string. 1367 If the message does not end with a newline, then a segment such as C<at 1368 foo.pl line 37> will be appended, and possibly other clauses indicating 1369 the current state of execution. The resulting message will end with a 1370 dot and a newline. 1371 1372 Normally, the resulting message is returned in a new mortal SV. 1373 During global destruction a single SV may be shared between uses of this 1374 function. If C<consume> is true, then the function is permitted (but not 1375 required) to modify and return C<basemsg> instead of allocating a new SV. 1376 1377 =cut 1378 */ 1379 1380 SV * 1381 Perl_mess_sv(pTHX_ SV *basemsg, bool consume) 1382 { 1383 SV *sv; 1384 1385 #if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR) 1386 { 1387 char *ws; 1388 UV wi; 1389 /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */ 1390 if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR")) 1391 && grok_atoUV(ws, &wi, NULL) 1392 && wi <= PERL_INT_MAX 1393 ) { 1394 Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1); 1395 } 1396 } 1397 #endif 1398 1399 PERL_ARGS_ASSERT_MESS_SV; 1400 1401 if (SvROK(basemsg)) { 1402 if (consume) { 1403 sv = basemsg; 1404 } 1405 else { 1406 sv = mess_alloc(); 1407 sv_setsv(sv, basemsg); 1408 } 1409 return sv; 1410 } 1411 1412 if (SvPOK(basemsg) && consume) { 1413 sv = basemsg; 1414 } 1415 else { 1416 sv = mess_alloc(); 1417 sv_copypv(sv, basemsg); 1418 } 1419 1420 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { 1421 /* 1422 * Try and find the file and line for PL_op. This will usually be 1423 * PL_curcop, but it might be a cop that has been optimised away. We 1424 * can try to find such a cop by searching through the optree starting 1425 * from the sibling of PL_curcop. 1426 */ 1427 1428 if (PL_curcop) { 1429 const COP *cop = 1430 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE); 1431 if (!cop) 1432 cop = PL_curcop; 1433 1434 if (CopLINE(cop)) 1435 Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf, 1436 OutCopFILE(cop), (IV)CopLINE(cop)); 1437 } 1438 1439 /* Seems that GvIO() can be untrustworthy during global destruction. */ 1440 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO) 1441 && IoLINES(GvIOp(PL_last_in_gv))) 1442 { 1443 STRLEN l; 1444 const bool line_mode = (RsSIMPLE(PL_rs) && 1445 *SvPV_const(PL_rs,l) == '\n' && l == 1); 1446 Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf, 1447 SVfARG(PL_last_in_gv == PL_argvgv 1448 ? &PL_sv_no 1449 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))), 1450 line_mode ? "line" : "chunk", 1451 (IV)IoLINES(GvIOp(PL_last_in_gv))); 1452 } 1453 if (PL_phase == PERL_PHASE_DESTRUCT) 1454 sv_catpvs(sv, " during global destruction"); 1455 sv_catpvs(sv, ".\n"); 1456 } 1457 return sv; 1458 } 1459 1460 /* 1461 =for apidoc Am|SV *|vmess|const char *pat|va_list *args 1462 1463 C<pat> and C<args> are a sprintf-style format pattern and encapsulated 1464 argument list, respectively. These are used to generate a string message. If 1465 the 1466 message does not end with a newline, then it will be extended with 1467 some indication of the current location in the code, as described for 1468 L</mess_sv>. 1469 1470 Normally, the resulting message is returned in a new mortal SV. 1471 During global destruction a single SV may be shared between uses of 1472 this function. 1473 1474 =cut 1475 */ 1476 1477 SV * 1478 Perl_vmess(pTHX_ const char *pat, va_list *args) 1479 { 1480 SV * const sv = mess_alloc(); 1481 1482 PERL_ARGS_ASSERT_VMESS; 1483 1484 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 1485 return mess_sv(sv, 1); 1486 } 1487 1488 void 1489 Perl_write_to_stderr(pTHX_ SV* msv) 1490 { 1491 IO *io; 1492 MAGIC *mg; 1493 1494 PERL_ARGS_ASSERT_WRITE_TO_STDERR; 1495 1496 if (PL_stderrgv && SvREFCNT(PL_stderrgv) 1497 && (io = GvIO(PL_stderrgv)) 1498 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 1499 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT), 1500 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv); 1501 else { 1502 PerlIO * const serr = Perl_error_log; 1503 1504 do_print(msv, serr); 1505 (void)PerlIO_flush(serr); 1506 } 1507 } 1508 1509 /* 1510 =head1 Warning and Dieing 1511 */ 1512 1513 /* Common code used in dieing and warning */ 1514 1515 STATIC SV * 1516 S_with_queued_errors(pTHX_ SV *ex) 1517 { 1518 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS; 1519 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) { 1520 sv_catsv(PL_errors, ex); 1521 ex = sv_mortalcopy(PL_errors); 1522 SvCUR_set(PL_errors, 0); 1523 } 1524 return ex; 1525 } 1526 1527 STATIC bool 1528 S_invoke_exception_hook(pTHX_ SV *ex, bool warn) 1529 { 1530 HV *stash; 1531 GV *gv; 1532 CV *cv; 1533 SV **const hook = warn ? &PL_warnhook : &PL_diehook; 1534 /* sv_2cv might call Perl_croak() or Perl_warner() */ 1535 SV * const oldhook = *hook; 1536 1537 if (!oldhook) 1538 return FALSE; 1539 1540 ENTER; 1541 SAVESPTR(*hook); 1542 *hook = NULL; 1543 cv = sv_2cv(oldhook, &stash, &gv, 0); 1544 LEAVE; 1545 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1546 dSP; 1547 SV *exarg; 1548 1549 ENTER; 1550 save_re_context(); 1551 if (warn) { 1552 SAVESPTR(*hook); 1553 *hook = NULL; 1554 } 1555 exarg = newSVsv(ex); 1556 SvREADONLY_on(exarg); 1557 SAVEFREESV(exarg); 1558 1559 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK); 1560 PUSHMARK(SP); 1561 XPUSHs(exarg); 1562 PUTBACK; 1563 call_sv(MUTABLE_SV(cv), G_DISCARD); 1564 POPSTACK; 1565 LEAVE; 1566 return TRUE; 1567 } 1568 return FALSE; 1569 } 1570 1571 /* 1572 =for apidoc Am|OP *|die_sv|SV *baseex 1573 1574 Behaves the same as L</croak_sv>, except for the return type. 1575 It should be used only where the C<OP *> return type is required. 1576 The function never actually returns. 1577 1578 =cut 1579 */ 1580 1581 #ifdef _MSC_VER 1582 # pragma warning( push ) 1583 # pragma warning( disable : 4646 ) /* warning C4646: function declared with 1584 __declspec(noreturn) has non-void return type */ 1585 # pragma warning( disable : 4645 ) /* warning C4645: function declared with 1586 __declspec(noreturn) has a return statement */ 1587 #endif 1588 OP * 1589 Perl_die_sv(pTHX_ SV *baseex) 1590 { 1591 PERL_ARGS_ASSERT_DIE_SV; 1592 croak_sv(baseex); 1593 /* NOTREACHED */ 1594 NORETURN_FUNCTION_END; 1595 } 1596 #ifdef _MSC_VER 1597 # pragma warning( pop ) 1598 #endif 1599 1600 /* 1601 =for apidoc Am|OP *|die|const char *pat|... 1602 1603 Behaves the same as L</croak>, except for the return type. 1604 It should be used only where the C<OP *> return type is required. 1605 The function never actually returns. 1606 1607 =cut 1608 */ 1609 1610 #if defined(PERL_IMPLICIT_CONTEXT) 1611 #ifdef _MSC_VER 1612 # pragma warning( push ) 1613 # pragma warning( disable : 4646 ) /* warning C4646: function declared with 1614 __declspec(noreturn) has non-void return type */ 1615 # pragma warning( disable : 4645 ) /* warning C4645: function declared with 1616 __declspec(noreturn) has a return statement */ 1617 #endif 1618 OP * 1619 Perl_die_nocontext(const char* pat, ...) 1620 { 1621 dTHX; 1622 va_list args; 1623 va_start(args, pat); 1624 vcroak(pat, &args); 1625 NOT_REACHED; /* NOTREACHED */ 1626 va_end(args); 1627 NORETURN_FUNCTION_END; 1628 } 1629 #ifdef _MSC_VER 1630 # pragma warning( pop ) 1631 #endif 1632 #endif /* PERL_IMPLICIT_CONTEXT */ 1633 1634 #ifdef _MSC_VER 1635 # pragma warning( push ) 1636 # pragma warning( disable : 4646 ) /* warning C4646: function declared with 1637 __declspec(noreturn) has non-void return type */ 1638 # pragma warning( disable : 4645 ) /* warning C4645: function declared with 1639 __declspec(noreturn) has a return statement */ 1640 #endif 1641 OP * 1642 Perl_die(pTHX_ const char* pat, ...) 1643 { 1644 va_list args; 1645 va_start(args, pat); 1646 vcroak(pat, &args); 1647 NOT_REACHED; /* NOTREACHED */ 1648 va_end(args); 1649 NORETURN_FUNCTION_END; 1650 } 1651 #ifdef _MSC_VER 1652 # pragma warning( pop ) 1653 #endif 1654 1655 /* 1656 =for apidoc Am|void|croak_sv|SV *baseex 1657 1658 This is an XS interface to Perl's C<die> function. 1659 1660 C<baseex> is the error message or object. If it is a reference, it 1661 will be used as-is. Otherwise it is used as a string, and if it does 1662 not end with a newline then it will be extended with some indication of 1663 the current location in the code, as described for L</mess_sv>. 1664 1665 The error message or object will be used as an exception, by default 1666 returning control to the nearest enclosing C<eval>, but subject to 1667 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv> 1668 function never returns normally. 1669 1670 To die with a simple string message, the L</croak> function may be 1671 more convenient. 1672 1673 =cut 1674 */ 1675 1676 void 1677 Perl_croak_sv(pTHX_ SV *baseex) 1678 { 1679 SV *ex = with_queued_errors(mess_sv(baseex, 0)); 1680 PERL_ARGS_ASSERT_CROAK_SV; 1681 invoke_exception_hook(ex, FALSE); 1682 die_unwind(ex); 1683 } 1684 1685 /* 1686 =for apidoc Am|void|vcroak|const char *pat|va_list *args 1687 1688 This is an XS interface to Perl's C<die> function. 1689 1690 C<pat> and C<args> are a sprintf-style format pattern and encapsulated 1691 argument list. These are used to generate a string message. If the 1692 message does not end with a newline, then it will be extended with 1693 some indication of the current location in the code, as described for 1694 L</mess_sv>. 1695 1696 The error message will be used as an exception, by default 1697 returning control to the nearest enclosing C<eval>, but subject to 1698 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak> 1699 function never returns normally. 1700 1701 For historical reasons, if C<pat> is null then the contents of C<ERRSV> 1702 (C<$@>) will be used as an error message or object instead of building an 1703 error message from arguments. If you want to throw a non-string object, 1704 or build an error message in an SV yourself, it is preferable to use 1705 the L</croak_sv> function, which does not involve clobbering C<ERRSV>. 1706 1707 =cut 1708 */ 1709 1710 void 1711 Perl_vcroak(pTHX_ const char* pat, va_list *args) 1712 { 1713 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0)); 1714 invoke_exception_hook(ex, FALSE); 1715 die_unwind(ex); 1716 } 1717 1718 /* 1719 =for apidoc Am|void|croak|const char *pat|... 1720 1721 This is an XS interface to Perl's C<die> function. 1722 1723 Take a sprintf-style format pattern and argument list. These are used to 1724 generate a string message. If the message does not end with a newline, 1725 then it will be extended with some indication of the current location 1726 in the code, as described for L</mess_sv>. 1727 1728 The error message will be used as an exception, by default 1729 returning control to the nearest enclosing C<eval>, but subject to 1730 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak> 1731 function never returns normally. 1732 1733 For historical reasons, if C<pat> is null then the contents of C<ERRSV> 1734 (C<$@>) will be used as an error message or object instead of building an 1735 error message from arguments. If you want to throw a non-string object, 1736 or build an error message in an SV yourself, it is preferable to use 1737 the L</croak_sv> function, which does not involve clobbering C<ERRSV>. 1738 1739 =cut 1740 */ 1741 1742 #if defined(PERL_IMPLICIT_CONTEXT) 1743 void 1744 Perl_croak_nocontext(const char *pat, ...) 1745 { 1746 dTHX; 1747 va_list args; 1748 va_start(args, pat); 1749 vcroak(pat, &args); 1750 NOT_REACHED; /* NOTREACHED */ 1751 va_end(args); 1752 } 1753 #endif /* PERL_IMPLICIT_CONTEXT */ 1754 1755 void 1756 Perl_croak(pTHX_ const char *pat, ...) 1757 { 1758 va_list args; 1759 va_start(args, pat); 1760 vcroak(pat, &args); 1761 NOT_REACHED; /* NOTREACHED */ 1762 va_end(args); 1763 } 1764 1765 /* 1766 =for apidoc Am|void|croak_no_modify 1767 1768 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates 1769 terser object code than using C<Perl_croak>. Less code used on exception code 1770 paths reduces CPU cache pressure. 1771 1772 =cut 1773 */ 1774 1775 void 1776 Perl_croak_no_modify(void) 1777 { 1778 Perl_croak_nocontext( "%s", PL_no_modify); 1779 } 1780 1781 /* does not return, used in util.c perlio.c and win32.c 1782 This is typically called when malloc returns NULL. 1783 */ 1784 void 1785 Perl_croak_no_mem(void) 1786 { 1787 dTHX; 1788 1789 int fd = PerlIO_fileno(Perl_error_log); 1790 if (fd < 0) 1791 SETERRNO(EBADF,RMS_IFI); 1792 else { 1793 /* Can't use PerlIO to write as it allocates memory */ 1794 PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1)); 1795 } 1796 my_exit(1); 1797 } 1798 1799 /* does not return, used only in POPSTACK */ 1800 void 1801 Perl_croak_popstack(void) 1802 { 1803 dTHX; 1804 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n"); 1805 my_exit(1); 1806 } 1807 1808 /* 1809 =for apidoc Am|void|warn_sv|SV *baseex 1810 1811 This is an XS interface to Perl's C<warn> function. 1812 1813 C<baseex> is the error message or object. If it is a reference, it 1814 will be used as-is. Otherwise it is used as a string, and if it does 1815 not end with a newline then it will be extended with some indication of 1816 the current location in the code, as described for L</mess_sv>. 1817 1818 The error message or object will by default be written to standard error, 1819 but this is subject to modification by a C<$SIG{__WARN__}> handler. 1820 1821 To warn with a simple string message, the L</warn> function may be 1822 more convenient. 1823 1824 =cut 1825 */ 1826 1827 void 1828 Perl_warn_sv(pTHX_ SV *baseex) 1829 { 1830 SV *ex = mess_sv(baseex, 0); 1831 PERL_ARGS_ASSERT_WARN_SV; 1832 if (!invoke_exception_hook(ex, TRUE)) 1833 write_to_stderr(ex); 1834 } 1835 1836 /* 1837 =for apidoc Am|void|vwarn|const char *pat|va_list *args 1838 1839 This is an XS interface to Perl's C<warn> function. 1840 1841 C<pat> and C<args> are a sprintf-style format pattern and encapsulated 1842 argument list. These are used to generate a string message. If the 1843 message does not end with a newline, then it will be extended with 1844 some indication of the current location in the code, as described for 1845 L</mess_sv>. 1846 1847 The error message or object will by default be written to standard error, 1848 but this is subject to modification by a C<$SIG{__WARN__}> handler. 1849 1850 Unlike with L</vcroak>, C<pat> is not permitted to be null. 1851 1852 =cut 1853 */ 1854 1855 void 1856 Perl_vwarn(pTHX_ const char* pat, va_list *args) 1857 { 1858 SV *ex = vmess(pat, args); 1859 PERL_ARGS_ASSERT_VWARN; 1860 if (!invoke_exception_hook(ex, TRUE)) 1861 write_to_stderr(ex); 1862 } 1863 1864 /* 1865 =for apidoc Am|void|warn|const char *pat|... 1866 1867 This is an XS interface to Perl's C<warn> function. 1868 1869 Take a sprintf-style format pattern and argument list. These are used to 1870 generate a string message. If the message does not end with a newline, 1871 then it will be extended with some indication of the current location 1872 in the code, as described for L</mess_sv>. 1873 1874 The error message or object will by default be written to standard error, 1875 but this is subject to modification by a C<$SIG{__WARN__}> handler. 1876 1877 Unlike with L</croak>, C<pat> is not permitted to be null. 1878 1879 =cut 1880 */ 1881 1882 #if defined(PERL_IMPLICIT_CONTEXT) 1883 void 1884 Perl_warn_nocontext(const char *pat, ...) 1885 { 1886 dTHX; 1887 va_list args; 1888 PERL_ARGS_ASSERT_WARN_NOCONTEXT; 1889 va_start(args, pat); 1890 vwarn(pat, &args); 1891 va_end(args); 1892 } 1893 #endif /* PERL_IMPLICIT_CONTEXT */ 1894 1895 void 1896 Perl_warn(pTHX_ const char *pat, ...) 1897 { 1898 va_list args; 1899 PERL_ARGS_ASSERT_WARN; 1900 va_start(args, pat); 1901 vwarn(pat, &args); 1902 va_end(args); 1903 } 1904 1905 #if defined(PERL_IMPLICIT_CONTEXT) 1906 void 1907 Perl_warner_nocontext(U32 err, const char *pat, ...) 1908 { 1909 dTHX; 1910 va_list args; 1911 PERL_ARGS_ASSERT_WARNER_NOCONTEXT; 1912 va_start(args, pat); 1913 vwarner(err, pat, &args); 1914 va_end(args); 1915 } 1916 #endif /* PERL_IMPLICIT_CONTEXT */ 1917 1918 void 1919 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...) 1920 { 1921 PERL_ARGS_ASSERT_CK_WARNER_D; 1922 1923 if (Perl_ckwarn_d(aTHX_ err)) { 1924 va_list args; 1925 va_start(args, pat); 1926 vwarner(err, pat, &args); 1927 va_end(args); 1928 } 1929 } 1930 1931 void 1932 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) 1933 { 1934 PERL_ARGS_ASSERT_CK_WARNER; 1935 1936 if (Perl_ckwarn(aTHX_ err)) { 1937 va_list args; 1938 va_start(args, pat); 1939 vwarner(err, pat, &args); 1940 va_end(args); 1941 } 1942 } 1943 1944 void 1945 Perl_warner(pTHX_ U32 err, const char* pat,...) 1946 { 1947 va_list args; 1948 PERL_ARGS_ASSERT_WARNER; 1949 va_start(args, pat); 1950 vwarner(err, pat, &args); 1951 va_end(args); 1952 } 1953 1954 void 1955 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) 1956 { 1957 dVAR; 1958 PERL_ARGS_ASSERT_VWARNER; 1959 if ( 1960 (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) && 1961 !(PL_in_eval & EVAL_KEEPERR) 1962 ) { 1963 SV * const msv = vmess(pat, args); 1964 1965 if (PL_parser && PL_parser->error_count) { 1966 qerror(msv); 1967 } 1968 else { 1969 invoke_exception_hook(msv, FALSE); 1970 die_unwind(msv); 1971 } 1972 } 1973 else { 1974 Perl_vwarn(aTHX_ pat, args); 1975 } 1976 } 1977 1978 /* implements the ckWARN? macros */ 1979 1980 bool 1981 Perl_ckwarn(pTHX_ U32 w) 1982 { 1983 /* If lexical warnings have not been set, use $^W. */ 1984 if (isLEXWARN_off) 1985 return PL_dowarn & G_WARN_ON; 1986 1987 return ckwarn_common(w); 1988 } 1989 1990 /* implements the ckWARN?_d macro */ 1991 1992 bool 1993 Perl_ckwarn_d(pTHX_ U32 w) 1994 { 1995 /* If lexical warnings have not been set then default classes warn. */ 1996 if (isLEXWARN_off) 1997 return TRUE; 1998 1999 return ckwarn_common(w); 2000 } 2001 2002 static bool 2003 S_ckwarn_common(pTHX_ U32 w) 2004 { 2005 if (PL_curcop->cop_warnings == pWARN_ALL) 2006 return TRUE; 2007 2008 if (PL_curcop->cop_warnings == pWARN_NONE) 2009 return FALSE; 2010 2011 /* Check the assumption that at least the first slot is non-zero. */ 2012 assert(unpackWARN1(w)); 2013 2014 /* Check the assumption that it is valid to stop as soon as a zero slot is 2015 seen. */ 2016 if (!unpackWARN2(w)) { 2017 assert(!unpackWARN3(w)); 2018 assert(!unpackWARN4(w)); 2019 } else if (!unpackWARN3(w)) { 2020 assert(!unpackWARN4(w)); 2021 } 2022 2023 /* Right, dealt with all the special cases, which are implemented as non- 2024 pointers, so there is a pointer to a real warnings mask. */ 2025 do { 2026 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))) 2027 return TRUE; 2028 } while (w >>= WARNshift); 2029 2030 return FALSE; 2031 } 2032 2033 /* Set buffer=NULL to get a new one. */ 2034 STRLEN * 2035 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, 2036 STRLEN size) { 2037 const MEM_SIZE len_wanted = 2038 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize); 2039 PERL_UNUSED_CONTEXT; 2040 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD; 2041 2042 buffer = (STRLEN*) 2043 (specialWARN(buffer) ? 2044 PerlMemShared_malloc(len_wanted) : 2045 PerlMemShared_realloc(buffer, len_wanted)); 2046 buffer[0] = size; 2047 Copy(bits, (buffer + 1), size, char); 2048 if (size < WARNsize) 2049 Zero((char *)(buffer + 1) + size, WARNsize - size, char); 2050 return buffer; 2051 } 2052 2053 /* since we've already done strlen() for both nam and val 2054 * we can use that info to make things faster than 2055 * sprintf(s, "%s=%s", nam, val) 2056 */ 2057 #define my_setenv_format(s, nam, nlen, val, vlen) \ 2058 Copy(nam, s, nlen, char); \ 2059 *(s+nlen) = '='; \ 2060 Copy(val, s+(nlen+1), vlen, char); \ 2061 *(s+(nlen+1+vlen)) = '\0' 2062 2063 #ifdef USE_ENVIRON_ARRAY 2064 2065 /* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if 2066 * 'current' is non-null, with up to three sizes that are added together. 2067 * It handles integer overflow. 2068 */ 2069 static char * 2070 S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size) 2071 { 2072 void *p; 2073 Size_t sl, l = l1 + l2; 2074 2075 if (l < l2) 2076 goto panic; 2077 l += l3; 2078 if (l < l3) 2079 goto panic; 2080 sl = l * size; 2081 if (sl < l) 2082 goto panic; 2083 2084 p = current 2085 ? safesysrealloc(current, sl) 2086 : safesysmalloc(sl); 2087 if (p) 2088 return (char*)p; 2089 2090 panic: 2091 croak_memory_wrap(); 2092 } 2093 2094 2095 /* VMS' my_setenv() is in vms.c */ 2096 #if !defined(WIN32) && !defined(NETWARE) 2097 2098 void 2099 Perl_my_setenv(pTHX_ const char *nam, const char *val) 2100 { 2101 dVAR; 2102 #ifdef __amigaos4__ 2103 amigaos4_obtain_environ(__FUNCTION__); 2104 #endif 2105 #ifdef USE_ITHREADS 2106 /* only parent thread can modify process environment */ 2107 if (PL_curinterp == aTHX) 2108 #endif 2109 { 2110 #ifndef PERL_USE_SAFE_PUTENV 2111 if (!PL_use_safe_putenv) { 2112 /* most putenv()s leak, so we manipulate environ directly */ 2113 UV i; 2114 Size_t vlen, nlen = strlen(nam); 2115 2116 /* where does it go? */ 2117 for (i = 0; environ[i]; i++) { 2118 if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=') 2119 break; 2120 } 2121 2122 if (environ == PL_origenviron) { /* need we copy environment? */ 2123 UV j, max; 2124 char **tmpenv; 2125 2126 max = i; 2127 while (environ[max]) 2128 max++; 2129 /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */ 2130 tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*)); 2131 for (j=0; j<max; j++) { /* copy environment */ 2132 const Size_t len = strlen(environ[j]); 2133 tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1); 2134 Copy(environ[j], tmpenv[j], len+1, char); 2135 } 2136 tmpenv[max] = NULL; 2137 environ = tmpenv; /* tell exec where it is now */ 2138 } 2139 if (!val) { 2140 safesysfree(environ[i]); 2141 while (environ[i]) { 2142 environ[i] = environ[i+1]; 2143 i++; 2144 } 2145 #ifdef __amigaos4__ 2146 goto my_setenv_out; 2147 #else 2148 return; 2149 #endif 2150 } 2151 if (!environ[i]) { /* does not exist yet */ 2152 environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*)); 2153 environ[i+1] = NULL; /* make sure it's null terminated */ 2154 } 2155 else 2156 safesysfree(environ[i]); 2157 2158 vlen = strlen(val); 2159 2160 environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1); 2161 /* all that work just for this */ 2162 my_setenv_format(environ[i], nam, nlen, val, vlen); 2163 } else { 2164 # endif 2165 /* This next branch should only be called #if defined(HAS_SETENV), but 2166 Configure doesn't test for that yet. For Solaris, setenv() and unsetenv() 2167 were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient. 2168 */ 2169 # if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN) 2170 # if defined(HAS_UNSETENV) 2171 if (val == NULL) { 2172 (void)unsetenv(nam); 2173 } else { 2174 (void)setenv(nam, val, 1); 2175 } 2176 # else /* ! HAS_UNSETENV */ 2177 (void)setenv(nam, val, 1); 2178 # endif /* HAS_UNSETENV */ 2179 # elif defined(HAS_UNSETENV) 2180 if (val == NULL) { 2181 if (environ) /* old glibc can crash with null environ */ 2182 (void)unsetenv(nam); 2183 } else { 2184 const Size_t nlen = strlen(nam); 2185 const Size_t vlen = strlen(val); 2186 char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1); 2187 my_setenv_format(new_env, nam, nlen, val, vlen); 2188 (void)putenv(new_env); 2189 } 2190 # else /* ! HAS_UNSETENV */ 2191 char *new_env; 2192 const Size_t nlen = strlen(nam); 2193 Size_t vlen; 2194 if (!val) { 2195 val = ""; 2196 } 2197 vlen = strlen(val); 2198 new_env = S_env_alloc(NULL, nlen, vlen, 2, 1); 2199 /* all that work just for this */ 2200 my_setenv_format(new_env, nam, nlen, val, vlen); 2201 (void)putenv(new_env); 2202 # endif /* __CYGWIN__ */ 2203 #ifndef PERL_USE_SAFE_PUTENV 2204 } 2205 #endif 2206 } 2207 #ifdef __amigaos4__ 2208 my_setenv_out: 2209 amigaos4_release_environ(__FUNCTION__); 2210 #endif 2211 } 2212 2213 #else /* WIN32 || NETWARE */ 2214 2215 void 2216 Perl_my_setenv(pTHX_ const char *nam, const char *val) 2217 { 2218 dVAR; 2219 char *envstr; 2220 const Size_t nlen = strlen(nam); 2221 Size_t vlen; 2222 2223 if (!val) { 2224 val = ""; 2225 } 2226 vlen = strlen(val); 2227 envstr = S_env_alloc(NULL, nlen, vlen, 2, 1); 2228 my_setenv_format(envstr, nam, nlen, val, vlen); 2229 (void)PerlEnv_putenv(envstr); 2230 Safefree(envstr); 2231 } 2232 2233 #endif /* WIN32 || NETWARE */ 2234 2235 #endif /* !VMS */ 2236 2237 #ifdef UNLINK_ALL_VERSIONS 2238 I32 2239 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ 2240 { 2241 I32 retries = 0; 2242 2243 PERL_ARGS_ASSERT_UNLNK; 2244 2245 while (PerlLIO_unlink(f) >= 0) 2246 retries++; 2247 return retries ? 0 : -1; 2248 } 2249 #endif 2250 2251 PerlIO * 2252 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) 2253 { 2254 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) 2255 int p[2]; 2256 I32 This, that; 2257 Pid_t pid; 2258 SV *sv; 2259 I32 did_pipes = 0; 2260 int pp[2]; 2261 2262 PERL_ARGS_ASSERT_MY_POPEN_LIST; 2263 2264 PERL_FLUSHALL_FOR_CHILD; 2265 This = (*mode == 'w'); 2266 that = !This; 2267 if (TAINTING_get) { 2268 taint_env(); 2269 taint_proper("Insecure %s%s", "EXEC"); 2270 } 2271 if (PerlProc_pipe_cloexec(p) < 0) 2272 return NULL; 2273 /* Try for another pipe pair for error return */ 2274 if (PerlProc_pipe_cloexec(pp) >= 0) 2275 did_pipes = 1; 2276 while ((pid = PerlProc_fork()) < 0) { 2277 if (errno != EAGAIN) { 2278 PerlLIO_close(p[This]); 2279 PerlLIO_close(p[that]); 2280 if (did_pipes) { 2281 PerlLIO_close(pp[0]); 2282 PerlLIO_close(pp[1]); 2283 } 2284 return NULL; 2285 } 2286 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); 2287 sleep(5); 2288 } 2289 if (pid == 0) { 2290 /* Child */ 2291 #undef THIS 2292 #undef THAT 2293 #define THIS that 2294 #define THAT This 2295 /* Close parent's end of error status pipe (if any) */ 2296 if (did_pipes) 2297 PerlLIO_close(pp[0]); 2298 /* Now dup our end of _the_ pipe to right position */ 2299 if (p[THIS] != (*mode == 'r')) { 2300 PerlLIO_dup2(p[THIS], *mode == 'r'); 2301 PerlLIO_close(p[THIS]); 2302 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 2303 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ 2304 } 2305 else 2306 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ 2307 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2308 /* No automatic close - do it by hand */ 2309 # ifndef NOFILE 2310 # define NOFILE 20 2311 # endif 2312 { 2313 int fd; 2314 2315 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { 2316 if (fd != pp[1]) 2317 PerlLIO_close(fd); 2318 } 2319 } 2320 #endif 2321 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes); 2322 PerlProc__exit(1); 2323 #undef THIS 2324 #undef THAT 2325 } 2326 /* Parent */ 2327 if (did_pipes) 2328 PerlLIO_close(pp[1]); 2329 /* Keep the lower of the two fd numbers */ 2330 if (p[that] < p[This]) { 2331 PerlLIO_dup2_cloexec(p[This], p[that]); 2332 PerlLIO_close(p[This]); 2333 p[This] = p[that]; 2334 } 2335 else 2336 PerlLIO_close(p[that]); /* close child's end of pipe */ 2337 2338 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2339 SvUPGRADE(sv,SVt_IV); 2340 SvIV_set(sv, pid); 2341 PL_forkprocess = pid; 2342 /* If we managed to get status pipe check for exec fail */ 2343 if (did_pipes && pid > 0) { 2344 int errkid; 2345 unsigned n = 0; 2346 2347 while (n < sizeof(int)) { 2348 const SSize_t n1 = PerlLIO_read(pp[0], 2349 (void*)(((char*)&errkid)+n), 2350 (sizeof(int)) - n); 2351 if (n1 <= 0) 2352 break; 2353 n += n1; 2354 } 2355 PerlLIO_close(pp[0]); 2356 did_pipes = 0; 2357 if (n) { /* Error */ 2358 int pid2, status; 2359 PerlLIO_close(p[This]); 2360 if (n != sizeof(int)) 2361 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); 2362 do { 2363 pid2 = wait4pid(pid, &status, 0); 2364 } while (pid2 == -1 && errno == EINTR); 2365 errno = errkid; /* Propagate errno from kid */ 2366 return NULL; 2367 } 2368 } 2369 if (did_pipes) 2370 PerlLIO_close(pp[0]); 2371 return PerlIO_fdopen(p[This], mode); 2372 #else 2373 # if defined(OS2) /* Same, without fork()ing and all extra overhead... */ 2374 return my_syspopen4(aTHX_ NULL, mode, n, args); 2375 # elif defined(WIN32) 2376 return win32_popenlist(mode, n, args); 2377 # else 2378 Perl_croak(aTHX_ "List form of piped open not implemented"); 2379 return (PerlIO *) NULL; 2380 # endif 2381 #endif 2382 } 2383 2384 /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */ 2385 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) 2386 PerlIO * 2387 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2388 { 2389 int p[2]; 2390 I32 This, that; 2391 Pid_t pid; 2392 SV *sv; 2393 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); 2394 I32 did_pipes = 0; 2395 int pp[2]; 2396 2397 PERL_ARGS_ASSERT_MY_POPEN; 2398 2399 PERL_FLUSHALL_FOR_CHILD; 2400 #ifdef OS2 2401 if (doexec) { 2402 return my_syspopen(aTHX_ cmd,mode); 2403 } 2404 #endif 2405 This = (*mode == 'w'); 2406 that = !This; 2407 if (doexec && TAINTING_get) { 2408 taint_env(); 2409 taint_proper("Insecure %s%s", "EXEC"); 2410 } 2411 if (PerlProc_pipe_cloexec(p) < 0) 2412 return NULL; 2413 if (doexec && PerlProc_pipe_cloexec(pp) >= 0) 2414 did_pipes = 1; 2415 while ((pid = PerlProc_fork()) < 0) { 2416 if (errno != EAGAIN) { 2417 PerlLIO_close(p[This]); 2418 PerlLIO_close(p[that]); 2419 if (did_pipes) { 2420 PerlLIO_close(pp[0]); 2421 PerlLIO_close(pp[1]); 2422 } 2423 if (!doexec) 2424 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); 2425 return NULL; 2426 } 2427 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); 2428 sleep(5); 2429 } 2430 if (pid == 0) { 2431 2432 #undef THIS 2433 #undef THAT 2434 #define THIS that 2435 #define THAT This 2436 if (did_pipes) 2437 PerlLIO_close(pp[0]); 2438 if (p[THIS] != (*mode == 'r')) { 2439 PerlLIO_dup2(p[THIS], *mode == 'r'); 2440 PerlLIO_close(p[THIS]); 2441 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 2442 PerlLIO_close(p[THAT]); 2443 } 2444 else 2445 PerlLIO_close(p[THAT]); 2446 #ifndef OS2 2447 if (doexec) { 2448 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2449 #ifndef NOFILE 2450 #define NOFILE 20 2451 #endif 2452 { 2453 int fd; 2454 2455 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) 2456 if (fd != pp[1]) 2457 PerlLIO_close(fd); 2458 } 2459 #endif 2460 /* may or may not use the shell */ 2461 do_exec3(cmd, pp[1], did_pipes); 2462 PerlProc__exit(1); 2463 } 2464 #endif /* defined OS2 */ 2465 2466 #ifdef PERLIO_USING_CRLF 2467 /* Since we circumvent IO layers when we manipulate low-level 2468 filedescriptors directly, need to manually switch to the 2469 default, binary, low-level mode; see PerlIOBuf_open(). */ 2470 PerlLIO_setmode((*mode == 'r'), O_BINARY); 2471 #endif 2472 PL_forkprocess = 0; 2473 #ifdef PERL_USES_PL_PIDSTATUS 2474 hv_clear(PL_pidstatus); /* we have no children */ 2475 #endif 2476 return NULL; 2477 #undef THIS 2478 #undef THAT 2479 } 2480 if (did_pipes) 2481 PerlLIO_close(pp[1]); 2482 if (p[that] < p[This]) { 2483 PerlLIO_dup2_cloexec(p[This], p[that]); 2484 PerlLIO_close(p[This]); 2485 p[This] = p[that]; 2486 } 2487 else 2488 PerlLIO_close(p[that]); 2489 2490 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2491 SvUPGRADE(sv,SVt_IV); 2492 SvIV_set(sv, pid); 2493 PL_forkprocess = pid; 2494 if (did_pipes && pid > 0) { 2495 int errkid; 2496 unsigned n = 0; 2497 2498 while (n < sizeof(int)) { 2499 const SSize_t n1 = PerlLIO_read(pp[0], 2500 (void*)(((char*)&errkid)+n), 2501 (sizeof(int)) - n); 2502 if (n1 <= 0) 2503 break; 2504 n += n1; 2505 } 2506 PerlLIO_close(pp[0]); 2507 did_pipes = 0; 2508 if (n) { /* Error */ 2509 int pid2, status; 2510 PerlLIO_close(p[This]); 2511 if (n != sizeof(int)) 2512 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); 2513 do { 2514 pid2 = wait4pid(pid, &status, 0); 2515 } while (pid2 == -1 && errno == EINTR); 2516 errno = errkid; /* Propagate errno from kid */ 2517 return NULL; 2518 } 2519 } 2520 if (did_pipes) 2521 PerlLIO_close(pp[0]); 2522 return PerlIO_fdopen(p[This], mode); 2523 } 2524 #elif defined(DJGPP) 2525 FILE *djgpp_popen(); 2526 PerlIO * 2527 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2528 { 2529 PERL_FLUSHALL_FOR_CHILD; 2530 /* Call system's popen() to get a FILE *, then import it. 2531 used 0 for 2nd parameter to PerlIO_importFILE; 2532 apparently not used 2533 */ 2534 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); 2535 } 2536 #elif defined(__LIBCATAMOUNT__) 2537 PerlIO * 2538 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2539 { 2540 return NULL; 2541 } 2542 2543 #endif /* !DOSISH */ 2544 2545 /* this is called in parent before the fork() */ 2546 void 2547 Perl_atfork_lock(void) 2548 #if defined(USE_ITHREADS) 2549 # ifdef USE_PERLIO 2550 PERL_TSA_ACQUIRE(PL_perlio_mutex) 2551 # endif 2552 # ifdef MYMALLOC 2553 PERL_TSA_ACQUIRE(PL_malloc_mutex) 2554 # endif 2555 PERL_TSA_ACQUIRE(PL_op_mutex) 2556 #endif 2557 { 2558 #if defined(USE_ITHREADS) 2559 dVAR; 2560 /* locks must be held in locking order (if any) */ 2561 # ifdef USE_PERLIO 2562 MUTEX_LOCK(&PL_perlio_mutex); 2563 # endif 2564 # ifdef MYMALLOC 2565 MUTEX_LOCK(&PL_malloc_mutex); 2566 # endif 2567 OP_REFCNT_LOCK; 2568 #endif 2569 } 2570 2571 /* this is called in both parent and child after the fork() */ 2572 void 2573 Perl_atfork_unlock(void) 2574 #if defined(USE_ITHREADS) 2575 # ifdef USE_PERLIO 2576 PERL_TSA_RELEASE(PL_perlio_mutex) 2577 # endif 2578 # ifdef MYMALLOC 2579 PERL_TSA_RELEASE(PL_malloc_mutex) 2580 # endif 2581 PERL_TSA_RELEASE(PL_op_mutex) 2582 #endif 2583 { 2584 #if defined(USE_ITHREADS) 2585 dVAR; 2586 /* locks must be released in same order as in atfork_lock() */ 2587 # ifdef USE_PERLIO 2588 MUTEX_UNLOCK(&PL_perlio_mutex); 2589 # endif 2590 # ifdef MYMALLOC 2591 MUTEX_UNLOCK(&PL_malloc_mutex); 2592 # endif 2593 OP_REFCNT_UNLOCK; 2594 #endif 2595 } 2596 2597 Pid_t 2598 Perl_my_fork(void) 2599 { 2600 #if defined(HAS_FORK) 2601 Pid_t pid; 2602 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK) 2603 atfork_lock(); 2604 pid = fork(); 2605 atfork_unlock(); 2606 #else 2607 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork() 2608 * handlers elsewhere in the code */ 2609 pid = fork(); 2610 #endif 2611 return pid; 2612 #elif defined(__amigaos4__) 2613 return amigaos_fork(); 2614 #else 2615 /* this "canna happen" since nothing should be calling here if !HAS_FORK */ 2616 Perl_croak_nocontext("fork() not available"); 2617 return 0; 2618 #endif /* HAS_FORK */ 2619 } 2620 2621 #ifndef HAS_DUP2 2622 int 2623 dup2(int oldfd, int newfd) 2624 { 2625 #if defined(HAS_FCNTL) && defined(F_DUPFD) 2626 if (oldfd == newfd) 2627 return oldfd; 2628 PerlLIO_close(newfd); 2629 return fcntl(oldfd, F_DUPFD, newfd); 2630 #else 2631 #define DUP2_MAX_FDS 256 2632 int fdtmp[DUP2_MAX_FDS]; 2633 I32 fdx = 0; 2634 int fd; 2635 2636 if (oldfd == newfd) 2637 return oldfd; 2638 PerlLIO_close(newfd); 2639 /* good enough for low fd's... */ 2640 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) { 2641 if (fdx >= DUP2_MAX_FDS) { 2642 PerlLIO_close(fd); 2643 fd = -1; 2644 break; 2645 } 2646 fdtmp[fdx++] = fd; 2647 } 2648 while (fdx > 0) 2649 PerlLIO_close(fdtmp[--fdx]); 2650 return fd; 2651 #endif 2652 } 2653 #endif 2654 2655 #ifndef PERL_MICRO 2656 #ifdef HAS_SIGACTION 2657 2658 Sighandler_t 2659 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2660 { 2661 struct sigaction act, oact; 2662 2663 #ifdef USE_ITHREADS 2664 dVAR; 2665 /* only "parent" interpreter can diddle signals */ 2666 if (PL_curinterp != aTHX) 2667 return (Sighandler_t) SIG_ERR; 2668 #endif 2669 2670 act.sa_handler = (void(*)(int))handler; 2671 sigemptyset(&act.sa_mask); 2672 act.sa_flags = 0; 2673 #ifdef SA_RESTART 2674 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 2675 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2676 #endif 2677 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 2678 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) 2679 act.sa_flags |= SA_NOCLDWAIT; 2680 #endif 2681 if (sigaction(signo, &act, &oact) == -1) 2682 return (Sighandler_t) SIG_ERR; 2683 else 2684 return (Sighandler_t) oact.sa_handler; 2685 } 2686 2687 Sighandler_t 2688 Perl_rsignal_state(pTHX_ int signo) 2689 { 2690 struct sigaction oact; 2691 PERL_UNUSED_CONTEXT; 2692 2693 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) 2694 return (Sighandler_t) SIG_ERR; 2695 else 2696 return (Sighandler_t) oact.sa_handler; 2697 } 2698 2699 int 2700 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2701 { 2702 #ifdef USE_ITHREADS 2703 dVAR; 2704 #endif 2705 struct sigaction act; 2706 2707 PERL_ARGS_ASSERT_RSIGNAL_SAVE; 2708 2709 #ifdef USE_ITHREADS 2710 /* only "parent" interpreter can diddle signals */ 2711 if (PL_curinterp != aTHX) 2712 return -1; 2713 #endif 2714 2715 act.sa_handler = (void(*)(int))handler; 2716 sigemptyset(&act.sa_mask); 2717 act.sa_flags = 0; 2718 #ifdef SA_RESTART 2719 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 2720 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2721 #endif 2722 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 2723 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) 2724 act.sa_flags |= SA_NOCLDWAIT; 2725 #endif 2726 return sigaction(signo, &act, save); 2727 } 2728 2729 int 2730 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2731 { 2732 #ifdef USE_ITHREADS 2733 dVAR; 2734 #endif 2735 PERL_UNUSED_CONTEXT; 2736 #ifdef USE_ITHREADS 2737 /* only "parent" interpreter can diddle signals */ 2738 if (PL_curinterp != aTHX) 2739 return -1; 2740 #endif 2741 2742 return sigaction(signo, save, (struct sigaction *)NULL); 2743 } 2744 2745 #else /* !HAS_SIGACTION */ 2746 2747 Sighandler_t 2748 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2749 { 2750 #if defined(USE_ITHREADS) && !defined(WIN32) 2751 /* only "parent" interpreter can diddle signals */ 2752 if (PL_curinterp != aTHX) 2753 return (Sighandler_t) SIG_ERR; 2754 #endif 2755 2756 return PerlProc_signal(signo, handler); 2757 } 2758 2759 static Signal_t 2760 sig_trap(int signo) 2761 { 2762 dVAR; 2763 PL_sig_trapped++; 2764 } 2765 2766 Sighandler_t 2767 Perl_rsignal_state(pTHX_ int signo) 2768 { 2769 dVAR; 2770 Sighandler_t oldsig; 2771 2772 #if defined(USE_ITHREADS) && !defined(WIN32) 2773 /* only "parent" interpreter can diddle signals */ 2774 if (PL_curinterp != aTHX) 2775 return (Sighandler_t) SIG_ERR; 2776 #endif 2777 2778 PL_sig_trapped = 0; 2779 oldsig = PerlProc_signal(signo, sig_trap); 2780 PerlProc_signal(signo, oldsig); 2781 if (PL_sig_trapped) 2782 PerlProc_kill(PerlProc_getpid(), signo); 2783 return oldsig; 2784 } 2785 2786 int 2787 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2788 { 2789 #if defined(USE_ITHREADS) && !defined(WIN32) 2790 /* only "parent" interpreter can diddle signals */ 2791 if (PL_curinterp != aTHX) 2792 return -1; 2793 #endif 2794 *save = PerlProc_signal(signo, handler); 2795 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0; 2796 } 2797 2798 int 2799 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2800 { 2801 #if defined(USE_ITHREADS) && !defined(WIN32) 2802 /* only "parent" interpreter can diddle signals */ 2803 if (PL_curinterp != aTHX) 2804 return -1; 2805 #endif 2806 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0; 2807 } 2808 2809 #endif /* !HAS_SIGACTION */ 2810 #endif /* !PERL_MICRO */ 2811 2812 /* VMS' my_pclose() is in VMS.c; same with OS/2 */ 2813 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) 2814 I32 2815 Perl_my_pclose(pTHX_ PerlIO *ptr) 2816 { 2817 int status; 2818 SV **svp; 2819 Pid_t pid; 2820 Pid_t pid2 = 0; 2821 bool close_failed; 2822 dSAVEDERRNO; 2823 const int fd = PerlIO_fileno(ptr); 2824 bool should_wait; 2825 2826 svp = av_fetch(PL_fdpid,fd,TRUE); 2827 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; 2828 SvREFCNT_dec(*svp); 2829 *svp = NULL; 2830 2831 #if defined(USE_PERLIO) 2832 /* Find out whether the refcount is low enough for us to wait for the 2833 child proc without blocking. */ 2834 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0; 2835 #else 2836 should_wait = pid > 0; 2837 #endif 2838 2839 #ifdef OS2 2840 if (pid == -1) { /* Opened by popen. */ 2841 return my_syspclose(ptr); 2842 } 2843 #endif 2844 close_failed = (PerlIO_close(ptr) == EOF); 2845 SAVE_ERRNO; 2846 if (should_wait) do { 2847 pid2 = wait4pid(pid, &status, 0); 2848 } while (pid2 == -1 && errno == EINTR); 2849 if (close_failed) { 2850 RESTORE_ERRNO; 2851 return -1; 2852 } 2853 return( 2854 should_wait 2855 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status) 2856 : 0 2857 ); 2858 } 2859 #elif defined(__LIBCATAMOUNT__) 2860 I32 2861 Perl_my_pclose(pTHX_ PerlIO *ptr) 2862 { 2863 return -1; 2864 } 2865 #endif /* !DOSISH */ 2866 2867 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__) 2868 I32 2869 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) 2870 { 2871 I32 result = 0; 2872 PERL_ARGS_ASSERT_WAIT4PID; 2873 #ifdef PERL_USES_PL_PIDSTATUS 2874 if (!pid) { 2875 /* PERL_USES_PL_PIDSTATUS is only defined when neither 2876 waitpid() nor wait4() is available, or on OS/2, which 2877 doesn't appear to support waiting for a progress group 2878 member, so we can only treat a 0 pid as an unknown child. 2879 */ 2880 errno = ECHILD; 2881 return -1; 2882 } 2883 { 2884 if (pid > 0) { 2885 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the 2886 pid, rather than a string form. */ 2887 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE); 2888 if (svp && *svp != &PL_sv_undef) { 2889 *statusp = SvIVX(*svp); 2890 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t), 2891 G_DISCARD); 2892 return pid; 2893 } 2894 } 2895 else { 2896 HE *entry; 2897 2898 hv_iterinit(PL_pidstatus); 2899 if ((entry = hv_iternext(PL_pidstatus))) { 2900 SV * const sv = hv_iterval(PL_pidstatus,entry); 2901 I32 len; 2902 const char * const spid = hv_iterkey(entry,&len); 2903 2904 assert (len == sizeof(Pid_t)); 2905 memcpy((char *)&pid, spid, len); 2906 *statusp = SvIVX(sv); 2907 /* The hash iterator is currently on this entry, so simply 2908 calling hv_delete would trigger the lazy delete, which on 2909 aggregate does more work, because next call to hv_iterinit() 2910 would spot the flag, and have to call the delete routine, 2911 while in the meantime any new entries can't re-use that 2912 memory. */ 2913 hv_iterinit(PL_pidstatus); 2914 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD); 2915 return pid; 2916 } 2917 } 2918 } 2919 #endif 2920 #ifdef HAS_WAITPID 2921 # ifdef HAS_WAITPID_RUNTIME 2922 if (!HAS_WAITPID_RUNTIME) 2923 goto hard_way; 2924 # endif 2925 result = PerlProc_waitpid(pid,statusp,flags); 2926 goto finish; 2927 #endif 2928 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) 2929 result = wait4(pid,statusp,flags,NULL); 2930 goto finish; 2931 #endif 2932 #ifdef PERL_USES_PL_PIDSTATUS 2933 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME) 2934 hard_way: 2935 #endif 2936 { 2937 if (flags) 2938 Perl_croak(aTHX_ "Can't do waitpid with flags"); 2939 else { 2940 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) 2941 pidgone(result,*statusp); 2942 if (result < 0) 2943 *statusp = -1; 2944 } 2945 } 2946 #endif 2947 #if defined(HAS_WAITPID) || defined(HAS_WAIT4) 2948 finish: 2949 #endif 2950 if (result < 0 && errno == EINTR) { 2951 PERL_ASYNC_CHECK(); 2952 errno = EINTR; /* reset in case a signal handler changed $! */ 2953 } 2954 return result; 2955 } 2956 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */ 2957 2958 #ifdef PERL_USES_PL_PIDSTATUS 2959 void 2960 S_pidgone(pTHX_ Pid_t pid, int status) 2961 { 2962 SV *sv; 2963 2964 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE); 2965 SvUPGRADE(sv,SVt_IV); 2966 SvIV_set(sv, status); 2967 return; 2968 } 2969 #endif 2970 2971 #if defined(OS2) 2972 int pclose(); 2973 #ifdef HAS_FORK 2974 int /* Cannot prototype with I32 2975 in os2ish.h. */ 2976 my_syspclose(PerlIO *ptr) 2977 #else 2978 I32 2979 Perl_my_pclose(pTHX_ PerlIO *ptr) 2980 #endif 2981 { 2982 /* Needs work for PerlIO ! */ 2983 FILE * const f = PerlIO_findFILE(ptr); 2984 const I32 result = pclose(f); 2985 PerlIO_releaseFILE(ptr,f); 2986 return result; 2987 } 2988 #endif 2989 2990 #if defined(DJGPP) 2991 int djgpp_pclose(); 2992 I32 2993 Perl_my_pclose(pTHX_ PerlIO *ptr) 2994 { 2995 /* Needs work for PerlIO ! */ 2996 FILE * const f = PerlIO_findFILE(ptr); 2997 I32 result = djgpp_pclose(f); 2998 result = (result << 8) & 0xff00; 2999 PerlIO_releaseFILE(ptr,f); 3000 return result; 3001 } 3002 #endif 3003 3004 #define PERL_REPEATCPY_LINEAR 4 3005 void 3006 Perl_repeatcpy(char *to, const char *from, I32 len, IV count) 3007 { 3008 PERL_ARGS_ASSERT_REPEATCPY; 3009 3010 assert(len >= 0); 3011 3012 if (count < 0) 3013 croak_memory_wrap(); 3014 3015 if (len == 1) 3016 memset(to, *from, count); 3017 else if (count) { 3018 char *p = to; 3019 IV items, linear, half; 3020 3021 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR; 3022 for (items = 0; items < linear; ++items) { 3023 const char *q = from; 3024 IV todo; 3025 for (todo = len; todo > 0; todo--) 3026 *p++ = *q++; 3027 } 3028 3029 half = count / 2; 3030 while (items <= half) { 3031 IV size = items * len; 3032 memcpy(p, to, size); 3033 p += size; 3034 items *= 2; 3035 } 3036 3037 if (count > items) 3038 memcpy(p, to, (count - items) * len); 3039 } 3040 } 3041 3042 #ifndef HAS_RENAME 3043 I32 3044 Perl_same_dirent(pTHX_ const char *a, const char *b) 3045 { 3046 char *fa = strrchr(a,'/'); 3047 char *fb = strrchr(b,'/'); 3048 Stat_t tmpstatbuf1; 3049 Stat_t tmpstatbuf2; 3050 SV * const tmpsv = sv_newmortal(); 3051 3052 PERL_ARGS_ASSERT_SAME_DIRENT; 3053 3054 if (fa) 3055 fa++; 3056 else 3057 fa = a; 3058 if (fb) 3059 fb++; 3060 else 3061 fb = b; 3062 if (strNE(a,b)) 3063 return FALSE; 3064 if (fa == a) 3065 sv_setpvs(tmpsv, "."); 3066 else 3067 sv_setpvn(tmpsv, a, fa - a); 3068 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) 3069 return FALSE; 3070 if (fb == b) 3071 sv_setpvs(tmpsv, "."); 3072 else 3073 sv_setpvn(tmpsv, b, fb - b); 3074 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) 3075 return FALSE; 3076 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && 3077 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; 3078 } 3079 #endif /* !HAS_RENAME */ 3080 3081 char* 3082 Perl_find_script(pTHX_ const char *scriptname, bool dosearch, 3083 const char *const *const search_ext, I32 flags) 3084 { 3085 const char *xfound = NULL; 3086 char *xfailed = NULL; 3087 char tmpbuf[MAXPATHLEN]; 3088 char *s; 3089 I32 len = 0; 3090 int retval; 3091 char *bufend; 3092 #if defined(DOSISH) && !defined(OS2) 3093 # define SEARCH_EXTS ".bat", ".cmd", NULL 3094 # define MAX_EXT_LEN 4 3095 #endif 3096 #ifdef OS2 3097 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL 3098 # define MAX_EXT_LEN 4 3099 #endif 3100 #ifdef VMS 3101 # define SEARCH_EXTS ".pl", ".com", NULL 3102 # define MAX_EXT_LEN 4 3103 #endif 3104 /* additional extensions to try in each dir if scriptname not found */ 3105 #ifdef SEARCH_EXTS 3106 static const char *const exts[] = { SEARCH_EXTS }; 3107 const char *const *const ext = search_ext ? search_ext : exts; 3108 int extidx = 0, i = 0; 3109 const char *curext = NULL; 3110 #else 3111 PERL_UNUSED_ARG(search_ext); 3112 # define MAX_EXT_LEN 0 3113 #endif 3114 3115 PERL_ARGS_ASSERT_FIND_SCRIPT; 3116 3117 /* 3118 * If dosearch is true and if scriptname does not contain path 3119 * delimiters, search the PATH for scriptname. 3120 * 3121 * If SEARCH_EXTS is also defined, will look for each 3122 * scriptname{SEARCH_EXTS} whenever scriptname is not found 3123 * while searching the PATH. 3124 * 3125 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search 3126 * proceeds as follows: 3127 * If DOSISH or VMSISH: 3128 * + look for ./scriptname{,.foo,.bar} 3129 * + search the PATH for scriptname{,.foo,.bar} 3130 * 3131 * If !DOSISH: 3132 * + look *only* in the PATH for scriptname{,.foo,.bar} (note 3133 * this will not look in '.' if it's not in the PATH) 3134 */ 3135 tmpbuf[0] = '\0'; 3136 3137 #ifdef VMS 3138 # ifdef ALWAYS_DEFTYPES 3139 len = strlen(scriptname); 3140 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { 3141 int idx = 0, deftypes = 1; 3142 bool seen_dot = 1; 3143 3144 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL); 3145 # else 3146 if (dosearch) { 3147 int idx = 0, deftypes = 1; 3148 bool seen_dot = 1; 3149 3150 const int hasdir = (strpbrk(scriptname,":[</") != NULL); 3151 # endif 3152 /* The first time through, just add SEARCH_EXTS to whatever we 3153 * already have, so we can check for default file types. */ 3154 while (deftypes || 3155 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) 3156 { 3157 Stat_t statbuf; 3158 if (deftypes) { 3159 deftypes = 0; 3160 *tmpbuf = '\0'; 3161 } 3162 if ((strlen(tmpbuf) + strlen(scriptname) 3163 + MAX_EXT_LEN) >= sizeof tmpbuf) 3164 continue; /* don't search dir with too-long name */ 3165 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf)); 3166 #else /* !VMS */ 3167 3168 #ifdef DOSISH 3169 if (strEQ(scriptname, "-")) 3170 dosearch = 0; 3171 if (dosearch) { /* Look in '.' first. */ 3172 const char *cur = scriptname; 3173 #ifdef SEARCH_EXTS 3174 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ 3175 while (ext[i]) 3176 if (strEQ(ext[i++],curext)) { 3177 extidx = -1; /* already has an ext */ 3178 break; 3179 } 3180 do { 3181 #endif 3182 DEBUG_p(PerlIO_printf(Perl_debug_log, 3183 "Looking for %s\n",cur)); 3184 { 3185 Stat_t statbuf; 3186 if (PerlLIO_stat(cur,&statbuf) >= 0 3187 && !S_ISDIR(statbuf.st_mode)) { 3188 dosearch = 0; 3189 scriptname = cur; 3190 #ifdef SEARCH_EXTS 3191 break; 3192 #endif 3193 } 3194 } 3195 #ifdef SEARCH_EXTS 3196 if (cur == scriptname) { 3197 len = strlen(scriptname); 3198 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) 3199 break; 3200 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf)); 3201 cur = tmpbuf; 3202 } 3203 } while (extidx >= 0 && ext[extidx] /* try an extension? */ 3204 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)); 3205 #endif 3206 } 3207 #endif 3208 3209 if (dosearch && !strchr(scriptname, '/') 3210 #ifdef DOSISH 3211 && !strchr(scriptname, '\\') 3212 #endif 3213 && (s = PerlEnv_getenv("PATH"))) 3214 { 3215 bool seen_dot = 0; 3216 3217 bufend = s + strlen(s); 3218 while (s < bufend) { 3219 Stat_t statbuf; 3220 # ifdef DOSISH 3221 for (len = 0; *s 3222 && *s != ';'; len++, s++) { 3223 if (len < sizeof tmpbuf) 3224 tmpbuf[len] = *s; 3225 } 3226 if (len < sizeof tmpbuf) 3227 tmpbuf[len] = '\0'; 3228 # else 3229 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, 3230 ':', &len); 3231 # endif 3232 if (s < bufend) 3233 s++; 3234 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) 3235 continue; /* don't search dir with too-long name */ 3236 if (len 3237 # ifdef DOSISH 3238 && tmpbuf[len - 1] != '/' 3239 && tmpbuf[len - 1] != '\\' 3240 # endif 3241 ) 3242 tmpbuf[len++] = '/'; 3243 if (len == 2 && tmpbuf[0] == '.') 3244 seen_dot = 1; 3245 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len); 3246 #endif /* !VMS */ 3247 3248 #ifdef SEARCH_EXTS 3249 len = strlen(tmpbuf); 3250 if (extidx > 0) /* reset after previous loop */ 3251 extidx = 0; 3252 do { 3253 #endif 3254 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); 3255 retval = PerlLIO_stat(tmpbuf,&statbuf); 3256 if (S_ISDIR(statbuf.st_mode)) { 3257 retval = -1; 3258 } 3259 #ifdef SEARCH_EXTS 3260 } while ( retval < 0 /* not there */ 3261 && extidx>=0 && ext[extidx] /* try an extension? */ 3262 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len) 3263 ); 3264 #endif 3265 if (retval < 0) 3266 continue; 3267 if (S_ISREG(statbuf.st_mode) 3268 && cando(S_IRUSR,TRUE,&statbuf) 3269 #if !defined(DOSISH) 3270 && cando(S_IXUSR,TRUE,&statbuf) 3271 #endif 3272 ) 3273 { 3274 xfound = tmpbuf; /* bingo! */ 3275 break; 3276 } 3277 if (!xfailed) 3278 xfailed = savepv(tmpbuf); 3279 } 3280 #ifndef DOSISH 3281 { 3282 Stat_t statbuf; 3283 if (!xfound && !seen_dot && !xfailed && 3284 (PerlLIO_stat(scriptname,&statbuf) < 0 3285 || S_ISDIR(statbuf.st_mode))) 3286 #endif 3287 seen_dot = 1; /* Disable message. */ 3288 #ifndef DOSISH 3289 } 3290 #endif 3291 if (!xfound) { 3292 if (flags & 1) { /* do or die? */ 3293 /* diag_listed_as: Can't execute %s */ 3294 Perl_croak(aTHX_ "Can't %s %s%s%s", 3295 (xfailed ? "execute" : "find"), 3296 (xfailed ? xfailed : scriptname), 3297 (xfailed ? "" : " on PATH"), 3298 (xfailed || seen_dot) ? "" : ", '.' not in PATH"); 3299 } 3300 scriptname = NULL; 3301 } 3302 Safefree(xfailed); 3303 scriptname = xfound; 3304 } 3305 return (scriptname ? savepv(scriptname) : NULL); 3306 } 3307 3308 #ifndef PERL_GET_CONTEXT_DEFINED 3309 3310 void * 3311 Perl_get_context(void) 3312 { 3313 #if defined(USE_ITHREADS) 3314 dVAR; 3315 # ifdef OLD_PTHREADS_API 3316 pthread_addr_t t; 3317 int error = pthread_getspecific(PL_thr_key, &t) 3318 if (error) 3319 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error); 3320 return (void*)t; 3321 # elif defined(I_MACH_CTHREADS) 3322 return (void*)cthread_data(cthread_self()); 3323 # else 3324 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); 3325 # endif 3326 #else 3327 return (void*)NULL; 3328 #endif 3329 } 3330 3331 void 3332 Perl_set_context(void *t) 3333 { 3334 #if defined(USE_ITHREADS) 3335 dVAR; 3336 #endif 3337 PERL_ARGS_ASSERT_SET_CONTEXT; 3338 #if defined(USE_ITHREADS) 3339 # ifdef I_MACH_CTHREADS 3340 cthread_set_data(cthread_self(), t); 3341 # else 3342 { 3343 const int error = pthread_setspecific(PL_thr_key, t); 3344 if (error) 3345 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error); 3346 } 3347 # endif 3348 #else 3349 PERL_UNUSED_ARG(t); 3350 #endif 3351 } 3352 3353 #endif /* !PERL_GET_CONTEXT_DEFINED */ 3354 3355 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) 3356 struct perl_vars * 3357 Perl_GetVars(pTHX) 3358 { 3359 PERL_UNUSED_CONTEXT; 3360 return &PL_Vars; 3361 } 3362 #endif 3363 3364 char ** 3365 Perl_get_op_names(pTHX) 3366 { 3367 PERL_UNUSED_CONTEXT; 3368 return (char **)PL_op_name; 3369 } 3370 3371 char ** 3372 Perl_get_op_descs(pTHX) 3373 { 3374 PERL_UNUSED_CONTEXT; 3375 return (char **)PL_op_desc; 3376 } 3377 3378 const char * 3379 Perl_get_no_modify(pTHX) 3380 { 3381 PERL_UNUSED_CONTEXT; 3382 return PL_no_modify; 3383 } 3384 3385 U32 * 3386 Perl_get_opargs(pTHX) 3387 { 3388 PERL_UNUSED_CONTEXT; 3389 return (U32 *)PL_opargs; 3390 } 3391 3392 PPADDR_t* 3393 Perl_get_ppaddr(pTHX) 3394 { 3395 dVAR; 3396 PERL_UNUSED_CONTEXT; 3397 return (PPADDR_t*)PL_ppaddr; 3398 } 3399 3400 #ifndef HAS_GETENV_LEN 3401 char * 3402 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) 3403 { 3404 char * const env_trans = PerlEnv_getenv(env_elem); 3405 PERL_UNUSED_CONTEXT; 3406 PERL_ARGS_ASSERT_GETENV_LEN; 3407 if (env_trans) 3408 *len = strlen(env_trans); 3409 return env_trans; 3410 } 3411 #endif 3412 3413 3414 MGVTBL* 3415 Perl_get_vtbl(pTHX_ int vtbl_id) 3416 { 3417 PERL_UNUSED_CONTEXT; 3418 3419 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) 3420 ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id; 3421 } 3422 3423 I32 3424 Perl_my_fflush_all(pTHX) 3425 { 3426 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) 3427 return PerlIO_flush(NULL); 3428 #else 3429 # if defined(HAS__FWALK) 3430 extern int fflush(FILE *); 3431 /* undocumented, unprototyped, but very useful BSDism */ 3432 extern void _fwalk(int (*)(FILE *)); 3433 _fwalk(&fflush); 3434 return 0; 3435 # else 3436 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) 3437 long open_max = -1; 3438 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX 3439 open_max = PERL_FFLUSH_ALL_FOPEN_MAX; 3440 # elif defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) 3441 open_max = sysconf(_SC_OPEN_MAX); 3442 # elif defined(FOPEN_MAX) 3443 open_max = FOPEN_MAX; 3444 # elif defined(OPEN_MAX) 3445 open_max = OPEN_MAX; 3446 # elif defined(_NFILE) 3447 open_max = _NFILE; 3448 # endif 3449 if (open_max > 0) { 3450 long i; 3451 for (i = 0; i < open_max; i++) 3452 if (STDIO_STREAM_ARRAY[i]._file >= 0 && 3453 STDIO_STREAM_ARRAY[i]._file < open_max && 3454 STDIO_STREAM_ARRAY[i]._flag) 3455 PerlIO_flush(&STDIO_STREAM_ARRAY[i]); 3456 return 0; 3457 } 3458 # endif 3459 SETERRNO(EBADF,RMS_IFI); 3460 return EOF; 3461 # endif 3462 #endif 3463 } 3464 3465 void 3466 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) 3467 { 3468 if (ckWARN(WARN_IO)) { 3469 HEK * const name 3470 = gv && (isGV_with_GP(gv)) 3471 ? GvENAME_HEK((gv)) 3472 : NULL; 3473 const char * const direction = have == '>' ? "out" : "in"; 3474 3475 if (name && HEK_LEN(name)) 3476 Perl_warner(aTHX_ packWARN(WARN_IO), 3477 "Filehandle %" HEKf " opened only for %sput", 3478 HEKfARG(name), direction); 3479 else 3480 Perl_warner(aTHX_ packWARN(WARN_IO), 3481 "Filehandle opened only for %sput", direction); 3482 } 3483 } 3484 3485 void 3486 Perl_report_evil_fh(pTHX_ const GV *gv) 3487 { 3488 const IO *io = gv ? GvIO(gv) : NULL; 3489 const PERL_BITFIELD16 op = PL_op->op_type; 3490 const char *vile; 3491 I32 warn_type; 3492 3493 if (io && IoTYPE(io) == IoTYPE_CLOSED) { 3494 vile = "closed"; 3495 warn_type = WARN_CLOSED; 3496 } 3497 else { 3498 vile = "unopened"; 3499 warn_type = WARN_UNOPENED; 3500 } 3501 3502 if (ckWARN(warn_type)) { 3503 SV * const name 3504 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ? 3505 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL; 3506 const char * const pars = 3507 (const char *)(OP_IS_FILETEST(op) ? "" : "()"); 3508 const char * const func = 3509 (const char *) 3510 (op == OP_READLINE || op == OP_RCATLINE 3511 ? "readline" : /* "<HANDLE>" not nice */ 3512 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ 3513 PL_op_desc[op]); 3514 const char * const type = 3515 (const char *) 3516 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) 3517 ? "socket" : "filehandle"); 3518 const bool have_name = name && SvCUR(name); 3519 Perl_warner(aTHX_ packWARN(warn_type), 3520 "%s%s on %s %s%s%" SVf, func, pars, vile, type, 3521 have_name ? " " : "", 3522 SVfARG(have_name ? name : &PL_sv_no)); 3523 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3524 Perl_warner( 3525 aTHX_ packWARN(warn_type), 3526 "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n", 3527 func, pars, have_name ? " " : "", 3528 SVfARG(have_name ? name : &PL_sv_no) 3529 ); 3530 } 3531 } 3532 3533 /* To workaround core dumps from the uninitialised tm_zone we get the 3534 * system to give us a reasonable struct to copy. This fix means that 3535 * strftime uses the tm_zone and tm_gmtoff values returned by 3536 * localtime(time()). That should give the desired result most of the 3537 * time. But probably not always! 3538 * 3539 * This does not address tzname aspects of NETaa14816. 3540 * 3541 */ 3542 3543 #ifdef __GLIBC__ 3544 # ifndef STRUCT_TM_HASZONE 3545 # define STRUCT_TM_HASZONE 3546 # endif 3547 #endif 3548 3549 #ifdef STRUCT_TM_HASZONE /* Backward compat */ 3550 # ifndef HAS_TM_TM_ZONE 3551 # define HAS_TM_TM_ZONE 3552 # endif 3553 #endif 3554 3555 void 3556 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ 3557 { 3558 #ifdef HAS_TM_TM_ZONE 3559 Time_t now; 3560 const struct tm* my_tm; 3561 PERL_UNUSED_CONTEXT; 3562 PERL_ARGS_ASSERT_INIT_TM; 3563 (void)time(&now); 3564 my_tm = localtime(&now); 3565 if (my_tm) 3566 Copy(my_tm, ptm, 1, struct tm); 3567 #else 3568 PERL_UNUSED_CONTEXT; 3569 PERL_ARGS_ASSERT_INIT_TM; 3570 PERL_UNUSED_ARG(ptm); 3571 #endif 3572 } 3573 3574 /* 3575 * mini_mktime - normalise struct tm values without the localtime() 3576 * semantics (and overhead) of mktime(). 3577 */ 3578 void 3579 Perl_mini_mktime(struct tm *ptm) 3580 { 3581 int yearday; 3582 int secs; 3583 int month, mday, year, jday; 3584 int odd_cent, odd_year; 3585 3586 PERL_ARGS_ASSERT_MINI_MKTIME; 3587 3588 #define DAYS_PER_YEAR 365 3589 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) 3590 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) 3591 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) 3592 #define SECS_PER_HOUR (60*60) 3593 #define SECS_PER_DAY (24*SECS_PER_HOUR) 3594 /* parentheses deliberately absent on these two, otherwise they don't work */ 3595 #define MONTH_TO_DAYS 153/5 3596 #define DAYS_TO_MONTH 5/153 3597 /* offset to bias by March (month 4) 1st between month/mday & year finding */ 3598 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1) 3599 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ 3600 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ 3601 3602 /* 3603 * Year/day algorithm notes: 3604 * 3605 * With a suitable offset for numeric value of the month, one can find 3606 * an offset into the year by considering months to have 30.6 (153/5) days, 3607 * using integer arithmetic (i.e., with truncation). To avoid too much 3608 * messing about with leap days, we consider January and February to be 3609 * the 13th and 14th month of the previous year. After that transformation, 3610 * we need the month index we use to be high by 1 from 'normal human' usage, 3611 * so the month index values we use run from 4 through 15. 3612 * 3613 * Given that, and the rules for the Gregorian calendar (leap years are those 3614 * divisible by 4 unless also divisible by 100, when they must be divisible 3615 * by 400 instead), we can simply calculate the number of days since some 3616 * arbitrary 'beginning of time' by futzing with the (adjusted) year number, 3617 * the days we derive from our month index, and adding in the day of the 3618 * month. The value used here is not adjusted for the actual origin which 3619 * it normally would use (1 January A.D. 1), since we're not exposing it. 3620 * We're only building the value so we can turn around and get the 3621 * normalised values for the year, month, day-of-month, and day-of-year. 3622 * 3623 * For going backward, we need to bias the value we're using so that we find 3624 * the right year value. (Basically, we don't want the contribution of 3625 * March 1st to the number to apply while deriving the year). Having done 3626 * that, we 'count up' the contribution to the year number by accounting for 3627 * full quadracenturies (400-year periods) with their extra leap days, plus 3628 * the contribution from full centuries (to avoid counting in the lost leap 3629 * days), plus the contribution from full quad-years (to count in the normal 3630 * leap days), plus the leftover contribution from any non-leap years. 3631 * At this point, if we were working with an actual leap day, we'll have 0 3632 * days left over. This is also true for March 1st, however. So, we have 3633 * to special-case that result, and (earlier) keep track of the 'odd' 3634 * century and year contributions. If we got 4 extra centuries in a qcent, 3635 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. 3636 * Otherwise, we add back in the earlier bias we removed (the 123 from 3637 * figuring in March 1st), find the month index (integer division by 30.6), 3638 * and the remainder is the day-of-month. We then have to convert back to 3639 * 'real' months (including fixing January and February from being 14/15 in 3640 * the previous year to being in the proper year). After that, to get 3641 * tm_yday, we work with the normalised year and get a new yearday value for 3642 * January 1st, which we subtract from the yearday value we had earlier, 3643 * representing the date we've re-built. This is done from January 1 3644 * because tm_yday is 0-origin. 3645 * 3646 * Since POSIX time routines are only guaranteed to work for times since the 3647 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm 3648 * applies Gregorian calendar rules even to dates before the 16th century 3649 * doesn't bother me. Besides, you'd need cultural context for a given 3650 * date to know whether it was Julian or Gregorian calendar, and that's 3651 * outside the scope for this routine. Since we convert back based on the 3652 * same rules we used to build the yearday, you'll only get strange results 3653 * for input which needed normalising, or for the 'odd' century years which 3654 * were leap years in the Julian calendar but not in the Gregorian one. 3655 * I can live with that. 3656 * 3657 * This algorithm also fails to handle years before A.D. 1 gracefully, but 3658 * that's still outside the scope for POSIX time manipulation, so I don't 3659 * care. 3660 * 3661 * - lwall 3662 */ 3663 3664 year = 1900 + ptm->tm_year; 3665 month = ptm->tm_mon; 3666 mday = ptm->tm_mday; 3667 jday = 0; 3668 if (month >= 2) 3669 month+=2; 3670 else 3671 month+=14, year--; 3672 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; 3673 yearday += month*MONTH_TO_DAYS + mday + jday; 3674 /* 3675 * Note that we don't know when leap-seconds were or will be, 3676 * so we have to trust the user if we get something which looks 3677 * like a sensible leap-second. Wild values for seconds will 3678 * be rationalised, however. 3679 */ 3680 if ((unsigned) ptm->tm_sec <= 60) { 3681 secs = 0; 3682 } 3683 else { 3684 secs = ptm->tm_sec; 3685 ptm->tm_sec = 0; 3686 } 3687 secs += 60 * ptm->tm_min; 3688 secs += SECS_PER_HOUR * ptm->tm_hour; 3689 if (secs < 0) { 3690 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { 3691 /* got negative remainder, but need positive time */ 3692 /* back off an extra day to compensate */ 3693 yearday += (secs/SECS_PER_DAY)-1; 3694 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); 3695 } 3696 else { 3697 yearday += (secs/SECS_PER_DAY); 3698 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); 3699 } 3700 } 3701 else if (secs >= SECS_PER_DAY) { 3702 yearday += (secs/SECS_PER_DAY); 3703 secs %= SECS_PER_DAY; 3704 } 3705 ptm->tm_hour = secs/SECS_PER_HOUR; 3706 secs %= SECS_PER_HOUR; 3707 ptm->tm_min = secs/60; 3708 secs %= 60; 3709 ptm->tm_sec += secs; 3710 /* done with time of day effects */ 3711 /* 3712 * The algorithm for yearday has (so far) left it high by 428. 3713 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to 3714 * bias it by 123 while trying to figure out what year it 3715 * really represents. Even with this tweak, the reverse 3716 * translation fails for years before A.D. 0001. 3717 * It would still fail for Feb 29, but we catch that one below. 3718 */ 3719 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ 3720 yearday -= YEAR_ADJUST; 3721 year = (yearday / DAYS_PER_QCENT) * 400; 3722 yearday %= DAYS_PER_QCENT; 3723 odd_cent = yearday / DAYS_PER_CENT; 3724 year += odd_cent * 100; 3725 yearday %= DAYS_PER_CENT; 3726 year += (yearday / DAYS_PER_QYEAR) * 4; 3727 yearday %= DAYS_PER_QYEAR; 3728 odd_year = yearday / DAYS_PER_YEAR; 3729 year += odd_year; 3730 yearday %= DAYS_PER_YEAR; 3731 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ 3732 month = 1; 3733 yearday = 29; 3734 } 3735 else { 3736 yearday += YEAR_ADJUST; /* recover March 1st crock */ 3737 month = yearday*DAYS_TO_MONTH; 3738 yearday -= month*MONTH_TO_DAYS; 3739 /* recover other leap-year adjustment */ 3740 if (month > 13) { 3741 month-=14; 3742 year++; 3743 } 3744 else { 3745 month-=2; 3746 } 3747 } 3748 ptm->tm_year = year - 1900; 3749 if (yearday) { 3750 ptm->tm_mday = yearday; 3751 ptm->tm_mon = month; 3752 } 3753 else { 3754 ptm->tm_mday = 31; 3755 ptm->tm_mon = month - 1; 3756 } 3757 /* re-build yearday based on Jan 1 to get tm_yday */ 3758 year--; 3759 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; 3760 yearday += 14*MONTH_TO_DAYS + 1; 3761 ptm->tm_yday = jday - yearday; 3762 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; 3763 } 3764 3765 char * 3766 Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) 3767 { 3768 #ifdef HAS_STRFTIME 3769 3770 /* strftime(), but with a different API so that the return value is a pointer 3771 * to the formatted result (which MUST be arranged to be FREED BY THE 3772 * CALLER). This allows this function to increase the buffer size as needed, 3773 * so that the caller doesn't have to worry about that. 3774 * 3775 * Note that yday and wday effectively are ignored by this function, as 3776 * mini_mktime() overwrites them */ 3777 3778 char *buf; 3779 int buflen; 3780 struct tm mytm; 3781 int len; 3782 3783 PERL_ARGS_ASSERT_MY_STRFTIME; 3784 3785 init_tm(&mytm); /* XXX workaround - see init_tm() above */ 3786 mytm.tm_sec = sec; 3787 mytm.tm_min = min; 3788 mytm.tm_hour = hour; 3789 mytm.tm_mday = mday; 3790 mytm.tm_mon = mon; 3791 mytm.tm_year = year; 3792 mytm.tm_wday = wday; 3793 mytm.tm_yday = yday; 3794 mytm.tm_isdst = isdst; 3795 mini_mktime(&mytm); 3796 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */ 3797 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE)) 3798 STMT_START { 3799 struct tm mytm2; 3800 mytm2 = mytm; 3801 mktime(&mytm2); 3802 #ifdef HAS_TM_TM_GMTOFF 3803 mytm.tm_gmtoff = mytm2.tm_gmtoff; 3804 #endif 3805 #ifdef HAS_TM_TM_ZONE 3806 mytm.tm_zone = mytm2.tm_zone; 3807 #endif 3808 } STMT_END; 3809 #endif 3810 buflen = 64; 3811 Newx(buf, buflen, char); 3812 3813 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */ 3814 len = strftime(buf, buflen, fmt, &mytm); 3815 GCC_DIAG_RESTORE_STMT; 3816 3817 /* 3818 ** The following is needed to handle to the situation where 3819 ** tmpbuf overflows. Basically we want to allocate a buffer 3820 ** and try repeatedly. The reason why it is so complicated 3821 ** is that getting a return value of 0 from strftime can indicate 3822 ** one of the following: 3823 ** 1. buffer overflowed, 3824 ** 2. illegal conversion specifier, or 3825 ** 3. the format string specifies nothing to be returned(not 3826 ** an error). This could be because format is an empty string 3827 ** or it specifies %p that yields an empty string in some locale. 3828 ** If there is a better way to make it portable, go ahead by 3829 ** all means. 3830 */ 3831 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0')) 3832 return buf; 3833 else { 3834 /* Possibly buf overflowed - try again with a bigger buf */ 3835 const int fmtlen = strlen(fmt); 3836 int bufsize = fmtlen + buflen; 3837 3838 Renew(buf, bufsize, char); 3839 while (buf) { 3840 3841 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */ 3842 buflen = strftime(buf, bufsize, fmt, &mytm); 3843 GCC_DIAG_RESTORE_STMT; 3844 3845 if (buflen > 0 && buflen < bufsize) 3846 break; 3847 /* heuristic to prevent out-of-memory errors */ 3848 if (bufsize > 100*fmtlen) { 3849 Safefree(buf); 3850 buf = NULL; 3851 break; 3852 } 3853 bufsize *= 2; 3854 Renew(buf, bufsize, char); 3855 } 3856 return buf; 3857 } 3858 #else 3859 Perl_croak(aTHX_ "panic: no strftime"); 3860 return NULL; 3861 #endif 3862 } 3863 3864 3865 #define SV_CWD_RETURN_UNDEF \ 3866 sv_set_undef(sv); \ 3867 return FALSE 3868 3869 #define SV_CWD_ISDOT(dp) \ 3870 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ 3871 (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) 3872 3873 /* 3874 =head1 Miscellaneous Functions 3875 3876 =for apidoc getcwd_sv 3877 3878 Fill C<sv> with current working directory 3879 3880 =cut 3881 */ 3882 3883 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. 3884 * rewritten again by dougm, optimized for use with xs TARG, and to prefer 3885 * getcwd(3) if available 3886 * Comments from the original: 3887 * This is a faster version of getcwd. It's also more dangerous 3888 * because you might chdir out of a directory that you can't chdir 3889 * back into. */ 3890 3891 int 3892 Perl_getcwd_sv(pTHX_ SV *sv) 3893 { 3894 #ifndef PERL_MICRO 3895 SvTAINTED_on(sv); 3896 3897 PERL_ARGS_ASSERT_GETCWD_SV; 3898 3899 #ifdef HAS_GETCWD 3900 { 3901 char buf[MAXPATHLEN]; 3902 3903 /* Some getcwd()s automatically allocate a buffer of the given 3904 * size from the heap if they are given a NULL buffer pointer. 3905 * The problem is that this behaviour is not portable. */ 3906 if (getcwd(buf, sizeof(buf) - 1)) { 3907 sv_setpv(sv, buf); 3908 return TRUE; 3909 } 3910 else { 3911 SV_CWD_RETURN_UNDEF; 3912 } 3913 } 3914 3915 #else 3916 3917 Stat_t statbuf; 3918 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; 3919 int pathlen=0; 3920 Direntry_t *dp; 3921 3922 SvUPGRADE(sv, SVt_PV); 3923 3924 if (PerlLIO_lstat(".", &statbuf) < 0) { 3925 SV_CWD_RETURN_UNDEF; 3926 } 3927 3928 orig_cdev = statbuf.st_dev; 3929 orig_cino = statbuf.st_ino; 3930 cdev = orig_cdev; 3931 cino = orig_cino; 3932 3933 for (;;) { 3934 DIR *dir; 3935 int namelen; 3936 odev = cdev; 3937 oino = cino; 3938 3939 if (PerlDir_chdir("..") < 0) { 3940 SV_CWD_RETURN_UNDEF; 3941 } 3942 if (PerlLIO_stat(".", &statbuf) < 0) { 3943 SV_CWD_RETURN_UNDEF; 3944 } 3945 3946 cdev = statbuf.st_dev; 3947 cino = statbuf.st_ino; 3948 3949 if (odev == cdev && oino == cino) { 3950 break; 3951 } 3952 if (!(dir = PerlDir_open("."))) { 3953 SV_CWD_RETURN_UNDEF; 3954 } 3955 3956 while ((dp = PerlDir_read(dir)) != NULL) { 3957 #ifdef DIRNAMLEN 3958 namelen = dp->d_namlen; 3959 #else 3960 namelen = strlen(dp->d_name); 3961 #endif 3962 /* skip . and .. */ 3963 if (SV_CWD_ISDOT(dp)) { 3964 continue; 3965 } 3966 3967 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { 3968 SV_CWD_RETURN_UNDEF; 3969 } 3970 3971 tdev = statbuf.st_dev; 3972 tino = statbuf.st_ino; 3973 if (tino == oino && tdev == odev) { 3974 break; 3975 } 3976 } 3977 3978 if (!dp) { 3979 SV_CWD_RETURN_UNDEF; 3980 } 3981 3982 if (pathlen + namelen + 1 >= MAXPATHLEN) { 3983 SV_CWD_RETURN_UNDEF; 3984 } 3985 3986 SvGROW(sv, pathlen + namelen + 1); 3987 3988 if (pathlen) { 3989 /* shift down */ 3990 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char); 3991 } 3992 3993 /* prepend current directory to the front */ 3994 *SvPVX(sv) = '/'; 3995 Move(dp->d_name, SvPVX(sv)+1, namelen, char); 3996 pathlen += (namelen + 1); 3997 3998 #ifdef VOID_CLOSEDIR 3999 PerlDir_close(dir); 4000 #else 4001 if (PerlDir_close(dir) < 0) { 4002 SV_CWD_RETURN_UNDEF; 4003 } 4004 #endif 4005 } 4006 4007 if (pathlen) { 4008 SvCUR_set(sv, pathlen); 4009 *SvEND(sv) = '\0'; 4010 SvPOK_only(sv); 4011 4012 if (PerlDir_chdir(SvPVX_const(sv)) < 0) { 4013 SV_CWD_RETURN_UNDEF; 4014 } 4015 } 4016 if (PerlLIO_stat(".", &statbuf) < 0) { 4017 SV_CWD_RETURN_UNDEF; 4018 } 4019 4020 cdev = statbuf.st_dev; 4021 cino = statbuf.st_ino; 4022 4023 if (cdev != orig_cdev || cino != orig_cino) { 4024 Perl_croak(aTHX_ "Unstable directory path, " 4025 "current directory changed unexpectedly"); 4026 } 4027 4028 return TRUE; 4029 #endif 4030 4031 #else 4032 return FALSE; 4033 #endif 4034 } 4035 4036 #include "vutil.c" 4037 4038 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) 4039 # define EMULATE_SOCKETPAIR_UDP 4040 #endif 4041 4042 #ifdef EMULATE_SOCKETPAIR_UDP 4043 static int 4044 S_socketpair_udp (int fd[2]) { 4045 dTHX; 4046 /* Fake a datagram socketpair using UDP to localhost. */ 4047 int sockets[2] = {-1, -1}; 4048 struct sockaddr_in addresses[2]; 4049 int i; 4050 Sock_size_t size = sizeof(struct sockaddr_in); 4051 unsigned short port; 4052 int got; 4053 4054 memset(&addresses, 0, sizeof(addresses)); 4055 i = 1; 4056 do { 4057 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET); 4058 if (sockets[i] == -1) 4059 goto tidy_up_and_fail; 4060 4061 addresses[i].sin_family = AF_INET; 4062 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK); 4063 addresses[i].sin_port = 0; /* kernel choses port. */ 4064 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i], 4065 sizeof(struct sockaddr_in)) == -1) 4066 goto tidy_up_and_fail; 4067 } while (i--); 4068 4069 /* Now have 2 UDP sockets. Find out which port each is connected to, and 4070 for each connect the other socket to it. */ 4071 i = 1; 4072 do { 4073 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i], 4074 &size) == -1) 4075 goto tidy_up_and_fail; 4076 if (size != sizeof(struct sockaddr_in)) 4077 goto abort_tidy_up_and_fail; 4078 /* !1 is 0, !0 is 1 */ 4079 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], 4080 sizeof(struct sockaddr_in)) == -1) 4081 goto tidy_up_and_fail; 4082 } while (i--); 4083 4084 /* Now we have 2 sockets connected to each other. I don't trust some other 4085 process not to have already sent a packet to us (by random) so send 4086 a packet from each to the other. */ 4087 i = 1; 4088 do { 4089 /* I'm going to send my own port number. As a short. 4090 (Who knows if someone somewhere has sin_port as a bitfield and needs 4091 this routine. (I'm assuming crays have socketpair)) */ 4092 port = addresses[i].sin_port; 4093 got = PerlLIO_write(sockets[i], &port, sizeof(port)); 4094 if (got != sizeof(port)) { 4095 if (got == -1) 4096 goto tidy_up_and_fail; 4097 goto abort_tidy_up_and_fail; 4098 } 4099 } while (i--); 4100 4101 /* Packets sent. I don't trust them to have arrived though. 4102 (As I understand it Solaris TCP stack is multithreaded. Non-blocking 4103 connect to localhost will use a second kernel thread. In 2.6 the 4104 first thread running the connect() returns before the second completes, 4105 so EINPROGRESS> In 2.7 the improved stack is faster and connect() 4106 returns 0. Poor programs have tripped up. One poor program's authors' 4107 had a 50-1 reverse stock split. Not sure how connected these were.) 4108 So I don't trust someone not to have an unpredictable UDP stack. 4109 */ 4110 4111 { 4112 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ 4113 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; 4114 fd_set rset; 4115 4116 FD_ZERO(&rset); 4117 FD_SET((unsigned int)sockets[0], &rset); 4118 FD_SET((unsigned int)sockets[1], &rset); 4119 4120 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor); 4121 if (got != 2 || !FD_ISSET(sockets[0], &rset) 4122 || !FD_ISSET(sockets[1], &rset)) { 4123 /* I hope this is portable and appropriate. */ 4124 if (got == -1) 4125 goto tidy_up_and_fail; 4126 goto abort_tidy_up_and_fail; 4127 } 4128 } 4129 4130 /* And the paranoia department even now doesn't trust it to have arrive 4131 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */ 4132 { 4133 struct sockaddr_in readfrom; 4134 unsigned short buffer[2]; 4135 4136 i = 1; 4137 do { 4138 #ifdef MSG_DONTWAIT 4139 got = PerlSock_recvfrom(sockets[i], (char *) &buffer, 4140 sizeof(buffer), MSG_DONTWAIT, 4141 (struct sockaddr *) &readfrom, &size); 4142 #else 4143 got = PerlSock_recvfrom(sockets[i], (char *) &buffer, 4144 sizeof(buffer), 0, 4145 (struct sockaddr *) &readfrom, &size); 4146 #endif 4147 4148 if (got == -1) 4149 goto tidy_up_and_fail; 4150 if (got != sizeof(port) 4151 || size != sizeof(struct sockaddr_in) 4152 /* Check other socket sent us its port. */ 4153 || buffer[0] != (unsigned short) addresses[!i].sin_port 4154 /* Check kernel says we got the datagram from that socket */ 4155 || readfrom.sin_family != addresses[!i].sin_family 4156 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr 4157 || readfrom.sin_port != addresses[!i].sin_port) 4158 goto abort_tidy_up_and_fail; 4159 } while (i--); 4160 } 4161 /* My caller (my_socketpair) has validated that this is non-NULL */ 4162 fd[0] = sockets[0]; 4163 fd[1] = sockets[1]; 4164 /* I hereby declare this connection open. May God bless all who cross 4165 her. */ 4166 return 0; 4167 4168 abort_tidy_up_and_fail: 4169 errno = ECONNABORTED; 4170 tidy_up_and_fail: 4171 { 4172 dSAVE_ERRNO; 4173 if (sockets[0] != -1) 4174 PerlLIO_close(sockets[0]); 4175 if (sockets[1] != -1) 4176 PerlLIO_close(sockets[1]); 4177 RESTORE_ERRNO; 4178 return -1; 4179 } 4180 } 4181 #endif /* EMULATE_SOCKETPAIR_UDP */ 4182 4183 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) 4184 int 4185 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { 4186 /* Stevens says that family must be AF_LOCAL, protocol 0. 4187 I'm going to enforce that, then ignore it, and use TCP (or UDP). */ 4188 dTHXa(NULL); 4189 int listener = -1; 4190 int connector = -1; 4191 int acceptor = -1; 4192 struct sockaddr_in listen_addr; 4193 struct sockaddr_in connect_addr; 4194 Sock_size_t size; 4195 4196 if (protocol 4197 #ifdef AF_UNIX 4198 || family != AF_UNIX 4199 #endif 4200 ) { 4201 errno = EAFNOSUPPORT; 4202 return -1; 4203 } 4204 if (!fd) { 4205 errno = EINVAL; 4206 return -1; 4207 } 4208 4209 #ifdef SOCK_CLOEXEC 4210 type &= ~SOCK_CLOEXEC; 4211 #endif 4212 4213 #ifdef EMULATE_SOCKETPAIR_UDP 4214 if (type == SOCK_DGRAM) 4215 return S_socketpair_udp(fd); 4216 #endif 4217 4218 aTHXa(PERL_GET_THX); 4219 listener = PerlSock_socket(AF_INET, type, 0); 4220 if (listener == -1) 4221 return -1; 4222 memset(&listen_addr, 0, sizeof(listen_addr)); 4223 listen_addr.sin_family = AF_INET; 4224 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); 4225 listen_addr.sin_port = 0; /* kernel choses port. */ 4226 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr, 4227 sizeof(listen_addr)) == -1) 4228 goto tidy_up_and_fail; 4229 if (PerlSock_listen(listener, 1) == -1) 4230 goto tidy_up_and_fail; 4231 4232 connector = PerlSock_socket(AF_INET, type, 0); 4233 if (connector == -1) 4234 goto tidy_up_and_fail; 4235 /* We want to find out the port number to connect to. */ 4236 size = sizeof(connect_addr); 4237 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr, 4238 &size) == -1) 4239 goto tidy_up_and_fail; 4240 if (size != sizeof(connect_addr)) 4241 goto abort_tidy_up_and_fail; 4242 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr, 4243 sizeof(connect_addr)) == -1) 4244 goto tidy_up_and_fail; 4245 4246 size = sizeof(listen_addr); 4247 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr, 4248 &size); 4249 if (acceptor == -1) 4250 goto tidy_up_and_fail; 4251 if (size != sizeof(listen_addr)) 4252 goto abort_tidy_up_and_fail; 4253 PerlLIO_close(listener); 4254 /* Now check we are talking to ourself by matching port and host on the 4255 two sockets. */ 4256 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr, 4257 &size) == -1) 4258 goto tidy_up_and_fail; 4259 if (size != sizeof(connect_addr) 4260 || listen_addr.sin_family != connect_addr.sin_family 4261 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr 4262 || listen_addr.sin_port != connect_addr.sin_port) { 4263 goto abort_tidy_up_and_fail; 4264 } 4265 fd[0] = connector; 4266 fd[1] = acceptor; 4267 return 0; 4268 4269 abort_tidy_up_and_fail: 4270 #ifdef ECONNABORTED 4271 errno = ECONNABORTED; /* This would be the standard thing to do. */ 4272 #elif defined(ECONNREFUSED) 4273 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */ 4274 #else 4275 errno = ETIMEDOUT; /* Desperation time. */ 4276 #endif 4277 tidy_up_and_fail: 4278 { 4279 dSAVE_ERRNO; 4280 if (listener != -1) 4281 PerlLIO_close(listener); 4282 if (connector != -1) 4283 PerlLIO_close(connector); 4284 if (acceptor != -1) 4285 PerlLIO_close(acceptor); 4286 RESTORE_ERRNO; 4287 return -1; 4288 } 4289 } 4290 #else 4291 /* In any case have a stub so that there's code corresponding 4292 * to the my_socketpair in embed.fnc. */ 4293 int 4294 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { 4295 #ifdef HAS_SOCKETPAIR 4296 return socketpair(family, type, protocol, fd); 4297 #else 4298 return -1; 4299 #endif 4300 } 4301 #endif 4302 4303 /* 4304 4305 =for apidoc sv_nosharing 4306 4307 Dummy routine which "shares" an SV when there is no sharing module present. 4308 Or "locks" it. Or "unlocks" it. In other 4309 words, ignores its single SV argument. 4310 Exists to avoid test for a C<NULL> function pointer and because it could 4311 potentially warn under some level of strict-ness. 4312 4313 =cut 4314 */ 4315 4316 void 4317 Perl_sv_nosharing(pTHX_ SV *sv) 4318 { 4319 PERL_UNUSED_CONTEXT; 4320 PERL_UNUSED_ARG(sv); 4321 } 4322 4323 /* 4324 4325 =for apidoc sv_destroyable 4326 4327 Dummy routine which reports that object can be destroyed when there is no 4328 sharing module present. It ignores its single SV argument, and returns 4329 'true'. Exists to avoid test for a C<NULL> function pointer and because it 4330 could potentially warn under some level of strict-ness. 4331 4332 =cut 4333 */ 4334 4335 bool 4336 Perl_sv_destroyable(pTHX_ SV *sv) 4337 { 4338 PERL_UNUSED_CONTEXT; 4339 PERL_UNUSED_ARG(sv); 4340 return TRUE; 4341 } 4342 4343 U32 4344 Perl_parse_unicode_opts(pTHX_ const char **popt) 4345 { 4346 const char *p = *popt; 4347 U32 opt = 0; 4348 4349 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS; 4350 4351 if (*p) { 4352 if (isDIGIT(*p)) { 4353 const char* endptr; 4354 UV uv; 4355 if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) { 4356 opt = (U32)uv; 4357 p = endptr; 4358 if (p && *p && *p != '\n' && *p != '\r') { 4359 if (isSPACE(*p)) 4360 goto the_end_of_the_opts_parser; 4361 else 4362 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); 4363 } 4364 } 4365 else { 4366 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p); 4367 } 4368 } 4369 else { 4370 for (; *p; p++) { 4371 switch (*p) { 4372 case PERL_UNICODE_STDIN: 4373 opt |= PERL_UNICODE_STDIN_FLAG; break; 4374 case PERL_UNICODE_STDOUT: 4375 opt |= PERL_UNICODE_STDOUT_FLAG; break; 4376 case PERL_UNICODE_STDERR: 4377 opt |= PERL_UNICODE_STDERR_FLAG; break; 4378 case PERL_UNICODE_STD: 4379 opt |= PERL_UNICODE_STD_FLAG; break; 4380 case PERL_UNICODE_IN: 4381 opt |= PERL_UNICODE_IN_FLAG; break; 4382 case PERL_UNICODE_OUT: 4383 opt |= PERL_UNICODE_OUT_FLAG; break; 4384 case PERL_UNICODE_INOUT: 4385 opt |= PERL_UNICODE_INOUT_FLAG; break; 4386 case PERL_UNICODE_LOCALE: 4387 opt |= PERL_UNICODE_LOCALE_FLAG; break; 4388 case PERL_UNICODE_ARGV: 4389 opt |= PERL_UNICODE_ARGV_FLAG; break; 4390 case PERL_UNICODE_UTF8CACHEASSERT: 4391 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break; 4392 default: 4393 if (*p != '\n' && *p != '\r') { 4394 if(isSPACE(*p)) goto the_end_of_the_opts_parser; 4395 else 4396 Perl_croak(aTHX_ 4397 "Unknown Unicode option letter '%c'", *p); 4398 } 4399 } 4400 } 4401 } 4402 } 4403 else 4404 opt = PERL_UNICODE_DEFAULT_FLAGS; 4405 4406 the_end_of_the_opts_parser: 4407 4408 if (opt & ~PERL_UNICODE_ALL_FLAGS) 4409 Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf, 4410 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); 4411 4412 *popt = p; 4413 4414 return opt; 4415 } 4416 4417 #ifdef VMS 4418 # include <starlet.h> 4419 #endif 4420 4421 U32 4422 Perl_seed(pTHX) 4423 { 4424 #if defined(__OpenBSD__) 4425 return arc4random(); 4426 #else 4427 /* 4428 * This is really just a quick hack which grabs various garbage 4429 * values. It really should be a real hash algorithm which 4430 * spreads the effect of every input bit onto every output bit, 4431 * if someone who knows about such things would bother to write it. 4432 * Might be a good idea to add that function to CORE as well. 4433 * No numbers below come from careful analysis or anything here, 4434 * except they are primes and SEED_C1 > 1E6 to get a full-width 4435 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should 4436 * probably be bigger too. 4437 */ 4438 #if RANDBITS > 16 4439 # define SEED_C1 1000003 4440 #define SEED_C4 73819 4441 #else 4442 # define SEED_C1 25747 4443 #define SEED_C4 20639 4444 #endif 4445 #define SEED_C2 3 4446 #define SEED_C3 269 4447 #define SEED_C5 26107 4448 4449 #ifndef PERL_NO_DEV_RANDOM 4450 int fd; 4451 #endif 4452 U32 u; 4453 #ifdef HAS_GETTIMEOFDAY 4454 struct timeval when; 4455 #else 4456 Time_t when; 4457 #endif 4458 4459 /* This test is an escape hatch, this symbol isn't set by Configure. */ 4460 #ifndef PERL_NO_DEV_RANDOM 4461 #ifndef PERL_RANDOM_DEVICE 4462 /* /dev/random isn't used by default because reads from it will block 4463 * if there isn't enough entropy available. You can compile with 4464 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there 4465 * is enough real entropy to fill the seed. */ 4466 # ifdef __amigaos4__ 4467 # define PERL_RANDOM_DEVICE "RANDOM:SIZE=4" 4468 # else 4469 # define PERL_RANDOM_DEVICE "/dev/urandom" 4470 # endif 4471 #endif 4472 fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0); 4473 if (fd != -1) { 4474 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u) 4475 u = 0; 4476 PerlLIO_close(fd); 4477 if (u) 4478 return u; 4479 } 4480 #endif 4481 4482 #ifdef HAS_GETTIMEOFDAY 4483 PerlProc_gettimeofday(&when,NULL); 4484 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; 4485 #else 4486 (void)time(&when); 4487 u = (U32)SEED_C1 * when; 4488 #endif 4489 u += SEED_C3 * (U32)PerlProc_getpid(); 4490 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); 4491 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ 4492 u += SEED_C5 * (U32)PTR2UV(&when); 4493 #endif 4494 return u; 4495 #endif 4496 } 4497 4498 void 4499 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer) 4500 { 4501 #ifndef NO_PERL_HASH_ENV 4502 const char *env_pv; 4503 #endif 4504 unsigned long i; 4505 4506 PERL_ARGS_ASSERT_GET_HASH_SEED; 4507 4508 #ifndef NO_PERL_HASH_ENV 4509 env_pv= PerlEnv_getenv("PERL_HASH_SEED"); 4510 4511 if ( env_pv ) 4512 { 4513 /* ignore leading spaces */ 4514 while (isSPACE(*env_pv)) 4515 env_pv++; 4516 # ifdef USE_PERL_PERTURB_KEYS 4517 /* if they set it to "0" we disable key traversal randomization completely */ 4518 if (strEQ(env_pv,"0")) { 4519 PL_hash_rand_bits_enabled= 0; 4520 } else { 4521 /* otherwise switch to deterministic mode */ 4522 PL_hash_rand_bits_enabled= 2; 4523 } 4524 # endif 4525 /* ignore a leading 0x... if it is there */ 4526 if (env_pv[0] == '0' && env_pv[1] == 'x') 4527 env_pv += 2; 4528 4529 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) { 4530 seed_buffer[i] = READ_XDIGIT(env_pv) << 4; 4531 if ( isXDIGIT(*env_pv)) { 4532 seed_buffer[i] |= READ_XDIGIT(env_pv); 4533 } 4534 } 4535 while (isSPACE(*env_pv)) 4536 env_pv++; 4537 4538 if (*env_pv && !isXDIGIT(*env_pv)) { 4539 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n"); 4540 } 4541 /* should we check for unparsed crap? */ 4542 /* should we warn about unused hex? */ 4543 /* should we warn about insufficient hex? */ 4544 } 4545 else 4546 #endif /* NO_PERL_HASH_ENV */ 4547 { 4548 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) { 4549 seed_buffer[i] = (unsigned char)(Perl_internal_drand48() * (U8_MAX+1)); 4550 } 4551 } 4552 #ifdef USE_PERL_PERTURB_KEYS 4553 { /* initialize PL_hash_rand_bits from the hash seed. 4554 * This value is highly volatile, it is updated every 4555 * hash insert, and is used as part of hash bucket chain 4556 * randomization and hash iterator randomization. */ 4557 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */ 4558 for( i = 0; i < sizeof(UV) ; i++ ) { 4559 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES]; 4560 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8); 4561 } 4562 } 4563 # ifndef NO_PERL_HASH_ENV 4564 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS"); 4565 if (env_pv) { 4566 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) { 4567 PL_hash_rand_bits_enabled= 0; 4568 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) { 4569 PL_hash_rand_bits_enabled= 1; 4570 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) { 4571 PL_hash_rand_bits_enabled= 2; 4572 } else { 4573 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv); 4574 } 4575 } 4576 # endif 4577 #endif 4578 } 4579 4580 #ifdef PERL_GLOBAL_STRUCT 4581 4582 #define PERL_GLOBAL_STRUCT_INIT 4583 #include "opcode.h" /* the ppaddr and check */ 4584 4585 struct perl_vars * 4586 Perl_init_global_struct(pTHX) 4587 { 4588 struct perl_vars *plvarsp = NULL; 4589 # ifdef PERL_GLOBAL_STRUCT 4590 const IV nppaddr = C_ARRAY_LENGTH(Gppaddr); 4591 const IV ncheck = C_ARRAY_LENGTH(Gcheck); 4592 PERL_UNUSED_CONTEXT; 4593 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4594 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */ 4595 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); 4596 if (!plvarsp) 4597 exit(1); 4598 # else 4599 plvarsp = PL_VarsPtr; 4600 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */ 4601 # undef PERLVAR 4602 # undef PERLVARA 4603 # undef PERLVARI 4604 # undef PERLVARIC 4605 # define PERLVAR(prefix,var,type) /**/ 4606 # define PERLVARA(prefix,var,n,type) /**/ 4607 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init; 4608 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init; 4609 # include "perlvars.h" 4610 # undef PERLVAR 4611 # undef PERLVARA 4612 # undef PERLVARI 4613 # undef PERLVARIC 4614 # ifdef PERL_GLOBAL_STRUCT 4615 plvarsp->Gppaddr = 4616 (Perl_ppaddr_t*) 4617 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); 4618 if (!plvarsp->Gppaddr) 4619 exit(1); 4620 plvarsp->Gcheck = 4621 (Perl_check_t*) 4622 PerlMem_malloc(ncheck * sizeof(Perl_check_t)); 4623 if (!plvarsp->Gcheck) 4624 exit(1); 4625 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 4626 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t); 4627 # endif 4628 # ifdef PERL_SET_VARS 4629 PERL_SET_VARS(plvarsp); 4630 # endif 4631 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4632 plvarsp->Gsv_placeholder.sv_flags = 0; 4633 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed)); 4634 # endif 4635 # undef PERL_GLOBAL_STRUCT_INIT 4636 # endif 4637 return plvarsp; 4638 } 4639 4640 #endif /* PERL_GLOBAL_STRUCT */ 4641 4642 #ifdef PERL_GLOBAL_STRUCT 4643 4644 void 4645 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) 4646 { 4647 int veto = plvarsp->Gveto_cleanup; 4648 4649 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT; 4650 PERL_UNUSED_CONTEXT; 4651 # ifdef PERL_GLOBAL_STRUCT 4652 # ifdef PERL_UNSET_VARS 4653 PERL_UNSET_VARS(plvarsp); 4654 # endif 4655 if (veto) 4656 return; 4657 free(plvarsp->Gppaddr); 4658 free(plvarsp->Gcheck); 4659 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4660 free(plvarsp); 4661 # endif 4662 # endif 4663 } 4664 4665 #endif /* PERL_GLOBAL_STRUCT */ 4666 4667 #ifdef PERL_MEM_LOG 4668 4669 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including 4670 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also 4671 * given, and you supply your own implementation. 4672 * 4673 * The default implementation reads a single env var, PERL_MEM_LOG, 4674 * expecting one or more of the following: 4675 * 4676 * \d+ - fd fd to write to : must be 1st (grok_atoUV) 4677 * 'm' - memlog was PERL_MEM_LOG=1 4678 * 's' - svlog was PERL_SV_LOG=1 4679 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 4680 * 4681 * This makes the logger controllable enough that it can reasonably be 4682 * added to the system perl. 4683 */ 4684 4685 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer 4686 * the Perl_mem_log_...() will use (either via sprintf or snprintf). 4687 */ 4688 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 4689 4690 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...() 4691 * writes to. In the default logger, this is settable at runtime. 4692 */ 4693 #ifndef PERL_MEM_LOG_FD 4694 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */ 4695 #endif 4696 4697 #ifndef PERL_MEM_LOG_NOIMPL 4698 4699 # ifdef DEBUG_LEAKING_SCALARS 4700 # define SV_LOG_SERIAL_FMT " [%lu]" 4701 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial 4702 # else 4703 # define SV_LOG_SERIAL_FMT 4704 # define _SV_LOG_SERIAL_ARG(sv) 4705 # endif 4706 4707 static void 4708 S_mem_log_common(enum mem_log_type mlt, const UV n, 4709 const UV typesize, const char *type_name, const SV *sv, 4710 Malloc_t oldalloc, Malloc_t newalloc, 4711 const char *filename, const int linenumber, 4712 const char *funcname) 4713 { 4714 const char *pmlenv; 4715 4716 PERL_ARGS_ASSERT_MEM_LOG_COMMON; 4717 4718 pmlenv = PerlEnv_getenv("PERL_MEM_LOG"); 4719 if (!pmlenv) 4720 return; 4721 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s')) 4722 { 4723 /* We can't use SVs or PerlIO for obvious reasons, 4724 * so we'll use stdio and low-level IO instead. */ 4725 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; 4726 4727 # ifdef HAS_GETTIMEOFDAY 4728 # define MEM_LOG_TIME_FMT "%10d.%06d: " 4729 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec 4730 struct timeval tv; 4731 gettimeofday(&tv, 0); 4732 # else 4733 # define MEM_LOG_TIME_FMT "%10d: " 4734 # define MEM_LOG_TIME_ARG (int)when 4735 Time_t when; 4736 (void)time(&when); 4737 # endif 4738 /* If there are other OS specific ways of hires time than 4739 * gettimeofday() (see dist/Time-HiRes), the easiest way is 4740 * probably that they would be used to fill in the struct 4741 * timeval. */ 4742 { 4743 STRLEN len; 4744 const char* endptr; 4745 int fd; 4746 UV uv; 4747 if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */ 4748 && uv && uv <= PERL_INT_MAX 4749 ) { 4750 fd = (int)uv; 4751 } else { 4752 fd = PERL_MEM_LOG_FD; 4753 } 4754 4755 if (strchr(pmlenv, 't')) { 4756 len = my_snprintf(buf, sizeof(buf), 4757 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); 4758 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len)); 4759 } 4760 switch (mlt) { 4761 case MLT_ALLOC: 4762 len = my_snprintf(buf, sizeof(buf), 4763 "alloc: %s:%d:%s: %" IVdf " %" UVuf 4764 " %s = %" IVdf ": %" UVxf "\n", 4765 filename, linenumber, funcname, n, typesize, 4766 type_name, n * typesize, PTR2UV(newalloc)); 4767 break; 4768 case MLT_REALLOC: 4769 len = my_snprintf(buf, sizeof(buf), 4770 "realloc: %s:%d:%s: %" IVdf " %" UVuf 4771 " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n", 4772 filename, linenumber, funcname, n, typesize, 4773 type_name, n * typesize, PTR2UV(oldalloc), 4774 PTR2UV(newalloc)); 4775 break; 4776 case MLT_FREE: 4777 len = my_snprintf(buf, sizeof(buf), 4778 "free: %s:%d:%s: %" UVxf "\n", 4779 filename, linenumber, funcname, 4780 PTR2UV(oldalloc)); 4781 break; 4782 case MLT_NEW_SV: 4783 case MLT_DEL_SV: 4784 len = my_snprintf(buf, sizeof(buf), 4785 "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n", 4786 mlt == MLT_NEW_SV ? "new" : "del", 4787 filename, linenumber, funcname, 4788 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv)); 4789 break; 4790 default: 4791 len = 0; 4792 } 4793 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len)); 4794 } 4795 } 4796 } 4797 #endif /* !PERL_MEM_LOG_NOIMPL */ 4798 4799 #ifndef PERL_MEM_LOG_NOIMPL 4800 # define \ 4801 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \ 4802 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) 4803 #else 4804 /* this is suboptimal, but bug compatible. User is providing their 4805 own implementation, but is getting these functions anyway, and they 4806 do nothing. But _NOIMPL users should be able to cope or fix */ 4807 # define \ 4808 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \ 4809 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */ 4810 #endif 4811 4812 Malloc_t 4813 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, 4814 Malloc_t newalloc, 4815 const char *filename, const int linenumber, 4816 const char *funcname) 4817 { 4818 PERL_ARGS_ASSERT_MEM_LOG_ALLOC; 4819 4820 mem_log_common_if(MLT_ALLOC, n, typesize, type_name, 4821 NULL, NULL, newalloc, 4822 filename, linenumber, funcname); 4823 return newalloc; 4824 } 4825 4826 Malloc_t 4827 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, 4828 Malloc_t oldalloc, Malloc_t newalloc, 4829 const char *filename, const int linenumber, 4830 const char *funcname) 4831 { 4832 PERL_ARGS_ASSERT_MEM_LOG_REALLOC; 4833 4834 mem_log_common_if(MLT_REALLOC, n, typesize, type_name, 4835 NULL, oldalloc, newalloc, 4836 filename, linenumber, funcname); 4837 return newalloc; 4838 } 4839 4840 Malloc_t 4841 Perl_mem_log_free(Malloc_t oldalloc, 4842 const char *filename, const int linenumber, 4843 const char *funcname) 4844 { 4845 PERL_ARGS_ASSERT_MEM_LOG_FREE; 4846 4847 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 4848 filename, linenumber, funcname); 4849 return oldalloc; 4850 } 4851 4852 void 4853 Perl_mem_log_new_sv(const SV *sv, 4854 const char *filename, const int linenumber, 4855 const char *funcname) 4856 { 4857 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, 4858 filename, linenumber, funcname); 4859 } 4860 4861 void 4862 Perl_mem_log_del_sv(const SV *sv, 4863 const char *filename, const int linenumber, 4864 const char *funcname) 4865 { 4866 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, 4867 filename, linenumber, funcname); 4868 } 4869 4870 #endif /* PERL_MEM_LOG */ 4871 4872 /* 4873 =for apidoc quadmath_format_single 4874 4875 C<quadmath_snprintf()> is very strict about its C<format> string and will 4876 fail, returning -1, if the format is invalid. It accepts exactly 4877 one format spec. 4878 4879 C<quadmath_format_single()> checks that the intended single spec looks 4880 sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>, 4881 and has C<Q> before it. This is not a full "printf syntax check", 4882 just the basics. 4883 4884 Returns the format if it is valid, NULL if not. 4885 4886 C<quadmath_format_single()> can and will actually patch in the missing 4887 C<Q>, if necessary. In this case it will return the modified copy of 4888 the format, B<which the caller will need to free.> 4889 4890 See also L</quadmath_format_needed>. 4891 4892 =cut 4893 */ 4894 #ifdef USE_QUADMATH 4895 const char* 4896 Perl_quadmath_format_single(const char* format) 4897 { 4898 STRLEN len; 4899 4900 PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE; 4901 4902 if (format[0] != '%' || strchr(format + 1, '%')) 4903 return NULL; 4904 len = strlen(format); 4905 /* minimum length three: %Qg */ 4906 if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL) 4907 return NULL; 4908 if (format[len - 2] != 'Q') { 4909 char* fixed; 4910 Newx(fixed, len + 1, char); 4911 memcpy(fixed, format, len - 1); 4912 fixed[len - 1] = 'Q'; 4913 fixed[len ] = format[len - 1]; 4914 fixed[len + 1] = 0; 4915 return (const char*)fixed; 4916 } 4917 return format; 4918 } 4919 #endif 4920 4921 /* 4922 =for apidoc quadmath_format_needed 4923 4924 C<quadmath_format_needed()> returns true if the C<format> string seems to 4925 contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier, 4926 or returns false otherwise. 4927 4928 The format specifier detection is not complete printf-syntax detection, 4929 but it should catch most common cases. 4930 4931 If true is returned, those arguments B<should> in theory be processed 4932 with C<quadmath_snprintf()>, but in case there is more than one such 4933 format specifier (see L</quadmath_format_single>), and if there is 4934 anything else beyond that one (even just a single byte), they 4935 B<cannot> be processed because C<quadmath_snprintf()> is very strict, 4936 accepting only one format spec, and nothing else. 4937 In this case, the code should probably fail. 4938 4939 =cut 4940 */ 4941 #ifdef USE_QUADMATH 4942 bool 4943 Perl_quadmath_format_needed(const char* format) 4944 { 4945 const char *p = format; 4946 const char *q; 4947 4948 PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED; 4949 4950 while ((q = strchr(p, '%'))) { 4951 q++; 4952 if (*q == '+') /* plus */ 4953 q++; 4954 if (*q == '#') /* alt */ 4955 q++; 4956 if (*q == '*') /* width */ 4957 q++; 4958 else { 4959 if (isDIGIT(*q)) { 4960 while (isDIGIT(*q)) q++; 4961 } 4962 } 4963 if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */ 4964 q++; 4965 if (*q == '*') 4966 q++; 4967 else 4968 while (isDIGIT(*q)) q++; 4969 } 4970 if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */ 4971 return TRUE; 4972 p = q + 1; 4973 } 4974 return FALSE; 4975 } 4976 #endif 4977 4978 /* 4979 =for apidoc my_snprintf 4980 4981 The C library C<snprintf> functionality, if available and 4982 standards-compliant (uses C<vsnprintf>, actually). However, if the 4983 C<vsnprintf> is not available, will unfortunately use the unsafe 4984 C<vsprintf> which can overrun the buffer (there is an overrun check, 4985 but that may be too late). Consider using C<sv_vcatpvf> instead, or 4986 getting C<vsnprintf>. 4987 4988 =cut 4989 */ 4990 int 4991 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) 4992 { 4993 int retval = -1; 4994 va_list ap; 4995 PERL_ARGS_ASSERT_MY_SNPRINTF; 4996 #ifndef HAS_VSNPRINTF 4997 PERL_UNUSED_VAR(len); 4998 #endif 4999 va_start(ap, format); 5000 #ifdef USE_QUADMATH 5001 { 5002 const char* qfmt = quadmath_format_single(format); 5003 bool quadmath_valid = FALSE; 5004 if (qfmt) { 5005 /* If the format looked promising, use it as quadmath. */ 5006 retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV)); 5007 if (retval == -1) { 5008 if (qfmt != format) { 5009 dTHX; 5010 SAVEFREEPV(qfmt); 5011 } 5012 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt); 5013 } 5014 quadmath_valid = TRUE; 5015 if (qfmt != format) 5016 Safefree(qfmt); 5017 qfmt = NULL; 5018 } 5019 assert(qfmt == NULL); 5020 /* quadmath_format_single() will return false for example for 5021 * "foo = %g", or simply "%g". We could handle the %g by 5022 * using quadmath for the NV args. More complex cases of 5023 * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise 5024 * quadmath-valid but has stuff in front). 5025 * 5026 * Handling the "Q-less" cases right would require walking 5027 * through the va_list and rewriting the format, calling 5028 * quadmath for the NVs, building a new va_list, and then 5029 * letting vsnprintf/vsprintf to take care of the other 5030 * arguments. This may be doable. 5031 * 5032 * We do not attempt that now. But for paranoia, we here try 5033 * to detect some common (but not all) cases where the 5034 * "Q-less" %[efgaEFGA] formats are present, and die if 5035 * detected. This doesn't fix the problem, but it stops the 5036 * vsnprintf/vsprintf pulling doubles off the va_list when 5037 * __float128 NVs should be pulled off instead. 5038 * 5039 * If quadmath_format_needed() returns false, we are reasonably 5040 * certain that we can call vnsprintf() or vsprintf() safely. */ 5041 if (!quadmath_valid && quadmath_format_needed(format)) 5042 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format); 5043 5044 } 5045 #endif 5046 if (retval == -1) 5047 #ifdef HAS_VSNPRINTF 5048 retval = vsnprintf(buffer, len, format, ap); 5049 #else 5050 retval = vsprintf(buffer, format, ap); 5051 #endif 5052 va_end(ap); 5053 /* vsprintf() shows failure with < 0 */ 5054 if (retval < 0 5055 #ifdef HAS_VSNPRINTF 5056 /* vsnprintf() shows failure with >= len */ 5057 || 5058 (len > 0 && (Size_t)retval >= len) 5059 #endif 5060 ) 5061 Perl_croak_nocontext("panic: my_snprintf buffer overflow"); 5062 return retval; 5063 } 5064 5065 /* 5066 =for apidoc my_vsnprintf 5067 5068 The C library C<vsnprintf> if available and standards-compliant. 5069 However, if if the C<vsnprintf> is not available, will unfortunately 5070 use the unsafe C<vsprintf> which can overrun the buffer (there is an 5071 overrun check, but that may be too late). Consider using 5072 C<sv_vcatpvf> instead, or getting C<vsnprintf>. 5073 5074 =cut 5075 */ 5076 int 5077 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) 5078 { 5079 #ifdef USE_QUADMATH 5080 PERL_UNUSED_ARG(buffer); 5081 PERL_UNUSED_ARG(len); 5082 PERL_UNUSED_ARG(format); 5083 /* the cast is to avoid gcc -Wsizeof-array-argument complaining */ 5084 PERL_UNUSED_ARG((void*)ap); 5085 Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath"); 5086 return 0; 5087 #else 5088 int retval; 5089 #ifdef NEED_VA_COPY 5090 va_list apc; 5091 5092 PERL_ARGS_ASSERT_MY_VSNPRINTF; 5093 Perl_va_copy(ap, apc); 5094 # ifdef HAS_VSNPRINTF 5095 retval = vsnprintf(buffer, len, format, apc); 5096 # else 5097 PERL_UNUSED_ARG(len); 5098 retval = vsprintf(buffer, format, apc); 5099 # endif 5100 va_end(apc); 5101 #else 5102 # ifdef HAS_VSNPRINTF 5103 retval = vsnprintf(buffer, len, format, ap); 5104 # else 5105 PERL_UNUSED_ARG(len); 5106 retval = vsprintf(buffer, format, ap); 5107 # endif 5108 #endif /* #ifdef NEED_VA_COPY */ 5109 /* vsprintf() shows failure with < 0 */ 5110 if (retval < 0 5111 #ifdef HAS_VSNPRINTF 5112 /* vsnprintf() shows failure with >= len */ 5113 || 5114 (len > 0 && (Size_t)retval >= len) 5115 #endif 5116 ) 5117 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); 5118 return retval; 5119 #endif 5120 } 5121 5122 void 5123 Perl_my_clearenv(pTHX) 5124 { 5125 dVAR; 5126 #if ! defined(PERL_MICRO) 5127 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32) 5128 PerlEnv_clearenv(); 5129 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */ 5130 # if defined(USE_ENVIRON_ARRAY) 5131 # if defined(USE_ITHREADS) 5132 /* only the parent thread can clobber the process environment */ 5133 if (PL_curinterp == aTHX) 5134 # endif /* USE_ITHREADS */ 5135 { 5136 # if ! defined(PERL_USE_SAFE_PUTENV) 5137 if ( !PL_use_safe_putenv) { 5138 I32 i; 5139 if (environ == PL_origenviron) 5140 environ = (char**)safesysmalloc(sizeof(char*)); 5141 else 5142 for (i = 0; environ[i]; i++) 5143 (void)safesysfree(environ[i]); 5144 } 5145 environ[0] = NULL; 5146 # else /* PERL_USE_SAFE_PUTENV */ 5147 # if defined(HAS_CLEARENV) 5148 (void)clearenv(); 5149 # elif defined(HAS_UNSETENV) 5150 int bsiz = 80; /* Most envvar names will be shorter than this. */ 5151 char *buf = (char*)safesysmalloc(bsiz); 5152 while (*environ != NULL) { 5153 char *e = strchr(*environ, '='); 5154 int l = e ? e - *environ : (int)strlen(*environ); 5155 if (bsiz < l + 1) { 5156 (void)safesysfree(buf); 5157 bsiz = l + 1; /* + 1 for the \0. */ 5158 buf = (char*)safesysmalloc(bsiz); 5159 } 5160 memcpy(buf, *environ, l); 5161 buf[l] = '\0'; 5162 (void)unsetenv(buf); 5163 } 5164 (void)safesysfree(buf); 5165 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */ 5166 /* Just null environ and accept the leakage. */ 5167 *environ = NULL; 5168 # endif /* HAS_CLEARENV || HAS_UNSETENV */ 5169 # endif /* ! PERL_USE_SAFE_PUTENV */ 5170 } 5171 # endif /* USE_ENVIRON_ARRAY */ 5172 # endif /* PERL_IMPLICIT_SYS || WIN32 */ 5173 #endif /* PERL_MICRO */ 5174 } 5175 5176 #ifdef PERL_IMPLICIT_CONTEXT 5177 5178 /* Implements the MY_CXT_INIT macro. The first time a module is loaded, 5179 the global PL_my_cxt_index is incremented, and that value is assigned to 5180 that module's static my_cxt_index (who's address is passed as an arg). 5181 Then, for each interpreter this function is called for, it makes sure a 5182 void* slot is available to hang the static data off, by allocating or 5183 extending the interpreter's PL_my_cxt_list array */ 5184 5185 #ifndef PERL_GLOBAL_STRUCT_PRIVATE 5186 void * 5187 Perl_my_cxt_init(pTHX_ int *index, size_t size) 5188 { 5189 dVAR; 5190 void *p; 5191 PERL_ARGS_ASSERT_MY_CXT_INIT; 5192 if (*index == -1) { 5193 /* this module hasn't been allocated an index yet */ 5194 MUTEX_LOCK(&PL_my_ctx_mutex); 5195 *index = PL_my_cxt_index++; 5196 MUTEX_UNLOCK(&PL_my_ctx_mutex); 5197 } 5198 5199 /* make sure the array is big enough */ 5200 if (PL_my_cxt_size <= *index) { 5201 if (PL_my_cxt_size) { 5202 IV new_size = PL_my_cxt_size; 5203 while (new_size <= *index) 5204 new_size *= 2; 5205 Renew(PL_my_cxt_list, new_size, void *); 5206 PL_my_cxt_size = new_size; 5207 } 5208 else { 5209 PL_my_cxt_size = 16; 5210 Newx(PL_my_cxt_list, PL_my_cxt_size, void *); 5211 } 5212 } 5213 /* newSV() allocates one more than needed */ 5214 p = (void*)SvPVX(newSV(size-1)); 5215 PL_my_cxt_list[*index] = p; 5216 Zero(p, size, char); 5217 return p; 5218 } 5219 5220 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ 5221 5222 int 5223 Perl_my_cxt_index(pTHX_ const char *my_cxt_key) 5224 { 5225 dVAR; 5226 int index; 5227 5228 PERL_ARGS_ASSERT_MY_CXT_INDEX; 5229 5230 for (index = 0; index < PL_my_cxt_index; index++) { 5231 const char *key = PL_my_cxt_keys[index]; 5232 /* try direct pointer compare first - there are chances to success, 5233 * and it's much faster. 5234 */ 5235 if ((key == my_cxt_key) || strEQ(key, my_cxt_key)) 5236 return index; 5237 } 5238 return -1; 5239 } 5240 5241 void * 5242 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) 5243 { 5244 dVAR; 5245 void *p; 5246 int index; 5247 5248 PERL_ARGS_ASSERT_MY_CXT_INIT; 5249 5250 index = Perl_my_cxt_index(aTHX_ my_cxt_key); 5251 if (index == -1) { 5252 /* this module hasn't been allocated an index yet */ 5253 MUTEX_LOCK(&PL_my_ctx_mutex); 5254 index = PL_my_cxt_index++; 5255 MUTEX_UNLOCK(&PL_my_ctx_mutex); 5256 } 5257 5258 /* make sure the array is big enough */ 5259 if (PL_my_cxt_size <= index) { 5260 int old_size = PL_my_cxt_size; 5261 int i; 5262 if (PL_my_cxt_size) { 5263 IV new_size = PL_my_cxt_size; 5264 while (new_size <= index) 5265 new_size *= 2; 5266 Renew(PL_my_cxt_list, new_size, void *); 5267 Renew(PL_my_cxt_keys, new_size, const char *); 5268 PL_my_cxt_size = new_size; 5269 } 5270 else { 5271 PL_my_cxt_size = 16; 5272 Newx(PL_my_cxt_list, PL_my_cxt_size, void *); 5273 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); 5274 } 5275 for (i = old_size; i < PL_my_cxt_size; i++) { 5276 PL_my_cxt_keys[i] = 0; 5277 PL_my_cxt_list[i] = 0; 5278 } 5279 } 5280 PL_my_cxt_keys[index] = my_cxt_key; 5281 /* newSV() allocates one more than needed */ 5282 p = (void*)SvPVX(newSV(size-1)); 5283 PL_my_cxt_list[index] = p; 5284 Zero(p, size, char); 5285 return p; 5286 } 5287 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ 5288 #endif /* PERL_IMPLICIT_CONTEXT */ 5289 5290 5291 /* Perl_xs_handshake(): 5292 implement the various XS_*_BOOTCHECK macros, which are added to .c 5293 files by ExtUtils::ParseXS, to check that the perl the module was built 5294 with is binary compatible with the running perl. 5295 5296 usage: 5297 Perl_xs_handshake(U32 key, void * v_my_perl, const char * file, 5298 [U32 items, U32 ax], [char * api_version], [char * xs_version]) 5299 5300 The meaning of the varargs is determined the U32 key arg (which is not 5301 a format string). The fields of key are assembled by using HS_KEY(). 5302 5303 Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type 5304 "PerlInterpreter *" and represents the callers context; otherwise it is 5305 of type "CV *", and is the boot xsub's CV. 5306 5307 v_my_perl will catch where a threaded future perl526.dll calling IO.dll 5308 for example, and IO.dll was linked with threaded perl524.dll, and both 5309 perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader 5310 successfully can load IO.dll into the process but simultaneously it 5311 loaded an interpreter of a different version into the process, and XS 5312 code will naturally pass SV*s created by perl524.dll for perl526.dll to 5313 use through perl526.dll's my_perl->Istack_base. 5314 5315 v_my_perl cannot be the first arg, since then 'key' will be out of 5316 place in a threaded vs non-threaded mixup; and analyzing the key 5317 number's bitfields won't reveal the problem, since it will be a valid 5318 key (unthreaded perl) on interp side, but croak will report the XS mod's 5319 key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if 5320 it's a threaded perl and an unthreaded XS module, threaded perl will 5321 look at an uninit C stack or an uninit register to get 'key' 5322 (remember that it assumes that the 1st arg is the interp cxt). 5323 5324 'file' is the source filename of the caller. 5325 */ 5326 5327 I32 5328 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) 5329 { 5330 va_list args; 5331 U32 items, ax; 5332 void * got; 5333 void * need; 5334 #ifdef PERL_IMPLICIT_CONTEXT 5335 dTHX; 5336 tTHX xs_interp; 5337 #else 5338 CV* cv; 5339 SV *** xs_spp; 5340 #endif 5341 PERL_ARGS_ASSERT_XS_HANDSHAKE; 5342 va_start(args, file); 5343 5344 got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH)); 5345 need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH); 5346 if (UNLIKELY(got != need)) 5347 goto bad_handshake; 5348 /* try to catch where a 2nd threaded perl interp DLL is loaded into a process 5349 by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the 5350 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so 5351 dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub 5352 passed to the XS DLL */ 5353 #ifdef PERL_IMPLICIT_CONTEXT 5354 xs_interp = (tTHX)v_my_perl; 5355 got = xs_interp; 5356 need = my_perl; 5357 #else 5358 /* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is 5359 loaded into a process by a XS DLL built by an unthreaded perl522.dll perl, 5360 but the DynaLoder/Perl that started the process and loaded the XS DLL is 5361 unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *) 5362 through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's 5363 location in the unthreaded perl binary) stored in CV * to figure out if this 5364 Perl_xs_handshake was called by the same pp_entersub */ 5365 cv = (CV*)v_my_perl; 5366 xs_spp = (SV***)CvHSCXT(cv); 5367 got = xs_spp; 5368 need = &PL_stack_sp; 5369 #endif 5370 if(UNLIKELY(got != need)) { 5371 bad_handshake:/* recycle branch and string from above */ 5372 if(got != (void *)HSf_NOCHK) 5373 noperl_die("%s: loadable library and perl binaries are mismatched" 5374 " (got handshake key %p, needed %p)\n", 5375 file, got, need); 5376 } 5377 5378 if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */ 5379 SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */ 5380 PL_xsubfilename = file; /* so the old name must be restored for 5381 additional XSUBs to register themselves */ 5382 /* XSUBs can't be perl lang/perl5db.pl debugged 5383 if (PERLDB_LINE_OR_SAVESRC) 5384 (void)gv_fetchfile(file); */ 5385 } 5386 5387 if(key & HSf_POPMARK) { 5388 ax = POPMARK; 5389 { SV **mark = PL_stack_base + ax++; 5390 { dSP; 5391 items = (I32)(SP - MARK); 5392 } 5393 } 5394 } else { 5395 items = va_arg(args, U32); 5396 ax = va_arg(args, U32); 5397 } 5398 { 5399 U32 apiverlen; 5400 assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX); 5401 if((apiverlen = HS_GETAPIVERLEN(key))) { 5402 char * api_p = va_arg(args, char*); 5403 if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1 5404 || memNE(api_p, "v" PERL_API_VERSION_STRING, 5405 sizeof("v" PERL_API_VERSION_STRING)-1)) 5406 Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s", 5407 api_p, SVfARG(PL_stack_base[ax + 0]), 5408 "v" PERL_API_VERSION_STRING); 5409 } 5410 } 5411 { 5412 U32 xsverlen; 5413 assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX); 5414 if((xsverlen = HS_GETXSVERLEN(key))) 5415 S_xs_version_bootcheck(aTHX_ 5416 items, ax, va_arg(args, char*), xsverlen); 5417 } 5418 va_end(args); 5419 return ax; 5420 } 5421 5422 5423 STATIC void 5424 S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, 5425 STRLEN xs_len) 5426 { 5427 SV *sv; 5428 const char *vn = NULL; 5429 SV *const module = PL_stack_base[ax]; 5430 5431 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK; 5432 5433 if (items >= 2) /* version supplied as bootstrap arg */ 5434 sv = PL_stack_base[ax + 1]; 5435 else { 5436 /* XXX GV_ADDWARN */ 5437 vn = "XS_VERSION"; 5438 sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0); 5439 if (!sv || !SvOK(sv)) { 5440 vn = "VERSION"; 5441 sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0); 5442 } 5443 } 5444 if (sv) { 5445 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP); 5446 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version") 5447 ? sv : sv_2mortal(new_version(sv)); 5448 xssv = upg_version(xssv, 0); 5449 if ( vcmp(pmsv,xssv) ) { 5450 SV *string = vstringify(xssv); 5451 SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf 5452 " does not match ", SVfARG(module), SVfARG(string)); 5453 5454 SvREFCNT_dec(string); 5455 string = vstringify(pmsv); 5456 5457 if (vn) { 5458 Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn, 5459 SVfARG(string)); 5460 } else { 5461 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string)); 5462 } 5463 SvREFCNT_dec(string); 5464 5465 Perl_sv_2mortal(aTHX_ xpt); 5466 Perl_croak_sv(aTHX_ xpt); 5467 } 5468 } 5469 } 5470 5471 /* 5472 =for apidoc my_strlcat 5473 5474 The C library C<strlcat> if available, or a Perl implementation of it. 5475 This operates on C C<NUL>-terminated strings. 5476 5477 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at 5478 most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate, 5479 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in 5480 practice this should not happen as it means that either C<size> is incorrect or 5481 that C<dst> is not a proper C<NUL>-terminated string). 5482 5483 Note that C<size> is the full size of the destination buffer and 5484 the result is guaranteed to be C<NUL>-terminated if there is room. Note that 5485 room for the C<NUL> should be included in C<size>. 5486 5487 The return value is the total length that C<dst> would have if C<size> is 5488 sufficiently large. Thus it is the initial length of C<dst> plus the length of 5489 C<src>. If C<size> is smaller than the return, the excess was not appended. 5490 5491 =cut 5492 5493 Description stolen from http://man.openbsd.org/strlcat.3 5494 */ 5495 #ifndef HAS_STRLCAT 5496 Size_t 5497 Perl_my_strlcat(char *dst, const char *src, Size_t size) 5498 { 5499 Size_t used, length, copy; 5500 5501 used = strlen(dst); 5502 length = strlen(src); 5503 if (size > 0 && used < size - 1) { 5504 copy = (length >= size - used) ? size - used - 1 : length; 5505 memcpy(dst + used, src, copy); 5506 dst[used + copy] = '\0'; 5507 } 5508 return used + length; 5509 } 5510 #endif 5511 5512 5513 /* 5514 =for apidoc my_strlcpy 5515 5516 The C library C<strlcpy> if available, or a Perl implementation of it. 5517 This operates on C C<NUL>-terminated strings. 5518 5519 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src> 5520 to C<dst>, C<NUL>-terminating the result if C<size> is not 0. 5521 5522 The return value is the total length C<src> would be if the copy completely 5523 succeeded. If it is larger than C<size>, the excess was not copied. 5524 5525 =cut 5526 5527 Description stolen from http://man.openbsd.org/strlcpy.3 5528 */ 5529 #ifndef HAS_STRLCPY 5530 Size_t 5531 Perl_my_strlcpy(char *dst, const char *src, Size_t size) 5532 { 5533 Size_t length, copy; 5534 5535 length = strlen(src); 5536 if (size > 0) { 5537 copy = (length >= size) ? size - 1 : length; 5538 memcpy(dst, src, copy); 5539 dst[copy] = '\0'; 5540 } 5541 return length; 5542 } 5543 #endif 5544 5545 /* 5546 =for apidoc my_strnlen 5547 5548 The C library C<strnlen> if available, or a Perl implementation of it. 5549 5550 C<my_strnlen()> computes the length of the string, up to C<maxlen> 5551 characters. It will will never attempt to address more than C<maxlen> 5552 characters, making it suitable for use with strings that are not 5553 guaranteed to be NUL-terminated. 5554 5555 =cut 5556 5557 Description stolen from http://man.openbsd.org/strnlen.3, 5558 implementation stolen from PostgreSQL. 5559 */ 5560 #ifndef HAS_STRNLEN 5561 Size_t 5562 Perl_my_strnlen(const char *str, Size_t maxlen) 5563 { 5564 const char *p = str; 5565 5566 PERL_ARGS_ASSERT_MY_STRNLEN; 5567 5568 while(maxlen-- && *p) 5569 p++; 5570 5571 return p - str; 5572 } 5573 #endif 5574 5575 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500) 5576 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */ 5577 long _ftol( double ); /* Defined by VC6 C libs. */ 5578 long _ftol2( double dblSource ) { return _ftol( dblSource ); } 5579 #endif 5580 5581 PERL_STATIC_INLINE bool 5582 S_gv_has_usable_name(pTHX_ GV *gv) 5583 { 5584 GV **gvp; 5585 return GvSTASH(gv) 5586 && HvENAME(GvSTASH(gv)) 5587 && (gvp = (GV **)hv_fetchhek( 5588 GvSTASH(gv), GvNAME_HEK(gv), 0 5589 )) 5590 && *gvp == gv; 5591 } 5592 5593 void 5594 Perl_get_db_sub(pTHX_ SV **svp, CV *cv) 5595 { 5596 SV * const dbsv = GvSVn(PL_DBsub); 5597 const bool save_taint = TAINT_get; 5598 5599 /* When we are called from pp_goto (svp is null), 5600 * we do not care about using dbsv to call CV; 5601 * it's for informational purposes only. 5602 */ 5603 5604 PERL_ARGS_ASSERT_GET_DB_SUB; 5605 5606 TAINT_set(FALSE); 5607 save_item(dbsv); 5608 if (!PERLDB_SUB_NN) { 5609 GV *gv = CvGV(cv); 5610 5611 if (!svp && !CvLEXICAL(cv)) { 5612 gv_efullname3(dbsv, gv, NULL); 5613 } 5614 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv) 5615 || strEQ(GvNAME(gv), "END") 5616 || ( /* Could be imported, and old sub redefined. */ 5617 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) 5618 && 5619 !( (SvTYPE(*svp) == SVt_PVGV) 5620 && (GvCV((const GV *)*svp) == cv) 5621 /* Use GV from the stack as a fallback. */ 5622 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) 5623 ) 5624 ) 5625 ) { 5626 /* GV is potentially non-unique, or contain different CV. */ 5627 SV * const tmp = newRV(MUTABLE_SV(cv)); 5628 sv_setsv(dbsv, tmp); 5629 SvREFCNT_dec(tmp); 5630 } 5631 else { 5632 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); 5633 sv_catpvs(dbsv, "::"); 5634 sv_cathek(dbsv, GvNAME_HEK(gv)); 5635 } 5636 } 5637 else { 5638 const int type = SvTYPE(dbsv); 5639 if (type < SVt_PVIV && type != SVt_IV) 5640 sv_upgrade(dbsv, SVt_PVIV); 5641 (void)SvIOK_on(dbsv); 5642 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ 5643 } 5644 SvSETMAGIC(dbsv); 5645 TAINT_IF(save_taint); 5646 #ifdef NO_TAINT_SUPPORT 5647 PERL_UNUSED_VAR(save_taint); 5648 #endif 5649 } 5650 5651 int 5652 Perl_my_dirfd(DIR * dir) { 5653 5654 /* Most dirfd implementations have problems when passed NULL. */ 5655 if(!dir) 5656 return -1; 5657 #ifdef HAS_DIRFD 5658 return dirfd(dir); 5659 #elif defined(HAS_DIR_DD_FD) 5660 return dir->dd_fd; 5661 #else 5662 Perl_croak_nocontext(PL_no_func, "dirfd"); 5663 NOT_REACHED; /* NOTREACHED */ 5664 return 0; 5665 #endif 5666 } 5667 5668 #if !defined(HAS_MKOSTEMP) || !defined(HAS_MKSTEMP) 5669 5670 #define TEMP_FILE_CH "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvxyz0123456789" 5671 #define TEMP_FILE_CH_COUNT (sizeof(TEMP_FILE_CH)-1) 5672 5673 static int 5674 S_my_mkostemp(char *templte, int flags) { 5675 dTHX; 5676 STRLEN len = strlen(templte); 5677 int fd; 5678 int attempts = 0; 5679 5680 if (len < 6 || 5681 templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' || 5682 templte[len-4] != 'X' || templte[len-5] != 'X' || templte[len-6] != 'X') { 5683 SETERRNO(EINVAL, LIB_INVARG); 5684 return -1; 5685 } 5686 5687 do { 5688 int i; 5689 for (i = 1; i <= 6; ++i) { 5690 templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)]; 5691 } 5692 fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600); 5693 } while (fd == -1 && errno == EEXIST && ++attempts <= 100); 5694 5695 return fd; 5696 } 5697 5698 #endif 5699 5700 #ifndef HAS_MKOSTEMP 5701 int 5702 Perl_my_mkostemp(char *templte, int flags) 5703 { 5704 PERL_ARGS_ASSERT_MY_MKOSTEMP; 5705 return S_my_mkostemp(templte, flags); 5706 } 5707 #endif 5708 5709 #ifndef HAS_MKSTEMP 5710 int 5711 Perl_my_mkstemp(char *templte) 5712 { 5713 PERL_ARGS_ASSERT_MY_MKSTEMP; 5714 return S_my_mkostemp(templte, 0); 5715 } 5716 #endif 5717 5718 REGEXP * 5719 Perl_get_re_arg(pTHX_ SV *sv) { 5720 5721 if (sv) { 5722 if (SvMAGICAL(sv)) 5723 mg_get(sv); 5724 if (SvROK(sv)) 5725 sv = MUTABLE_SV(SvRV(sv)); 5726 if (SvTYPE(sv) == SVt_REGEXP) 5727 return (REGEXP*) sv; 5728 } 5729 5730 return NULL; 5731 } 5732 5733 /* 5734 * This code is derived from drand48() implementation from FreeBSD, 5735 * found in lib/libc/gen/_rand48.c. 5736 * 5737 * The U64 implementation is original, based on the POSIX 5738 * specification for drand48(). 5739 */ 5740 5741 /* 5742 * Copyright (c) 1993 Martin Birgmeier 5743 * All rights reserved. 5744 * 5745 * You may redistribute unmodified or modified versions of this source 5746 * code provided that the above copyright notice and this and the 5747 * following conditions are retained. 5748 * 5749 * This software is provided ``as is'', and comes with no warranties 5750 * of any kind. I shall in no event be liable for anything that happens 5751 * to anyone/anything when using this software. 5752 */ 5753 5754 #define FREEBSD_DRAND48_SEED_0 (0x330e) 5755 5756 #ifdef PERL_DRAND48_QUAD 5757 5758 #define DRAND48_MULT UINT64_C(0x5deece66d) 5759 #define DRAND48_ADD 0xb 5760 #define DRAND48_MASK UINT64_C(0xffffffffffff) 5761 5762 #else 5763 5764 #define FREEBSD_DRAND48_SEED_1 (0xabcd) 5765 #define FREEBSD_DRAND48_SEED_2 (0x1234) 5766 #define FREEBSD_DRAND48_MULT_0 (0xe66d) 5767 #define FREEBSD_DRAND48_MULT_1 (0xdeec) 5768 #define FREEBSD_DRAND48_MULT_2 (0x0005) 5769 #define FREEBSD_DRAND48_ADD (0x000b) 5770 5771 const unsigned short _rand48_mult[3] = { 5772 FREEBSD_DRAND48_MULT_0, 5773 FREEBSD_DRAND48_MULT_1, 5774 FREEBSD_DRAND48_MULT_2 5775 }; 5776 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD; 5777 5778 #endif 5779 5780 void 5781 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed) 5782 { 5783 PERL_ARGS_ASSERT_DRAND48_INIT_R; 5784 5785 #ifdef PERL_DRAND48_QUAD 5786 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16); 5787 #else 5788 random_state->seed[0] = FREEBSD_DRAND48_SEED_0; 5789 random_state->seed[1] = (U16) seed; 5790 random_state->seed[2] = (U16) (seed >> 16); 5791 #endif 5792 } 5793 5794 double 5795 Perl_drand48_r(perl_drand48_t *random_state) 5796 { 5797 PERL_ARGS_ASSERT_DRAND48_R; 5798 5799 #ifdef PERL_DRAND48_QUAD 5800 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD) 5801 & DRAND48_MASK; 5802 5803 return ldexp((double)*random_state, -48); 5804 #else 5805 { 5806 U32 accu; 5807 U16 temp[2]; 5808 5809 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0] 5810 + (U32) _rand48_add; 5811 temp[0] = (U16) accu; /* lower 16 bits */ 5812 accu >>= sizeof(U16) * 8; 5813 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1] 5814 + (U32) _rand48_mult[1] * (U32) random_state->seed[0]; 5815 temp[1] = (U16) accu; /* middle 16 bits */ 5816 accu >>= sizeof(U16) * 8; 5817 accu += _rand48_mult[0] * random_state->seed[2] 5818 + _rand48_mult[1] * random_state->seed[1] 5819 + _rand48_mult[2] * random_state->seed[0]; 5820 random_state->seed[0] = temp[0]; 5821 random_state->seed[1] = temp[1]; 5822 random_state->seed[2] = (U16) accu; 5823 5824 return ldexp((double) random_state->seed[0], -48) + 5825 ldexp((double) random_state->seed[1], -32) + 5826 ldexp((double) random_state->seed[2], -16); 5827 } 5828 #endif 5829 } 5830 5831 #ifdef USE_C_BACKTRACE 5832 5833 /* Possibly move all this USE_C_BACKTRACE code into a new file. */ 5834 5835 #ifdef USE_BFD 5836 5837 typedef struct { 5838 /* abfd is the BFD handle. */ 5839 bfd* abfd; 5840 /* bfd_syms is the BFD symbol table. */ 5841 asymbol** bfd_syms; 5842 /* bfd_text is handle to the the ".text" section of the object file. */ 5843 asection* bfd_text; 5844 /* Since opening the executable and scanning its symbols is quite 5845 * heavy operation, we remember the filename we used the last time, 5846 * and do the opening and scanning only if the filename changes. 5847 * This removes most (but not all) open+scan cycles. */ 5848 const char* fname_prev; 5849 } bfd_context; 5850 5851 /* Given a dl_info, update the BFD context if necessary. */ 5852 static void bfd_update(bfd_context* ctx, Dl_info* dl_info) 5853 { 5854 /* BFD open and scan only if the filename changed. */ 5855 if (ctx->fname_prev == NULL || 5856 strNE(dl_info->dli_fname, ctx->fname_prev)) { 5857 if (ctx->abfd) { 5858 bfd_close(ctx->abfd); 5859 } 5860 ctx->abfd = bfd_openr(dl_info->dli_fname, 0); 5861 if (ctx->abfd) { 5862 if (bfd_check_format(ctx->abfd, bfd_object)) { 5863 IV symbol_size = bfd_get_symtab_upper_bound(ctx->abfd); 5864 if (symbol_size > 0) { 5865 Safefree(ctx->bfd_syms); 5866 Newx(ctx->bfd_syms, symbol_size, asymbol*); 5867 ctx->bfd_text = 5868 bfd_get_section_by_name(ctx->abfd, ".text"); 5869 } 5870 else 5871 ctx->abfd = NULL; 5872 } 5873 else 5874 ctx->abfd = NULL; 5875 } 5876 ctx->fname_prev = dl_info->dli_fname; 5877 } 5878 } 5879 5880 /* Given a raw frame, try to symbolize it and store 5881 * symbol information (source file, line number) away. */ 5882 static void bfd_symbolize(bfd_context* ctx, 5883 void* raw_frame, 5884 char** symbol_name, 5885 STRLEN* symbol_name_size, 5886 char** source_name, 5887 STRLEN* source_name_size, 5888 STRLEN* source_line) 5889 { 5890 *symbol_name = NULL; 5891 *symbol_name_size = 0; 5892 if (ctx->abfd) { 5893 IV offset = PTR2IV(raw_frame) - PTR2IV(ctx->bfd_text->vma); 5894 if (offset > 0 && 5895 bfd_canonicalize_symtab(ctx->abfd, ctx->bfd_syms) > 0) { 5896 const char *file; 5897 const char *func; 5898 unsigned int line = 0; 5899 if (bfd_find_nearest_line(ctx->abfd, ctx->bfd_text, 5900 ctx->bfd_syms, offset, 5901 &file, &func, &line) && 5902 file && func && line > 0) { 5903 /* Size and copy the source file, use only 5904 * the basename of the source file. 5905 * 5906 * NOTE: the basenames are fine for the 5907 * Perl source files, but may not always 5908 * be the best idea for XS files. */ 5909 const char *p, *b = NULL; 5910 /* Look for the last slash. */ 5911 for (p = file; *p; p++) { 5912 if (*p == '/') 5913 b = p + 1; 5914 } 5915 if (b == NULL || *b == 0) { 5916 b = file; 5917 } 5918 *source_name_size = p - b + 1; 5919 Newx(*source_name, *source_name_size + 1, char); 5920 Copy(b, *source_name, *source_name_size + 1, char); 5921 5922 *symbol_name_size = strlen(func); 5923 Newx(*symbol_name, *symbol_name_size + 1, char); 5924 Copy(func, *symbol_name, *symbol_name_size + 1, char); 5925 5926 *source_line = line; 5927 } 5928 } 5929 } 5930 } 5931 5932 #endif /* #ifdef USE_BFD */ 5933 5934 #ifdef PERL_DARWIN 5935 5936 /* OS X has no public API for for 'symbolicating' (Apple official term) 5937 * stack addresses to {function_name, source_file, line_number}. 5938 * Good news: there is command line utility atos(1) which does that. 5939 * Bad news 1: it's a command line utility. 5940 * Bad news 2: one needs to have the Developer Tools installed. 5941 * Bad news 3: in newer releases it needs to be run as 'xcrun atos'. 5942 * 5943 * To recap: we need to open a pipe for reading for a utility which 5944 * might not exist, or exists in different locations, and then parse 5945 * the output. And since this is all for a low-level API, we cannot 5946 * use high-level stuff. Thanks, Apple. */ 5947 5948 typedef struct { 5949 /* tool is set to the absolute pathname of the tool to use: 5950 * xcrun or atos. */ 5951 const char* tool; 5952 /* format is set to a printf format string used for building 5953 * the external command to run. */ 5954 const char* format; 5955 /* unavail is set if e.g. xcrun cannot be found, or something 5956 * else happens that makes getting the backtrace dubious. Note, 5957 * however, that the context isn't persistent, the next call to 5958 * get_c_backtrace() will start from scratch. */ 5959 bool unavail; 5960 /* fname is the current object file name. */ 5961 const char* fname; 5962 /* object_base_addr is the base address of the shared object. */ 5963 void* object_base_addr; 5964 } atos_context; 5965 5966 /* Given |dl_info|, updates the context. If the context has been 5967 * marked unavailable, return immediately. If not but the tool has 5968 * not been set, set it to either "xcrun atos" or "atos" (also set the 5969 * format to use for creating commands for piping), or if neither is 5970 * unavailable (one needs the Developer Tools installed), mark the context 5971 * an unavailable. Finally, update the filename (object name), 5972 * and its base address. */ 5973 5974 static void atos_update(atos_context* ctx, 5975 Dl_info* dl_info) 5976 { 5977 if (ctx->unavail) 5978 return; 5979 if (ctx->tool == NULL) { 5980 const char* tools[] = { 5981 "/usr/bin/xcrun", 5982 "/usr/bin/atos" 5983 }; 5984 const char* formats[] = { 5985 "/usr/bin/xcrun atos -o '%s' -l %08x %08x 2>&1", 5986 "/usr/bin/atos -d -o '%s' -l %08x %08x 2>&1" 5987 }; 5988 struct stat st; 5989 UV i; 5990 for (i = 0; i < C_ARRAY_LENGTH(tools); i++) { 5991 if (stat(tools[i], &st) == 0 && S_ISREG(st.st_mode)) { 5992 ctx->tool = tools[i]; 5993 ctx->format = formats[i]; 5994 break; 5995 } 5996 } 5997 if (ctx->tool == NULL) { 5998 ctx->unavail = TRUE; 5999 return; 6000 } 6001 } 6002 if (ctx->fname == NULL || 6003 strNE(dl_info->dli_fname, ctx->fname)) { 6004 ctx->fname = dl_info->dli_fname; 6005 ctx->object_base_addr = dl_info->dli_fbase; 6006 } 6007 } 6008 6009 /* Given an output buffer end |p| and its |start|, matches 6010 * for the atos output, extracting the source code location 6011 * and returning non-NULL if possible, returning NULL otherwise. */ 6012 static const char* atos_parse(const char* p, 6013 const char* start, 6014 STRLEN* source_name_size, 6015 STRLEN* source_line) { 6016 /* atos() output is something like: 6017 * perl_parse (in miniperl) (perl.c:2314)\n\n". 6018 * We cannot use Perl regular expressions, because we need to 6019 * stay low-level. Therefore here we have a rolled-out version 6020 * of a state machine which matches _backwards_from_the_end_ and 6021 * if there's a success, returns the starts of the filename, 6022 * also setting the filename size and the source line number. 6023 * The matched regular expression is roughly "\(.*:\d+\)\s*$" */ 6024 const char* source_number_start; 6025 const char* source_name_end; 6026 const char* source_line_end; 6027 const char* close_paren; 6028 UV uv; 6029 6030 /* Skip trailing whitespace. */ 6031 while (p > start && isSPACE(*p)) p--; 6032 /* Now we should be at the close paren. */ 6033 if (p == start || *p != ')') 6034 return NULL; 6035 close_paren = p; 6036 p--; 6037 /* Now we should be in the line number. */ 6038 if (p == start || !isDIGIT(*p)) 6039 return NULL; 6040 /* Skip over the digits. */ 6041 while (p > start && isDIGIT(*p)) 6042 p--; 6043 /* Now we should be at the colon. */ 6044 if (p == start || *p != ':') 6045 return NULL; 6046 source_number_start = p + 1; 6047 source_name_end = p; /* Just beyond the end. */ 6048 p--; 6049 /* Look for the open paren. */ 6050 while (p > start && *p != '(') 6051 p--; 6052 if (p == start) 6053 return NULL; 6054 p++; 6055 *source_name_size = source_name_end - p; 6056 if (grok_atoUV(source_number_start, &uv, &source_line_end) 6057 && source_line_end == close_paren 6058 && uv <= PERL_INT_MAX 6059 ) { 6060 *source_line = (STRLEN)uv; 6061 return p; 6062 } 6063 return NULL; 6064 } 6065 6066 /* Given a raw frame, read a pipe from the symbolicator (that's the 6067 * technical term) atos, reads the result, and parses the source code 6068 * location. We must stay low-level, so we use snprintf(), pipe(), 6069 * and fread(), and then also parse the output ourselves. */ 6070 static void atos_symbolize(atos_context* ctx, 6071 void* raw_frame, 6072 char** source_name, 6073 STRLEN* source_name_size, 6074 STRLEN* source_line) 6075 { 6076 char cmd[1024]; 6077 const char* p; 6078 Size_t cnt; 6079 6080 if (ctx->unavail) 6081 return; 6082 /* Simple security measure: if there's any funny business with 6083 * the object name (used as "-o '%s'" ), leave since at least 6084 * partially the user controls it. */ 6085 for (p = ctx->fname; *p; p++) { 6086 if (*p == '\'' || isCNTRL(*p)) { 6087 ctx->unavail = TRUE; 6088 return; 6089 } 6090 } 6091 cnt = snprintf(cmd, sizeof(cmd), ctx->format, 6092 ctx->fname, ctx->object_base_addr, raw_frame); 6093 if (cnt < sizeof(cmd)) { 6094 /* Undo nostdio.h #defines that disable stdio. 6095 * This is somewhat naughty, but is used elsewhere 6096 * in the core, and affects only OS X. */ 6097 #undef FILE 6098 #undef popen 6099 #undef fread 6100 #undef pclose 6101 FILE* fp = popen(cmd, "r"); 6102 /* At the moment we open a new pipe for each stack frame. 6103 * This is naturally somewhat slow, but hopefully generating 6104 * stack traces is never going to in a performance critical path. 6105 * 6106 * We could play tricks with atos by batching the stack 6107 * addresses to be resolved: atos can either take multiple 6108 * addresses from the command line, or read addresses from 6109 * a file (though the mess of creating temporary files would 6110 * probably negate much of any possible speedup). 6111 * 6112 * Normally there are only two objects present in the backtrace: 6113 * perl itself, and the libdyld.dylib. (Note that the object 6114 * filenames contain the full pathname, so perl may not always 6115 * be in the same place.) Whenever the object in the 6116 * backtrace changes, the base address also changes. 6117 * 6118 * The problem with batching the addresses, though, would be 6119 * matching the results with the addresses: the parsing of 6120 * the results is already painful enough with a single address. */ 6121 if (fp) { 6122 char out[1024]; 6123 UV cnt = fread(out, 1, sizeof(out), fp); 6124 if (cnt < sizeof(out)) { 6125 const char* p = atos_parse(out + cnt - 1, out, 6126 source_name_size, 6127 source_line); 6128 if (p) { 6129 Newx(*source_name, 6130 *source_name_size, char); 6131 Copy(p, *source_name, 6132 *source_name_size, char); 6133 } 6134 } 6135 pclose(fp); 6136 } 6137 } 6138 } 6139 6140 #endif /* #ifdef PERL_DARWIN */ 6141 6142 /* 6143 =for apidoc get_c_backtrace 6144 6145 Collects the backtrace (aka "stacktrace") into a single linear 6146 malloced buffer, which the caller B<must> C<Perl_free_c_backtrace()>. 6147 6148 Scans the frames back by S<C<depth + skip>>, then drops the C<skip> innermost, 6149 returning at most C<depth> frames. 6150 6151 =cut 6152 */ 6153 6154 Perl_c_backtrace* 6155 Perl_get_c_backtrace(pTHX_ int depth, int skip) 6156 { 6157 /* Note that here we must stay as low-level as possible: Newx(), 6158 * Copy(), Safefree(); since we may be called from anywhere, 6159 * so we should avoid higher level constructs like SVs or AVs. 6160 * 6161 * Since we are using safesysmalloc() via Newx(), don't try 6162 * getting backtrace() there, unless you like deep recursion. */ 6163 6164 /* Currently only implemented with backtrace() and dladdr(), 6165 * for other platforms NULL is returned. */ 6166 6167 #if defined(HAS_BACKTRACE) && defined(HAS_DLADDR) 6168 /* backtrace() is available via <execinfo.h> in glibc and in most 6169 * modern BSDs; dladdr() is available via <dlfcn.h>. */ 6170 6171 /* We try fetching this many frames total, but then discard 6172 * the |skip| first ones. For the remaining ones we will try 6173 * retrieving more information with dladdr(). */ 6174 int try_depth = skip + depth; 6175 6176 /* The addresses (program counters) returned by backtrace(). */ 6177 void** raw_frames; 6178 6179 /* Retrieved with dladdr() from the addresses returned by backtrace(). */ 6180 Dl_info* dl_infos; 6181 6182 /* Sizes _including_ the terminating \0 of the object name 6183 * and symbol name strings. */ 6184 STRLEN* object_name_sizes; 6185 STRLEN* symbol_name_sizes; 6186 6187 #ifdef USE_BFD 6188 /* The symbol names comes either from dli_sname, 6189 * or if using BFD, they can come from BFD. */ 6190 char** symbol_names; 6191 #endif 6192 6193 /* The source code location information. Dug out with e.g. BFD. */ 6194 char** source_names; 6195 STRLEN* source_name_sizes; 6196 STRLEN* source_lines; 6197 6198 Perl_c_backtrace* bt = NULL; /* This is what will be returned. */ 6199 int got_depth; /* How many frames were returned from backtrace(). */ 6200 UV frame_count = 0; /* How many frames we return. */ 6201 UV total_bytes = 0; /* The size of the whole returned backtrace. */ 6202 6203 #ifdef USE_BFD 6204 bfd_context bfd_ctx; 6205 #endif 6206 #ifdef PERL_DARWIN 6207 atos_context atos_ctx; 6208 #endif 6209 6210 /* Here are probably possibilities for optimizing. We could for 6211 * example have a struct that contains most of these and then 6212 * allocate |try_depth| of them, saving a bunch of malloc calls. 6213 * Note, however, that |frames| could not be part of that struct 6214 * because backtrace() will want an array of just them. Also be 6215 * careful about the name strings. */ 6216 Newx(raw_frames, try_depth, void*); 6217 Newx(dl_infos, try_depth, Dl_info); 6218 Newx(object_name_sizes, try_depth, STRLEN); 6219 Newx(symbol_name_sizes, try_depth, STRLEN); 6220 Newx(source_names, try_depth, char*); 6221 Newx(source_name_sizes, try_depth, STRLEN); 6222 Newx(source_lines, try_depth, STRLEN); 6223 #ifdef USE_BFD 6224 Newx(symbol_names, try_depth, char*); 6225 #endif 6226 6227 /* Get the raw frames. */ 6228 got_depth = (int)backtrace(raw_frames, try_depth); 6229 6230 /* We use dladdr() instead of backtrace_symbols() because we want 6231 * the full details instead of opaque strings. This is useful for 6232 * two reasons: () the details are needed for further symbolic 6233 * digging, for example in OS X (2) by having the details we fully 6234 * control the output, which in turn is useful when more platforms 6235 * are added: we can keep out output "portable". */ 6236 6237 /* We want a single linear allocation, which can then be freed 6238 * with a single swoop. We will do the usual trick of first 6239 * walking over the structure and seeing how much we need to 6240 * allocate, then allocating, and then walking over the structure 6241 * the second time and populating it. */ 6242 6243 /* First we must compute the total size of the buffer. */ 6244 total_bytes = sizeof(Perl_c_backtrace_header); 6245 if (got_depth > skip) { 6246 int i; 6247 #ifdef USE_BFD 6248 bfd_init(); /* Is this safe to call multiple times? */ 6249 Zero(&bfd_ctx, 1, bfd_context); 6250 #endif 6251 #ifdef PERL_DARWIN 6252 Zero(&atos_ctx, 1, atos_context); 6253 #endif 6254 for (i = skip; i < try_depth; i++) { 6255 Dl_info* dl_info = &dl_infos[i]; 6256 6257 object_name_sizes[i] = 0; 6258 source_names[i] = NULL; 6259 source_name_sizes[i] = 0; 6260 source_lines[i] = 0; 6261 6262 /* Yes, zero from dladdr() is failure. */ 6263 if (dladdr(raw_frames[i], dl_info)) { 6264 total_bytes += sizeof(Perl_c_backtrace_frame); 6265 6266 object_name_sizes[i] = 6267 dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0; 6268 symbol_name_sizes[i] = 6269 dl_info->dli_sname ? strlen(dl_info->dli_sname) : 0; 6270 #ifdef USE_BFD 6271 bfd_update(&bfd_ctx, dl_info); 6272 bfd_symbolize(&bfd_ctx, raw_frames[i], 6273 &symbol_names[i], 6274 &symbol_name_sizes[i], 6275 &source_names[i], 6276 &source_name_sizes[i], 6277 &source_lines[i]); 6278 #endif 6279 #if PERL_DARWIN 6280 atos_update(&atos_ctx, dl_info); 6281 atos_symbolize(&atos_ctx, 6282 raw_frames[i], 6283 &source_names[i], 6284 &source_name_sizes[i], 6285 &source_lines[i]); 6286 #endif 6287 6288 /* Plus ones for the terminating \0. */ 6289 total_bytes += object_name_sizes[i] + 1; 6290 total_bytes += symbol_name_sizes[i] + 1; 6291 total_bytes += source_name_sizes[i] + 1; 6292 6293 frame_count++; 6294 } else { 6295 break; 6296 } 6297 } 6298 #ifdef USE_BFD 6299 Safefree(bfd_ctx.bfd_syms); 6300 #endif 6301 } 6302 6303 /* Now we can allocate and populate the result buffer. */ 6304 Newxc(bt, total_bytes, char, Perl_c_backtrace); 6305 Zero(bt, total_bytes, char); 6306 bt->header.frame_count = frame_count; 6307 bt->header.total_bytes = total_bytes; 6308 if (frame_count > 0) { 6309 Perl_c_backtrace_frame* frame = bt->frame_info; 6310 char* name_base = (char *)(frame + frame_count); 6311 char* name_curr = name_base; /* Outputting the name strings here. */ 6312 UV i; 6313 for (i = skip; i < skip + frame_count; i++) { 6314 Dl_info* dl_info = &dl_infos[i]; 6315 6316 frame->addr = raw_frames[i]; 6317 frame->object_base_addr = dl_info->dli_fbase; 6318 frame->symbol_addr = dl_info->dli_saddr; 6319 6320 /* Copies a string, including the \0, and advances the name_curr. 6321 * Also copies the start and the size to the frame. */ 6322 #define PERL_C_BACKTRACE_STRCPY(frame, doffset, src, dsize, size) \ 6323 if (size && src) \ 6324 Copy(src, name_curr, size, char); \ 6325 frame->doffset = name_curr - (char*)bt; \ 6326 frame->dsize = size; \ 6327 name_curr += size; \ 6328 *name_curr++ = 0; 6329 6330 PERL_C_BACKTRACE_STRCPY(frame, object_name_offset, 6331 dl_info->dli_fname, 6332 object_name_size, object_name_sizes[i]); 6333 6334 #ifdef USE_BFD 6335 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset, 6336 symbol_names[i], 6337 symbol_name_size, symbol_name_sizes[i]); 6338 Safefree(symbol_names[i]); 6339 #else 6340 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset, 6341 dl_info->dli_sname, 6342 symbol_name_size, symbol_name_sizes[i]); 6343 #endif 6344 6345 PERL_C_BACKTRACE_STRCPY(frame, source_name_offset, 6346 source_names[i], 6347 source_name_size, source_name_sizes[i]); 6348 Safefree(source_names[i]); 6349 6350 #undef PERL_C_BACKTRACE_STRCPY 6351 6352 frame->source_line_number = source_lines[i]; 6353 6354 frame++; 6355 } 6356 assert(total_bytes == 6357 (UV)(sizeof(Perl_c_backtrace_header) + 6358 frame_count * sizeof(Perl_c_backtrace_frame) + 6359 name_curr - name_base)); 6360 } 6361 #ifdef USE_BFD 6362 Safefree(symbol_names); 6363 if (bfd_ctx.abfd) { 6364 bfd_close(bfd_ctx.abfd); 6365 } 6366 #endif 6367 Safefree(source_lines); 6368 Safefree(source_name_sizes); 6369 Safefree(source_names); 6370 Safefree(symbol_name_sizes); 6371 Safefree(object_name_sizes); 6372 /* Assuming the strings returned by dladdr() are pointers 6373 * to read-only static memory (the object file), so that 6374 * they do not need freeing (and cannot be). */ 6375 Safefree(dl_infos); 6376 Safefree(raw_frames); 6377 return bt; 6378 #else 6379 PERL_UNUSED_ARGV(depth); 6380 PERL_UNUSED_ARGV(skip); 6381 return NULL; 6382 #endif 6383 } 6384 6385 /* 6386 =for apidoc free_c_backtrace 6387 6388 Deallocates a backtrace received from get_c_bracktrace. 6389 6390 =cut 6391 */ 6392 6393 /* 6394 =for apidoc get_c_backtrace_dump 6395 6396 Returns a SV containing a dump of C<depth> frames of the call stack, skipping 6397 the C<skip> innermost ones. C<depth> of 20 is usually enough. 6398 6399 The appended output looks like: 6400 6401 ... 6402 1 10e004812:0082 Perl_croak util.c:1716 /usr/bin/perl 6403 2 10df8d6d2:1d72 perl_parse perl.c:3975 /usr/bin/perl 6404 ... 6405 6406 The fields are tab-separated. The first column is the depth (zero 6407 being the innermost non-skipped frame). In the hex:offset, the hex is 6408 where the program counter was in C<S_parse_body>, and the :offset (might 6409 be missing) tells how much inside the C<S_parse_body> the program counter was. 6410 6411 The C<util.c:1716> is the source code file and line number. 6412 6413 The F</usr/bin/perl> is obvious (hopefully). 6414 6415 Unknowns are C<"-">. Unknowns can happen unfortunately quite easily: 6416 if the platform doesn't support retrieving the information; 6417 if the binary is missing the debug information; 6418 if the optimizer has transformed the code by for example inlining. 6419 6420 =cut 6421 */ 6422 6423 SV* 6424 Perl_get_c_backtrace_dump(pTHX_ int depth, int skip) 6425 { 6426 Perl_c_backtrace* bt; 6427 6428 bt = get_c_backtrace(depth, skip + 1 /* Hide ourselves. */); 6429 if (bt) { 6430 Perl_c_backtrace_frame* frame; 6431 SV* dsv = newSVpvs(""); 6432 UV i; 6433 for (i = 0, frame = bt->frame_info; 6434 i < bt->header.frame_count; i++, frame++) { 6435 Perl_sv_catpvf(aTHX_ dsv, "%d", (int)i); 6436 Perl_sv_catpvf(aTHX_ dsv, "\t%p", frame->addr ? frame->addr : "-"); 6437 /* Symbol (function) names might disappear without debug info. 6438 * 6439 * The source code location might disappear in case of the 6440 * optimizer inlining or otherwise rearranging the code. */ 6441 if (frame->symbol_addr) { 6442 Perl_sv_catpvf(aTHX_ dsv, ":%04x", 6443 (int) 6444 ((char*)frame->addr - (char*)frame->symbol_addr)); 6445 } 6446 Perl_sv_catpvf(aTHX_ dsv, "\t%s", 6447 frame->symbol_name_size && 6448 frame->symbol_name_offset ? 6449 (char*)bt + frame->symbol_name_offset : "-"); 6450 if (frame->source_name_size && 6451 frame->source_name_offset && 6452 frame->source_line_number) { 6453 Perl_sv_catpvf(aTHX_ dsv, "\t%s:%" UVuf, 6454 (char*)bt + frame->source_name_offset, 6455 (UV)frame->source_line_number); 6456 } else { 6457 Perl_sv_catpvf(aTHX_ dsv, "\t-"); 6458 } 6459 Perl_sv_catpvf(aTHX_ dsv, "\t%s", 6460 frame->object_name_size && 6461 frame->object_name_offset ? 6462 (char*)bt + frame->object_name_offset : "-"); 6463 /* The frame->object_base_addr is not output, 6464 * but it is used for symbolizing/symbolicating. */ 6465 sv_catpvs(dsv, "\n"); 6466 } 6467 6468 Perl_free_c_backtrace(bt); 6469 6470 return dsv; 6471 } 6472 6473 return NULL; 6474 } 6475 6476 /* 6477 =for apidoc dump_c_backtrace 6478 6479 Dumps the C backtrace to the given C<fp>. 6480 6481 Returns true if a backtrace could be retrieved, false if not. 6482 6483 =cut 6484 */ 6485 6486 bool 6487 Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip) 6488 { 6489 SV* sv; 6490 6491 PERL_ARGS_ASSERT_DUMP_C_BACKTRACE; 6492 6493 sv = Perl_get_c_backtrace_dump(aTHX_ depth, skip); 6494 if (sv) { 6495 sv_2mortal(sv); 6496 PerlIO_printf(fp, "%s", SvPV_nolen(sv)); 6497 return TRUE; 6498 } 6499 return FALSE; 6500 } 6501 6502 #endif /* #ifdef USE_C_BACKTRACE */ 6503 6504 #ifdef PERL_TSA_ACTIVE 6505 6506 /* pthread_mutex_t and perl_mutex are typedef equivalent 6507 * so casting the pointers is fine. */ 6508 6509 int perl_tsa_mutex_lock(perl_mutex* mutex) 6510 { 6511 return pthread_mutex_lock((pthread_mutex_t *) mutex); 6512 } 6513 6514 int perl_tsa_mutex_unlock(perl_mutex* mutex) 6515 { 6516 return pthread_mutex_unlock((pthread_mutex_t *) mutex); 6517 } 6518 6519 int perl_tsa_mutex_destroy(perl_mutex* mutex) 6520 { 6521 return pthread_mutex_destroy((pthread_mutex_t *) mutex); 6522 } 6523 6524 #endif 6525 6526 6527 #ifdef USE_DTRACE 6528 6529 /* log a sub call or return */ 6530 6531 void 6532 Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call) 6533 { 6534 const char *func; 6535 const char *file; 6536 const char *stash; 6537 const COP *start; 6538 line_t line; 6539 6540 PERL_ARGS_ASSERT_DTRACE_PROBE_CALL; 6541 6542 if (CvNAMED(cv)) { 6543 HEK *hek = CvNAME_HEK(cv); 6544 func = HEK_KEY(hek); 6545 } 6546 else { 6547 GV *gv = CvGV(cv); 6548 func = GvENAME(gv); 6549 } 6550 start = (const COP *)CvSTART(cv); 6551 file = CopFILE(start); 6552 line = CopLINE(start); 6553 stash = CopSTASHPV(start); 6554 6555 if (is_call) { 6556 PERL_SUB_ENTRY(func, file, line, stash); 6557 } 6558 else { 6559 PERL_SUB_RETURN(func, file, line, stash); 6560 } 6561 } 6562 6563 6564 /* log a require file loading/loaded */ 6565 6566 void 6567 Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading) 6568 { 6569 PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD; 6570 6571 if (is_loading) { 6572 PERL_LOADING_FILE(name); 6573 } 6574 else { 6575 PERL_LOADED_FILE(name); 6576 } 6577 } 6578 6579 6580 /* log an op execution */ 6581 6582 void 6583 Perl_dtrace_probe_op(pTHX_ const OP *op) 6584 { 6585 PERL_ARGS_ASSERT_DTRACE_PROBE_OP; 6586 6587 PERL_OP_ENTRY(OP_NAME(op)); 6588 } 6589 6590 6591 /* log a compile/run phase change */ 6592 6593 void 6594 Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase) 6595 { 6596 const char *ph_old = PL_phase_names[PL_phase]; 6597 const char *ph_new = PL_phase_names[phase]; 6598 6599 PERL_PHASE_CHANGE(ph_new, ph_old); 6600 } 6601 6602 #endif 6603 6604 /* 6605 * ex: set ts=8 sts=4 sw=4 et: 6606 */ 6607