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 setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]); 2307 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ 2308 } 2309 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2310 /* No automatic close - do it by hand */ 2311 # ifndef NOFILE 2312 # define NOFILE 20 2313 # endif 2314 { 2315 int fd; 2316 2317 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { 2318 if (fd != pp[1]) 2319 PerlLIO_close(fd); 2320 } 2321 } 2322 #endif 2323 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes); 2324 PerlProc__exit(1); 2325 #undef THIS 2326 #undef THAT 2327 } 2328 /* Parent */ 2329 if (did_pipes) 2330 PerlLIO_close(pp[1]); 2331 /* Keep the lower of the two fd numbers */ 2332 if (p[that] < p[This]) { 2333 PerlLIO_dup2_cloexec(p[This], p[that]); 2334 PerlLIO_close(p[This]); 2335 p[This] = p[that]; 2336 } 2337 else 2338 PerlLIO_close(p[that]); /* close child's end of pipe */ 2339 2340 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2341 SvUPGRADE(sv,SVt_IV); 2342 SvIV_set(sv, pid); 2343 PL_forkprocess = pid; 2344 /* If we managed to get status pipe check for exec fail */ 2345 if (did_pipes && pid > 0) { 2346 int errkid; 2347 unsigned n = 0; 2348 2349 while (n < sizeof(int)) { 2350 const SSize_t n1 = PerlLIO_read(pp[0], 2351 (void*)(((char*)&errkid)+n), 2352 (sizeof(int)) - n); 2353 if (n1 <= 0) 2354 break; 2355 n += n1; 2356 } 2357 PerlLIO_close(pp[0]); 2358 did_pipes = 0; 2359 if (n) { /* Error */ 2360 int pid2, status; 2361 PerlLIO_close(p[This]); 2362 if (n != sizeof(int)) 2363 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); 2364 do { 2365 pid2 = wait4pid(pid, &status, 0); 2366 } while (pid2 == -1 && errno == EINTR); 2367 errno = errkid; /* Propagate errno from kid */ 2368 return NULL; 2369 } 2370 } 2371 if (did_pipes) 2372 PerlLIO_close(pp[0]); 2373 return PerlIO_fdopen(p[This], mode); 2374 #else 2375 # if defined(OS2) /* Same, without fork()ing and all extra overhead... */ 2376 return my_syspopen4(aTHX_ NULL, mode, n, args); 2377 # elif defined(WIN32) 2378 return win32_popenlist(mode, n, args); 2379 # else 2380 Perl_croak(aTHX_ "List form of piped open not implemented"); 2381 return (PerlIO *) NULL; 2382 # endif 2383 #endif 2384 } 2385 2386 /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */ 2387 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) 2388 PerlIO * 2389 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2390 { 2391 int p[2]; 2392 I32 This, that; 2393 Pid_t pid; 2394 SV *sv; 2395 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); 2396 I32 did_pipes = 0; 2397 int pp[2]; 2398 2399 PERL_ARGS_ASSERT_MY_POPEN; 2400 2401 PERL_FLUSHALL_FOR_CHILD; 2402 #ifdef OS2 2403 if (doexec) { 2404 return my_syspopen(aTHX_ cmd,mode); 2405 } 2406 #endif 2407 This = (*mode == 'w'); 2408 that = !This; 2409 if (doexec && TAINTING_get) { 2410 taint_env(); 2411 taint_proper("Insecure %s%s", "EXEC"); 2412 } 2413 if (PerlProc_pipe_cloexec(p) < 0) 2414 return NULL; 2415 if (doexec && PerlProc_pipe_cloexec(pp) >= 0) 2416 did_pipes = 1; 2417 while ((pid = PerlProc_fork()) < 0) { 2418 if (errno != EAGAIN) { 2419 PerlLIO_close(p[This]); 2420 PerlLIO_close(p[that]); 2421 if (did_pipes) { 2422 PerlLIO_close(pp[0]); 2423 PerlLIO_close(pp[1]); 2424 } 2425 if (!doexec) 2426 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); 2427 return NULL; 2428 } 2429 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); 2430 sleep(5); 2431 } 2432 if (pid == 0) { 2433 2434 #undef THIS 2435 #undef THAT 2436 #define THIS that 2437 #define THAT This 2438 if (did_pipes) 2439 PerlLIO_close(pp[0]); 2440 if (p[THIS] != (*mode == 'r')) { 2441 PerlLIO_dup2(p[THIS], *mode == 'r'); 2442 PerlLIO_close(p[THIS]); 2443 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 2444 PerlLIO_close(p[THAT]); 2445 } 2446 else { 2447 setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]); 2448 PerlLIO_close(p[THAT]); 2449 } 2450 #ifndef OS2 2451 if (doexec) { 2452 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2453 #ifndef NOFILE 2454 #define NOFILE 20 2455 #endif 2456 { 2457 int fd; 2458 2459 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) 2460 if (fd != pp[1]) 2461 PerlLIO_close(fd); 2462 } 2463 #endif 2464 /* may or may not use the shell */ 2465 do_exec3(cmd, pp[1], did_pipes); 2466 PerlProc__exit(1); 2467 } 2468 #endif /* defined OS2 */ 2469 2470 #ifdef PERLIO_USING_CRLF 2471 /* Since we circumvent IO layers when we manipulate low-level 2472 filedescriptors directly, need to manually switch to the 2473 default, binary, low-level mode; see PerlIOBuf_open(). */ 2474 PerlLIO_setmode((*mode == 'r'), O_BINARY); 2475 #endif 2476 PL_forkprocess = 0; 2477 #ifdef PERL_USES_PL_PIDSTATUS 2478 hv_clear(PL_pidstatus); /* we have no children */ 2479 #endif 2480 return NULL; 2481 #undef THIS 2482 #undef THAT 2483 } 2484 if (did_pipes) 2485 PerlLIO_close(pp[1]); 2486 if (p[that] < p[This]) { 2487 PerlLIO_dup2_cloexec(p[This], p[that]); 2488 PerlLIO_close(p[This]); 2489 p[This] = p[that]; 2490 } 2491 else 2492 PerlLIO_close(p[that]); 2493 2494 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2495 SvUPGRADE(sv,SVt_IV); 2496 SvIV_set(sv, pid); 2497 PL_forkprocess = pid; 2498 if (did_pipes && pid > 0) { 2499 int errkid; 2500 unsigned n = 0; 2501 2502 while (n < sizeof(int)) { 2503 const SSize_t n1 = PerlLIO_read(pp[0], 2504 (void*)(((char*)&errkid)+n), 2505 (sizeof(int)) - n); 2506 if (n1 <= 0) 2507 break; 2508 n += n1; 2509 } 2510 PerlLIO_close(pp[0]); 2511 did_pipes = 0; 2512 if (n) { /* Error */ 2513 int pid2, status; 2514 PerlLIO_close(p[This]); 2515 if (n != sizeof(int)) 2516 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); 2517 do { 2518 pid2 = wait4pid(pid, &status, 0); 2519 } while (pid2 == -1 && errno == EINTR); 2520 errno = errkid; /* Propagate errno from kid */ 2521 return NULL; 2522 } 2523 } 2524 if (did_pipes) 2525 PerlLIO_close(pp[0]); 2526 return PerlIO_fdopen(p[This], mode); 2527 } 2528 #elif defined(DJGPP) 2529 FILE *djgpp_popen(); 2530 PerlIO * 2531 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2532 { 2533 PERL_FLUSHALL_FOR_CHILD; 2534 /* Call system's popen() to get a FILE *, then import it. 2535 used 0 for 2nd parameter to PerlIO_importFILE; 2536 apparently not used 2537 */ 2538 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); 2539 } 2540 #elif defined(__LIBCATAMOUNT__) 2541 PerlIO * 2542 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2543 { 2544 return NULL; 2545 } 2546 2547 #endif /* !DOSISH */ 2548 2549 /* this is called in parent before the fork() */ 2550 void 2551 Perl_atfork_lock(void) 2552 #if defined(USE_ITHREADS) 2553 # ifdef USE_PERLIO 2554 PERL_TSA_ACQUIRE(PL_perlio_mutex) 2555 # endif 2556 # ifdef MYMALLOC 2557 PERL_TSA_ACQUIRE(PL_malloc_mutex) 2558 # endif 2559 PERL_TSA_ACQUIRE(PL_op_mutex) 2560 #endif 2561 { 2562 #if defined(USE_ITHREADS) 2563 dVAR; 2564 /* locks must be held in locking order (if any) */ 2565 # ifdef USE_PERLIO 2566 MUTEX_LOCK(&PL_perlio_mutex); 2567 # endif 2568 # ifdef MYMALLOC 2569 MUTEX_LOCK(&PL_malloc_mutex); 2570 # endif 2571 OP_REFCNT_LOCK; 2572 #endif 2573 } 2574 2575 /* this is called in both parent and child after the fork() */ 2576 void 2577 Perl_atfork_unlock(void) 2578 #if defined(USE_ITHREADS) 2579 # ifdef USE_PERLIO 2580 PERL_TSA_RELEASE(PL_perlio_mutex) 2581 # endif 2582 # ifdef MYMALLOC 2583 PERL_TSA_RELEASE(PL_malloc_mutex) 2584 # endif 2585 PERL_TSA_RELEASE(PL_op_mutex) 2586 #endif 2587 { 2588 #if defined(USE_ITHREADS) 2589 dVAR; 2590 /* locks must be released in same order as in atfork_lock() */ 2591 # ifdef USE_PERLIO 2592 MUTEX_UNLOCK(&PL_perlio_mutex); 2593 # endif 2594 # ifdef MYMALLOC 2595 MUTEX_UNLOCK(&PL_malloc_mutex); 2596 # endif 2597 OP_REFCNT_UNLOCK; 2598 #endif 2599 } 2600 2601 Pid_t 2602 Perl_my_fork(void) 2603 { 2604 #if defined(HAS_FORK) 2605 Pid_t pid; 2606 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK) 2607 atfork_lock(); 2608 pid = fork(); 2609 atfork_unlock(); 2610 #else 2611 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork() 2612 * handlers elsewhere in the code */ 2613 pid = fork(); 2614 #endif 2615 return pid; 2616 #elif defined(__amigaos4__) 2617 return amigaos_fork(); 2618 #else 2619 /* this "canna happen" since nothing should be calling here if !HAS_FORK */ 2620 Perl_croak_nocontext("fork() not available"); 2621 return 0; 2622 #endif /* HAS_FORK */ 2623 } 2624 2625 #ifndef HAS_DUP2 2626 int 2627 dup2(int oldfd, int newfd) 2628 { 2629 #if defined(HAS_FCNTL) && defined(F_DUPFD) 2630 if (oldfd == newfd) 2631 return oldfd; 2632 PerlLIO_close(newfd); 2633 return fcntl(oldfd, F_DUPFD, newfd); 2634 #else 2635 #define DUP2_MAX_FDS 256 2636 int fdtmp[DUP2_MAX_FDS]; 2637 I32 fdx = 0; 2638 int fd; 2639 2640 if (oldfd == newfd) 2641 return oldfd; 2642 PerlLIO_close(newfd); 2643 /* good enough for low fd's... */ 2644 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) { 2645 if (fdx >= DUP2_MAX_FDS) { 2646 PerlLIO_close(fd); 2647 fd = -1; 2648 break; 2649 } 2650 fdtmp[fdx++] = fd; 2651 } 2652 while (fdx > 0) 2653 PerlLIO_close(fdtmp[--fdx]); 2654 return fd; 2655 #endif 2656 } 2657 #endif 2658 2659 #ifndef PERL_MICRO 2660 #ifdef HAS_SIGACTION 2661 2662 Sighandler_t 2663 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2664 { 2665 struct sigaction act, oact; 2666 2667 #ifdef USE_ITHREADS 2668 dVAR; 2669 /* only "parent" interpreter can diddle signals */ 2670 if (PL_curinterp != aTHX) 2671 return (Sighandler_t) SIG_ERR; 2672 #endif 2673 2674 act.sa_handler = (void(*)(int))handler; 2675 sigemptyset(&act.sa_mask); 2676 act.sa_flags = 0; 2677 #ifdef SA_RESTART 2678 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 2679 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2680 #endif 2681 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 2682 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) 2683 act.sa_flags |= SA_NOCLDWAIT; 2684 #endif 2685 if (sigaction(signo, &act, &oact) == -1) 2686 return (Sighandler_t) SIG_ERR; 2687 else 2688 return (Sighandler_t) oact.sa_handler; 2689 } 2690 2691 Sighandler_t 2692 Perl_rsignal_state(pTHX_ int signo) 2693 { 2694 struct sigaction oact; 2695 PERL_UNUSED_CONTEXT; 2696 2697 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) 2698 return (Sighandler_t) SIG_ERR; 2699 else 2700 return (Sighandler_t) oact.sa_handler; 2701 } 2702 2703 int 2704 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2705 { 2706 #ifdef USE_ITHREADS 2707 dVAR; 2708 #endif 2709 struct sigaction act; 2710 2711 PERL_ARGS_ASSERT_RSIGNAL_SAVE; 2712 2713 #ifdef USE_ITHREADS 2714 /* only "parent" interpreter can diddle signals */ 2715 if (PL_curinterp != aTHX) 2716 return -1; 2717 #endif 2718 2719 act.sa_handler = (void(*)(int))handler; 2720 sigemptyset(&act.sa_mask); 2721 act.sa_flags = 0; 2722 #ifdef SA_RESTART 2723 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 2724 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2725 #endif 2726 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 2727 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) 2728 act.sa_flags |= SA_NOCLDWAIT; 2729 #endif 2730 return sigaction(signo, &act, save); 2731 } 2732 2733 int 2734 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2735 { 2736 #ifdef USE_ITHREADS 2737 dVAR; 2738 #endif 2739 PERL_UNUSED_CONTEXT; 2740 #ifdef USE_ITHREADS 2741 /* only "parent" interpreter can diddle signals */ 2742 if (PL_curinterp != aTHX) 2743 return -1; 2744 #endif 2745 2746 return sigaction(signo, save, (struct sigaction *)NULL); 2747 } 2748 2749 #else /* !HAS_SIGACTION */ 2750 2751 Sighandler_t 2752 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2753 { 2754 #if defined(USE_ITHREADS) && !defined(WIN32) 2755 /* only "parent" interpreter can diddle signals */ 2756 if (PL_curinterp != aTHX) 2757 return (Sighandler_t) SIG_ERR; 2758 #endif 2759 2760 return PerlProc_signal(signo, handler); 2761 } 2762 2763 static Signal_t 2764 sig_trap(int signo) 2765 { 2766 dVAR; 2767 PL_sig_trapped++; 2768 } 2769 2770 Sighandler_t 2771 Perl_rsignal_state(pTHX_ int signo) 2772 { 2773 dVAR; 2774 Sighandler_t oldsig; 2775 2776 #if defined(USE_ITHREADS) && !defined(WIN32) 2777 /* only "parent" interpreter can diddle signals */ 2778 if (PL_curinterp != aTHX) 2779 return (Sighandler_t) SIG_ERR; 2780 #endif 2781 2782 PL_sig_trapped = 0; 2783 oldsig = PerlProc_signal(signo, sig_trap); 2784 PerlProc_signal(signo, oldsig); 2785 if (PL_sig_trapped) 2786 PerlProc_kill(PerlProc_getpid(), signo); 2787 return oldsig; 2788 } 2789 2790 int 2791 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2792 { 2793 #if defined(USE_ITHREADS) && !defined(WIN32) 2794 /* only "parent" interpreter can diddle signals */ 2795 if (PL_curinterp != aTHX) 2796 return -1; 2797 #endif 2798 *save = PerlProc_signal(signo, handler); 2799 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0; 2800 } 2801 2802 int 2803 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2804 { 2805 #if defined(USE_ITHREADS) && !defined(WIN32) 2806 /* only "parent" interpreter can diddle signals */ 2807 if (PL_curinterp != aTHX) 2808 return -1; 2809 #endif 2810 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0; 2811 } 2812 2813 #endif /* !HAS_SIGACTION */ 2814 #endif /* !PERL_MICRO */ 2815 2816 /* VMS' my_pclose() is in VMS.c; same with OS/2 */ 2817 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) 2818 I32 2819 Perl_my_pclose(pTHX_ PerlIO *ptr) 2820 { 2821 int status; 2822 SV **svp; 2823 Pid_t pid; 2824 Pid_t pid2 = 0; 2825 bool close_failed; 2826 dSAVEDERRNO; 2827 const int fd = PerlIO_fileno(ptr); 2828 bool should_wait; 2829 2830 svp = av_fetch(PL_fdpid,fd,TRUE); 2831 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; 2832 SvREFCNT_dec(*svp); 2833 *svp = NULL; 2834 2835 #if defined(USE_PERLIO) 2836 /* Find out whether the refcount is low enough for us to wait for the 2837 child proc without blocking. */ 2838 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0; 2839 #else 2840 should_wait = pid > 0; 2841 #endif 2842 2843 #ifdef OS2 2844 if (pid == -1) { /* Opened by popen. */ 2845 return my_syspclose(ptr); 2846 } 2847 #endif 2848 close_failed = (PerlIO_close(ptr) == EOF); 2849 SAVE_ERRNO; 2850 if (should_wait) do { 2851 pid2 = wait4pid(pid, &status, 0); 2852 } while (pid2 == -1 && errno == EINTR); 2853 if (close_failed) { 2854 RESTORE_ERRNO; 2855 return -1; 2856 } 2857 return( 2858 should_wait 2859 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status) 2860 : 0 2861 ); 2862 } 2863 #elif defined(__LIBCATAMOUNT__) 2864 I32 2865 Perl_my_pclose(pTHX_ PerlIO *ptr) 2866 { 2867 return -1; 2868 } 2869 #endif /* !DOSISH */ 2870 2871 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__) 2872 I32 2873 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) 2874 { 2875 I32 result = 0; 2876 PERL_ARGS_ASSERT_WAIT4PID; 2877 #ifdef PERL_USES_PL_PIDSTATUS 2878 if (!pid) { 2879 /* PERL_USES_PL_PIDSTATUS is only defined when neither 2880 waitpid() nor wait4() is available, or on OS/2, which 2881 doesn't appear to support waiting for a progress group 2882 member, so we can only treat a 0 pid as an unknown child. 2883 */ 2884 errno = ECHILD; 2885 return -1; 2886 } 2887 { 2888 if (pid > 0) { 2889 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the 2890 pid, rather than a string form. */ 2891 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE); 2892 if (svp && *svp != &PL_sv_undef) { 2893 *statusp = SvIVX(*svp); 2894 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t), 2895 G_DISCARD); 2896 return pid; 2897 } 2898 } 2899 else { 2900 HE *entry; 2901 2902 hv_iterinit(PL_pidstatus); 2903 if ((entry = hv_iternext(PL_pidstatus))) { 2904 SV * const sv = hv_iterval(PL_pidstatus,entry); 2905 I32 len; 2906 const char * const spid = hv_iterkey(entry,&len); 2907 2908 assert (len == sizeof(Pid_t)); 2909 memcpy((char *)&pid, spid, len); 2910 *statusp = SvIVX(sv); 2911 /* The hash iterator is currently on this entry, so simply 2912 calling hv_delete would trigger the lazy delete, which on 2913 aggregate does more work, because next call to hv_iterinit() 2914 would spot the flag, and have to call the delete routine, 2915 while in the meantime any new entries can't re-use that 2916 memory. */ 2917 hv_iterinit(PL_pidstatus); 2918 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD); 2919 return pid; 2920 } 2921 } 2922 } 2923 #endif 2924 #ifdef HAS_WAITPID 2925 # ifdef HAS_WAITPID_RUNTIME 2926 if (!HAS_WAITPID_RUNTIME) 2927 goto hard_way; 2928 # endif 2929 result = PerlProc_waitpid(pid,statusp,flags); 2930 goto finish; 2931 #endif 2932 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) 2933 result = wait4(pid,statusp,flags,NULL); 2934 goto finish; 2935 #endif 2936 #ifdef PERL_USES_PL_PIDSTATUS 2937 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME) 2938 hard_way: 2939 #endif 2940 { 2941 if (flags) 2942 Perl_croak(aTHX_ "Can't do waitpid with flags"); 2943 else { 2944 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) 2945 pidgone(result,*statusp); 2946 if (result < 0) 2947 *statusp = -1; 2948 } 2949 } 2950 #endif 2951 #if defined(HAS_WAITPID) || defined(HAS_WAIT4) 2952 finish: 2953 #endif 2954 if (result < 0 && errno == EINTR) { 2955 PERL_ASYNC_CHECK(); 2956 errno = EINTR; /* reset in case a signal handler changed $! */ 2957 } 2958 return result; 2959 } 2960 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */ 2961 2962 #ifdef PERL_USES_PL_PIDSTATUS 2963 void 2964 S_pidgone(pTHX_ Pid_t pid, int status) 2965 { 2966 SV *sv; 2967 2968 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE); 2969 SvUPGRADE(sv,SVt_IV); 2970 SvIV_set(sv, status); 2971 return; 2972 } 2973 #endif 2974 2975 #if defined(OS2) 2976 int pclose(); 2977 #ifdef HAS_FORK 2978 int /* Cannot prototype with I32 2979 in os2ish.h. */ 2980 my_syspclose(PerlIO *ptr) 2981 #else 2982 I32 2983 Perl_my_pclose(pTHX_ PerlIO *ptr) 2984 #endif 2985 { 2986 /* Needs work for PerlIO ! */ 2987 FILE * const f = PerlIO_findFILE(ptr); 2988 const I32 result = pclose(f); 2989 PerlIO_releaseFILE(ptr,f); 2990 return result; 2991 } 2992 #endif 2993 2994 #if defined(DJGPP) 2995 int djgpp_pclose(); 2996 I32 2997 Perl_my_pclose(pTHX_ PerlIO *ptr) 2998 { 2999 /* Needs work for PerlIO ! */ 3000 FILE * const f = PerlIO_findFILE(ptr); 3001 I32 result = djgpp_pclose(f); 3002 result = (result << 8) & 0xff00; 3003 PerlIO_releaseFILE(ptr,f); 3004 return result; 3005 } 3006 #endif 3007 3008 #define PERL_REPEATCPY_LINEAR 4 3009 void 3010 Perl_repeatcpy(char *to, const char *from, I32 len, IV count) 3011 { 3012 PERL_ARGS_ASSERT_REPEATCPY; 3013 3014 assert(len >= 0); 3015 3016 if (count < 0) 3017 croak_memory_wrap(); 3018 3019 if (len == 1) 3020 memset(to, *from, count); 3021 else if (count) { 3022 char *p = to; 3023 IV items, linear, half; 3024 3025 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR; 3026 for (items = 0; items < linear; ++items) { 3027 const char *q = from; 3028 IV todo; 3029 for (todo = len; todo > 0; todo--) 3030 *p++ = *q++; 3031 } 3032 3033 half = count / 2; 3034 while (items <= half) { 3035 IV size = items * len; 3036 memcpy(p, to, size); 3037 p += size; 3038 items *= 2; 3039 } 3040 3041 if (count > items) 3042 memcpy(p, to, (count - items) * len); 3043 } 3044 } 3045 3046 #ifndef HAS_RENAME 3047 I32 3048 Perl_same_dirent(pTHX_ const char *a, const char *b) 3049 { 3050 char *fa = strrchr(a,'/'); 3051 char *fb = strrchr(b,'/'); 3052 Stat_t tmpstatbuf1; 3053 Stat_t tmpstatbuf2; 3054 SV * const tmpsv = sv_newmortal(); 3055 3056 PERL_ARGS_ASSERT_SAME_DIRENT; 3057 3058 if (fa) 3059 fa++; 3060 else 3061 fa = a; 3062 if (fb) 3063 fb++; 3064 else 3065 fb = b; 3066 if (strNE(a,b)) 3067 return FALSE; 3068 if (fa == a) 3069 sv_setpvs(tmpsv, "."); 3070 else 3071 sv_setpvn(tmpsv, a, fa - a); 3072 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) 3073 return FALSE; 3074 if (fb == b) 3075 sv_setpvs(tmpsv, "."); 3076 else 3077 sv_setpvn(tmpsv, b, fb - b); 3078 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) 3079 return FALSE; 3080 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && 3081 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; 3082 } 3083 #endif /* !HAS_RENAME */ 3084 3085 char* 3086 Perl_find_script(pTHX_ const char *scriptname, bool dosearch, 3087 const char *const *const search_ext, I32 flags) 3088 { 3089 const char *xfound = NULL; 3090 char *xfailed = NULL; 3091 char tmpbuf[MAXPATHLEN]; 3092 char *s; 3093 I32 len = 0; 3094 int retval; 3095 char *bufend; 3096 #if defined(DOSISH) && !defined(OS2) 3097 # define SEARCH_EXTS ".bat", ".cmd", NULL 3098 # define MAX_EXT_LEN 4 3099 #endif 3100 #ifdef OS2 3101 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL 3102 # define MAX_EXT_LEN 4 3103 #endif 3104 #ifdef VMS 3105 # define SEARCH_EXTS ".pl", ".com", NULL 3106 # define MAX_EXT_LEN 4 3107 #endif 3108 /* additional extensions to try in each dir if scriptname not found */ 3109 #ifdef SEARCH_EXTS 3110 static const char *const exts[] = { SEARCH_EXTS }; 3111 const char *const *const ext = search_ext ? search_ext : exts; 3112 int extidx = 0, i = 0; 3113 const char *curext = NULL; 3114 #else 3115 PERL_UNUSED_ARG(search_ext); 3116 # define MAX_EXT_LEN 0 3117 #endif 3118 3119 PERL_ARGS_ASSERT_FIND_SCRIPT; 3120 3121 /* 3122 * If dosearch is true and if scriptname does not contain path 3123 * delimiters, search the PATH for scriptname. 3124 * 3125 * If SEARCH_EXTS is also defined, will look for each 3126 * scriptname{SEARCH_EXTS} whenever scriptname is not found 3127 * while searching the PATH. 3128 * 3129 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search 3130 * proceeds as follows: 3131 * If DOSISH or VMSISH: 3132 * + look for ./scriptname{,.foo,.bar} 3133 * + search the PATH for scriptname{,.foo,.bar} 3134 * 3135 * If !DOSISH: 3136 * + look *only* in the PATH for scriptname{,.foo,.bar} (note 3137 * this will not look in '.' if it's not in the PATH) 3138 */ 3139 tmpbuf[0] = '\0'; 3140 3141 #ifdef VMS 3142 # ifdef ALWAYS_DEFTYPES 3143 len = strlen(scriptname); 3144 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { 3145 int idx = 0, deftypes = 1; 3146 bool seen_dot = 1; 3147 3148 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL); 3149 # else 3150 if (dosearch) { 3151 int idx = 0, deftypes = 1; 3152 bool seen_dot = 1; 3153 3154 const int hasdir = (strpbrk(scriptname,":[</") != NULL); 3155 # endif 3156 /* The first time through, just add SEARCH_EXTS to whatever we 3157 * already have, so we can check for default file types. */ 3158 while (deftypes || 3159 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) 3160 { 3161 Stat_t statbuf; 3162 if (deftypes) { 3163 deftypes = 0; 3164 *tmpbuf = '\0'; 3165 } 3166 if ((strlen(tmpbuf) + strlen(scriptname) 3167 + MAX_EXT_LEN) >= sizeof tmpbuf) 3168 continue; /* don't search dir with too-long name */ 3169 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf)); 3170 #else /* !VMS */ 3171 3172 #ifdef DOSISH 3173 if (strEQ(scriptname, "-")) 3174 dosearch = 0; 3175 if (dosearch) { /* Look in '.' first. */ 3176 const char *cur = scriptname; 3177 #ifdef SEARCH_EXTS 3178 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ 3179 while (ext[i]) 3180 if (strEQ(ext[i++],curext)) { 3181 extidx = -1; /* already has an ext */ 3182 break; 3183 } 3184 do { 3185 #endif 3186 DEBUG_p(PerlIO_printf(Perl_debug_log, 3187 "Looking for %s\n",cur)); 3188 { 3189 Stat_t statbuf; 3190 if (PerlLIO_stat(cur,&statbuf) >= 0 3191 && !S_ISDIR(statbuf.st_mode)) { 3192 dosearch = 0; 3193 scriptname = cur; 3194 #ifdef SEARCH_EXTS 3195 break; 3196 #endif 3197 } 3198 } 3199 #ifdef SEARCH_EXTS 3200 if (cur == scriptname) { 3201 len = strlen(scriptname); 3202 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) 3203 break; 3204 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf)); 3205 cur = tmpbuf; 3206 } 3207 } while (extidx >= 0 && ext[extidx] /* try an extension? */ 3208 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)); 3209 #endif 3210 } 3211 #endif 3212 3213 if (dosearch && !strchr(scriptname, '/') 3214 #ifdef DOSISH 3215 && !strchr(scriptname, '\\') 3216 #endif 3217 && (s = PerlEnv_getenv("PATH"))) 3218 { 3219 bool seen_dot = 0; 3220 3221 bufend = s + strlen(s); 3222 while (s < bufend) { 3223 Stat_t statbuf; 3224 # ifdef DOSISH 3225 for (len = 0; *s 3226 && *s != ';'; len++, s++) { 3227 if (len < sizeof tmpbuf) 3228 tmpbuf[len] = *s; 3229 } 3230 if (len < sizeof tmpbuf) 3231 tmpbuf[len] = '\0'; 3232 # else 3233 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, 3234 ':', &len); 3235 # endif 3236 if (s < bufend) 3237 s++; 3238 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) 3239 continue; /* don't search dir with too-long name */ 3240 if (len 3241 # ifdef DOSISH 3242 && tmpbuf[len - 1] != '/' 3243 && tmpbuf[len - 1] != '\\' 3244 # endif 3245 ) 3246 tmpbuf[len++] = '/'; 3247 if (len == 2 && tmpbuf[0] == '.') 3248 seen_dot = 1; 3249 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len); 3250 #endif /* !VMS */ 3251 3252 #ifdef SEARCH_EXTS 3253 len = strlen(tmpbuf); 3254 if (extidx > 0) /* reset after previous loop */ 3255 extidx = 0; 3256 do { 3257 #endif 3258 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); 3259 retval = PerlLIO_stat(tmpbuf,&statbuf); 3260 if (S_ISDIR(statbuf.st_mode)) { 3261 retval = -1; 3262 } 3263 #ifdef SEARCH_EXTS 3264 } while ( retval < 0 /* not there */ 3265 && extidx>=0 && ext[extidx] /* try an extension? */ 3266 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len) 3267 ); 3268 #endif 3269 if (retval < 0) 3270 continue; 3271 if (S_ISREG(statbuf.st_mode) 3272 && cando(S_IRUSR,TRUE,&statbuf) 3273 #if !defined(DOSISH) 3274 && cando(S_IXUSR,TRUE,&statbuf) 3275 #endif 3276 ) 3277 { 3278 xfound = tmpbuf; /* bingo! */ 3279 break; 3280 } 3281 if (!xfailed) 3282 xfailed = savepv(tmpbuf); 3283 } 3284 #ifndef DOSISH 3285 { 3286 Stat_t statbuf; 3287 if (!xfound && !seen_dot && !xfailed && 3288 (PerlLIO_stat(scriptname,&statbuf) < 0 3289 || S_ISDIR(statbuf.st_mode))) 3290 #endif 3291 seen_dot = 1; /* Disable message. */ 3292 #ifndef DOSISH 3293 } 3294 #endif 3295 if (!xfound) { 3296 if (flags & 1) { /* do or die? */ 3297 /* diag_listed_as: Can't execute %s */ 3298 Perl_croak(aTHX_ "Can't %s %s%s%s", 3299 (xfailed ? "execute" : "find"), 3300 (xfailed ? xfailed : scriptname), 3301 (xfailed ? "" : " on PATH"), 3302 (xfailed || seen_dot) ? "" : ", '.' not in PATH"); 3303 } 3304 scriptname = NULL; 3305 } 3306 Safefree(xfailed); 3307 scriptname = xfound; 3308 } 3309 return (scriptname ? savepv(scriptname) : NULL); 3310 } 3311 3312 #ifndef PERL_GET_CONTEXT_DEFINED 3313 3314 void * 3315 Perl_get_context(void) 3316 { 3317 #if defined(USE_ITHREADS) 3318 dVAR; 3319 # ifdef OLD_PTHREADS_API 3320 pthread_addr_t t; 3321 int error = pthread_getspecific(PL_thr_key, &t) 3322 if (error) 3323 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error); 3324 return (void*)t; 3325 # elif defined(I_MACH_CTHREADS) 3326 return (void*)cthread_data(cthread_self()); 3327 # else 3328 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); 3329 # endif 3330 #else 3331 return (void*)NULL; 3332 #endif 3333 } 3334 3335 void 3336 Perl_set_context(void *t) 3337 { 3338 #if defined(USE_ITHREADS) 3339 dVAR; 3340 #endif 3341 PERL_ARGS_ASSERT_SET_CONTEXT; 3342 #if defined(USE_ITHREADS) 3343 # ifdef I_MACH_CTHREADS 3344 cthread_set_data(cthread_self(), t); 3345 # else 3346 { 3347 const int error = pthread_setspecific(PL_thr_key, t); 3348 if (error) 3349 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error); 3350 } 3351 # endif 3352 #else 3353 PERL_UNUSED_ARG(t); 3354 #endif 3355 } 3356 3357 #endif /* !PERL_GET_CONTEXT_DEFINED */ 3358 3359 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) 3360 struct perl_vars * 3361 Perl_GetVars(pTHX) 3362 { 3363 PERL_UNUSED_CONTEXT; 3364 return &PL_Vars; 3365 } 3366 #endif 3367 3368 char ** 3369 Perl_get_op_names(pTHX) 3370 { 3371 PERL_UNUSED_CONTEXT; 3372 return (char **)PL_op_name; 3373 } 3374 3375 char ** 3376 Perl_get_op_descs(pTHX) 3377 { 3378 PERL_UNUSED_CONTEXT; 3379 return (char **)PL_op_desc; 3380 } 3381 3382 const char * 3383 Perl_get_no_modify(pTHX) 3384 { 3385 PERL_UNUSED_CONTEXT; 3386 return PL_no_modify; 3387 } 3388 3389 U32 * 3390 Perl_get_opargs(pTHX) 3391 { 3392 PERL_UNUSED_CONTEXT; 3393 return (U32 *)PL_opargs; 3394 } 3395 3396 PPADDR_t* 3397 Perl_get_ppaddr(pTHX) 3398 { 3399 dVAR; 3400 PERL_UNUSED_CONTEXT; 3401 return (PPADDR_t*)PL_ppaddr; 3402 } 3403 3404 #ifndef HAS_GETENV_LEN 3405 char * 3406 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) 3407 { 3408 char * const env_trans = PerlEnv_getenv(env_elem); 3409 PERL_UNUSED_CONTEXT; 3410 PERL_ARGS_ASSERT_GETENV_LEN; 3411 if (env_trans) 3412 *len = strlen(env_trans); 3413 return env_trans; 3414 } 3415 #endif 3416 3417 3418 MGVTBL* 3419 Perl_get_vtbl(pTHX_ int vtbl_id) 3420 { 3421 PERL_UNUSED_CONTEXT; 3422 3423 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) 3424 ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id; 3425 } 3426 3427 I32 3428 Perl_my_fflush_all(pTHX) 3429 { 3430 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) 3431 return PerlIO_flush(NULL); 3432 #else 3433 # if defined(HAS__FWALK) 3434 extern int fflush(FILE *); 3435 /* undocumented, unprototyped, but very useful BSDism */ 3436 extern void _fwalk(int (*)(FILE *)); 3437 _fwalk(&fflush); 3438 return 0; 3439 # else 3440 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) 3441 long open_max = -1; 3442 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX 3443 open_max = PERL_FFLUSH_ALL_FOPEN_MAX; 3444 # elif defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) 3445 open_max = sysconf(_SC_OPEN_MAX); 3446 # elif defined(FOPEN_MAX) 3447 open_max = FOPEN_MAX; 3448 # elif defined(OPEN_MAX) 3449 open_max = OPEN_MAX; 3450 # elif defined(_NFILE) 3451 open_max = _NFILE; 3452 # endif 3453 if (open_max > 0) { 3454 long i; 3455 for (i = 0; i < open_max; i++) 3456 if (STDIO_STREAM_ARRAY[i]._file >= 0 && 3457 STDIO_STREAM_ARRAY[i]._file < open_max && 3458 STDIO_STREAM_ARRAY[i]._flag) 3459 PerlIO_flush(&STDIO_STREAM_ARRAY[i]); 3460 return 0; 3461 } 3462 # endif 3463 SETERRNO(EBADF,RMS_IFI); 3464 return EOF; 3465 # endif 3466 #endif 3467 } 3468 3469 void 3470 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) 3471 { 3472 if (ckWARN(WARN_IO)) { 3473 HEK * const name 3474 = gv && (isGV_with_GP(gv)) 3475 ? GvENAME_HEK((gv)) 3476 : NULL; 3477 const char * const direction = have == '>' ? "out" : "in"; 3478 3479 if (name && HEK_LEN(name)) 3480 Perl_warner(aTHX_ packWARN(WARN_IO), 3481 "Filehandle %" HEKf " opened only for %sput", 3482 HEKfARG(name), direction); 3483 else 3484 Perl_warner(aTHX_ packWARN(WARN_IO), 3485 "Filehandle opened only for %sput", direction); 3486 } 3487 } 3488 3489 void 3490 Perl_report_evil_fh(pTHX_ const GV *gv) 3491 { 3492 const IO *io = gv ? GvIO(gv) : NULL; 3493 const PERL_BITFIELD16 op = PL_op->op_type; 3494 const char *vile; 3495 I32 warn_type; 3496 3497 if (io && IoTYPE(io) == IoTYPE_CLOSED) { 3498 vile = "closed"; 3499 warn_type = WARN_CLOSED; 3500 } 3501 else { 3502 vile = "unopened"; 3503 warn_type = WARN_UNOPENED; 3504 } 3505 3506 if (ckWARN(warn_type)) { 3507 SV * const name 3508 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ? 3509 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL; 3510 const char * const pars = 3511 (const char *)(OP_IS_FILETEST(op) ? "" : "()"); 3512 const char * const func = 3513 (const char *) 3514 (op == OP_READLINE || op == OP_RCATLINE 3515 ? "readline" : /* "<HANDLE>" not nice */ 3516 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ 3517 PL_op_desc[op]); 3518 const char * const type = 3519 (const char *) 3520 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) 3521 ? "socket" : "filehandle"); 3522 const bool have_name = name && SvCUR(name); 3523 Perl_warner(aTHX_ packWARN(warn_type), 3524 "%s%s on %s %s%s%" SVf, func, pars, vile, type, 3525 have_name ? " " : "", 3526 SVfARG(have_name ? name : &PL_sv_no)); 3527 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3528 Perl_warner( 3529 aTHX_ packWARN(warn_type), 3530 "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n", 3531 func, pars, have_name ? " " : "", 3532 SVfARG(have_name ? name : &PL_sv_no) 3533 ); 3534 } 3535 } 3536 3537 /* To workaround core dumps from the uninitialised tm_zone we get the 3538 * system to give us a reasonable struct to copy. This fix means that 3539 * strftime uses the tm_zone and tm_gmtoff values returned by 3540 * localtime(time()). That should give the desired result most of the 3541 * time. But probably not always! 3542 * 3543 * This does not address tzname aspects of NETaa14816. 3544 * 3545 */ 3546 3547 #ifdef __GLIBC__ 3548 # ifndef STRUCT_TM_HASZONE 3549 # define STRUCT_TM_HASZONE 3550 # endif 3551 #endif 3552 3553 #ifdef STRUCT_TM_HASZONE /* Backward compat */ 3554 # ifndef HAS_TM_TM_ZONE 3555 # define HAS_TM_TM_ZONE 3556 # endif 3557 #endif 3558 3559 void 3560 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ 3561 { 3562 #ifdef HAS_TM_TM_ZONE 3563 Time_t now; 3564 const struct tm* my_tm; 3565 PERL_UNUSED_CONTEXT; 3566 PERL_ARGS_ASSERT_INIT_TM; 3567 (void)time(&now); 3568 my_tm = localtime(&now); 3569 if (my_tm) 3570 Copy(my_tm, ptm, 1, struct tm); 3571 #else 3572 PERL_UNUSED_CONTEXT; 3573 PERL_ARGS_ASSERT_INIT_TM; 3574 PERL_UNUSED_ARG(ptm); 3575 #endif 3576 } 3577 3578 /* 3579 * mini_mktime - normalise struct tm values without the localtime() 3580 * semantics (and overhead) of mktime(). 3581 */ 3582 void 3583 Perl_mini_mktime(struct tm *ptm) 3584 { 3585 int yearday; 3586 int secs; 3587 int month, mday, year, jday; 3588 int odd_cent, odd_year; 3589 3590 PERL_ARGS_ASSERT_MINI_MKTIME; 3591 3592 #define DAYS_PER_YEAR 365 3593 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) 3594 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) 3595 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) 3596 #define SECS_PER_HOUR (60*60) 3597 #define SECS_PER_DAY (24*SECS_PER_HOUR) 3598 /* parentheses deliberately absent on these two, otherwise they don't work */ 3599 #define MONTH_TO_DAYS 153/5 3600 #define DAYS_TO_MONTH 5/153 3601 /* offset to bias by March (month 4) 1st between month/mday & year finding */ 3602 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1) 3603 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ 3604 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ 3605 3606 /* 3607 * Year/day algorithm notes: 3608 * 3609 * With a suitable offset for numeric value of the month, one can find 3610 * an offset into the year by considering months to have 30.6 (153/5) days, 3611 * using integer arithmetic (i.e., with truncation). To avoid too much 3612 * messing about with leap days, we consider January and February to be 3613 * the 13th and 14th month of the previous year. After that transformation, 3614 * we need the month index we use to be high by 1 from 'normal human' usage, 3615 * so the month index values we use run from 4 through 15. 3616 * 3617 * Given that, and the rules for the Gregorian calendar (leap years are those 3618 * divisible by 4 unless also divisible by 100, when they must be divisible 3619 * by 400 instead), we can simply calculate the number of days since some 3620 * arbitrary 'beginning of time' by futzing with the (adjusted) year number, 3621 * the days we derive from our month index, and adding in the day of the 3622 * month. The value used here is not adjusted for the actual origin which 3623 * it normally would use (1 January A.D. 1), since we're not exposing it. 3624 * We're only building the value so we can turn around and get the 3625 * normalised values for the year, month, day-of-month, and day-of-year. 3626 * 3627 * For going backward, we need to bias the value we're using so that we find 3628 * the right year value. (Basically, we don't want the contribution of 3629 * March 1st to the number to apply while deriving the year). Having done 3630 * that, we 'count up' the contribution to the year number by accounting for 3631 * full quadracenturies (400-year periods) with their extra leap days, plus 3632 * the contribution from full centuries (to avoid counting in the lost leap 3633 * days), plus the contribution from full quad-years (to count in the normal 3634 * leap days), plus the leftover contribution from any non-leap years. 3635 * At this point, if we were working with an actual leap day, we'll have 0 3636 * days left over. This is also true for March 1st, however. So, we have 3637 * to special-case that result, and (earlier) keep track of the 'odd' 3638 * century and year contributions. If we got 4 extra centuries in a qcent, 3639 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. 3640 * Otherwise, we add back in the earlier bias we removed (the 123 from 3641 * figuring in March 1st), find the month index (integer division by 30.6), 3642 * and the remainder is the day-of-month. We then have to convert back to 3643 * 'real' months (including fixing January and February from being 14/15 in 3644 * the previous year to being in the proper year). After that, to get 3645 * tm_yday, we work with the normalised year and get a new yearday value for 3646 * January 1st, which we subtract from the yearday value we had earlier, 3647 * representing the date we've re-built. This is done from January 1 3648 * because tm_yday is 0-origin. 3649 * 3650 * Since POSIX time routines are only guaranteed to work for times since the 3651 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm 3652 * applies Gregorian calendar rules even to dates before the 16th century 3653 * doesn't bother me. Besides, you'd need cultural context for a given 3654 * date to know whether it was Julian or Gregorian calendar, and that's 3655 * outside the scope for this routine. Since we convert back based on the 3656 * same rules we used to build the yearday, you'll only get strange results 3657 * for input which needed normalising, or for the 'odd' century years which 3658 * were leap years in the Julian calendar but not in the Gregorian one. 3659 * I can live with that. 3660 * 3661 * This algorithm also fails to handle years before A.D. 1 gracefully, but 3662 * that's still outside the scope for POSIX time manipulation, so I don't 3663 * care. 3664 * 3665 * - lwall 3666 */ 3667 3668 year = 1900 + ptm->tm_year; 3669 month = ptm->tm_mon; 3670 mday = ptm->tm_mday; 3671 jday = 0; 3672 if (month >= 2) 3673 month+=2; 3674 else 3675 month+=14, year--; 3676 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; 3677 yearday += month*MONTH_TO_DAYS + mday + jday; 3678 /* 3679 * Note that we don't know when leap-seconds were or will be, 3680 * so we have to trust the user if we get something which looks 3681 * like a sensible leap-second. Wild values for seconds will 3682 * be rationalised, however. 3683 */ 3684 if ((unsigned) ptm->tm_sec <= 60) { 3685 secs = 0; 3686 } 3687 else { 3688 secs = ptm->tm_sec; 3689 ptm->tm_sec = 0; 3690 } 3691 secs += 60 * ptm->tm_min; 3692 secs += SECS_PER_HOUR * ptm->tm_hour; 3693 if (secs < 0) { 3694 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { 3695 /* got negative remainder, but need positive time */ 3696 /* back off an extra day to compensate */ 3697 yearday += (secs/SECS_PER_DAY)-1; 3698 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); 3699 } 3700 else { 3701 yearday += (secs/SECS_PER_DAY); 3702 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); 3703 } 3704 } 3705 else if (secs >= SECS_PER_DAY) { 3706 yearday += (secs/SECS_PER_DAY); 3707 secs %= SECS_PER_DAY; 3708 } 3709 ptm->tm_hour = secs/SECS_PER_HOUR; 3710 secs %= SECS_PER_HOUR; 3711 ptm->tm_min = secs/60; 3712 secs %= 60; 3713 ptm->tm_sec += secs; 3714 /* done with time of day effects */ 3715 /* 3716 * The algorithm for yearday has (so far) left it high by 428. 3717 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to 3718 * bias it by 123 while trying to figure out what year it 3719 * really represents. Even with this tweak, the reverse 3720 * translation fails for years before A.D. 0001. 3721 * It would still fail for Feb 29, but we catch that one below. 3722 */ 3723 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ 3724 yearday -= YEAR_ADJUST; 3725 year = (yearday / DAYS_PER_QCENT) * 400; 3726 yearday %= DAYS_PER_QCENT; 3727 odd_cent = yearday / DAYS_PER_CENT; 3728 year += odd_cent * 100; 3729 yearday %= DAYS_PER_CENT; 3730 year += (yearday / DAYS_PER_QYEAR) * 4; 3731 yearday %= DAYS_PER_QYEAR; 3732 odd_year = yearday / DAYS_PER_YEAR; 3733 year += odd_year; 3734 yearday %= DAYS_PER_YEAR; 3735 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ 3736 month = 1; 3737 yearday = 29; 3738 } 3739 else { 3740 yearday += YEAR_ADJUST; /* recover March 1st crock */ 3741 month = yearday*DAYS_TO_MONTH; 3742 yearday -= month*MONTH_TO_DAYS; 3743 /* recover other leap-year adjustment */ 3744 if (month > 13) { 3745 month-=14; 3746 year++; 3747 } 3748 else { 3749 month-=2; 3750 } 3751 } 3752 ptm->tm_year = year - 1900; 3753 if (yearday) { 3754 ptm->tm_mday = yearday; 3755 ptm->tm_mon = month; 3756 } 3757 else { 3758 ptm->tm_mday = 31; 3759 ptm->tm_mon = month - 1; 3760 } 3761 /* re-build yearday based on Jan 1 to get tm_yday */ 3762 year--; 3763 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; 3764 yearday += 14*MONTH_TO_DAYS + 1; 3765 ptm->tm_yday = jday - yearday; 3766 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; 3767 } 3768 3769 char * 3770 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) 3771 { 3772 #ifdef HAS_STRFTIME 3773 3774 /* strftime(), but with a different API so that the return value is a pointer 3775 * to the formatted result (which MUST be arranged to be FREED BY THE 3776 * CALLER). This allows this function to increase the buffer size as needed, 3777 * so that the caller doesn't have to worry about that. 3778 * 3779 * Note that yday and wday effectively are ignored by this function, as 3780 * mini_mktime() overwrites them */ 3781 3782 char *buf; 3783 int buflen; 3784 struct tm mytm; 3785 int len; 3786 3787 PERL_ARGS_ASSERT_MY_STRFTIME; 3788 3789 init_tm(&mytm); /* XXX workaround - see init_tm() above */ 3790 mytm.tm_sec = sec; 3791 mytm.tm_min = min; 3792 mytm.tm_hour = hour; 3793 mytm.tm_mday = mday; 3794 mytm.tm_mon = mon; 3795 mytm.tm_year = year; 3796 mytm.tm_wday = wday; 3797 mytm.tm_yday = yday; 3798 mytm.tm_isdst = isdst; 3799 mini_mktime(&mytm); 3800 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */ 3801 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE)) 3802 STMT_START { 3803 struct tm mytm2; 3804 mytm2 = mytm; 3805 mktime(&mytm2); 3806 #ifdef HAS_TM_TM_GMTOFF 3807 mytm.tm_gmtoff = mytm2.tm_gmtoff; 3808 #endif 3809 #ifdef HAS_TM_TM_ZONE 3810 mytm.tm_zone = mytm2.tm_zone; 3811 #endif 3812 } STMT_END; 3813 #endif 3814 buflen = 64; 3815 Newx(buf, buflen, char); 3816 3817 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */ 3818 len = strftime(buf, buflen, fmt, &mytm); 3819 GCC_DIAG_RESTORE_STMT; 3820 3821 /* 3822 ** The following is needed to handle to the situation where 3823 ** tmpbuf overflows. Basically we want to allocate a buffer 3824 ** and try repeatedly. The reason why it is so complicated 3825 ** is that getting a return value of 0 from strftime can indicate 3826 ** one of the following: 3827 ** 1. buffer overflowed, 3828 ** 2. illegal conversion specifier, or 3829 ** 3. the format string specifies nothing to be returned(not 3830 ** an error). This could be because format is an empty string 3831 ** or it specifies %p that yields an empty string in some locale. 3832 ** If there is a better way to make it portable, go ahead by 3833 ** all means. 3834 */ 3835 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0')) 3836 return buf; 3837 else { 3838 /* Possibly buf overflowed - try again with a bigger buf */ 3839 const int fmtlen = strlen(fmt); 3840 int bufsize = fmtlen + buflen; 3841 3842 Renew(buf, bufsize, char); 3843 while (buf) { 3844 3845 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */ 3846 buflen = strftime(buf, bufsize, fmt, &mytm); 3847 GCC_DIAG_RESTORE_STMT; 3848 3849 if (buflen > 0 && buflen < bufsize) 3850 break; 3851 /* heuristic to prevent out-of-memory errors */ 3852 if (bufsize > 100*fmtlen) { 3853 Safefree(buf); 3854 buf = NULL; 3855 break; 3856 } 3857 bufsize *= 2; 3858 Renew(buf, bufsize, char); 3859 } 3860 return buf; 3861 } 3862 #else 3863 Perl_croak(aTHX_ "panic: no strftime"); 3864 return NULL; 3865 #endif 3866 } 3867 3868 3869 #define SV_CWD_RETURN_UNDEF \ 3870 sv_set_undef(sv); \ 3871 return FALSE 3872 3873 #define SV_CWD_ISDOT(dp) \ 3874 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ 3875 (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) 3876 3877 /* 3878 =head1 Miscellaneous Functions 3879 3880 =for apidoc getcwd_sv 3881 3882 Fill C<sv> with current working directory 3883 3884 =cut 3885 */ 3886 3887 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. 3888 * rewritten again by dougm, optimized for use with xs TARG, and to prefer 3889 * getcwd(3) if available 3890 * Comments from the original: 3891 * This is a faster version of getcwd. It's also more dangerous 3892 * because you might chdir out of a directory that you can't chdir 3893 * back into. */ 3894 3895 int 3896 Perl_getcwd_sv(pTHX_ SV *sv) 3897 { 3898 #ifndef PERL_MICRO 3899 SvTAINTED_on(sv); 3900 3901 PERL_ARGS_ASSERT_GETCWD_SV; 3902 3903 #ifdef HAS_GETCWD 3904 { 3905 char buf[MAXPATHLEN]; 3906 3907 /* Some getcwd()s automatically allocate a buffer of the given 3908 * size from the heap if they are given a NULL buffer pointer. 3909 * The problem is that this behaviour is not portable. */ 3910 if (getcwd(buf, sizeof(buf) - 1)) { 3911 sv_setpv(sv, buf); 3912 return TRUE; 3913 } 3914 else { 3915 SV_CWD_RETURN_UNDEF; 3916 } 3917 } 3918 3919 #else 3920 3921 Stat_t statbuf; 3922 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; 3923 int pathlen=0; 3924 Direntry_t *dp; 3925 3926 SvUPGRADE(sv, SVt_PV); 3927 3928 if (PerlLIO_lstat(".", &statbuf) < 0) { 3929 SV_CWD_RETURN_UNDEF; 3930 } 3931 3932 orig_cdev = statbuf.st_dev; 3933 orig_cino = statbuf.st_ino; 3934 cdev = orig_cdev; 3935 cino = orig_cino; 3936 3937 for (;;) { 3938 DIR *dir; 3939 int namelen; 3940 odev = cdev; 3941 oino = cino; 3942 3943 if (PerlDir_chdir("..") < 0) { 3944 SV_CWD_RETURN_UNDEF; 3945 } 3946 if (PerlLIO_stat(".", &statbuf) < 0) { 3947 SV_CWD_RETURN_UNDEF; 3948 } 3949 3950 cdev = statbuf.st_dev; 3951 cino = statbuf.st_ino; 3952 3953 if (odev == cdev && oino == cino) { 3954 break; 3955 } 3956 if (!(dir = PerlDir_open("."))) { 3957 SV_CWD_RETURN_UNDEF; 3958 } 3959 3960 while ((dp = PerlDir_read(dir)) != NULL) { 3961 #ifdef DIRNAMLEN 3962 namelen = dp->d_namlen; 3963 #else 3964 namelen = strlen(dp->d_name); 3965 #endif 3966 /* skip . and .. */ 3967 if (SV_CWD_ISDOT(dp)) { 3968 continue; 3969 } 3970 3971 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { 3972 SV_CWD_RETURN_UNDEF; 3973 } 3974 3975 tdev = statbuf.st_dev; 3976 tino = statbuf.st_ino; 3977 if (tino == oino && tdev == odev) { 3978 break; 3979 } 3980 } 3981 3982 if (!dp) { 3983 SV_CWD_RETURN_UNDEF; 3984 } 3985 3986 if (pathlen + namelen + 1 >= MAXPATHLEN) { 3987 SV_CWD_RETURN_UNDEF; 3988 } 3989 3990 SvGROW(sv, pathlen + namelen + 1); 3991 3992 if (pathlen) { 3993 /* shift down */ 3994 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char); 3995 } 3996 3997 /* prepend current directory to the front */ 3998 *SvPVX(sv) = '/'; 3999 Move(dp->d_name, SvPVX(sv)+1, namelen, char); 4000 pathlen += (namelen + 1); 4001 4002 #ifdef VOID_CLOSEDIR 4003 PerlDir_close(dir); 4004 #else 4005 if (PerlDir_close(dir) < 0) { 4006 SV_CWD_RETURN_UNDEF; 4007 } 4008 #endif 4009 } 4010 4011 if (pathlen) { 4012 SvCUR_set(sv, pathlen); 4013 *SvEND(sv) = '\0'; 4014 SvPOK_only(sv); 4015 4016 if (PerlDir_chdir(SvPVX_const(sv)) < 0) { 4017 SV_CWD_RETURN_UNDEF; 4018 } 4019 } 4020 if (PerlLIO_stat(".", &statbuf) < 0) { 4021 SV_CWD_RETURN_UNDEF; 4022 } 4023 4024 cdev = statbuf.st_dev; 4025 cino = statbuf.st_ino; 4026 4027 if (cdev != orig_cdev || cino != orig_cino) { 4028 Perl_croak(aTHX_ "Unstable directory path, " 4029 "current directory changed unexpectedly"); 4030 } 4031 4032 return TRUE; 4033 #endif 4034 4035 #else 4036 return FALSE; 4037 #endif 4038 } 4039 4040 #include "vutil.c" 4041 4042 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) 4043 # define EMULATE_SOCKETPAIR_UDP 4044 #endif 4045 4046 #ifdef EMULATE_SOCKETPAIR_UDP 4047 static int 4048 S_socketpair_udp (int fd[2]) { 4049 dTHX; 4050 /* Fake a datagram socketpair using UDP to localhost. */ 4051 int sockets[2] = {-1, -1}; 4052 struct sockaddr_in addresses[2]; 4053 int i; 4054 Sock_size_t size = sizeof(struct sockaddr_in); 4055 unsigned short port; 4056 int got; 4057 4058 memset(&addresses, 0, sizeof(addresses)); 4059 i = 1; 4060 do { 4061 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET); 4062 if (sockets[i] == -1) 4063 goto tidy_up_and_fail; 4064 4065 addresses[i].sin_family = AF_INET; 4066 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK); 4067 addresses[i].sin_port = 0; /* kernel choses port. */ 4068 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i], 4069 sizeof(struct sockaddr_in)) == -1) 4070 goto tidy_up_and_fail; 4071 } while (i--); 4072 4073 /* Now have 2 UDP sockets. Find out which port each is connected to, and 4074 for each connect the other socket to it. */ 4075 i = 1; 4076 do { 4077 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i], 4078 &size) == -1) 4079 goto tidy_up_and_fail; 4080 if (size != sizeof(struct sockaddr_in)) 4081 goto abort_tidy_up_and_fail; 4082 /* !1 is 0, !0 is 1 */ 4083 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], 4084 sizeof(struct sockaddr_in)) == -1) 4085 goto tidy_up_and_fail; 4086 } while (i--); 4087 4088 /* Now we have 2 sockets connected to each other. I don't trust some other 4089 process not to have already sent a packet to us (by random) so send 4090 a packet from each to the other. */ 4091 i = 1; 4092 do { 4093 /* I'm going to send my own port number. As a short. 4094 (Who knows if someone somewhere has sin_port as a bitfield and needs 4095 this routine. (I'm assuming crays have socketpair)) */ 4096 port = addresses[i].sin_port; 4097 got = PerlLIO_write(sockets[i], &port, sizeof(port)); 4098 if (got != sizeof(port)) { 4099 if (got == -1) 4100 goto tidy_up_and_fail; 4101 goto abort_tidy_up_and_fail; 4102 } 4103 } while (i--); 4104 4105 /* Packets sent. I don't trust them to have arrived though. 4106 (As I understand it Solaris TCP stack is multithreaded. Non-blocking 4107 connect to localhost will use a second kernel thread. In 2.6 the 4108 first thread running the connect() returns before the second completes, 4109 so EINPROGRESS> In 2.7 the improved stack is faster and connect() 4110 returns 0. Poor programs have tripped up. One poor program's authors' 4111 had a 50-1 reverse stock split. Not sure how connected these were.) 4112 So I don't trust someone not to have an unpredictable UDP stack. 4113 */ 4114 4115 { 4116 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ 4117 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; 4118 fd_set rset; 4119 4120 FD_ZERO(&rset); 4121 FD_SET((unsigned int)sockets[0], &rset); 4122 FD_SET((unsigned int)sockets[1], &rset); 4123 4124 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor); 4125 if (got != 2 || !FD_ISSET(sockets[0], &rset) 4126 || !FD_ISSET(sockets[1], &rset)) { 4127 /* I hope this is portable and appropriate. */ 4128 if (got == -1) 4129 goto tidy_up_and_fail; 4130 goto abort_tidy_up_and_fail; 4131 } 4132 } 4133 4134 /* And the paranoia department even now doesn't trust it to have arrive 4135 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */ 4136 { 4137 struct sockaddr_in readfrom; 4138 unsigned short buffer[2]; 4139 4140 i = 1; 4141 do { 4142 #ifdef MSG_DONTWAIT 4143 got = PerlSock_recvfrom(sockets[i], (char *) &buffer, 4144 sizeof(buffer), MSG_DONTWAIT, 4145 (struct sockaddr *) &readfrom, &size); 4146 #else 4147 got = PerlSock_recvfrom(sockets[i], (char *) &buffer, 4148 sizeof(buffer), 0, 4149 (struct sockaddr *) &readfrom, &size); 4150 #endif 4151 4152 if (got == -1) 4153 goto tidy_up_and_fail; 4154 if (got != sizeof(port) 4155 || size != sizeof(struct sockaddr_in) 4156 /* Check other socket sent us its port. */ 4157 || buffer[0] != (unsigned short) addresses[!i].sin_port 4158 /* Check kernel says we got the datagram from that socket */ 4159 || readfrom.sin_family != addresses[!i].sin_family 4160 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr 4161 || readfrom.sin_port != addresses[!i].sin_port) 4162 goto abort_tidy_up_and_fail; 4163 } while (i--); 4164 } 4165 /* My caller (my_socketpair) has validated that this is non-NULL */ 4166 fd[0] = sockets[0]; 4167 fd[1] = sockets[1]; 4168 /* I hereby declare this connection open. May God bless all who cross 4169 her. */ 4170 return 0; 4171 4172 abort_tidy_up_and_fail: 4173 errno = ECONNABORTED; 4174 tidy_up_and_fail: 4175 { 4176 dSAVE_ERRNO; 4177 if (sockets[0] != -1) 4178 PerlLIO_close(sockets[0]); 4179 if (sockets[1] != -1) 4180 PerlLIO_close(sockets[1]); 4181 RESTORE_ERRNO; 4182 return -1; 4183 } 4184 } 4185 #endif /* EMULATE_SOCKETPAIR_UDP */ 4186 4187 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) 4188 int 4189 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { 4190 /* Stevens says that family must be AF_LOCAL, protocol 0. 4191 I'm going to enforce that, then ignore it, and use TCP (or UDP). */ 4192 dTHXa(NULL); 4193 int listener = -1; 4194 int connector = -1; 4195 int acceptor = -1; 4196 struct sockaddr_in listen_addr; 4197 struct sockaddr_in connect_addr; 4198 Sock_size_t size; 4199 4200 if (protocol 4201 #ifdef AF_UNIX 4202 || family != AF_UNIX 4203 #endif 4204 ) { 4205 errno = EAFNOSUPPORT; 4206 return -1; 4207 } 4208 if (!fd) { 4209 errno = EINVAL; 4210 return -1; 4211 } 4212 4213 #ifdef SOCK_CLOEXEC 4214 type &= ~SOCK_CLOEXEC; 4215 #endif 4216 4217 #ifdef EMULATE_SOCKETPAIR_UDP 4218 if (type == SOCK_DGRAM) 4219 return S_socketpair_udp(fd); 4220 #endif 4221 4222 aTHXa(PERL_GET_THX); 4223 listener = PerlSock_socket(AF_INET, type, 0); 4224 if (listener == -1) 4225 return -1; 4226 memset(&listen_addr, 0, sizeof(listen_addr)); 4227 listen_addr.sin_family = AF_INET; 4228 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); 4229 listen_addr.sin_port = 0; /* kernel choses port. */ 4230 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr, 4231 sizeof(listen_addr)) == -1) 4232 goto tidy_up_and_fail; 4233 if (PerlSock_listen(listener, 1) == -1) 4234 goto tidy_up_and_fail; 4235 4236 connector = PerlSock_socket(AF_INET, type, 0); 4237 if (connector == -1) 4238 goto tidy_up_and_fail; 4239 /* We want to find out the port number to connect to. */ 4240 size = sizeof(connect_addr); 4241 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr, 4242 &size) == -1) 4243 goto tidy_up_and_fail; 4244 if (size != sizeof(connect_addr)) 4245 goto abort_tidy_up_and_fail; 4246 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr, 4247 sizeof(connect_addr)) == -1) 4248 goto tidy_up_and_fail; 4249 4250 size = sizeof(listen_addr); 4251 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr, 4252 &size); 4253 if (acceptor == -1) 4254 goto tidy_up_and_fail; 4255 if (size != sizeof(listen_addr)) 4256 goto abort_tidy_up_and_fail; 4257 PerlLIO_close(listener); 4258 /* Now check we are talking to ourself by matching port and host on the 4259 two sockets. */ 4260 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr, 4261 &size) == -1) 4262 goto tidy_up_and_fail; 4263 if (size != sizeof(connect_addr) 4264 || listen_addr.sin_family != connect_addr.sin_family 4265 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr 4266 || listen_addr.sin_port != connect_addr.sin_port) { 4267 goto abort_tidy_up_and_fail; 4268 } 4269 fd[0] = connector; 4270 fd[1] = acceptor; 4271 return 0; 4272 4273 abort_tidy_up_and_fail: 4274 #ifdef ECONNABORTED 4275 errno = ECONNABORTED; /* This would be the standard thing to do. */ 4276 #elif defined(ECONNREFUSED) 4277 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */ 4278 #else 4279 errno = ETIMEDOUT; /* Desperation time. */ 4280 #endif 4281 tidy_up_and_fail: 4282 { 4283 dSAVE_ERRNO; 4284 if (listener != -1) 4285 PerlLIO_close(listener); 4286 if (connector != -1) 4287 PerlLIO_close(connector); 4288 if (acceptor != -1) 4289 PerlLIO_close(acceptor); 4290 RESTORE_ERRNO; 4291 return -1; 4292 } 4293 } 4294 #else 4295 /* In any case have a stub so that there's code corresponding 4296 * to the my_socketpair in embed.fnc. */ 4297 int 4298 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { 4299 #ifdef HAS_SOCKETPAIR 4300 return socketpair(family, type, protocol, fd); 4301 #else 4302 return -1; 4303 #endif 4304 } 4305 #endif 4306 4307 /* 4308 4309 =for apidoc sv_nosharing 4310 4311 Dummy routine which "shares" an SV when there is no sharing module present. 4312 Or "locks" it. Or "unlocks" it. In other 4313 words, ignores its single SV argument. 4314 Exists to avoid test for a C<NULL> function pointer and because it could 4315 potentially warn under some level of strict-ness. 4316 4317 =cut 4318 */ 4319 4320 void 4321 Perl_sv_nosharing(pTHX_ SV *sv) 4322 { 4323 PERL_UNUSED_CONTEXT; 4324 PERL_UNUSED_ARG(sv); 4325 } 4326 4327 /* 4328 4329 =for apidoc sv_destroyable 4330 4331 Dummy routine which reports that object can be destroyed when there is no 4332 sharing module present. It ignores its single SV argument, and returns 4333 'true'. Exists to avoid test for a C<NULL> function pointer and because it 4334 could potentially warn under some level of strict-ness. 4335 4336 =cut 4337 */ 4338 4339 bool 4340 Perl_sv_destroyable(pTHX_ SV *sv) 4341 { 4342 PERL_UNUSED_CONTEXT; 4343 PERL_UNUSED_ARG(sv); 4344 return TRUE; 4345 } 4346 4347 U32 4348 Perl_parse_unicode_opts(pTHX_ const char **popt) 4349 { 4350 const char *p = *popt; 4351 U32 opt = 0; 4352 4353 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS; 4354 4355 if (*p) { 4356 if (isDIGIT(*p)) { 4357 const char* endptr; 4358 UV uv; 4359 if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) { 4360 opt = (U32)uv; 4361 p = endptr; 4362 if (p && *p && *p != '\n' && *p != '\r') { 4363 if (isSPACE(*p)) 4364 goto the_end_of_the_opts_parser; 4365 else 4366 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); 4367 } 4368 } 4369 else { 4370 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p); 4371 } 4372 } 4373 else { 4374 for (; *p; p++) { 4375 switch (*p) { 4376 case PERL_UNICODE_STDIN: 4377 opt |= PERL_UNICODE_STDIN_FLAG; break; 4378 case PERL_UNICODE_STDOUT: 4379 opt |= PERL_UNICODE_STDOUT_FLAG; break; 4380 case PERL_UNICODE_STDERR: 4381 opt |= PERL_UNICODE_STDERR_FLAG; break; 4382 case PERL_UNICODE_STD: 4383 opt |= PERL_UNICODE_STD_FLAG; break; 4384 case PERL_UNICODE_IN: 4385 opt |= PERL_UNICODE_IN_FLAG; break; 4386 case PERL_UNICODE_OUT: 4387 opt |= PERL_UNICODE_OUT_FLAG; break; 4388 case PERL_UNICODE_INOUT: 4389 opt |= PERL_UNICODE_INOUT_FLAG; break; 4390 case PERL_UNICODE_LOCALE: 4391 opt |= PERL_UNICODE_LOCALE_FLAG; break; 4392 case PERL_UNICODE_ARGV: 4393 opt |= PERL_UNICODE_ARGV_FLAG; break; 4394 case PERL_UNICODE_UTF8CACHEASSERT: 4395 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break; 4396 default: 4397 if (*p != '\n' && *p != '\r') { 4398 if(isSPACE(*p)) goto the_end_of_the_opts_parser; 4399 else 4400 Perl_croak(aTHX_ 4401 "Unknown Unicode option letter '%c'", *p); 4402 } 4403 } 4404 } 4405 } 4406 } 4407 else 4408 opt = PERL_UNICODE_DEFAULT_FLAGS; 4409 4410 the_end_of_the_opts_parser: 4411 4412 if (opt & ~PERL_UNICODE_ALL_FLAGS) 4413 Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf, 4414 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); 4415 4416 *popt = p; 4417 4418 return opt; 4419 } 4420 4421 #ifdef VMS 4422 # include <starlet.h> 4423 #endif 4424 4425 U32 4426 Perl_seed(pTHX) 4427 { 4428 #if defined(__OpenBSD__) 4429 return arc4random(); 4430 #else 4431 /* 4432 * This is really just a quick hack which grabs various garbage 4433 * values. It really should be a real hash algorithm which 4434 * spreads the effect of every input bit onto every output bit, 4435 * if someone who knows about such things would bother to write it. 4436 * Might be a good idea to add that function to CORE as well. 4437 * No numbers below come from careful analysis or anything here, 4438 * except they are primes and SEED_C1 > 1E6 to get a full-width 4439 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should 4440 * probably be bigger too. 4441 */ 4442 #if RANDBITS > 16 4443 # define SEED_C1 1000003 4444 #define SEED_C4 73819 4445 #else 4446 # define SEED_C1 25747 4447 #define SEED_C4 20639 4448 #endif 4449 #define SEED_C2 3 4450 #define SEED_C3 269 4451 #define SEED_C5 26107 4452 4453 #ifndef PERL_NO_DEV_RANDOM 4454 int fd; 4455 #endif 4456 U32 u; 4457 #ifdef HAS_GETTIMEOFDAY 4458 struct timeval when; 4459 #else 4460 Time_t when; 4461 #endif 4462 4463 /* This test is an escape hatch, this symbol isn't set by Configure. */ 4464 #ifndef PERL_NO_DEV_RANDOM 4465 #ifndef PERL_RANDOM_DEVICE 4466 /* /dev/random isn't used by default because reads from it will block 4467 * if there isn't enough entropy available. You can compile with 4468 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there 4469 * is enough real entropy to fill the seed. */ 4470 # ifdef __amigaos4__ 4471 # define PERL_RANDOM_DEVICE "RANDOM:SIZE=4" 4472 # else 4473 # define PERL_RANDOM_DEVICE "/dev/urandom" 4474 # endif 4475 #endif 4476 fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0); 4477 if (fd != -1) { 4478 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u) 4479 u = 0; 4480 PerlLIO_close(fd); 4481 if (u) 4482 return u; 4483 } 4484 #endif 4485 4486 #ifdef HAS_GETTIMEOFDAY 4487 PerlProc_gettimeofday(&when,NULL); 4488 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; 4489 #else 4490 (void)time(&when); 4491 u = (U32)SEED_C1 * when; 4492 #endif 4493 u += SEED_C3 * (U32)PerlProc_getpid(); 4494 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); 4495 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ 4496 u += SEED_C5 * (U32)PTR2UV(&when); 4497 #endif 4498 return u; 4499 #endif 4500 } 4501 4502 void 4503 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer) 4504 { 4505 #ifndef NO_PERL_HASH_ENV 4506 const char *env_pv; 4507 #endif 4508 unsigned long i; 4509 4510 PERL_ARGS_ASSERT_GET_HASH_SEED; 4511 4512 #ifndef NO_PERL_HASH_ENV 4513 env_pv= PerlEnv_getenv("PERL_HASH_SEED"); 4514 4515 if ( env_pv ) 4516 { 4517 /* ignore leading spaces */ 4518 while (isSPACE(*env_pv)) 4519 env_pv++; 4520 # ifdef USE_PERL_PERTURB_KEYS 4521 /* if they set it to "0" we disable key traversal randomization completely */ 4522 if (strEQ(env_pv,"0")) { 4523 PL_hash_rand_bits_enabled= 0; 4524 } else { 4525 /* otherwise switch to deterministic mode */ 4526 PL_hash_rand_bits_enabled= 2; 4527 } 4528 # endif 4529 /* ignore a leading 0x... if it is there */ 4530 if (env_pv[0] == '0' && env_pv[1] == 'x') 4531 env_pv += 2; 4532 4533 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) { 4534 seed_buffer[i] = READ_XDIGIT(env_pv) << 4; 4535 if ( isXDIGIT(*env_pv)) { 4536 seed_buffer[i] |= READ_XDIGIT(env_pv); 4537 } 4538 } 4539 while (isSPACE(*env_pv)) 4540 env_pv++; 4541 4542 if (*env_pv && !isXDIGIT(*env_pv)) { 4543 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n"); 4544 } 4545 /* should we check for unparsed crap? */ 4546 /* should we warn about unused hex? */ 4547 /* should we warn about insufficient hex? */ 4548 } 4549 else 4550 #endif /* NO_PERL_HASH_ENV */ 4551 { 4552 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) { 4553 seed_buffer[i] = (unsigned char)(Perl_internal_drand48() * (U8_MAX+1)); 4554 } 4555 } 4556 #ifdef USE_PERL_PERTURB_KEYS 4557 { /* initialize PL_hash_rand_bits from the hash seed. 4558 * This value is highly volatile, it is updated every 4559 * hash insert, and is used as part of hash bucket chain 4560 * randomization and hash iterator randomization. */ 4561 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */ 4562 for( i = 0; i < sizeof(UV) ; i++ ) { 4563 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES]; 4564 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8); 4565 } 4566 } 4567 # ifndef NO_PERL_HASH_ENV 4568 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS"); 4569 if (env_pv) { 4570 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) { 4571 PL_hash_rand_bits_enabled= 0; 4572 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) { 4573 PL_hash_rand_bits_enabled= 1; 4574 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) { 4575 PL_hash_rand_bits_enabled= 2; 4576 } else { 4577 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv); 4578 } 4579 } 4580 # endif 4581 #endif 4582 } 4583 4584 #ifdef PERL_GLOBAL_STRUCT 4585 4586 #define PERL_GLOBAL_STRUCT_INIT 4587 #include "opcode.h" /* the ppaddr and check */ 4588 4589 struct perl_vars * 4590 Perl_init_global_struct(pTHX) 4591 { 4592 struct perl_vars *plvarsp = NULL; 4593 # ifdef PERL_GLOBAL_STRUCT 4594 const IV nppaddr = C_ARRAY_LENGTH(Gppaddr); 4595 const IV ncheck = C_ARRAY_LENGTH(Gcheck); 4596 PERL_UNUSED_CONTEXT; 4597 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4598 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */ 4599 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); 4600 if (!plvarsp) 4601 exit(1); 4602 # else 4603 plvarsp = PL_VarsPtr; 4604 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */ 4605 # undef PERLVAR 4606 # undef PERLVARA 4607 # undef PERLVARI 4608 # undef PERLVARIC 4609 # define PERLVAR(prefix,var,type) /**/ 4610 # define PERLVARA(prefix,var,n,type) /**/ 4611 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init; 4612 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init; 4613 # include "perlvars.h" 4614 # undef PERLVAR 4615 # undef PERLVARA 4616 # undef PERLVARI 4617 # undef PERLVARIC 4618 # ifdef PERL_GLOBAL_STRUCT 4619 plvarsp->Gppaddr = 4620 (Perl_ppaddr_t*) 4621 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); 4622 if (!plvarsp->Gppaddr) 4623 exit(1); 4624 plvarsp->Gcheck = 4625 (Perl_check_t*) 4626 PerlMem_malloc(ncheck * sizeof(Perl_check_t)); 4627 if (!plvarsp->Gcheck) 4628 exit(1); 4629 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 4630 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t); 4631 # endif 4632 # ifdef PERL_SET_VARS 4633 PERL_SET_VARS(plvarsp); 4634 # endif 4635 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4636 plvarsp->Gsv_placeholder.sv_flags = 0; 4637 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed)); 4638 # endif 4639 # undef PERL_GLOBAL_STRUCT_INIT 4640 # endif 4641 return plvarsp; 4642 } 4643 4644 #endif /* PERL_GLOBAL_STRUCT */ 4645 4646 #ifdef PERL_GLOBAL_STRUCT 4647 4648 void 4649 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) 4650 { 4651 int veto = plvarsp->Gveto_cleanup; 4652 4653 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT; 4654 PERL_UNUSED_CONTEXT; 4655 # ifdef PERL_GLOBAL_STRUCT 4656 # ifdef PERL_UNSET_VARS 4657 PERL_UNSET_VARS(plvarsp); 4658 # endif 4659 if (veto) 4660 return; 4661 free(plvarsp->Gppaddr); 4662 free(plvarsp->Gcheck); 4663 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4664 free(plvarsp); 4665 # endif 4666 # endif 4667 } 4668 4669 #endif /* PERL_GLOBAL_STRUCT */ 4670 4671 #ifdef PERL_MEM_LOG 4672 4673 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including 4674 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also 4675 * given, and you supply your own implementation. 4676 * 4677 * The default implementation reads a single env var, PERL_MEM_LOG, 4678 * expecting one or more of the following: 4679 * 4680 * \d+ - fd fd to write to : must be 1st (grok_atoUV) 4681 * 'm' - memlog was PERL_MEM_LOG=1 4682 * 's' - svlog was PERL_SV_LOG=1 4683 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 4684 * 4685 * This makes the logger controllable enough that it can reasonably be 4686 * added to the system perl. 4687 */ 4688 4689 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer 4690 * the Perl_mem_log_...() will use (either via sprintf or snprintf). 4691 */ 4692 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 4693 4694 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...() 4695 * writes to. In the default logger, this is settable at runtime. 4696 */ 4697 #ifndef PERL_MEM_LOG_FD 4698 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */ 4699 #endif 4700 4701 #ifndef PERL_MEM_LOG_NOIMPL 4702 4703 # ifdef DEBUG_LEAKING_SCALARS 4704 # define SV_LOG_SERIAL_FMT " [%lu]" 4705 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial 4706 # else 4707 # define SV_LOG_SERIAL_FMT 4708 # define _SV_LOG_SERIAL_ARG(sv) 4709 # endif 4710 4711 static void 4712 S_mem_log_common(enum mem_log_type mlt, const UV n, 4713 const UV typesize, const char *type_name, const SV *sv, 4714 Malloc_t oldalloc, Malloc_t newalloc, 4715 const char *filename, const int linenumber, 4716 const char *funcname) 4717 { 4718 const char *pmlenv; 4719 4720 PERL_ARGS_ASSERT_MEM_LOG_COMMON; 4721 4722 pmlenv = PerlEnv_getenv("PERL_MEM_LOG"); 4723 if (!pmlenv) 4724 return; 4725 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s')) 4726 { 4727 /* We can't use SVs or PerlIO for obvious reasons, 4728 * so we'll use stdio and low-level IO instead. */ 4729 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; 4730 4731 # ifdef HAS_GETTIMEOFDAY 4732 # define MEM_LOG_TIME_FMT "%10d.%06d: " 4733 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec 4734 struct timeval tv; 4735 gettimeofday(&tv, 0); 4736 # else 4737 # define MEM_LOG_TIME_FMT "%10d: " 4738 # define MEM_LOG_TIME_ARG (int)when 4739 Time_t when; 4740 (void)time(&when); 4741 # endif 4742 /* If there are other OS specific ways of hires time than 4743 * gettimeofday() (see dist/Time-HiRes), the easiest way is 4744 * probably that they would be used to fill in the struct 4745 * timeval. */ 4746 { 4747 STRLEN len; 4748 const char* endptr; 4749 int fd; 4750 UV uv; 4751 if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */ 4752 && uv && uv <= PERL_INT_MAX 4753 ) { 4754 fd = (int)uv; 4755 } else { 4756 fd = PERL_MEM_LOG_FD; 4757 } 4758 4759 if (strchr(pmlenv, 't')) { 4760 len = my_snprintf(buf, sizeof(buf), 4761 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); 4762 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len)); 4763 } 4764 switch (mlt) { 4765 case MLT_ALLOC: 4766 len = my_snprintf(buf, sizeof(buf), 4767 "alloc: %s:%d:%s: %" IVdf " %" UVuf 4768 " %s = %" IVdf ": %" UVxf "\n", 4769 filename, linenumber, funcname, n, typesize, 4770 type_name, n * typesize, PTR2UV(newalloc)); 4771 break; 4772 case MLT_REALLOC: 4773 len = my_snprintf(buf, sizeof(buf), 4774 "realloc: %s:%d:%s: %" IVdf " %" UVuf 4775 " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n", 4776 filename, linenumber, funcname, n, typesize, 4777 type_name, n * typesize, PTR2UV(oldalloc), 4778 PTR2UV(newalloc)); 4779 break; 4780 case MLT_FREE: 4781 len = my_snprintf(buf, sizeof(buf), 4782 "free: %s:%d:%s: %" UVxf "\n", 4783 filename, linenumber, funcname, 4784 PTR2UV(oldalloc)); 4785 break; 4786 case MLT_NEW_SV: 4787 case MLT_DEL_SV: 4788 len = my_snprintf(buf, sizeof(buf), 4789 "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n", 4790 mlt == MLT_NEW_SV ? "new" : "del", 4791 filename, linenumber, funcname, 4792 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv)); 4793 break; 4794 default: 4795 len = 0; 4796 } 4797 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len)); 4798 } 4799 } 4800 } 4801 #endif /* !PERL_MEM_LOG_NOIMPL */ 4802 4803 #ifndef PERL_MEM_LOG_NOIMPL 4804 # define \ 4805 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \ 4806 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) 4807 #else 4808 /* this is suboptimal, but bug compatible. User is providing their 4809 own implementation, but is getting these functions anyway, and they 4810 do nothing. But _NOIMPL users should be able to cope or fix */ 4811 # define \ 4812 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \ 4813 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */ 4814 #endif 4815 4816 Malloc_t 4817 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, 4818 Malloc_t newalloc, 4819 const char *filename, const int linenumber, 4820 const char *funcname) 4821 { 4822 PERL_ARGS_ASSERT_MEM_LOG_ALLOC; 4823 4824 mem_log_common_if(MLT_ALLOC, n, typesize, type_name, 4825 NULL, NULL, newalloc, 4826 filename, linenumber, funcname); 4827 return newalloc; 4828 } 4829 4830 Malloc_t 4831 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, 4832 Malloc_t oldalloc, Malloc_t newalloc, 4833 const char *filename, const int linenumber, 4834 const char *funcname) 4835 { 4836 PERL_ARGS_ASSERT_MEM_LOG_REALLOC; 4837 4838 mem_log_common_if(MLT_REALLOC, n, typesize, type_name, 4839 NULL, oldalloc, newalloc, 4840 filename, linenumber, funcname); 4841 return newalloc; 4842 } 4843 4844 Malloc_t 4845 Perl_mem_log_free(Malloc_t oldalloc, 4846 const char *filename, const int linenumber, 4847 const char *funcname) 4848 { 4849 PERL_ARGS_ASSERT_MEM_LOG_FREE; 4850 4851 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 4852 filename, linenumber, funcname); 4853 return oldalloc; 4854 } 4855 4856 void 4857 Perl_mem_log_new_sv(const SV *sv, 4858 const char *filename, const int linenumber, 4859 const char *funcname) 4860 { 4861 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, 4862 filename, linenumber, funcname); 4863 } 4864 4865 void 4866 Perl_mem_log_del_sv(const SV *sv, 4867 const char *filename, const int linenumber, 4868 const char *funcname) 4869 { 4870 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, 4871 filename, linenumber, funcname); 4872 } 4873 4874 #endif /* PERL_MEM_LOG */ 4875 4876 /* 4877 =for apidoc quadmath_format_single 4878 4879 C<quadmath_snprintf()> is very strict about its C<format> string and will 4880 fail, returning -1, if the format is invalid. It accepts exactly 4881 one format spec. 4882 4883 C<quadmath_format_single()> checks that the intended single spec looks 4884 sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>, 4885 and has C<Q> before it. This is not a full "printf syntax check", 4886 just the basics. 4887 4888 Returns the format if it is valid, NULL if not. 4889 4890 C<quadmath_format_single()> can and will actually patch in the missing 4891 C<Q>, if necessary. In this case it will return the modified copy of 4892 the format, B<which the caller will need to free.> 4893 4894 See also L</quadmath_format_needed>. 4895 4896 =cut 4897 */ 4898 #ifdef USE_QUADMATH 4899 const char* 4900 Perl_quadmath_format_single(const char* format) 4901 { 4902 STRLEN len; 4903 4904 PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE; 4905 4906 if (format[0] != '%' || strchr(format + 1, '%')) 4907 return NULL; 4908 len = strlen(format); 4909 /* minimum length three: %Qg */ 4910 if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL) 4911 return NULL; 4912 if (format[len - 2] != 'Q') { 4913 char* fixed; 4914 Newx(fixed, len + 1, char); 4915 memcpy(fixed, format, len - 1); 4916 fixed[len - 1] = 'Q'; 4917 fixed[len ] = format[len - 1]; 4918 fixed[len + 1] = 0; 4919 return (const char*)fixed; 4920 } 4921 return format; 4922 } 4923 #endif 4924 4925 /* 4926 =for apidoc quadmath_format_needed 4927 4928 C<quadmath_format_needed()> returns true if the C<format> string seems to 4929 contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier, 4930 or returns false otherwise. 4931 4932 The format specifier detection is not complete printf-syntax detection, 4933 but it should catch most common cases. 4934 4935 If true is returned, those arguments B<should> in theory be processed 4936 with C<quadmath_snprintf()>, but in case there is more than one such 4937 format specifier (see L</quadmath_format_single>), and if there is 4938 anything else beyond that one (even just a single byte), they 4939 B<cannot> be processed because C<quadmath_snprintf()> is very strict, 4940 accepting only one format spec, and nothing else. 4941 In this case, the code should probably fail. 4942 4943 =cut 4944 */ 4945 #ifdef USE_QUADMATH 4946 bool 4947 Perl_quadmath_format_needed(const char* format) 4948 { 4949 const char *p = format; 4950 const char *q; 4951 4952 PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED; 4953 4954 while ((q = strchr(p, '%'))) { 4955 q++; 4956 if (*q == '+') /* plus */ 4957 q++; 4958 if (*q == '#') /* alt */ 4959 q++; 4960 if (*q == '*') /* width */ 4961 q++; 4962 else { 4963 if (isDIGIT(*q)) { 4964 while (isDIGIT(*q)) q++; 4965 } 4966 } 4967 if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */ 4968 q++; 4969 if (*q == '*') 4970 q++; 4971 else 4972 while (isDIGIT(*q)) q++; 4973 } 4974 if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */ 4975 return TRUE; 4976 p = q + 1; 4977 } 4978 return FALSE; 4979 } 4980 #endif 4981 4982 /* 4983 =for apidoc my_snprintf 4984 4985 The C library C<snprintf> functionality, if available and 4986 standards-compliant (uses C<vsnprintf>, actually). However, if the 4987 C<vsnprintf> is not available, will unfortunately use the unsafe 4988 C<vsprintf> which can overrun the buffer (there is an overrun check, 4989 but that may be too late). Consider using C<sv_vcatpvf> instead, or 4990 getting C<vsnprintf>. 4991 4992 =cut 4993 */ 4994 int 4995 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) 4996 { 4997 int retval = -1; 4998 va_list ap; 4999 PERL_ARGS_ASSERT_MY_SNPRINTF; 5000 #ifndef HAS_VSNPRINTF 5001 PERL_UNUSED_VAR(len); 5002 #endif 5003 va_start(ap, format); 5004 #ifdef USE_QUADMATH 5005 { 5006 const char* qfmt = quadmath_format_single(format); 5007 bool quadmath_valid = FALSE; 5008 if (qfmt) { 5009 /* If the format looked promising, use it as quadmath. */ 5010 retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV)); 5011 if (retval == -1) { 5012 if (qfmt != format) { 5013 dTHX; 5014 SAVEFREEPV(qfmt); 5015 } 5016 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt); 5017 } 5018 quadmath_valid = TRUE; 5019 if (qfmt != format) 5020 Safefree(qfmt); 5021 qfmt = NULL; 5022 } 5023 assert(qfmt == NULL); 5024 /* quadmath_format_single() will return false for example for 5025 * "foo = %g", or simply "%g". We could handle the %g by 5026 * using quadmath for the NV args. More complex cases of 5027 * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise 5028 * quadmath-valid but has stuff in front). 5029 * 5030 * Handling the "Q-less" cases right would require walking 5031 * through the va_list and rewriting the format, calling 5032 * quadmath for the NVs, building a new va_list, and then 5033 * letting vsnprintf/vsprintf to take care of the other 5034 * arguments. This may be doable. 5035 * 5036 * We do not attempt that now. But for paranoia, we here try 5037 * to detect some common (but not all) cases where the 5038 * "Q-less" %[efgaEFGA] formats are present, and die if 5039 * detected. This doesn't fix the problem, but it stops the 5040 * vsnprintf/vsprintf pulling doubles off the va_list when 5041 * __float128 NVs should be pulled off instead. 5042 * 5043 * If quadmath_format_needed() returns false, we are reasonably 5044 * certain that we can call vnsprintf() or vsprintf() safely. */ 5045 if (!quadmath_valid && quadmath_format_needed(format)) 5046 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format); 5047 5048 } 5049 #endif 5050 if (retval == -1) 5051 #ifdef HAS_VSNPRINTF 5052 retval = vsnprintf(buffer, len, format, ap); 5053 #else 5054 retval = vsprintf(buffer, format, ap); 5055 #endif 5056 va_end(ap); 5057 /* vsprintf() shows failure with < 0 */ 5058 if (retval < 0 5059 #ifdef HAS_VSNPRINTF 5060 /* vsnprintf() shows failure with >= len */ 5061 || 5062 (len > 0 && (Size_t)retval >= len) 5063 #endif 5064 ) 5065 Perl_croak_nocontext("panic: my_snprintf buffer overflow"); 5066 return retval; 5067 } 5068 5069 /* 5070 =for apidoc my_vsnprintf 5071 5072 The C library C<vsnprintf> if available and standards-compliant. 5073 However, if if the C<vsnprintf> is not available, will unfortunately 5074 use the unsafe C<vsprintf> which can overrun the buffer (there is an 5075 overrun check, but that may be too late). Consider using 5076 C<sv_vcatpvf> instead, or getting C<vsnprintf>. 5077 5078 =cut 5079 */ 5080 int 5081 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) 5082 { 5083 #ifdef USE_QUADMATH 5084 PERL_UNUSED_ARG(buffer); 5085 PERL_UNUSED_ARG(len); 5086 PERL_UNUSED_ARG(format); 5087 /* the cast is to avoid gcc -Wsizeof-array-argument complaining */ 5088 PERL_UNUSED_ARG((void*)ap); 5089 Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath"); 5090 return 0; 5091 #else 5092 int retval; 5093 #ifdef NEED_VA_COPY 5094 va_list apc; 5095 5096 PERL_ARGS_ASSERT_MY_VSNPRINTF; 5097 Perl_va_copy(ap, apc); 5098 # ifdef HAS_VSNPRINTF 5099 retval = vsnprintf(buffer, len, format, apc); 5100 # else 5101 PERL_UNUSED_ARG(len); 5102 retval = vsprintf(buffer, format, apc); 5103 # endif 5104 va_end(apc); 5105 #else 5106 # ifdef HAS_VSNPRINTF 5107 retval = vsnprintf(buffer, len, format, ap); 5108 # else 5109 PERL_UNUSED_ARG(len); 5110 retval = vsprintf(buffer, format, ap); 5111 # endif 5112 #endif /* #ifdef NEED_VA_COPY */ 5113 /* vsprintf() shows failure with < 0 */ 5114 if (retval < 0 5115 #ifdef HAS_VSNPRINTF 5116 /* vsnprintf() shows failure with >= len */ 5117 || 5118 (len > 0 && (Size_t)retval >= len) 5119 #endif 5120 ) 5121 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); 5122 return retval; 5123 #endif 5124 } 5125 5126 void 5127 Perl_my_clearenv(pTHX) 5128 { 5129 dVAR; 5130 #if ! defined(PERL_MICRO) 5131 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32) 5132 PerlEnv_clearenv(); 5133 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */ 5134 # if defined(USE_ENVIRON_ARRAY) 5135 # if defined(USE_ITHREADS) 5136 /* only the parent thread can clobber the process environment */ 5137 if (PL_curinterp == aTHX) 5138 # endif /* USE_ITHREADS */ 5139 { 5140 # if ! defined(PERL_USE_SAFE_PUTENV) 5141 if ( !PL_use_safe_putenv) { 5142 I32 i; 5143 if (environ == PL_origenviron) 5144 environ = (char**)safesysmalloc(sizeof(char*)); 5145 else 5146 for (i = 0; environ[i]; i++) 5147 (void)safesysfree(environ[i]); 5148 } 5149 environ[0] = NULL; 5150 # else /* PERL_USE_SAFE_PUTENV */ 5151 # if defined(HAS_CLEARENV) 5152 (void)clearenv(); 5153 # elif defined(HAS_UNSETENV) 5154 int bsiz = 80; /* Most envvar names will be shorter than this. */ 5155 char *buf = (char*)safesysmalloc(bsiz); 5156 while (*environ != NULL) { 5157 char *e = strchr(*environ, '='); 5158 int l = e ? e - *environ : (int)strlen(*environ); 5159 if (bsiz < l + 1) { 5160 (void)safesysfree(buf); 5161 bsiz = l + 1; /* + 1 for the \0. */ 5162 buf = (char*)safesysmalloc(bsiz); 5163 } 5164 memcpy(buf, *environ, l); 5165 buf[l] = '\0'; 5166 (void)unsetenv(buf); 5167 } 5168 (void)safesysfree(buf); 5169 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */ 5170 /* Just null environ and accept the leakage. */ 5171 *environ = NULL; 5172 # endif /* HAS_CLEARENV || HAS_UNSETENV */ 5173 # endif /* ! PERL_USE_SAFE_PUTENV */ 5174 } 5175 # endif /* USE_ENVIRON_ARRAY */ 5176 # endif /* PERL_IMPLICIT_SYS || WIN32 */ 5177 #endif /* PERL_MICRO */ 5178 } 5179 5180 #ifdef PERL_IMPLICIT_CONTEXT 5181 5182 /* Implements the MY_CXT_INIT macro. The first time a module is loaded, 5183 the global PL_my_cxt_index is incremented, and that value is assigned to 5184 that module's static my_cxt_index (who's address is passed as an arg). 5185 Then, for each interpreter this function is called for, it makes sure a 5186 void* slot is available to hang the static data off, by allocating or 5187 extending the interpreter's PL_my_cxt_list array */ 5188 5189 #ifndef PERL_GLOBAL_STRUCT_PRIVATE 5190 void * 5191 Perl_my_cxt_init(pTHX_ int *index, size_t size) 5192 { 5193 dVAR; 5194 void *p; 5195 PERL_ARGS_ASSERT_MY_CXT_INIT; 5196 if (*index == -1) { 5197 /* this module hasn't been allocated an index yet */ 5198 MUTEX_LOCK(&PL_my_ctx_mutex); 5199 *index = PL_my_cxt_index++; 5200 MUTEX_UNLOCK(&PL_my_ctx_mutex); 5201 } 5202 5203 /* make sure the array is big enough */ 5204 if (PL_my_cxt_size <= *index) { 5205 if (PL_my_cxt_size) { 5206 IV new_size = PL_my_cxt_size; 5207 while (new_size <= *index) 5208 new_size *= 2; 5209 Renew(PL_my_cxt_list, new_size, void *); 5210 PL_my_cxt_size = new_size; 5211 } 5212 else { 5213 PL_my_cxt_size = 16; 5214 Newx(PL_my_cxt_list, PL_my_cxt_size, void *); 5215 } 5216 } 5217 /* newSV() allocates one more than needed */ 5218 p = (void*)SvPVX(newSV(size-1)); 5219 PL_my_cxt_list[*index] = p; 5220 Zero(p, size, char); 5221 return p; 5222 } 5223 5224 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ 5225 5226 int 5227 Perl_my_cxt_index(pTHX_ const char *my_cxt_key) 5228 { 5229 dVAR; 5230 int index; 5231 5232 PERL_ARGS_ASSERT_MY_CXT_INDEX; 5233 5234 for (index = 0; index < PL_my_cxt_index; index++) { 5235 const char *key = PL_my_cxt_keys[index]; 5236 /* try direct pointer compare first - there are chances to success, 5237 * and it's much faster. 5238 */ 5239 if ((key == my_cxt_key) || strEQ(key, my_cxt_key)) 5240 return index; 5241 } 5242 return -1; 5243 } 5244 5245 void * 5246 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) 5247 { 5248 dVAR; 5249 void *p; 5250 int index; 5251 5252 PERL_ARGS_ASSERT_MY_CXT_INIT; 5253 5254 index = Perl_my_cxt_index(aTHX_ my_cxt_key); 5255 if (index == -1) { 5256 /* this module hasn't been allocated an index yet */ 5257 MUTEX_LOCK(&PL_my_ctx_mutex); 5258 index = PL_my_cxt_index++; 5259 MUTEX_UNLOCK(&PL_my_ctx_mutex); 5260 } 5261 5262 /* make sure the array is big enough */ 5263 if (PL_my_cxt_size <= index) { 5264 int old_size = PL_my_cxt_size; 5265 int i; 5266 if (PL_my_cxt_size) { 5267 IV new_size = PL_my_cxt_size; 5268 while (new_size <= index) 5269 new_size *= 2; 5270 Renew(PL_my_cxt_list, new_size, void *); 5271 Renew(PL_my_cxt_keys, new_size, const char *); 5272 PL_my_cxt_size = new_size; 5273 } 5274 else { 5275 PL_my_cxt_size = 16; 5276 Newx(PL_my_cxt_list, PL_my_cxt_size, void *); 5277 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); 5278 } 5279 for (i = old_size; i < PL_my_cxt_size; i++) { 5280 PL_my_cxt_keys[i] = 0; 5281 PL_my_cxt_list[i] = 0; 5282 } 5283 } 5284 PL_my_cxt_keys[index] = my_cxt_key; 5285 /* newSV() allocates one more than needed */ 5286 p = (void*)SvPVX(newSV(size-1)); 5287 PL_my_cxt_list[index] = p; 5288 Zero(p, size, char); 5289 return p; 5290 } 5291 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ 5292 #endif /* PERL_IMPLICIT_CONTEXT */ 5293 5294 5295 /* Perl_xs_handshake(): 5296 implement the various XS_*_BOOTCHECK macros, which are added to .c 5297 files by ExtUtils::ParseXS, to check that the perl the module was built 5298 with is binary compatible with the running perl. 5299 5300 usage: 5301 Perl_xs_handshake(U32 key, void * v_my_perl, const char * file, 5302 [U32 items, U32 ax], [char * api_version], [char * xs_version]) 5303 5304 The meaning of the varargs is determined the U32 key arg (which is not 5305 a format string). The fields of key are assembled by using HS_KEY(). 5306 5307 Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type 5308 "PerlInterpreter *" and represents the callers context; otherwise it is 5309 of type "CV *", and is the boot xsub's CV. 5310 5311 v_my_perl will catch where a threaded future perl526.dll calling IO.dll 5312 for example, and IO.dll was linked with threaded perl524.dll, and both 5313 perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader 5314 successfully can load IO.dll into the process but simultaneously it 5315 loaded an interpreter of a different version into the process, and XS 5316 code will naturally pass SV*s created by perl524.dll for perl526.dll to 5317 use through perl526.dll's my_perl->Istack_base. 5318 5319 v_my_perl cannot be the first arg, since then 'key' will be out of 5320 place in a threaded vs non-threaded mixup; and analyzing the key 5321 number's bitfields won't reveal the problem, since it will be a valid 5322 key (unthreaded perl) on interp side, but croak will report the XS mod's 5323 key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if 5324 it's a threaded perl and an unthreaded XS module, threaded perl will 5325 look at an uninit C stack or an uninit register to get 'key' 5326 (remember that it assumes that the 1st arg is the interp cxt). 5327 5328 'file' is the source filename of the caller. 5329 */ 5330 5331 I32 5332 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) 5333 { 5334 va_list args; 5335 U32 items, ax; 5336 void * got; 5337 void * need; 5338 #ifdef PERL_IMPLICIT_CONTEXT 5339 dTHX; 5340 tTHX xs_interp; 5341 #else 5342 CV* cv; 5343 SV *** xs_spp; 5344 #endif 5345 PERL_ARGS_ASSERT_XS_HANDSHAKE; 5346 va_start(args, file); 5347 5348 got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH)); 5349 need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH); 5350 if (UNLIKELY(got != need)) 5351 goto bad_handshake; 5352 /* try to catch where a 2nd threaded perl interp DLL is loaded into a process 5353 by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the 5354 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so 5355 dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub 5356 passed to the XS DLL */ 5357 #ifdef PERL_IMPLICIT_CONTEXT 5358 xs_interp = (tTHX)v_my_perl; 5359 got = xs_interp; 5360 need = my_perl; 5361 #else 5362 /* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is 5363 loaded into a process by a XS DLL built by an unthreaded perl522.dll perl, 5364 but the DynaLoder/Perl that started the process and loaded the XS DLL is 5365 unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *) 5366 through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's 5367 location in the unthreaded perl binary) stored in CV * to figure out if this 5368 Perl_xs_handshake was called by the same pp_entersub */ 5369 cv = (CV*)v_my_perl; 5370 xs_spp = (SV***)CvHSCXT(cv); 5371 got = xs_spp; 5372 need = &PL_stack_sp; 5373 #endif 5374 if(UNLIKELY(got != need)) { 5375 bad_handshake:/* recycle branch and string from above */ 5376 if(got != (void *)HSf_NOCHK) 5377 noperl_die("%s: loadable library and perl binaries are mismatched" 5378 " (got handshake key %p, needed %p)\n", 5379 file, got, need); 5380 } 5381 5382 if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */ 5383 SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */ 5384 PL_xsubfilename = file; /* so the old name must be restored for 5385 additional XSUBs to register themselves */ 5386 /* XSUBs can't be perl lang/perl5db.pl debugged 5387 if (PERLDB_LINE_OR_SAVESRC) 5388 (void)gv_fetchfile(file); */ 5389 } 5390 5391 if(key & HSf_POPMARK) { 5392 ax = POPMARK; 5393 { SV **mark = PL_stack_base + ax++; 5394 { dSP; 5395 items = (I32)(SP - MARK); 5396 } 5397 } 5398 } else { 5399 items = va_arg(args, U32); 5400 ax = va_arg(args, U32); 5401 } 5402 { 5403 U32 apiverlen; 5404 assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX); 5405 if((apiverlen = HS_GETAPIVERLEN(key))) { 5406 char * api_p = va_arg(args, char*); 5407 if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1 5408 || memNE(api_p, "v" PERL_API_VERSION_STRING, 5409 sizeof("v" PERL_API_VERSION_STRING)-1)) 5410 Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s", 5411 api_p, SVfARG(PL_stack_base[ax + 0]), 5412 "v" PERL_API_VERSION_STRING); 5413 } 5414 } 5415 { 5416 U32 xsverlen; 5417 assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX); 5418 if((xsverlen = HS_GETXSVERLEN(key))) 5419 S_xs_version_bootcheck(aTHX_ 5420 items, ax, va_arg(args, char*), xsverlen); 5421 } 5422 va_end(args); 5423 return ax; 5424 } 5425 5426 5427 STATIC void 5428 S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, 5429 STRLEN xs_len) 5430 { 5431 SV *sv; 5432 const char *vn = NULL; 5433 SV *const module = PL_stack_base[ax]; 5434 5435 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK; 5436 5437 if (items >= 2) /* version supplied as bootstrap arg */ 5438 sv = PL_stack_base[ax + 1]; 5439 else { 5440 /* XXX GV_ADDWARN */ 5441 vn = "XS_VERSION"; 5442 sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0); 5443 if (!sv || !SvOK(sv)) { 5444 vn = "VERSION"; 5445 sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0); 5446 } 5447 } 5448 if (sv) { 5449 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP); 5450 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version") 5451 ? sv : sv_2mortal(new_version(sv)); 5452 xssv = upg_version(xssv, 0); 5453 if ( vcmp(pmsv,xssv) ) { 5454 SV *string = vstringify(xssv); 5455 SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf 5456 " does not match ", SVfARG(module), SVfARG(string)); 5457 5458 SvREFCNT_dec(string); 5459 string = vstringify(pmsv); 5460 5461 if (vn) { 5462 Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn, 5463 SVfARG(string)); 5464 } else { 5465 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string)); 5466 } 5467 SvREFCNT_dec(string); 5468 5469 Perl_sv_2mortal(aTHX_ xpt); 5470 Perl_croak_sv(aTHX_ xpt); 5471 } 5472 } 5473 } 5474 5475 /* 5476 =for apidoc my_strlcat 5477 5478 The C library C<strlcat> if available, or a Perl implementation of it. 5479 This operates on C C<NUL>-terminated strings. 5480 5481 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at 5482 most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate, 5483 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in 5484 practice this should not happen as it means that either C<size> is incorrect or 5485 that C<dst> is not a proper C<NUL>-terminated string). 5486 5487 Note that C<size> is the full size of the destination buffer and 5488 the result is guaranteed to be C<NUL>-terminated if there is room. Note that 5489 room for the C<NUL> should be included in C<size>. 5490 5491 The return value is the total length that C<dst> would have if C<size> is 5492 sufficiently large. Thus it is the initial length of C<dst> plus the length of 5493 C<src>. If C<size> is smaller than the return, the excess was not appended. 5494 5495 =cut 5496 5497 Description stolen from http://man.openbsd.org/strlcat.3 5498 */ 5499 #ifndef HAS_STRLCAT 5500 Size_t 5501 Perl_my_strlcat(char *dst, const char *src, Size_t size) 5502 { 5503 Size_t used, length, copy; 5504 5505 used = strlen(dst); 5506 length = strlen(src); 5507 if (size > 0 && used < size - 1) { 5508 copy = (length >= size - used) ? size - used - 1 : length; 5509 memcpy(dst + used, src, copy); 5510 dst[used + copy] = '\0'; 5511 } 5512 return used + length; 5513 } 5514 #endif 5515 5516 5517 /* 5518 =for apidoc my_strlcpy 5519 5520 The C library C<strlcpy> if available, or a Perl implementation of it. 5521 This operates on C C<NUL>-terminated strings. 5522 5523 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src> 5524 to C<dst>, C<NUL>-terminating the result if C<size> is not 0. 5525 5526 The return value is the total length C<src> would be if the copy completely 5527 succeeded. If it is larger than C<size>, the excess was not copied. 5528 5529 =cut 5530 5531 Description stolen from http://man.openbsd.org/strlcpy.3 5532 */ 5533 #ifndef HAS_STRLCPY 5534 Size_t 5535 Perl_my_strlcpy(char *dst, const char *src, Size_t size) 5536 { 5537 Size_t length, copy; 5538 5539 length = strlen(src); 5540 if (size > 0) { 5541 copy = (length >= size) ? size - 1 : length; 5542 memcpy(dst, src, copy); 5543 dst[copy] = '\0'; 5544 } 5545 return length; 5546 } 5547 #endif 5548 5549 /* 5550 =for apidoc my_strnlen 5551 5552 The C library C<strnlen> if available, or a Perl implementation of it. 5553 5554 C<my_strnlen()> computes the length of the string, up to C<maxlen> 5555 characters. It will will never attempt to address more than C<maxlen> 5556 characters, making it suitable for use with strings that are not 5557 guaranteed to be NUL-terminated. 5558 5559 =cut 5560 5561 Description stolen from http://man.openbsd.org/strnlen.3, 5562 implementation stolen from PostgreSQL. 5563 */ 5564 #ifndef HAS_STRNLEN 5565 Size_t 5566 Perl_my_strnlen(const char *str, Size_t maxlen) 5567 { 5568 const char *p = str; 5569 5570 PERL_ARGS_ASSERT_MY_STRNLEN; 5571 5572 while(maxlen-- && *p) 5573 p++; 5574 5575 return p - str; 5576 } 5577 #endif 5578 5579 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500) 5580 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */ 5581 long _ftol( double ); /* Defined by VC6 C libs. */ 5582 long _ftol2( double dblSource ) { return _ftol( dblSource ); } 5583 #endif 5584 5585 PERL_STATIC_INLINE bool 5586 S_gv_has_usable_name(pTHX_ GV *gv) 5587 { 5588 GV **gvp; 5589 return GvSTASH(gv) 5590 && HvENAME(GvSTASH(gv)) 5591 && (gvp = (GV **)hv_fetchhek( 5592 GvSTASH(gv), GvNAME_HEK(gv), 0 5593 )) 5594 && *gvp == gv; 5595 } 5596 5597 void 5598 Perl_get_db_sub(pTHX_ SV **svp, CV *cv) 5599 { 5600 SV * const dbsv = GvSVn(PL_DBsub); 5601 const bool save_taint = TAINT_get; 5602 5603 /* When we are called from pp_goto (svp is null), 5604 * we do not care about using dbsv to call CV; 5605 * it's for informational purposes only. 5606 */ 5607 5608 PERL_ARGS_ASSERT_GET_DB_SUB; 5609 5610 TAINT_set(FALSE); 5611 save_item(dbsv); 5612 if (!PERLDB_SUB_NN) { 5613 GV *gv = CvGV(cv); 5614 5615 if (!svp && !CvLEXICAL(cv)) { 5616 gv_efullname3(dbsv, gv, NULL); 5617 } 5618 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv) 5619 || strEQ(GvNAME(gv), "END") 5620 || ( /* Could be imported, and old sub redefined. */ 5621 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) 5622 && 5623 !( (SvTYPE(*svp) == SVt_PVGV) 5624 && (GvCV((const GV *)*svp) == cv) 5625 /* Use GV from the stack as a fallback. */ 5626 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) 5627 ) 5628 ) 5629 ) { 5630 /* GV is potentially non-unique, or contain different CV. */ 5631 SV * const tmp = newRV(MUTABLE_SV(cv)); 5632 sv_setsv(dbsv, tmp); 5633 SvREFCNT_dec(tmp); 5634 } 5635 else { 5636 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); 5637 sv_catpvs(dbsv, "::"); 5638 sv_cathek(dbsv, GvNAME_HEK(gv)); 5639 } 5640 } 5641 else { 5642 const int type = SvTYPE(dbsv); 5643 if (type < SVt_PVIV && type != SVt_IV) 5644 sv_upgrade(dbsv, SVt_PVIV); 5645 (void)SvIOK_on(dbsv); 5646 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ 5647 } 5648 SvSETMAGIC(dbsv); 5649 TAINT_IF(save_taint); 5650 #ifdef NO_TAINT_SUPPORT 5651 PERL_UNUSED_VAR(save_taint); 5652 #endif 5653 } 5654 5655 int 5656 Perl_my_dirfd(DIR * dir) { 5657 5658 /* Most dirfd implementations have problems when passed NULL. */ 5659 if(!dir) 5660 return -1; 5661 #ifdef HAS_DIRFD 5662 return dirfd(dir); 5663 #elif defined(HAS_DIR_DD_FD) 5664 return dir->dd_fd; 5665 #else 5666 Perl_croak_nocontext(PL_no_func, "dirfd"); 5667 NOT_REACHED; /* NOTREACHED */ 5668 return 0; 5669 #endif 5670 } 5671 5672 #if !defined(HAS_MKOSTEMP) || !defined(HAS_MKSTEMP) 5673 5674 #define TEMP_FILE_CH "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvxyz0123456789" 5675 #define TEMP_FILE_CH_COUNT (sizeof(TEMP_FILE_CH)-1) 5676 5677 static int 5678 S_my_mkostemp(char *templte, int flags) { 5679 dTHX; 5680 STRLEN len = strlen(templte); 5681 int fd; 5682 int attempts = 0; 5683 5684 if (len < 6 || 5685 templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' || 5686 templte[len-4] != 'X' || templte[len-5] != 'X' || templte[len-6] != 'X') { 5687 SETERRNO(EINVAL, LIB_INVARG); 5688 return -1; 5689 } 5690 5691 do { 5692 int i; 5693 for (i = 1; i <= 6; ++i) { 5694 templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)]; 5695 } 5696 fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600); 5697 } while (fd == -1 && errno == EEXIST && ++attempts <= 100); 5698 5699 return fd; 5700 } 5701 5702 #endif 5703 5704 #ifndef HAS_MKOSTEMP 5705 int 5706 Perl_my_mkostemp(char *templte, int flags) 5707 { 5708 PERL_ARGS_ASSERT_MY_MKOSTEMP; 5709 return S_my_mkostemp(templte, flags); 5710 } 5711 #endif 5712 5713 #ifndef HAS_MKSTEMP 5714 int 5715 Perl_my_mkstemp(char *templte) 5716 { 5717 PERL_ARGS_ASSERT_MY_MKSTEMP; 5718 return S_my_mkostemp(templte, 0); 5719 } 5720 #endif 5721 5722 REGEXP * 5723 Perl_get_re_arg(pTHX_ SV *sv) { 5724 5725 if (sv) { 5726 if (SvMAGICAL(sv)) 5727 mg_get(sv); 5728 if (SvROK(sv)) 5729 sv = MUTABLE_SV(SvRV(sv)); 5730 if (SvTYPE(sv) == SVt_REGEXP) 5731 return (REGEXP*) sv; 5732 } 5733 5734 return NULL; 5735 } 5736 5737 /* 5738 * This code is derived from drand48() implementation from FreeBSD, 5739 * found in lib/libc/gen/_rand48.c. 5740 * 5741 * The U64 implementation is original, based on the POSIX 5742 * specification for drand48(). 5743 */ 5744 5745 /* 5746 * Copyright (c) 1993 Martin Birgmeier 5747 * All rights reserved. 5748 * 5749 * You may redistribute unmodified or modified versions of this source 5750 * code provided that the above copyright notice and this and the 5751 * following conditions are retained. 5752 * 5753 * This software is provided ``as is'', and comes with no warranties 5754 * of any kind. I shall in no event be liable for anything that happens 5755 * to anyone/anything when using this software. 5756 */ 5757 5758 #define FREEBSD_DRAND48_SEED_0 (0x330e) 5759 5760 #ifdef PERL_DRAND48_QUAD 5761 5762 #define DRAND48_MULT UINT64_C(0x5deece66d) 5763 #define DRAND48_ADD 0xb 5764 #define DRAND48_MASK UINT64_C(0xffffffffffff) 5765 5766 #else 5767 5768 #define FREEBSD_DRAND48_SEED_1 (0xabcd) 5769 #define FREEBSD_DRAND48_SEED_2 (0x1234) 5770 #define FREEBSD_DRAND48_MULT_0 (0xe66d) 5771 #define FREEBSD_DRAND48_MULT_1 (0xdeec) 5772 #define FREEBSD_DRAND48_MULT_2 (0x0005) 5773 #define FREEBSD_DRAND48_ADD (0x000b) 5774 5775 const unsigned short _rand48_mult[3] = { 5776 FREEBSD_DRAND48_MULT_0, 5777 FREEBSD_DRAND48_MULT_1, 5778 FREEBSD_DRAND48_MULT_2 5779 }; 5780 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD; 5781 5782 #endif 5783 5784 void 5785 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed) 5786 { 5787 PERL_ARGS_ASSERT_DRAND48_INIT_R; 5788 5789 #ifdef PERL_DRAND48_QUAD 5790 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16); 5791 #else 5792 random_state->seed[0] = FREEBSD_DRAND48_SEED_0; 5793 random_state->seed[1] = (U16) seed; 5794 random_state->seed[2] = (U16) (seed >> 16); 5795 #endif 5796 } 5797 5798 double 5799 Perl_drand48_r(perl_drand48_t *random_state) 5800 { 5801 PERL_ARGS_ASSERT_DRAND48_R; 5802 5803 #ifdef PERL_DRAND48_QUAD 5804 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD) 5805 & DRAND48_MASK; 5806 5807 return ldexp((double)*random_state, -48); 5808 #else 5809 { 5810 U32 accu; 5811 U16 temp[2]; 5812 5813 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0] 5814 + (U32) _rand48_add; 5815 temp[0] = (U16) accu; /* lower 16 bits */ 5816 accu >>= sizeof(U16) * 8; 5817 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1] 5818 + (U32) _rand48_mult[1] * (U32) random_state->seed[0]; 5819 temp[1] = (U16) accu; /* middle 16 bits */ 5820 accu >>= sizeof(U16) * 8; 5821 accu += _rand48_mult[0] * random_state->seed[2] 5822 + _rand48_mult[1] * random_state->seed[1] 5823 + _rand48_mult[2] * random_state->seed[0]; 5824 random_state->seed[0] = temp[0]; 5825 random_state->seed[1] = temp[1]; 5826 random_state->seed[2] = (U16) accu; 5827 5828 return ldexp((double) random_state->seed[0], -48) + 5829 ldexp((double) random_state->seed[1], -32) + 5830 ldexp((double) random_state->seed[2], -16); 5831 } 5832 #endif 5833 } 5834 5835 #ifdef USE_C_BACKTRACE 5836 5837 /* Possibly move all this USE_C_BACKTRACE code into a new file. */ 5838 5839 #ifdef USE_BFD 5840 5841 typedef struct { 5842 /* abfd is the BFD handle. */ 5843 bfd* abfd; 5844 /* bfd_syms is the BFD symbol table. */ 5845 asymbol** bfd_syms; 5846 /* bfd_text is handle to the the ".text" section of the object file. */ 5847 asection* bfd_text; 5848 /* Since opening the executable and scanning its symbols is quite 5849 * heavy operation, we remember the filename we used the last time, 5850 * and do the opening and scanning only if the filename changes. 5851 * This removes most (but not all) open+scan cycles. */ 5852 const char* fname_prev; 5853 } bfd_context; 5854 5855 /* Given a dl_info, update the BFD context if necessary. */ 5856 static void bfd_update(bfd_context* ctx, Dl_info* dl_info) 5857 { 5858 /* BFD open and scan only if the filename changed. */ 5859 if (ctx->fname_prev == NULL || 5860 strNE(dl_info->dli_fname, ctx->fname_prev)) { 5861 if (ctx->abfd) { 5862 bfd_close(ctx->abfd); 5863 } 5864 ctx->abfd = bfd_openr(dl_info->dli_fname, 0); 5865 if (ctx->abfd) { 5866 if (bfd_check_format(ctx->abfd, bfd_object)) { 5867 IV symbol_size = bfd_get_symtab_upper_bound(ctx->abfd); 5868 if (symbol_size > 0) { 5869 Safefree(ctx->bfd_syms); 5870 Newx(ctx->bfd_syms, symbol_size, asymbol*); 5871 ctx->bfd_text = 5872 bfd_get_section_by_name(ctx->abfd, ".text"); 5873 } 5874 else 5875 ctx->abfd = NULL; 5876 } 5877 else 5878 ctx->abfd = NULL; 5879 } 5880 ctx->fname_prev = dl_info->dli_fname; 5881 } 5882 } 5883 5884 /* Given a raw frame, try to symbolize it and store 5885 * symbol information (source file, line number) away. */ 5886 static void bfd_symbolize(bfd_context* ctx, 5887 void* raw_frame, 5888 char** symbol_name, 5889 STRLEN* symbol_name_size, 5890 char** source_name, 5891 STRLEN* source_name_size, 5892 STRLEN* source_line) 5893 { 5894 *symbol_name = NULL; 5895 *symbol_name_size = 0; 5896 if (ctx->abfd) { 5897 IV offset = PTR2IV(raw_frame) - PTR2IV(ctx->bfd_text->vma); 5898 if (offset > 0 && 5899 bfd_canonicalize_symtab(ctx->abfd, ctx->bfd_syms) > 0) { 5900 const char *file; 5901 const char *func; 5902 unsigned int line = 0; 5903 if (bfd_find_nearest_line(ctx->abfd, ctx->bfd_text, 5904 ctx->bfd_syms, offset, 5905 &file, &func, &line) && 5906 file && func && line > 0) { 5907 /* Size and copy the source file, use only 5908 * the basename of the source file. 5909 * 5910 * NOTE: the basenames are fine for the 5911 * Perl source files, but may not always 5912 * be the best idea for XS files. */ 5913 const char *p, *b = NULL; 5914 /* Look for the last slash. */ 5915 for (p = file; *p; p++) { 5916 if (*p == '/') 5917 b = p + 1; 5918 } 5919 if (b == NULL || *b == 0) { 5920 b = file; 5921 } 5922 *source_name_size = p - b + 1; 5923 Newx(*source_name, *source_name_size + 1, char); 5924 Copy(b, *source_name, *source_name_size + 1, char); 5925 5926 *symbol_name_size = strlen(func); 5927 Newx(*symbol_name, *symbol_name_size + 1, char); 5928 Copy(func, *symbol_name, *symbol_name_size + 1, char); 5929 5930 *source_line = line; 5931 } 5932 } 5933 } 5934 } 5935 5936 #endif /* #ifdef USE_BFD */ 5937 5938 #ifdef PERL_DARWIN 5939 5940 /* OS X has no public API for for 'symbolicating' (Apple official term) 5941 * stack addresses to {function_name, source_file, line_number}. 5942 * Good news: there is command line utility atos(1) which does that. 5943 * Bad news 1: it's a command line utility. 5944 * Bad news 2: one needs to have the Developer Tools installed. 5945 * Bad news 3: in newer releases it needs to be run as 'xcrun atos'. 5946 * 5947 * To recap: we need to open a pipe for reading for a utility which 5948 * might not exist, or exists in different locations, and then parse 5949 * the output. And since this is all for a low-level API, we cannot 5950 * use high-level stuff. Thanks, Apple. */ 5951 5952 typedef struct { 5953 /* tool is set to the absolute pathname of the tool to use: 5954 * xcrun or atos. */ 5955 const char* tool; 5956 /* format is set to a printf format string used for building 5957 * the external command to run. */ 5958 const char* format; 5959 /* unavail is set if e.g. xcrun cannot be found, or something 5960 * else happens that makes getting the backtrace dubious. Note, 5961 * however, that the context isn't persistent, the next call to 5962 * get_c_backtrace() will start from scratch. */ 5963 bool unavail; 5964 /* fname is the current object file name. */ 5965 const char* fname; 5966 /* object_base_addr is the base address of the shared object. */ 5967 void* object_base_addr; 5968 } atos_context; 5969 5970 /* Given |dl_info|, updates the context. If the context has been 5971 * marked unavailable, return immediately. If not but the tool has 5972 * not been set, set it to either "xcrun atos" or "atos" (also set the 5973 * format to use for creating commands for piping), or if neither is 5974 * unavailable (one needs the Developer Tools installed), mark the context 5975 * an unavailable. Finally, update the filename (object name), 5976 * and its base address. */ 5977 5978 static void atos_update(atos_context* ctx, 5979 Dl_info* dl_info) 5980 { 5981 if (ctx->unavail) 5982 return; 5983 if (ctx->tool == NULL) { 5984 const char* tools[] = { 5985 "/usr/bin/xcrun", 5986 "/usr/bin/atos" 5987 }; 5988 const char* formats[] = { 5989 "/usr/bin/xcrun atos -o '%s' -l %08x %08x 2>&1", 5990 "/usr/bin/atos -d -o '%s' -l %08x %08x 2>&1" 5991 }; 5992 struct stat st; 5993 UV i; 5994 for (i = 0; i < C_ARRAY_LENGTH(tools); i++) { 5995 if (stat(tools[i], &st) == 0 && S_ISREG(st.st_mode)) { 5996 ctx->tool = tools[i]; 5997 ctx->format = formats[i]; 5998 break; 5999 } 6000 } 6001 if (ctx->tool == NULL) { 6002 ctx->unavail = TRUE; 6003 return; 6004 } 6005 } 6006 if (ctx->fname == NULL || 6007 strNE(dl_info->dli_fname, ctx->fname)) { 6008 ctx->fname = dl_info->dli_fname; 6009 ctx->object_base_addr = dl_info->dli_fbase; 6010 } 6011 } 6012 6013 /* Given an output buffer end |p| and its |start|, matches 6014 * for the atos output, extracting the source code location 6015 * and returning non-NULL if possible, returning NULL otherwise. */ 6016 static const char* atos_parse(const char* p, 6017 const char* start, 6018 STRLEN* source_name_size, 6019 STRLEN* source_line) { 6020 /* atos() output is something like: 6021 * perl_parse (in miniperl) (perl.c:2314)\n\n". 6022 * We cannot use Perl regular expressions, because we need to 6023 * stay low-level. Therefore here we have a rolled-out version 6024 * of a state machine which matches _backwards_from_the_end_ and 6025 * if there's a success, returns the starts of the filename, 6026 * also setting the filename size and the source line number. 6027 * The matched regular expression is roughly "\(.*:\d+\)\s*$" */ 6028 const char* source_number_start; 6029 const char* source_name_end; 6030 const char* source_line_end; 6031 const char* close_paren; 6032 UV uv; 6033 6034 /* Skip trailing whitespace. */ 6035 while (p > start && isSPACE(*p)) p--; 6036 /* Now we should be at the close paren. */ 6037 if (p == start || *p != ')') 6038 return NULL; 6039 close_paren = p; 6040 p--; 6041 /* Now we should be in the line number. */ 6042 if (p == start || !isDIGIT(*p)) 6043 return NULL; 6044 /* Skip over the digits. */ 6045 while (p > start && isDIGIT(*p)) 6046 p--; 6047 /* Now we should be at the colon. */ 6048 if (p == start || *p != ':') 6049 return NULL; 6050 source_number_start = p + 1; 6051 source_name_end = p; /* Just beyond the end. */ 6052 p--; 6053 /* Look for the open paren. */ 6054 while (p > start && *p != '(') 6055 p--; 6056 if (p == start) 6057 return NULL; 6058 p++; 6059 *source_name_size = source_name_end - p; 6060 if (grok_atoUV(source_number_start, &uv, &source_line_end) 6061 && source_line_end == close_paren 6062 && uv <= PERL_INT_MAX 6063 ) { 6064 *source_line = (STRLEN)uv; 6065 return p; 6066 } 6067 return NULL; 6068 } 6069 6070 /* Given a raw frame, read a pipe from the symbolicator (that's the 6071 * technical term) atos, reads the result, and parses the source code 6072 * location. We must stay low-level, so we use snprintf(), pipe(), 6073 * and fread(), and then also parse the output ourselves. */ 6074 static void atos_symbolize(atos_context* ctx, 6075 void* raw_frame, 6076 char** source_name, 6077 STRLEN* source_name_size, 6078 STRLEN* source_line) 6079 { 6080 char cmd[1024]; 6081 const char* p; 6082 Size_t cnt; 6083 6084 if (ctx->unavail) 6085 return; 6086 /* Simple security measure: if there's any funny business with 6087 * the object name (used as "-o '%s'" ), leave since at least 6088 * partially the user controls it. */ 6089 for (p = ctx->fname; *p; p++) { 6090 if (*p == '\'' || isCNTRL(*p)) { 6091 ctx->unavail = TRUE; 6092 return; 6093 } 6094 } 6095 cnt = snprintf(cmd, sizeof(cmd), ctx->format, 6096 ctx->fname, ctx->object_base_addr, raw_frame); 6097 if (cnt < sizeof(cmd)) { 6098 /* Undo nostdio.h #defines that disable stdio. 6099 * This is somewhat naughty, but is used elsewhere 6100 * in the core, and affects only OS X. */ 6101 #undef FILE 6102 #undef popen 6103 #undef fread 6104 #undef pclose 6105 FILE* fp = popen(cmd, "r"); 6106 /* At the moment we open a new pipe for each stack frame. 6107 * This is naturally somewhat slow, but hopefully generating 6108 * stack traces is never going to in a performance critical path. 6109 * 6110 * We could play tricks with atos by batching the stack 6111 * addresses to be resolved: atos can either take multiple 6112 * addresses from the command line, or read addresses from 6113 * a file (though the mess of creating temporary files would 6114 * probably negate much of any possible speedup). 6115 * 6116 * Normally there are only two objects present in the backtrace: 6117 * perl itself, and the libdyld.dylib. (Note that the object 6118 * filenames contain the full pathname, so perl may not always 6119 * be in the same place.) Whenever the object in the 6120 * backtrace changes, the base address also changes. 6121 * 6122 * The problem with batching the addresses, though, would be 6123 * matching the results with the addresses: the parsing of 6124 * the results is already painful enough with a single address. */ 6125 if (fp) { 6126 char out[1024]; 6127 UV cnt = fread(out, 1, sizeof(out), fp); 6128 if (cnt < sizeof(out)) { 6129 const char* p = atos_parse(out + cnt - 1, out, 6130 source_name_size, 6131 source_line); 6132 if (p) { 6133 Newx(*source_name, 6134 *source_name_size, char); 6135 Copy(p, *source_name, 6136 *source_name_size, char); 6137 } 6138 } 6139 pclose(fp); 6140 } 6141 } 6142 } 6143 6144 #endif /* #ifdef PERL_DARWIN */ 6145 6146 /* 6147 =for apidoc get_c_backtrace 6148 6149 Collects the backtrace (aka "stacktrace") into a single linear 6150 malloced buffer, which the caller B<must> C<Perl_free_c_backtrace()>. 6151 6152 Scans the frames back by S<C<depth + skip>>, then drops the C<skip> innermost, 6153 returning at most C<depth> frames. 6154 6155 =cut 6156 */ 6157 6158 Perl_c_backtrace* 6159 Perl_get_c_backtrace(pTHX_ int depth, int skip) 6160 { 6161 /* Note that here we must stay as low-level as possible: Newx(), 6162 * Copy(), Safefree(); since we may be called from anywhere, 6163 * so we should avoid higher level constructs like SVs or AVs. 6164 * 6165 * Since we are using safesysmalloc() via Newx(), don't try 6166 * getting backtrace() there, unless you like deep recursion. */ 6167 6168 /* Currently only implemented with backtrace() and dladdr(), 6169 * for other platforms NULL is returned. */ 6170 6171 #if defined(HAS_BACKTRACE) && defined(HAS_DLADDR) 6172 /* backtrace() is available via <execinfo.h> in glibc and in most 6173 * modern BSDs; dladdr() is available via <dlfcn.h>. */ 6174 6175 /* We try fetching this many frames total, but then discard 6176 * the |skip| first ones. For the remaining ones we will try 6177 * retrieving more information with dladdr(). */ 6178 int try_depth = skip + depth; 6179 6180 /* The addresses (program counters) returned by backtrace(). */ 6181 void** raw_frames; 6182 6183 /* Retrieved with dladdr() from the addresses returned by backtrace(). */ 6184 Dl_info* dl_infos; 6185 6186 /* Sizes _including_ the terminating \0 of the object name 6187 * and symbol name strings. */ 6188 STRLEN* object_name_sizes; 6189 STRLEN* symbol_name_sizes; 6190 6191 #ifdef USE_BFD 6192 /* The symbol names comes either from dli_sname, 6193 * or if using BFD, they can come from BFD. */ 6194 char** symbol_names; 6195 #endif 6196 6197 /* The source code location information. Dug out with e.g. BFD. */ 6198 char** source_names; 6199 STRLEN* source_name_sizes; 6200 STRLEN* source_lines; 6201 6202 Perl_c_backtrace* bt = NULL; /* This is what will be returned. */ 6203 int got_depth; /* How many frames were returned from backtrace(). */ 6204 UV frame_count = 0; /* How many frames we return. */ 6205 UV total_bytes = 0; /* The size of the whole returned backtrace. */ 6206 6207 #ifdef USE_BFD 6208 bfd_context bfd_ctx; 6209 #endif 6210 #ifdef PERL_DARWIN 6211 atos_context atos_ctx; 6212 #endif 6213 6214 /* Here are probably possibilities for optimizing. We could for 6215 * example have a struct that contains most of these and then 6216 * allocate |try_depth| of them, saving a bunch of malloc calls. 6217 * Note, however, that |frames| could not be part of that struct 6218 * because backtrace() will want an array of just them. Also be 6219 * careful about the name strings. */ 6220 Newx(raw_frames, try_depth, void*); 6221 Newx(dl_infos, try_depth, Dl_info); 6222 Newx(object_name_sizes, try_depth, STRLEN); 6223 Newx(symbol_name_sizes, try_depth, STRLEN); 6224 Newx(source_names, try_depth, char*); 6225 Newx(source_name_sizes, try_depth, STRLEN); 6226 Newx(source_lines, try_depth, STRLEN); 6227 #ifdef USE_BFD 6228 Newx(symbol_names, try_depth, char*); 6229 #endif 6230 6231 /* Get the raw frames. */ 6232 got_depth = (int)backtrace(raw_frames, try_depth); 6233 6234 /* We use dladdr() instead of backtrace_symbols() because we want 6235 * the full details instead of opaque strings. This is useful for 6236 * two reasons: () the details are needed for further symbolic 6237 * digging, for example in OS X (2) by having the details we fully 6238 * control the output, which in turn is useful when more platforms 6239 * are added: we can keep out output "portable". */ 6240 6241 /* We want a single linear allocation, which can then be freed 6242 * with a single swoop. We will do the usual trick of first 6243 * walking over the structure and seeing how much we need to 6244 * allocate, then allocating, and then walking over the structure 6245 * the second time and populating it. */ 6246 6247 /* First we must compute the total size of the buffer. */ 6248 total_bytes = sizeof(Perl_c_backtrace_header); 6249 if (got_depth > skip) { 6250 int i; 6251 #ifdef USE_BFD 6252 bfd_init(); /* Is this safe to call multiple times? */ 6253 Zero(&bfd_ctx, 1, bfd_context); 6254 #endif 6255 #ifdef PERL_DARWIN 6256 Zero(&atos_ctx, 1, atos_context); 6257 #endif 6258 for (i = skip; i < try_depth; i++) { 6259 Dl_info* dl_info = &dl_infos[i]; 6260 6261 object_name_sizes[i] = 0; 6262 source_names[i] = NULL; 6263 source_name_sizes[i] = 0; 6264 source_lines[i] = 0; 6265 6266 /* Yes, zero from dladdr() is failure. */ 6267 if (dladdr(raw_frames[i], dl_info)) { 6268 total_bytes += sizeof(Perl_c_backtrace_frame); 6269 6270 object_name_sizes[i] = 6271 dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0; 6272 symbol_name_sizes[i] = 6273 dl_info->dli_sname ? strlen(dl_info->dli_sname) : 0; 6274 #ifdef USE_BFD 6275 bfd_update(&bfd_ctx, dl_info); 6276 bfd_symbolize(&bfd_ctx, raw_frames[i], 6277 &symbol_names[i], 6278 &symbol_name_sizes[i], 6279 &source_names[i], 6280 &source_name_sizes[i], 6281 &source_lines[i]); 6282 #endif 6283 #if PERL_DARWIN 6284 atos_update(&atos_ctx, dl_info); 6285 atos_symbolize(&atos_ctx, 6286 raw_frames[i], 6287 &source_names[i], 6288 &source_name_sizes[i], 6289 &source_lines[i]); 6290 #endif 6291 6292 /* Plus ones for the terminating \0. */ 6293 total_bytes += object_name_sizes[i] + 1; 6294 total_bytes += symbol_name_sizes[i] + 1; 6295 total_bytes += source_name_sizes[i] + 1; 6296 6297 frame_count++; 6298 } else { 6299 break; 6300 } 6301 } 6302 #ifdef USE_BFD 6303 Safefree(bfd_ctx.bfd_syms); 6304 #endif 6305 } 6306 6307 /* Now we can allocate and populate the result buffer. */ 6308 Newxc(bt, total_bytes, char, Perl_c_backtrace); 6309 Zero(bt, total_bytes, char); 6310 bt->header.frame_count = frame_count; 6311 bt->header.total_bytes = total_bytes; 6312 if (frame_count > 0) { 6313 Perl_c_backtrace_frame* frame = bt->frame_info; 6314 char* name_base = (char *)(frame + frame_count); 6315 char* name_curr = name_base; /* Outputting the name strings here. */ 6316 UV i; 6317 for (i = skip; i < skip + frame_count; i++) { 6318 Dl_info* dl_info = &dl_infos[i]; 6319 6320 frame->addr = raw_frames[i]; 6321 frame->object_base_addr = dl_info->dli_fbase; 6322 frame->symbol_addr = dl_info->dli_saddr; 6323 6324 /* Copies a string, including the \0, and advances the name_curr. 6325 * Also copies the start and the size to the frame. */ 6326 #define PERL_C_BACKTRACE_STRCPY(frame, doffset, src, dsize, size) \ 6327 if (size && src) \ 6328 Copy(src, name_curr, size, char); \ 6329 frame->doffset = name_curr - (char*)bt; \ 6330 frame->dsize = size; \ 6331 name_curr += size; \ 6332 *name_curr++ = 0; 6333 6334 PERL_C_BACKTRACE_STRCPY(frame, object_name_offset, 6335 dl_info->dli_fname, 6336 object_name_size, object_name_sizes[i]); 6337 6338 #ifdef USE_BFD 6339 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset, 6340 symbol_names[i], 6341 symbol_name_size, symbol_name_sizes[i]); 6342 Safefree(symbol_names[i]); 6343 #else 6344 PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset, 6345 dl_info->dli_sname, 6346 symbol_name_size, symbol_name_sizes[i]); 6347 #endif 6348 6349 PERL_C_BACKTRACE_STRCPY(frame, source_name_offset, 6350 source_names[i], 6351 source_name_size, source_name_sizes[i]); 6352 Safefree(source_names[i]); 6353 6354 #undef PERL_C_BACKTRACE_STRCPY 6355 6356 frame->source_line_number = source_lines[i]; 6357 6358 frame++; 6359 } 6360 assert(total_bytes == 6361 (UV)(sizeof(Perl_c_backtrace_header) + 6362 frame_count * sizeof(Perl_c_backtrace_frame) + 6363 name_curr - name_base)); 6364 } 6365 #ifdef USE_BFD 6366 Safefree(symbol_names); 6367 if (bfd_ctx.abfd) { 6368 bfd_close(bfd_ctx.abfd); 6369 } 6370 #endif 6371 Safefree(source_lines); 6372 Safefree(source_name_sizes); 6373 Safefree(source_names); 6374 Safefree(symbol_name_sizes); 6375 Safefree(object_name_sizes); 6376 /* Assuming the strings returned by dladdr() are pointers 6377 * to read-only static memory (the object file), so that 6378 * they do not need freeing (and cannot be). */ 6379 Safefree(dl_infos); 6380 Safefree(raw_frames); 6381 return bt; 6382 #else 6383 PERL_UNUSED_ARGV(depth); 6384 PERL_UNUSED_ARGV(skip); 6385 return NULL; 6386 #endif 6387 } 6388 6389 /* 6390 =for apidoc free_c_backtrace 6391 6392 Deallocates a backtrace received from get_c_bracktrace. 6393 6394 =cut 6395 */ 6396 6397 /* 6398 =for apidoc get_c_backtrace_dump 6399 6400 Returns a SV containing a dump of C<depth> frames of the call stack, skipping 6401 the C<skip> innermost ones. C<depth> of 20 is usually enough. 6402 6403 The appended output looks like: 6404 6405 ... 6406 1 10e004812:0082 Perl_croak util.c:1716 /usr/bin/perl 6407 2 10df8d6d2:1d72 perl_parse perl.c:3975 /usr/bin/perl 6408 ... 6409 6410 The fields are tab-separated. The first column is the depth (zero 6411 being the innermost non-skipped frame). In the hex:offset, the hex is 6412 where the program counter was in C<S_parse_body>, and the :offset (might 6413 be missing) tells how much inside the C<S_parse_body> the program counter was. 6414 6415 The C<util.c:1716> is the source code file and line number. 6416 6417 The F</usr/bin/perl> is obvious (hopefully). 6418 6419 Unknowns are C<"-">. Unknowns can happen unfortunately quite easily: 6420 if the platform doesn't support retrieving the information; 6421 if the binary is missing the debug information; 6422 if the optimizer has transformed the code by for example inlining. 6423 6424 =cut 6425 */ 6426 6427 SV* 6428 Perl_get_c_backtrace_dump(pTHX_ int depth, int skip) 6429 { 6430 Perl_c_backtrace* bt; 6431 6432 bt = get_c_backtrace(depth, skip + 1 /* Hide ourselves. */); 6433 if (bt) { 6434 Perl_c_backtrace_frame* frame; 6435 SV* dsv = newSVpvs(""); 6436 UV i; 6437 for (i = 0, frame = bt->frame_info; 6438 i < bt->header.frame_count; i++, frame++) { 6439 Perl_sv_catpvf(aTHX_ dsv, "%d", (int)i); 6440 Perl_sv_catpvf(aTHX_ dsv, "\t%p", frame->addr ? frame->addr : "-"); 6441 /* Symbol (function) names might disappear without debug info. 6442 * 6443 * The source code location might disappear in case of the 6444 * optimizer inlining or otherwise rearranging the code. */ 6445 if (frame->symbol_addr) { 6446 Perl_sv_catpvf(aTHX_ dsv, ":%04x", 6447 (int) 6448 ((char*)frame->addr - (char*)frame->symbol_addr)); 6449 } 6450 Perl_sv_catpvf(aTHX_ dsv, "\t%s", 6451 frame->symbol_name_size && 6452 frame->symbol_name_offset ? 6453 (char*)bt + frame->symbol_name_offset : "-"); 6454 if (frame->source_name_size && 6455 frame->source_name_offset && 6456 frame->source_line_number) { 6457 Perl_sv_catpvf(aTHX_ dsv, "\t%s:%" UVuf, 6458 (char*)bt + frame->source_name_offset, 6459 (UV)frame->source_line_number); 6460 } else { 6461 Perl_sv_catpvf(aTHX_ dsv, "\t-"); 6462 } 6463 Perl_sv_catpvf(aTHX_ dsv, "\t%s", 6464 frame->object_name_size && 6465 frame->object_name_offset ? 6466 (char*)bt + frame->object_name_offset : "-"); 6467 /* The frame->object_base_addr is not output, 6468 * but it is used for symbolizing/symbolicating. */ 6469 sv_catpvs(dsv, "\n"); 6470 } 6471 6472 Perl_free_c_backtrace(bt); 6473 6474 return dsv; 6475 } 6476 6477 return NULL; 6478 } 6479 6480 /* 6481 =for apidoc dump_c_backtrace 6482 6483 Dumps the C backtrace to the given C<fp>. 6484 6485 Returns true if a backtrace could be retrieved, false if not. 6486 6487 =cut 6488 */ 6489 6490 bool 6491 Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip) 6492 { 6493 SV* sv; 6494 6495 PERL_ARGS_ASSERT_DUMP_C_BACKTRACE; 6496 6497 sv = Perl_get_c_backtrace_dump(aTHX_ depth, skip); 6498 if (sv) { 6499 sv_2mortal(sv); 6500 PerlIO_printf(fp, "%s", SvPV_nolen(sv)); 6501 return TRUE; 6502 } 6503 return FALSE; 6504 } 6505 6506 #endif /* #ifdef USE_C_BACKTRACE */ 6507 6508 #ifdef PERL_TSA_ACTIVE 6509 6510 /* pthread_mutex_t and perl_mutex are typedef equivalent 6511 * so casting the pointers is fine. */ 6512 6513 int perl_tsa_mutex_lock(perl_mutex* mutex) 6514 { 6515 return pthread_mutex_lock((pthread_mutex_t *) mutex); 6516 } 6517 6518 int perl_tsa_mutex_unlock(perl_mutex* mutex) 6519 { 6520 return pthread_mutex_unlock((pthread_mutex_t *) mutex); 6521 } 6522 6523 int perl_tsa_mutex_destroy(perl_mutex* mutex) 6524 { 6525 return pthread_mutex_destroy((pthread_mutex_t *) mutex); 6526 } 6527 6528 #endif 6529 6530 6531 #ifdef USE_DTRACE 6532 6533 /* log a sub call or return */ 6534 6535 void 6536 Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call) 6537 { 6538 const char *func; 6539 const char *file; 6540 const char *stash; 6541 const COP *start; 6542 line_t line; 6543 6544 PERL_ARGS_ASSERT_DTRACE_PROBE_CALL; 6545 6546 if (CvNAMED(cv)) { 6547 HEK *hek = CvNAME_HEK(cv); 6548 func = HEK_KEY(hek); 6549 } 6550 else { 6551 GV *gv = CvGV(cv); 6552 func = GvENAME(gv); 6553 } 6554 start = (const COP *)CvSTART(cv); 6555 file = CopFILE(start); 6556 line = CopLINE(start); 6557 stash = CopSTASHPV(start); 6558 6559 if (is_call) { 6560 PERL_SUB_ENTRY(func, file, line, stash); 6561 } 6562 else { 6563 PERL_SUB_RETURN(func, file, line, stash); 6564 } 6565 } 6566 6567 6568 /* log a require file loading/loaded */ 6569 6570 void 6571 Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading) 6572 { 6573 PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD; 6574 6575 if (is_loading) { 6576 PERL_LOADING_FILE(name); 6577 } 6578 else { 6579 PERL_LOADED_FILE(name); 6580 } 6581 } 6582 6583 6584 /* log an op execution */ 6585 6586 void 6587 Perl_dtrace_probe_op(pTHX_ const OP *op) 6588 { 6589 PERL_ARGS_ASSERT_DTRACE_PROBE_OP; 6590 6591 PERL_OP_ENTRY(OP_NAME(op)); 6592 } 6593 6594 6595 /* log a compile/run phase change */ 6596 6597 void 6598 Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase) 6599 { 6600 const char *ph_old = PL_phase_names[PL_phase]; 6601 const char *ph_new = PL_phase_names[phase]; 6602 6603 PERL_PHASE_CHANGE(ph_new, ph_old); 6604 } 6605 6606 #endif 6607 6608 /* 6609 * ex: set ts=8 sts=4 sw=4 et: 6610 */ 6611