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