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