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