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