1 /* util.c 2 * 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * 'Very useful, no doubt, that was to Saruman; yet it seems that he was 13 * not content.' --Gandalf to Pippin 14 * 15 * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"] 16 */ 17 18 /* This file contains assorted utility routines. 19 * Which is a polite way of saying any stuff that people couldn't think of 20 * a better place for. Amongst other things, it includes the warning and 21 * dieing stuff, plus wrappers for malloc code. 22 */ 23 24 #include "EXTERN.h" 25 #define PERL_IN_UTIL_C 26 #include "perl.h" 27 #include "reentr.h" 28 29 #if defined(USE_PERLIO) 30 #include "perliol.h" /* For PerlIOUnix_refcnt */ 31 #endif 32 33 #ifndef PERL_MICRO 34 #include <signal.h> 35 #ifndef SIG_ERR 36 # define SIG_ERR ((Sighandler_t) -1) 37 #endif 38 #endif 39 40 #include <math.h> 41 #include <stdlib.h> 42 43 #ifdef __Lynx__ 44 /* Missing protos on LynxOS */ 45 int putenv(char *); 46 #endif 47 48 #ifdef HAS_SELECT 49 # ifdef I_SYS_SELECT 50 # include <sys/select.h> 51 # endif 52 #endif 53 54 #ifdef PERL_DEBUG_READONLY_COW 55 # include <sys/mman.h> 56 #endif 57 58 #define FLUSH 59 60 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) 61 # define FD_CLOEXEC 1 /* NeXT needs this */ 62 #endif 63 64 /* NOTE: Do not call the next three routines directly. Use the macros 65 * in handy.h, so that we can easily redefine everything to do tracking of 66 * allocated hunks back to the original New to track down any memory leaks. 67 * XXX This advice seems to be widely ignored :-( --AD August 1996. 68 */ 69 70 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL) 71 # define ALWAYS_NEED_THX 72 #endif 73 74 #if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW) 75 static void 76 S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header) 77 { 78 if (header->readonly 79 && mprotect(header, header->size, PROT_READ|PROT_WRITE)) 80 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d", 81 header, header->size, errno); 82 } 83 84 static void 85 S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header) 86 { 87 if (header->readonly 88 && mprotect(header, header->size, PROT_READ)) 89 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d", 90 header, header->size, errno); 91 } 92 # define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo) 93 # define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo) 94 #else 95 # define maybe_protect_rw(foo) NOOP 96 # define maybe_protect_ro(foo) NOOP 97 #endif 98 99 #if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW) 100 /* Use memory_debug_header */ 101 # define USE_MDH 102 # if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \ 103 || defined(PERL_DEBUG_READONLY_COW) 104 # define MDH_HAS_SIZE 105 # endif 106 #endif 107 108 /* paranoid version of system's malloc() */ 109 110 Malloc_t 111 Perl_safesysmalloc(MEM_SIZE size) 112 { 113 #ifdef ALWAYS_NEED_THX 114 dTHX; 115 #endif 116 Malloc_t ptr; 117 size += PERL_MEMORY_DEBUG_HEADER_SIZE; 118 #ifdef DEBUGGING 119 if ((SSize_t)size < 0) 120 Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size); 121 #endif 122 if (!size) size = 1; /* malloc(0) is NASTY on our system */ 123 #ifdef PERL_DEBUG_READONLY_COW 124 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE, 125 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { 126 perror("mmap failed"); 127 abort(); 128 } 129 #else 130 ptr = (Malloc_t)PerlMem_malloc(size?size:1); 131 #endif 132 PERL_ALLOC_CHECK(ptr); 133 if (ptr != NULL) { 134 #ifdef USE_MDH 135 struct perl_memory_debug_header *const header 136 = (struct perl_memory_debug_header *)ptr; 137 #endif 138 139 #ifdef PERL_POISON 140 PoisonNew(((char *)ptr), size, char); 141 #endif 142 143 #ifdef PERL_TRACK_MEMPOOL 144 header->interpreter = aTHX; 145 /* Link us into the list. */ 146 header->prev = &PL_memory_debug_header; 147 header->next = PL_memory_debug_header.next; 148 PL_memory_debug_header.next = header; 149 maybe_protect_rw(header->next); 150 header->next->prev = header; 151 maybe_protect_ro(header->next); 152 # ifdef PERL_DEBUG_READONLY_COW 153 header->readonly = 0; 154 # endif 155 #endif 156 #ifdef MDH_HAS_SIZE 157 header->size = size; 158 #endif 159 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); 160 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 161 return ptr; 162 } 163 else { 164 #ifndef ALWAYS_NEED_THX 165 dTHX; 166 #endif 167 if (PL_nomemok) 168 return NULL; 169 else { 170 croak_no_mem(); 171 } 172 } 173 /*NOTREACHED*/ 174 } 175 176 /* paranoid version of system's realloc() */ 177 178 Malloc_t 179 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) 180 { 181 #ifdef ALWAYS_NEED_THX 182 dTHX; 183 #endif 184 Malloc_t ptr; 185 #ifdef PERL_DEBUG_READONLY_COW 186 const MEM_SIZE oldsize = where 187 ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size 188 : 0; 189 #endif 190 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO) 191 Malloc_t PerlMem_realloc(); 192 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ 193 194 if (!size) { 195 safesysfree(where); 196 return NULL; 197 } 198 199 if (!where) 200 return safesysmalloc(size); 201 #ifdef USE_MDH 202 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); 203 size += PERL_MEMORY_DEBUG_HEADER_SIZE; 204 { 205 struct perl_memory_debug_header *const header 206 = (struct perl_memory_debug_header *)where; 207 208 # ifdef PERL_TRACK_MEMPOOL 209 if (header->interpreter != aTHX) { 210 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p", 211 header->interpreter, aTHX); 212 } 213 assert(header->next->prev == header); 214 assert(header->prev->next == header); 215 # ifdef PERL_POISON 216 if (header->size > size) { 217 const MEM_SIZE freed_up = header->size - size; 218 char *start_of_freed = ((char *)where) + size; 219 PoisonFree(start_of_freed, freed_up, char); 220 } 221 # endif 222 # endif 223 # ifdef MDH_HAS_SIZE 224 header->size = size; 225 # endif 226 } 227 #endif 228 #ifdef DEBUGGING 229 if ((SSize_t)size < 0) 230 Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size); 231 #endif 232 #ifdef PERL_DEBUG_READONLY_COW 233 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE, 234 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { 235 perror("mmap failed"); 236 abort(); 237 } 238 Copy(where,ptr,oldsize < size ? oldsize : size,char); 239 if (munmap(where, oldsize)) { 240 perror("munmap failed"); 241 abort(); 242 } 243 #else 244 ptr = (Malloc_t)PerlMem_realloc(where,size); 245 #endif 246 PERL_ALLOC_CHECK(ptr); 247 248 /* MUST do this fixup first, before doing ANYTHING else, as anything else 249 might allocate memory/free/move memory, and until we do the fixup, it 250 may well be chasing (and writing to) free memory. */ 251 if (ptr != NULL) { 252 #ifdef PERL_TRACK_MEMPOOL 253 struct perl_memory_debug_header *const header 254 = (struct perl_memory_debug_header *)ptr; 255 256 # ifdef PERL_POISON 257 if (header->size < size) { 258 const MEM_SIZE fresh = size - header->size; 259 char *start_of_fresh = ((char *)ptr) + size; 260 PoisonNew(start_of_fresh, fresh, char); 261 } 262 # endif 263 264 maybe_protect_rw(header->next); 265 header->next->prev = header; 266 maybe_protect_ro(header->next); 267 maybe_protect_rw(header->prev); 268 header->prev->next = header; 269 maybe_protect_ro(header->prev); 270 #endif 271 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); 272 } 273 274 /* In particular, must do that fixup above before logging anything via 275 *printf(), as it can reallocate memory, which can cause SEGVs. */ 276 277 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); 278 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 279 280 281 if (ptr != NULL) { 282 return ptr; 283 } 284 else { 285 #ifndef ALWAYS_NEED_THX 286 dTHX; 287 #endif 288 if (PL_nomemok) 289 return NULL; 290 else { 291 croak_no_mem(); 292 } 293 } 294 /*NOTREACHED*/ 295 } 296 297 /* safe version of system's free() */ 298 299 Free_t 300 Perl_safesysfree(Malloc_t where) 301 { 302 #ifdef ALWAYS_NEED_THX 303 dTHX; 304 #else 305 dVAR; 306 #endif 307 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); 308 if (where) { 309 #ifdef USE_MDH 310 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); 311 { 312 struct perl_memory_debug_header *const header 313 = (struct perl_memory_debug_header *)where; 314 315 # ifdef MDH_HAS_SIZE 316 const MEM_SIZE size = header->size; 317 # endif 318 # ifdef PERL_TRACK_MEMPOOL 319 if (header->interpreter != aTHX) { 320 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p", 321 header->interpreter, aTHX); 322 } 323 if (!header->prev) { 324 Perl_croak_nocontext("panic: duplicate free"); 325 } 326 if (!(header->next)) 327 Perl_croak_nocontext("panic: bad free, header->next==NULL"); 328 if (header->next->prev != header || header->prev->next != header) { 329 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, " 330 "header=%p, ->prev->next=%p", 331 header->next->prev, header, 332 header->prev->next); 333 } 334 /* Unlink us from the chain. */ 335 maybe_protect_rw(header->next); 336 header->next->prev = header->prev; 337 maybe_protect_ro(header->next); 338 maybe_protect_rw(header->prev); 339 header->prev->next = header->next; 340 maybe_protect_ro(header->prev); 341 maybe_protect_rw(header); 342 # ifdef PERL_POISON 343 PoisonNew(where, size, char); 344 # endif 345 /* Trigger the duplicate free warning. */ 346 header->next = NULL; 347 # endif 348 # ifdef PERL_DEBUG_READONLY_COW 349 if (munmap(where, size)) { 350 perror("munmap failed"); 351 abort(); 352 } 353 # endif 354 } 355 #endif 356 #ifndef PERL_DEBUG_READONLY_COW 357 PerlMem_free(where); 358 #endif 359 } 360 } 361 362 /* safe version of system's calloc() */ 363 364 Malloc_t 365 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) 366 { 367 #ifdef ALWAYS_NEED_THX 368 dTHX; 369 #endif 370 Malloc_t ptr; 371 #if defined(USE_MDH) || defined(DEBUGGING) 372 MEM_SIZE total_size = 0; 373 #endif 374 375 /* Even though calloc() for zero bytes is strange, be robust. */ 376 if (size && (count <= MEM_SIZE_MAX / size)) { 377 #if defined(USE_MDH) || defined(DEBUGGING) 378 total_size = size * count; 379 #endif 380 } 381 else 382 croak_memory_wrap(); 383 #ifdef USE_MDH 384 if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size) 385 total_size += PERL_MEMORY_DEBUG_HEADER_SIZE; 386 else 387 croak_memory_wrap(); 388 #endif 389 #ifdef DEBUGGING 390 if ((SSize_t)size < 0 || (SSize_t)count < 0) 391 Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf, 392 (UV)size, (UV)count); 393 #endif 394 #ifdef PERL_DEBUG_READONLY_COW 395 if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE, 396 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { 397 perror("mmap failed"); 398 abort(); 399 } 400 #elif defined(PERL_TRACK_MEMPOOL) 401 /* Have to use malloc() because we've added some space for our tracking 402 header. */ 403 /* malloc(0) is non-portable. */ 404 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1); 405 #else 406 /* Use calloc() because it might save a memset() if the memory is fresh 407 and clean from the OS. */ 408 if (count && size) 409 ptr = (Malloc_t)PerlMem_calloc(count, size); 410 else /* calloc(0) is non-portable. */ 411 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1); 412 #endif 413 PERL_ALLOC_CHECK(ptr); 414 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size)); 415 if (ptr != NULL) { 416 #ifdef USE_MDH 417 { 418 struct perl_memory_debug_header *const header 419 = (struct perl_memory_debug_header *)ptr; 420 421 # ifndef PERL_DEBUG_READONLY_COW 422 memset((void*)ptr, 0, total_size); 423 # endif 424 # ifdef PERL_TRACK_MEMPOOL 425 header->interpreter = aTHX; 426 /* Link us into the list. */ 427 header->prev = &PL_memory_debug_header; 428 header->next = PL_memory_debug_header.next; 429 PL_memory_debug_header.next = header; 430 maybe_protect_rw(header->next); 431 header->next->prev = header; 432 maybe_protect_ro(header->next); 433 # ifdef PERL_DEBUG_READONLY_COW 434 header->readonly = 0; 435 # endif 436 # endif 437 # ifdef MDH_HAS_SIZE 438 header->size = total_size; 439 # endif 440 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); 441 } 442 #endif 443 return ptr; 444 } 445 else { 446 #ifndef ALWAYS_NEED_THX 447 dTHX; 448 #endif 449 if (PL_nomemok) 450 return NULL; 451 croak_no_mem(); 452 } 453 } 454 455 /* These must be defined when not using Perl's malloc for binary 456 * compatibility */ 457 458 #ifndef MYMALLOC 459 460 Malloc_t Perl_malloc (MEM_SIZE nbytes) 461 { 462 dTHXs; 463 return (Malloc_t)PerlMem_malloc(nbytes); 464 } 465 466 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) 467 { 468 dTHXs; 469 return (Malloc_t)PerlMem_calloc(elements, size); 470 } 471 472 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) 473 { 474 dTHXs; 475 return (Malloc_t)PerlMem_realloc(where, nbytes); 476 } 477 478 Free_t Perl_mfree (Malloc_t where) 479 { 480 dTHXs; 481 PerlMem_free(where); 482 } 483 484 #endif 485 486 /* copy a string up to some (non-backslashed) delimiter, if any */ 487 488 char * 489 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen) 490 { 491 I32 tolen; 492 493 PERL_ARGS_ASSERT_DELIMCPY; 494 495 for (tolen = 0; from < fromend; from++, tolen++) { 496 if (*from == '\\') { 497 if (from[1] != delim) { 498 if (to < toend) 499 *to++ = *from; 500 tolen++; 501 } 502 from++; 503 } 504 else if (*from == delim) 505 break; 506 if (to < toend) 507 *to++ = *from; 508 } 509 if (to < toend) 510 *to = '\0'; 511 *retlen = tolen; 512 return (char *)from; 513 } 514 515 /* return ptr to little string in big string, NULL if not found */ 516 /* This routine was donated by Corey Satten. */ 517 518 char * 519 Perl_instr(const char *big, const char *little) 520 { 521 522 PERL_ARGS_ASSERT_INSTR; 523 524 /* libc prior to 4.6.27 (late 1994) did not work properly on a NULL 525 * 'little' */ 526 if (!little) 527 return (char*)big; 528 return strstr((char*)big, (char*)little); 529 } 530 531 /* same as instr but allow embedded nulls. The end pointers point to 1 beyond 532 * the final character desired to be checked */ 533 534 char * 535 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend) 536 { 537 PERL_ARGS_ASSERT_NINSTR; 538 if (little >= lend) 539 return (char*)big; 540 { 541 const char first = *little; 542 const char *s, *x; 543 bigend -= lend - little++; 544 OUTER: 545 while (big <= bigend) { 546 if (*big++ == first) { 547 for (x=big,s=little; s < lend; x++,s++) { 548 if (*s != *x) 549 goto OUTER; 550 } 551 return (char*)(big-1); 552 } 553 } 554 } 555 return NULL; 556 } 557 558 /* reverse of the above--find last substring */ 559 560 char * 561 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend) 562 { 563 const char *bigbeg; 564 const I32 first = *little; 565 const char * const littleend = lend; 566 567 PERL_ARGS_ASSERT_RNINSTR; 568 569 if (little >= littleend) 570 return (char*)bigend; 571 bigbeg = big; 572 big = bigend - (littleend - little++); 573 while (big >= bigbeg) { 574 const char *s, *x; 575 if (*big-- != first) 576 continue; 577 for (x=big+2,s=little; s < littleend; /**/ ) { 578 if (*s != *x) 579 break; 580 else { 581 x++; 582 s++; 583 } 584 } 585 if (s >= littleend) 586 return (char*)(big+1); 587 } 588 return NULL; 589 } 590 591 /* As a space optimization, we do not compile tables for strings of length 592 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are 593 special-cased in fbm_instr(). 594 595 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ 596 597 /* 598 =head1 Miscellaneous Functions 599 600 =for apidoc fbm_compile 601 602 Analyses the string in order to make fast searches on it using fbm_instr() 603 -- the Boyer-Moore algorithm. 604 605 =cut 606 */ 607 608 void 609 Perl_fbm_compile(pTHX_ SV *sv, U32 flags) 610 { 611 dVAR; 612 const U8 *s; 613 STRLEN i; 614 STRLEN len; 615 U32 frequency = 256; 616 MAGIC *mg; 617 PERL_DEB( STRLEN rarest = 0 ); 618 619 PERL_ARGS_ASSERT_FBM_COMPILE; 620 621 if (isGV_with_GP(sv) || SvROK(sv)) 622 return; 623 624 if (SvVALID(sv)) 625 return; 626 627 if (flags & FBMcf_TAIL) { 628 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; 629 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */ 630 if (mg && mg->mg_len >= 0) 631 mg->mg_len++; 632 } 633 if (!SvPOK(sv) || SvNIOKp(sv)) 634 s = (U8*)SvPV_force_mutable(sv, len); 635 else s = (U8 *)SvPV_mutable(sv, len); 636 if (len == 0) /* TAIL might be on a zero-length string. */ 637 return; 638 SvUPGRADE(sv, SVt_PVMG); 639 SvIOK_off(sv); 640 SvNOK_off(sv); 641 SvVALID_on(sv); 642 643 /* "deep magic", the comment used to add. The use of MAGIC itself isn't 644 really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2) 645 to call SvVALID_off() if the scalar was assigned to. 646 647 The comment itself (and "deeper magic" below) date back to 648 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on 649 str->str_pok |= 2; 650 where the magic (presumably) was that the scalar had a BM table hidden 651 inside itself. 652 653 As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store 654 the table instead of the previous (somewhat hacky) approach of co-opting 655 the string buffer and storing it after the string. */ 656 657 assert(!mg_find(sv, PERL_MAGIC_bm)); 658 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0); 659 assert(mg); 660 661 if (len > 2) { 662 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use 663 the BM table. */ 664 const U8 mlen = (len>255) ? 255 : (U8)len; 665 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */ 666 U8 *table; 667 668 Newx(table, 256, U8); 669 memset((void*)table, mlen, 256); 670 mg->mg_ptr = (char *)table; 671 mg->mg_len = 256; 672 673 s += len - 1; /* last char */ 674 i = 0; 675 while (s >= sb) { 676 if (table[*s] == mlen) 677 table[*s] = (U8)i; 678 s--, i++; 679 } 680 } 681 682 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ 683 for (i = 0; i < len; i++) { 684 if (PL_freq[s[i]] < frequency) { 685 PERL_DEB( rarest = i ); 686 frequency = PL_freq[s[i]]; 687 } 688 } 689 BmUSEFUL(sv) = 100; /* Initial value */ 690 if (flags & FBMcf_TAIL) 691 SvTAIL_on(sv); 692 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n", 693 s[rarest], (UV)rarest)); 694 } 695 696 /* If SvTAIL(littlestr), it has a fake '\n' at end. */ 697 /* If SvTAIL is actually due to \Z or \z, this gives false positives 698 if multiline */ 699 700 /* 701 =for apidoc fbm_instr 702 703 Returns the location of the SV in the string delimited by C<big> and 704 C<bigend>. It returns C<NULL> if the string can't be found. The C<sv> 705 does not have to be fbm_compiled, but the search will not be as fast 706 then. 707 708 =cut 709 */ 710 711 char * 712 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags) 713 { 714 unsigned char *s; 715 STRLEN l; 716 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l); 717 STRLEN littlelen = l; 718 const I32 multiline = flags & FBMrf_MULTILINE; 719 720 PERL_ARGS_ASSERT_FBM_INSTR; 721 722 if ((STRLEN)(bigend - big) < littlelen) { 723 if ( SvTAIL(littlestr) 724 && ((STRLEN)(bigend - big) == littlelen - 1) 725 && (littlelen == 1 726 || (*big == *little && 727 memEQ((char *)big, (char *)little, littlelen - 1)))) 728 return (char*)big; 729 return NULL; 730 } 731 732 switch (littlelen) { /* Special cases for 0, 1 and 2 */ 733 case 0: 734 return (char*)big; /* Cannot be SvTAIL! */ 735 case 1: 736 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ 737 /* Know that bigend != big. */ 738 if (bigend[-1] == '\n') 739 return (char *)(bigend - 1); 740 return (char *) bigend; 741 } 742 s = big; 743 while (s < bigend) { 744 if (*s == *little) 745 return (char *)s; 746 s++; 747 } 748 if (SvTAIL(littlestr)) 749 return (char *) bigend; 750 return NULL; 751 case 2: 752 if (SvTAIL(littlestr) && !multiline) { 753 if (bigend[-1] == '\n' && bigend[-2] == *little) 754 return (char*)bigend - 2; 755 if (bigend[-1] == *little) 756 return (char*)bigend - 1; 757 return NULL; 758 } 759 { 760 /* This should be better than FBM if c1 == c2, and almost 761 as good otherwise: maybe better since we do less indirection. 762 And we save a lot of memory by caching no table. */ 763 const unsigned char c1 = little[0]; 764 const unsigned char c2 = little[1]; 765 766 s = big + 1; 767 bigend--; 768 if (c1 != c2) { 769 while (s <= bigend) { 770 if (s[0] == c2) { 771 if (s[-1] == c1) 772 return (char*)s - 1; 773 s += 2; 774 continue; 775 } 776 next_chars: 777 if (s[0] == c1) { 778 if (s == bigend) 779 goto check_1char_anchor; 780 if (s[1] == c2) 781 return (char*)s; 782 else { 783 s++; 784 goto next_chars; 785 } 786 } 787 else 788 s += 2; 789 } 790 goto check_1char_anchor; 791 } 792 /* Now c1 == c2 */ 793 while (s <= bigend) { 794 if (s[0] == c1) { 795 if (s[-1] == c1) 796 return (char*)s - 1; 797 if (s == bigend) 798 goto check_1char_anchor; 799 if (s[1] == c1) 800 return (char*)s; 801 s += 3; 802 } 803 else 804 s += 2; 805 } 806 } 807 check_1char_anchor: /* One char and anchor! */ 808 if (SvTAIL(littlestr) && (*bigend == *little)) 809 return (char *)bigend; /* bigend is already decremented. */ 810 return NULL; 811 default: 812 break; /* Only lengths 0 1 and 2 have special-case code. */ 813 } 814 815 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ 816 s = bigend - littlelen; 817 if (s >= big && bigend[-1] == '\n' && *s == *little 818 /* Automatically of length > 2 */ 819 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) 820 { 821 return (char*)s; /* how sweet it is */ 822 } 823 if (s[1] == *little 824 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) 825 { 826 return (char*)s + 1; /* how sweet it is */ 827 } 828 return NULL; 829 } 830 if (!SvVALID(littlestr)) { 831 char * const b = ninstr((char*)big,(char*)bigend, 832 (char*)little, (char*)little + littlelen); 833 834 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ 835 /* Chop \n from littlestr: */ 836 s = bigend - littlelen + 1; 837 if (*s == *little 838 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) 839 { 840 return (char*)s; 841 } 842 return NULL; 843 } 844 return b; 845 } 846 847 /* Do actual FBM. */ 848 if (littlelen > (STRLEN)(bigend - big)) 849 return NULL; 850 851 { 852 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm); 853 const unsigned char * const table = (const unsigned char *) mg->mg_ptr; 854 const unsigned char *oldlittle; 855 856 --littlelen; /* Last char found by table lookup */ 857 858 s = big + littlelen; 859 little += littlelen; /* last char */ 860 oldlittle = little; 861 if (s < bigend) { 862 I32 tmp; 863 864 top2: 865 if ((tmp = table[*s])) { 866 if ((s += tmp) < bigend) 867 goto top2; 868 goto check_end; 869 } 870 else { /* less expensive than calling strncmp() */ 871 unsigned char * const olds = s; 872 873 tmp = littlelen; 874 875 while (tmp--) { 876 if (*--s == *--little) 877 continue; 878 s = olds + 1; /* here we pay the price for failure */ 879 little = oldlittle; 880 if (s < bigend) /* fake up continue to outer loop */ 881 goto top2; 882 goto check_end; 883 } 884 return (char *)s; 885 } 886 } 887 check_end: 888 if ( s == bigend 889 && SvTAIL(littlestr) 890 && memEQ((char *)(bigend - littlelen), 891 (char *)(oldlittle - littlelen), littlelen) ) 892 return (char*)bigend - littlelen; 893 return NULL; 894 } 895 } 896 897 char * 898 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) 899 { 900 dVAR; 901 PERL_ARGS_ASSERT_SCREAMINSTR; 902 PERL_UNUSED_ARG(bigstr); 903 PERL_UNUSED_ARG(littlestr); 904 PERL_UNUSED_ARG(start_shift); 905 PERL_UNUSED_ARG(end_shift); 906 PERL_UNUSED_ARG(old_posp); 907 PERL_UNUSED_ARG(last); 908 909 /* This function must only ever be called on a scalar with study magic, 910 but those do not happen any more. */ 911 Perl_croak(aTHX_ "panic: screaminstr"); 912 return NULL; 913 } 914 915 /* 916 =for apidoc foldEQ 917 918 Returns true if the leading len bytes of the strings s1 and s2 are the same 919 case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes 920 match themselves and their opposite case counterparts. Non-cased and non-ASCII 921 range bytes match only themselves. 922 923 =cut 924 */ 925 926 927 I32 928 Perl_foldEQ(const char *s1, const char *s2, I32 len) 929 { 930 const U8 *a = (const U8 *)s1; 931 const U8 *b = (const U8 *)s2; 932 933 PERL_ARGS_ASSERT_FOLDEQ; 934 935 assert(len >= 0); 936 937 while (len--) { 938 if (*a != *b && *a != PL_fold[*b]) 939 return 0; 940 a++,b++; 941 } 942 return 1; 943 } 944 I32 945 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len) 946 { 947 /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on 948 * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor 949 * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor 950 * does it check that the strings each have at least 'len' characters */ 951 952 const U8 *a = (const U8 *)s1; 953 const U8 *b = (const U8 *)s2; 954 955 PERL_ARGS_ASSERT_FOLDEQ_LATIN1; 956 957 assert(len >= 0); 958 959 while (len--) { 960 if (*a != *b && *a != PL_fold_latin1[*b]) { 961 return 0; 962 } 963 a++, b++; 964 } 965 return 1; 966 } 967 968 /* 969 =for apidoc foldEQ_locale 970 971 Returns true if the leading len bytes of the strings s1 and s2 are the same 972 case-insensitively in the current locale; false otherwise. 973 974 =cut 975 */ 976 977 I32 978 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len) 979 { 980 dVAR; 981 const U8 *a = (const U8 *)s1; 982 const U8 *b = (const U8 *)s2; 983 984 PERL_ARGS_ASSERT_FOLDEQ_LOCALE; 985 986 assert(len >= 0); 987 988 while (len--) { 989 if (*a != *b && *a != PL_fold_locale[*b]) 990 return 0; 991 a++,b++; 992 } 993 return 1; 994 } 995 996 /* copy a string to a safe spot */ 997 998 /* 999 =head1 Memory Management 1000 1001 =for apidoc savepv 1002 1003 Perl's version of C<strdup()>. Returns a pointer to a newly allocated 1004 string which is a duplicate of C<pv>. The size of the string is 1005 determined by C<strlen()>, which means it may not contain embedded C<NUL> 1006 characters and must have a trailing C<NUL>. The memory allocated for the new 1007 string can be freed with the C<Safefree()> function. 1008 1009 On some platforms, Windows for example, all allocated memory owned by a thread 1010 is deallocated when that thread ends. So if you need that not to happen, you 1011 need to use the shared memory functions, such as C<L</savesharedpv>>. 1012 1013 =cut 1014 */ 1015 1016 char * 1017 Perl_savepv(pTHX_ const char *pv) 1018 { 1019 PERL_UNUSED_CONTEXT; 1020 if (!pv) 1021 return NULL; 1022 else { 1023 char *newaddr; 1024 const STRLEN pvlen = strlen(pv)+1; 1025 Newx(newaddr, pvlen, char); 1026 return (char*)memcpy(newaddr, pv, pvlen); 1027 } 1028 } 1029 1030 /* same thing but with a known length */ 1031 1032 /* 1033 =for apidoc savepvn 1034 1035 Perl's version of what C<strndup()> would be if it existed. Returns a 1036 pointer to a newly allocated string which is a duplicate of the first 1037 C<len> bytes from C<pv>, plus a trailing 1038 C<NUL> byte. The memory allocated for 1039 the new string can be freed with the C<Safefree()> function. 1040 1041 On some platforms, Windows for example, all allocated memory owned by a thread 1042 is deallocated when that thread ends. So if you need that not to happen, you 1043 need to use the shared memory functions, such as C<L</savesharedpvn>>. 1044 1045 =cut 1046 */ 1047 1048 char * 1049 Perl_savepvn(pTHX_ const char *pv, I32 len) 1050 { 1051 char *newaddr; 1052 PERL_UNUSED_CONTEXT; 1053 1054 assert(len >= 0); 1055 1056 Newx(newaddr,len+1,char); 1057 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ 1058 if (pv) { 1059 /* might not be null terminated */ 1060 newaddr[len] = '\0'; 1061 return (char *) CopyD(pv,newaddr,len,char); 1062 } 1063 else { 1064 return (char *) ZeroD(newaddr,len+1,char); 1065 } 1066 } 1067 1068 /* 1069 =for apidoc savesharedpv 1070 1071 A version of C<savepv()> which allocates the duplicate string in memory 1072 which is shared between threads. 1073 1074 =cut 1075 */ 1076 char * 1077 Perl_savesharedpv(pTHX_ const char *pv) 1078 { 1079 char *newaddr; 1080 STRLEN pvlen; 1081 if (!pv) 1082 return NULL; 1083 1084 pvlen = strlen(pv)+1; 1085 newaddr = (char*)PerlMemShared_malloc(pvlen); 1086 if (!newaddr) { 1087 croak_no_mem(); 1088 } 1089 return (char*)memcpy(newaddr, pv, pvlen); 1090 } 1091 1092 /* 1093 =for apidoc savesharedpvn 1094 1095 A version of C<savepvn()> which allocates the duplicate string in memory 1096 which is shared between threads. (With the specific difference that a NULL 1097 pointer is not acceptable) 1098 1099 =cut 1100 */ 1101 char * 1102 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) 1103 { 1104 char *const newaddr = (char*)PerlMemShared_malloc(len + 1); 1105 1106 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */ 1107 1108 if (!newaddr) { 1109 croak_no_mem(); 1110 } 1111 newaddr[len] = '\0'; 1112 return (char*)memcpy(newaddr, pv, len); 1113 } 1114 1115 /* 1116 =for apidoc savesvpv 1117 1118 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from 1119 the passed in SV using C<SvPV()> 1120 1121 On some platforms, Windows for example, all allocated memory owned by a thread 1122 is deallocated when that thread ends. So if you need that not to happen, you 1123 need to use the shared memory functions, such as C<L</savesharedsvpv>>. 1124 1125 =cut 1126 */ 1127 1128 char * 1129 Perl_savesvpv(pTHX_ SV *sv) 1130 { 1131 STRLEN len; 1132 const char * const pv = SvPV_const(sv, len); 1133 char *newaddr; 1134 1135 PERL_ARGS_ASSERT_SAVESVPV; 1136 1137 ++len; 1138 Newx(newaddr,len,char); 1139 return (char *) CopyD(pv,newaddr,len,char); 1140 } 1141 1142 /* 1143 =for apidoc savesharedsvpv 1144 1145 A version of C<savesharedpv()> which allocates the duplicate string in 1146 memory which is shared between threads. 1147 1148 =cut 1149 */ 1150 1151 char * 1152 Perl_savesharedsvpv(pTHX_ SV *sv) 1153 { 1154 STRLEN len; 1155 const char * const pv = SvPV_const(sv, len); 1156 1157 PERL_ARGS_ASSERT_SAVESHAREDSVPV; 1158 1159 return savesharedpvn(pv, len); 1160 } 1161 1162 /* the SV for Perl_form() and mess() is not kept in an arena */ 1163 1164 STATIC SV * 1165 S_mess_alloc(pTHX) 1166 { 1167 dVAR; 1168 SV *sv; 1169 XPVMG *any; 1170 1171 if (PL_phase != PERL_PHASE_DESTRUCT) 1172 return newSVpvs_flags("", SVs_TEMP); 1173 1174 if (PL_mess_sv) 1175 return PL_mess_sv; 1176 1177 /* Create as PVMG now, to avoid any upgrading later */ 1178 Newx(sv, 1, SV); 1179 Newxz(any, 1, XPVMG); 1180 SvFLAGS(sv) = SVt_PVMG; 1181 SvANY(sv) = (void*)any; 1182 SvPV_set(sv, NULL); 1183 SvREFCNT(sv) = 1 << 30; /* practically infinite */ 1184 PL_mess_sv = sv; 1185 return sv; 1186 } 1187 1188 #if defined(PERL_IMPLICIT_CONTEXT) 1189 char * 1190 Perl_form_nocontext(const char* pat, ...) 1191 { 1192 dTHX; 1193 char *retval; 1194 va_list args; 1195 PERL_ARGS_ASSERT_FORM_NOCONTEXT; 1196 va_start(args, pat); 1197 retval = vform(pat, &args); 1198 va_end(args); 1199 return retval; 1200 } 1201 #endif /* PERL_IMPLICIT_CONTEXT */ 1202 1203 /* 1204 =head1 Miscellaneous Functions 1205 =for apidoc form 1206 1207 Takes a sprintf-style format pattern and conventional 1208 (non-SV) arguments and returns the formatted string. 1209 1210 (char *) Perl_form(pTHX_ const char* pat, ...) 1211 1212 can be used any place a string (char *) is required: 1213 1214 char * s = Perl_form("%d.%d",major,minor); 1215 1216 Uses a single private buffer so if you want to format several strings you 1217 must explicitly copy the earlier strings away (and free the copies when you 1218 are done). 1219 1220 =cut 1221 */ 1222 1223 char * 1224 Perl_form(pTHX_ const char* pat, ...) 1225 { 1226 char *retval; 1227 va_list args; 1228 PERL_ARGS_ASSERT_FORM; 1229 va_start(args, pat); 1230 retval = vform(pat, &args); 1231 va_end(args); 1232 return retval; 1233 } 1234 1235 char * 1236 Perl_vform(pTHX_ const char *pat, va_list *args) 1237 { 1238 SV * const sv = mess_alloc(); 1239 PERL_ARGS_ASSERT_VFORM; 1240 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 1241 return SvPVX(sv); 1242 } 1243 1244 /* 1245 =for apidoc Am|SV *|mess|const char *pat|... 1246 1247 Take a sprintf-style format pattern and argument list. These are used to 1248 generate a string message. If the message does not end with a newline, 1249 then it will be extended with some indication of the current location 1250 in the code, as described for L</mess_sv>. 1251 1252 Normally, the resulting message is returned in a new mortal SV. 1253 During global destruction a single SV may be shared between uses of 1254 this function. 1255 1256 =cut 1257 */ 1258 1259 #if defined(PERL_IMPLICIT_CONTEXT) 1260 SV * 1261 Perl_mess_nocontext(const char *pat, ...) 1262 { 1263 dTHX; 1264 SV *retval; 1265 va_list args; 1266 PERL_ARGS_ASSERT_MESS_NOCONTEXT; 1267 va_start(args, pat); 1268 retval = vmess(pat, &args); 1269 va_end(args); 1270 return retval; 1271 } 1272 #endif /* PERL_IMPLICIT_CONTEXT */ 1273 1274 SV * 1275 Perl_mess(pTHX_ const char *pat, ...) 1276 { 1277 SV *retval; 1278 va_list args; 1279 PERL_ARGS_ASSERT_MESS; 1280 va_start(args, pat); 1281 retval = vmess(pat, &args); 1282 va_end(args); 1283 return retval; 1284 } 1285 1286 const COP* 1287 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, 1288 bool opnext) 1289 { 1290 dVAR; 1291 /* Look for curop starting from o. cop is the last COP we've seen. */ 1292 /* opnext means that curop is actually the ->op_next of the op we are 1293 seeking. */ 1294 1295 PERL_ARGS_ASSERT_CLOSEST_COP; 1296 1297 if (!o || !curop || ( 1298 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop 1299 )) 1300 return cop; 1301 1302 if (o->op_flags & OPf_KIDS) { 1303 const OP *kid; 1304 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { 1305 const COP *new_cop; 1306 1307 /* If the OP_NEXTSTATE has been optimised away we can still use it 1308 * the get the file and line number. */ 1309 1310 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) 1311 cop = (const COP *)kid; 1312 1313 /* Keep searching, and return when we've found something. */ 1314 1315 new_cop = closest_cop(cop, kid, curop, opnext); 1316 if (new_cop) 1317 return new_cop; 1318 } 1319 } 1320 1321 /* Nothing found. */ 1322 1323 return NULL; 1324 } 1325 1326 /* 1327 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume 1328 1329 Expands a message, intended for the user, to include an indication of 1330 the current location in the code, if the message does not already appear 1331 to be complete. 1332 1333 C<basemsg> is the initial message or object. If it is a reference, it 1334 will be used as-is and will be the result of this function. Otherwise it 1335 is used as a string, and if it already ends with a newline, it is taken 1336 to be complete, and the result of this function will be the same string. 1337 If the message does not end with a newline, then a segment such as C<at 1338 foo.pl line 37> will be appended, and possibly other clauses indicating 1339 the current state of execution. The resulting message will end with a 1340 dot and a newline. 1341 1342 Normally, the resulting message is returned in a new mortal SV. 1343 During global destruction a single SV may be shared between uses of this 1344 function. If C<consume> is true, then the function is permitted (but not 1345 required) to modify and return C<basemsg> instead of allocating a new SV. 1346 1347 =cut 1348 */ 1349 1350 SV * 1351 Perl_mess_sv(pTHX_ SV *basemsg, bool consume) 1352 { 1353 dVAR; 1354 SV *sv; 1355 1356 PERL_ARGS_ASSERT_MESS_SV; 1357 1358 if (SvROK(basemsg)) { 1359 if (consume) { 1360 sv = basemsg; 1361 } 1362 else { 1363 sv = mess_alloc(); 1364 sv_setsv(sv, basemsg); 1365 } 1366 return sv; 1367 } 1368 1369 if (SvPOK(basemsg) && consume) { 1370 sv = basemsg; 1371 } 1372 else { 1373 sv = mess_alloc(); 1374 sv_copypv(sv, basemsg); 1375 } 1376 1377 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { 1378 /* 1379 * Try and find the file and line for PL_op. This will usually be 1380 * PL_curcop, but it might be a cop that has been optimised away. We 1381 * can try to find such a cop by searching through the optree starting 1382 * from the sibling of PL_curcop. 1383 */ 1384 1385 const COP *cop = 1386 closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE); 1387 if (!cop) 1388 cop = PL_curcop; 1389 1390 if (CopLINE(cop)) 1391 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, 1392 OutCopFILE(cop), (IV)CopLINE(cop)); 1393 /* Seems that GvIO() can be untrustworthy during global destruction. */ 1394 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO) 1395 && IoLINES(GvIOp(PL_last_in_gv))) 1396 { 1397 STRLEN l; 1398 const bool line_mode = (RsSIMPLE(PL_rs) && 1399 *SvPV_const(PL_rs,l) == '\n' && l == 1); 1400 Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf, 1401 SVfARG(PL_last_in_gv == PL_argvgv 1402 ? &PL_sv_no 1403 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))), 1404 line_mode ? "line" : "chunk", 1405 (IV)IoLINES(GvIOp(PL_last_in_gv))); 1406 } 1407 if (PL_phase == PERL_PHASE_DESTRUCT) 1408 sv_catpvs(sv, " during global destruction"); 1409 sv_catpvs(sv, ".\n"); 1410 } 1411 return sv; 1412 } 1413 1414 /* 1415 =for apidoc Am|SV *|vmess|const char *pat|va_list *args 1416 1417 C<pat> and C<args> are a sprintf-style format pattern and encapsulated 1418 argument list. These are used to generate a string message. If the 1419 message does not end with a newline, then it will be extended with 1420 some indication of the current location in the code, as described for 1421 L</mess_sv>. 1422 1423 Normally, the resulting message is returned in a new mortal SV. 1424 During global destruction a single SV may be shared between uses of 1425 this function. 1426 1427 =cut 1428 */ 1429 1430 SV * 1431 Perl_vmess(pTHX_ const char *pat, va_list *args) 1432 { 1433 dVAR; 1434 SV * const sv = mess_alloc(); 1435 1436 PERL_ARGS_ASSERT_VMESS; 1437 1438 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); 1439 return mess_sv(sv, 1); 1440 } 1441 1442 void 1443 Perl_write_to_stderr(pTHX_ SV* msv) 1444 { 1445 dVAR; 1446 IO *io; 1447 MAGIC *mg; 1448 1449 PERL_ARGS_ASSERT_WRITE_TO_STDERR; 1450 1451 if (PL_stderrgv && SvREFCNT(PL_stderrgv) 1452 && (io = GvIO(PL_stderrgv)) 1453 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 1454 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT), 1455 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv); 1456 else { 1457 PerlIO * const serr = Perl_error_log; 1458 1459 do_print(msv, serr); 1460 (void)PerlIO_flush(serr); 1461 } 1462 } 1463 1464 /* 1465 =head1 Warning and Dieing 1466 */ 1467 1468 /* Common code used in dieing and warning */ 1469 1470 STATIC SV * 1471 S_with_queued_errors(pTHX_ SV *ex) 1472 { 1473 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS; 1474 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) { 1475 sv_catsv(PL_errors, ex); 1476 ex = sv_mortalcopy(PL_errors); 1477 SvCUR_set(PL_errors, 0); 1478 } 1479 return ex; 1480 } 1481 1482 STATIC bool 1483 S_invoke_exception_hook(pTHX_ SV *ex, bool warn) 1484 { 1485 dVAR; 1486 HV *stash; 1487 GV *gv; 1488 CV *cv; 1489 SV **const hook = warn ? &PL_warnhook : &PL_diehook; 1490 /* sv_2cv might call Perl_croak() or Perl_warner() */ 1491 SV * const oldhook = *hook; 1492 1493 if (!oldhook) 1494 return FALSE; 1495 1496 ENTER; 1497 SAVESPTR(*hook); 1498 *hook = NULL; 1499 cv = sv_2cv(oldhook, &stash, &gv, 0); 1500 LEAVE; 1501 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1502 dSP; 1503 SV *exarg; 1504 1505 ENTER; 1506 save_re_context(); 1507 if (warn) { 1508 SAVESPTR(*hook); 1509 *hook = NULL; 1510 } 1511 exarg = newSVsv(ex); 1512 SvREADONLY_on(exarg); 1513 SAVEFREESV(exarg); 1514 1515 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK); 1516 PUSHMARK(SP); 1517 XPUSHs(exarg); 1518 PUTBACK; 1519 call_sv(MUTABLE_SV(cv), G_DISCARD); 1520 POPSTACK; 1521 LEAVE; 1522 return TRUE; 1523 } 1524 return FALSE; 1525 } 1526 1527 /* 1528 =for apidoc Am|OP *|die_sv|SV *baseex 1529 1530 Behaves the same as L</croak_sv>, except for the return type. 1531 It should be used only where the C<OP *> return type is required. 1532 The function never actually returns. 1533 1534 =cut 1535 */ 1536 1537 OP * 1538 Perl_die_sv(pTHX_ SV *baseex) 1539 { 1540 PERL_ARGS_ASSERT_DIE_SV; 1541 croak_sv(baseex); 1542 assert(0); /* NOTREACHED */ 1543 return NULL; 1544 } 1545 1546 /* 1547 =for apidoc Am|OP *|die|const char *pat|... 1548 1549 Behaves the same as L</croak>, except for the return type. 1550 It should be used only where the C<OP *> return type is required. 1551 The function never actually returns. 1552 1553 =cut 1554 */ 1555 1556 #if defined(PERL_IMPLICIT_CONTEXT) 1557 OP * 1558 Perl_die_nocontext(const char* pat, ...) 1559 { 1560 dTHX; 1561 va_list args; 1562 va_start(args, pat); 1563 vcroak(pat, &args); 1564 assert(0); /* NOTREACHED */ 1565 va_end(args); 1566 return NULL; 1567 } 1568 #endif /* PERL_IMPLICIT_CONTEXT */ 1569 1570 OP * 1571 Perl_die(pTHX_ const char* pat, ...) 1572 { 1573 va_list args; 1574 va_start(args, pat); 1575 vcroak(pat, &args); 1576 assert(0); /* NOTREACHED */ 1577 va_end(args); 1578 return NULL; 1579 } 1580 1581 /* 1582 =for apidoc Am|void|croak_sv|SV *baseex 1583 1584 This is an XS interface to Perl's C<die> function. 1585 1586 C<baseex> is the error message or object. If it is a reference, it 1587 will be used as-is. Otherwise it is used as a string, and if it does 1588 not end with a newline then it will be extended with some indication of 1589 the current location in the code, as described for L</mess_sv>. 1590 1591 The error message or object will be used as an exception, by default 1592 returning control to the nearest enclosing C<eval>, but subject to 1593 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv> 1594 function never returns normally. 1595 1596 To die with a simple string message, the L</croak> function may be 1597 more convenient. 1598 1599 =cut 1600 */ 1601 1602 void 1603 Perl_croak_sv(pTHX_ SV *baseex) 1604 { 1605 SV *ex = with_queued_errors(mess_sv(baseex, 0)); 1606 PERL_ARGS_ASSERT_CROAK_SV; 1607 invoke_exception_hook(ex, FALSE); 1608 die_unwind(ex); 1609 } 1610 1611 /* 1612 =for apidoc Am|void|vcroak|const char *pat|va_list *args 1613 1614 This is an XS interface to Perl's C<die> function. 1615 1616 C<pat> and C<args> are a sprintf-style format pattern and encapsulated 1617 argument list. These are used to generate a string message. If the 1618 message does not end with a newline, then it will be extended with 1619 some indication of the current location in the code, as described for 1620 L</mess_sv>. 1621 1622 The error message will be used as an exception, by default 1623 returning control to the nearest enclosing C<eval>, but subject to 1624 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak> 1625 function never returns normally. 1626 1627 For historical reasons, if C<pat> is null then the contents of C<ERRSV> 1628 (C<$@>) will be used as an error message or object instead of building an 1629 error message from arguments. If you want to throw a non-string object, 1630 or build an error message in an SV yourself, it is preferable to use 1631 the L</croak_sv> function, which does not involve clobbering C<ERRSV>. 1632 1633 =cut 1634 */ 1635 1636 void 1637 Perl_vcroak(pTHX_ const char* pat, va_list *args) 1638 { 1639 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0)); 1640 invoke_exception_hook(ex, FALSE); 1641 die_unwind(ex); 1642 } 1643 1644 /* 1645 =for apidoc Am|void|croak|const char *pat|... 1646 1647 This is an XS interface to Perl's C<die> function. 1648 1649 Take a sprintf-style format pattern and argument list. These are used to 1650 generate a string message. If the message does not end with a newline, 1651 then it will be extended with some indication of the current location 1652 in the code, as described for L</mess_sv>. 1653 1654 The error message will be used as an exception, by default 1655 returning control to the nearest enclosing C<eval>, but subject to 1656 modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak> 1657 function never returns normally. 1658 1659 For historical reasons, if C<pat> is null then the contents of C<ERRSV> 1660 (C<$@>) will be used as an error message or object instead of building an 1661 error message from arguments. If you want to throw a non-string object, 1662 or build an error message in an SV yourself, it is preferable to use 1663 the L</croak_sv> function, which does not involve clobbering C<ERRSV>. 1664 1665 =cut 1666 */ 1667 1668 #if defined(PERL_IMPLICIT_CONTEXT) 1669 void 1670 Perl_croak_nocontext(const char *pat, ...) 1671 { 1672 dTHX; 1673 va_list args; 1674 va_start(args, pat); 1675 vcroak(pat, &args); 1676 assert(0); /* NOTREACHED */ 1677 va_end(args); 1678 } 1679 #endif /* PERL_IMPLICIT_CONTEXT */ 1680 1681 void 1682 Perl_croak(pTHX_ const char *pat, ...) 1683 { 1684 va_list args; 1685 va_start(args, pat); 1686 vcroak(pat, &args); 1687 assert(0); /* NOTREACHED */ 1688 va_end(args); 1689 } 1690 1691 /* 1692 =for apidoc Am|void|croak_no_modify 1693 1694 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates 1695 terser object code than using C<Perl_croak>. Less code used on exception code 1696 paths reduces CPU cache pressure. 1697 1698 =cut 1699 */ 1700 1701 void 1702 Perl_croak_no_modify(void) 1703 { 1704 Perl_croak_nocontext( "%s", PL_no_modify); 1705 } 1706 1707 /* does not return, used in util.c perlio.c and win32.c 1708 This is typically called when malloc returns NULL. 1709 */ 1710 void 1711 Perl_croak_no_mem(void) 1712 { 1713 dTHX; 1714 /* Can't use PerlIO to write as it allocates memory */ 1715 PERL_UNUSED_RESULT(PerlLIO_write(PerlIO_fileno(Perl_error_log), 1716 PL_no_mem, sizeof(PL_no_mem)-1)); 1717 my_exit(1); 1718 } 1719 1720 /* does not return, used only in POPSTACK */ 1721 void 1722 Perl_croak_popstack(void) 1723 { 1724 dTHX; 1725 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n"); 1726 my_exit(1); 1727 } 1728 1729 /* 1730 =for apidoc Am|void|warn_sv|SV *baseex 1731 1732 This is an XS interface to Perl's C<warn> function. 1733 1734 C<baseex> is the error message or object. If it is a reference, it 1735 will be used as-is. Otherwise it is used as a string, and if it does 1736 not end with a newline then it will be extended with some indication of 1737 the current location in the code, as described for L</mess_sv>. 1738 1739 The error message or object will by default be written to standard error, 1740 but this is subject to modification by a C<$SIG{__WARN__}> handler. 1741 1742 To warn with a simple string message, the L</warn> function may be 1743 more convenient. 1744 1745 =cut 1746 */ 1747 1748 void 1749 Perl_warn_sv(pTHX_ SV *baseex) 1750 { 1751 SV *ex = mess_sv(baseex, 0); 1752 PERL_ARGS_ASSERT_WARN_SV; 1753 if (!invoke_exception_hook(ex, TRUE)) 1754 write_to_stderr(ex); 1755 } 1756 1757 /* 1758 =for apidoc Am|void|vwarn|const char *pat|va_list *args 1759 1760 This is an XS interface to Perl's C<warn> function. 1761 1762 C<pat> and C<args> are a sprintf-style format pattern and encapsulated 1763 argument list. These are used to generate a string message. If the 1764 message does not end with a newline, then it will be extended with 1765 some indication of the current location in the code, as described for 1766 L</mess_sv>. 1767 1768 The error message or object will by default be written to standard error, 1769 but this is subject to modification by a C<$SIG{__WARN__}> handler. 1770 1771 Unlike with L</vcroak>, C<pat> is not permitted to be null. 1772 1773 =cut 1774 */ 1775 1776 void 1777 Perl_vwarn(pTHX_ const char* pat, va_list *args) 1778 { 1779 SV *ex = vmess(pat, args); 1780 PERL_ARGS_ASSERT_VWARN; 1781 if (!invoke_exception_hook(ex, TRUE)) 1782 write_to_stderr(ex); 1783 } 1784 1785 /* 1786 =for apidoc Am|void|warn|const char *pat|... 1787 1788 This is an XS interface to Perl's C<warn> function. 1789 1790 Take a sprintf-style format pattern and argument list. These are used to 1791 generate a string message. If the message does not end with a newline, 1792 then it will be extended with some indication of the current location 1793 in the code, as described for L</mess_sv>. 1794 1795 The error message or object will by default be written to standard error, 1796 but this is subject to modification by a C<$SIG{__WARN__}> handler. 1797 1798 Unlike with L</croak>, C<pat> is not permitted to be null. 1799 1800 =cut 1801 */ 1802 1803 #if defined(PERL_IMPLICIT_CONTEXT) 1804 void 1805 Perl_warn_nocontext(const char *pat, ...) 1806 { 1807 dTHX; 1808 va_list args; 1809 PERL_ARGS_ASSERT_WARN_NOCONTEXT; 1810 va_start(args, pat); 1811 vwarn(pat, &args); 1812 va_end(args); 1813 } 1814 #endif /* PERL_IMPLICIT_CONTEXT */ 1815 1816 void 1817 Perl_warn(pTHX_ const char *pat, ...) 1818 { 1819 va_list args; 1820 PERL_ARGS_ASSERT_WARN; 1821 va_start(args, pat); 1822 vwarn(pat, &args); 1823 va_end(args); 1824 } 1825 1826 #if defined(PERL_IMPLICIT_CONTEXT) 1827 void 1828 Perl_warner_nocontext(U32 err, const char *pat, ...) 1829 { 1830 dTHX; 1831 va_list args; 1832 PERL_ARGS_ASSERT_WARNER_NOCONTEXT; 1833 va_start(args, pat); 1834 vwarner(err, pat, &args); 1835 va_end(args); 1836 } 1837 #endif /* PERL_IMPLICIT_CONTEXT */ 1838 1839 void 1840 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...) 1841 { 1842 PERL_ARGS_ASSERT_CK_WARNER_D; 1843 1844 if (Perl_ckwarn_d(aTHX_ err)) { 1845 va_list args; 1846 va_start(args, pat); 1847 vwarner(err, pat, &args); 1848 va_end(args); 1849 } 1850 } 1851 1852 void 1853 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) 1854 { 1855 PERL_ARGS_ASSERT_CK_WARNER; 1856 1857 if (Perl_ckwarn(aTHX_ err)) { 1858 va_list args; 1859 va_start(args, pat); 1860 vwarner(err, pat, &args); 1861 va_end(args); 1862 } 1863 } 1864 1865 void 1866 Perl_warner(pTHX_ U32 err, const char* pat,...) 1867 { 1868 va_list args; 1869 PERL_ARGS_ASSERT_WARNER; 1870 va_start(args, pat); 1871 vwarner(err, pat, &args); 1872 va_end(args); 1873 } 1874 1875 void 1876 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) 1877 { 1878 dVAR; 1879 PERL_ARGS_ASSERT_VWARNER; 1880 if ( 1881 (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) && 1882 !(PL_in_eval & EVAL_KEEPERR) 1883 ) { 1884 SV * const msv = vmess(pat, args); 1885 1886 invoke_exception_hook(msv, FALSE); 1887 die_unwind(msv); 1888 } 1889 else { 1890 Perl_vwarn(aTHX_ pat, args); 1891 } 1892 } 1893 1894 /* implements the ckWARN? macros */ 1895 1896 bool 1897 Perl_ckwarn(pTHX_ U32 w) 1898 { 1899 dVAR; 1900 /* If lexical warnings have not been set, use $^W. */ 1901 if (isLEXWARN_off) 1902 return PL_dowarn & G_WARN_ON; 1903 1904 return ckwarn_common(w); 1905 } 1906 1907 /* implements the ckWARN?_d macro */ 1908 1909 bool 1910 Perl_ckwarn_d(pTHX_ U32 w) 1911 { 1912 dVAR; 1913 /* If lexical warnings have not been set then default classes warn. */ 1914 if (isLEXWARN_off) 1915 return TRUE; 1916 1917 return ckwarn_common(w); 1918 } 1919 1920 static bool 1921 S_ckwarn_common(pTHX_ U32 w) 1922 { 1923 if (PL_curcop->cop_warnings == pWARN_ALL) 1924 return TRUE; 1925 1926 if (PL_curcop->cop_warnings == pWARN_NONE) 1927 return FALSE; 1928 1929 /* Check the assumption that at least the first slot is non-zero. */ 1930 assert(unpackWARN1(w)); 1931 1932 /* Check the assumption that it is valid to stop as soon as a zero slot is 1933 seen. */ 1934 if (!unpackWARN2(w)) { 1935 assert(!unpackWARN3(w)); 1936 assert(!unpackWARN4(w)); 1937 } else if (!unpackWARN3(w)) { 1938 assert(!unpackWARN4(w)); 1939 } 1940 1941 /* Right, dealt with all the special cases, which are implemented as non- 1942 pointers, so there is a pointer to a real warnings mask. */ 1943 do { 1944 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))) 1945 return TRUE; 1946 } while (w >>= WARNshift); 1947 1948 return FALSE; 1949 } 1950 1951 /* Set buffer=NULL to get a new one. */ 1952 STRLEN * 1953 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, 1954 STRLEN size) { 1955 const MEM_SIZE len_wanted = 1956 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize); 1957 PERL_UNUSED_CONTEXT; 1958 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD; 1959 1960 buffer = (STRLEN*) 1961 (specialWARN(buffer) ? 1962 PerlMemShared_malloc(len_wanted) : 1963 PerlMemShared_realloc(buffer, len_wanted)); 1964 buffer[0] = size; 1965 Copy(bits, (buffer + 1), size, char); 1966 if (size < WARNsize) 1967 Zero((char *)(buffer + 1) + size, WARNsize - size, char); 1968 return buffer; 1969 } 1970 1971 /* since we've already done strlen() for both nam and val 1972 * we can use that info to make things faster than 1973 * sprintf(s, "%s=%s", nam, val) 1974 */ 1975 #define my_setenv_format(s, nam, nlen, val, vlen) \ 1976 Copy(nam, s, nlen, char); \ 1977 *(s+nlen) = '='; \ 1978 Copy(val, s+(nlen+1), vlen, char); \ 1979 *(s+(nlen+1+vlen)) = '\0' 1980 1981 #ifdef USE_ENVIRON_ARRAY 1982 /* VMS' my_setenv() is in vms.c */ 1983 #if !defined(WIN32) && !defined(NETWARE) 1984 void 1985 Perl_my_setenv(pTHX_ const char *nam, const char *val) 1986 { 1987 dVAR; 1988 #ifdef USE_ITHREADS 1989 /* only parent thread can modify process environment */ 1990 if (PL_curinterp == aTHX) 1991 #endif 1992 { 1993 #ifndef PERL_USE_SAFE_PUTENV 1994 if (!PL_use_safe_putenv) { 1995 /* most putenv()s leak, so we manipulate environ directly */ 1996 I32 i; 1997 const I32 len = strlen(nam); 1998 int nlen, vlen; 1999 2000 /* where does it go? */ 2001 for (i = 0; environ[i]; i++) { 2002 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') 2003 break; 2004 } 2005 2006 if (environ == PL_origenviron) { /* need we copy environment? */ 2007 I32 j; 2008 I32 max; 2009 char **tmpenv; 2010 2011 max = i; 2012 while (environ[max]) 2013 max++; 2014 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); 2015 for (j=0; j<max; j++) { /* copy environment */ 2016 const int len = strlen(environ[j]); 2017 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char)); 2018 Copy(environ[j], tmpenv[j], len+1, char); 2019 } 2020 tmpenv[max] = NULL; 2021 environ = tmpenv; /* tell exec where it is now */ 2022 } 2023 if (!val) { 2024 safesysfree(environ[i]); 2025 while (environ[i]) { 2026 environ[i] = environ[i+1]; 2027 i++; 2028 } 2029 return; 2030 } 2031 if (!environ[i]) { /* does not exist yet */ 2032 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*)); 2033 environ[i+1] = NULL; /* make sure it's null terminated */ 2034 } 2035 else 2036 safesysfree(environ[i]); 2037 nlen = strlen(nam); 2038 vlen = strlen(val); 2039 2040 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char)); 2041 /* all that work just for this */ 2042 my_setenv_format(environ[i], nam, nlen, val, vlen); 2043 } else { 2044 # endif 2045 /* This next branch should only be called #if defined(HAS_SETENV), but 2046 Configure doesn't test for that yet. For Solaris, setenv() and unsetenv() 2047 were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient. 2048 */ 2049 # if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) 2050 # if defined(HAS_UNSETENV) 2051 if (val == NULL) { 2052 (void)unsetenv(nam); 2053 } else { 2054 (void)setenv(nam, val, 1); 2055 } 2056 # else /* ! HAS_UNSETENV */ 2057 (void)setenv(nam, val, 1); 2058 # endif /* HAS_UNSETENV */ 2059 # else 2060 # if defined(HAS_UNSETENV) 2061 if (val == NULL) { 2062 if (environ) /* old glibc can crash with null environ */ 2063 (void)unsetenv(nam); 2064 } else { 2065 const int nlen = strlen(nam); 2066 const int vlen = strlen(val); 2067 char * const new_env = 2068 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); 2069 my_setenv_format(new_env, nam, nlen, val, vlen); 2070 (void)putenv(new_env); 2071 } 2072 # else /* ! HAS_UNSETENV */ 2073 char *new_env; 2074 const int nlen = strlen(nam); 2075 int vlen; 2076 if (!val) { 2077 val = ""; 2078 } 2079 vlen = strlen(val); 2080 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); 2081 /* all that work just for this */ 2082 my_setenv_format(new_env, nam, nlen, val, vlen); 2083 (void)putenv(new_env); 2084 # endif /* HAS_UNSETENV */ 2085 # endif /* __CYGWIN__ */ 2086 #ifndef PERL_USE_SAFE_PUTENV 2087 } 2088 #endif 2089 } 2090 } 2091 2092 #else /* WIN32 || NETWARE */ 2093 2094 void 2095 Perl_my_setenv(pTHX_ const char *nam, const char *val) 2096 { 2097 dVAR; 2098 char *envstr; 2099 const int nlen = strlen(nam); 2100 int vlen; 2101 2102 if (!val) { 2103 val = ""; 2104 } 2105 vlen = strlen(val); 2106 Newx(envstr, nlen+vlen+2, char); 2107 my_setenv_format(envstr, nam, nlen, val, vlen); 2108 (void)PerlEnv_putenv(envstr); 2109 Safefree(envstr); 2110 } 2111 2112 #endif /* WIN32 || NETWARE */ 2113 2114 #endif /* !VMS */ 2115 2116 #ifdef UNLINK_ALL_VERSIONS 2117 I32 2118 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ 2119 { 2120 I32 retries = 0; 2121 2122 PERL_ARGS_ASSERT_UNLNK; 2123 2124 while (PerlLIO_unlink(f) >= 0) 2125 retries++; 2126 return retries ? 0 : -1; 2127 } 2128 #endif 2129 2130 /* this is a drop-in replacement for bcopy() */ 2131 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) 2132 char * 2133 Perl_my_bcopy(const char *from, char *to, I32 len) 2134 { 2135 char * const retval = to; 2136 2137 PERL_ARGS_ASSERT_MY_BCOPY; 2138 2139 assert(len >= 0); 2140 2141 if (from - to >= 0) { 2142 while (len--) 2143 *to++ = *from++; 2144 } 2145 else { 2146 to += len; 2147 from += len; 2148 while (len--) 2149 *(--to) = *(--from); 2150 } 2151 return retval; 2152 } 2153 #endif 2154 2155 /* this is a drop-in replacement for memset() */ 2156 #ifndef HAS_MEMSET 2157 void * 2158 Perl_my_memset(char *loc, I32 ch, I32 len) 2159 { 2160 char * const retval = loc; 2161 2162 PERL_ARGS_ASSERT_MY_MEMSET; 2163 2164 assert(len >= 0); 2165 2166 while (len--) 2167 *loc++ = ch; 2168 return retval; 2169 } 2170 #endif 2171 2172 /* this is a drop-in replacement for bzero() */ 2173 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) 2174 char * 2175 Perl_my_bzero(char *loc, I32 len) 2176 { 2177 char * const retval = loc; 2178 2179 PERL_ARGS_ASSERT_MY_BZERO; 2180 2181 assert(len >= 0); 2182 2183 while (len--) 2184 *loc++ = 0; 2185 return retval; 2186 } 2187 #endif 2188 2189 /* this is a drop-in replacement for memcmp() */ 2190 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) 2191 I32 2192 Perl_my_memcmp(const char *s1, const char *s2, I32 len) 2193 { 2194 const U8 *a = (const U8 *)s1; 2195 const U8 *b = (const U8 *)s2; 2196 I32 tmp; 2197 2198 PERL_ARGS_ASSERT_MY_MEMCMP; 2199 2200 assert(len >= 0); 2201 2202 while (len--) { 2203 if ((tmp = *a++ - *b++)) 2204 return tmp; 2205 } 2206 return 0; 2207 } 2208 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ 2209 2210 #ifndef HAS_VPRINTF 2211 /* This vsprintf replacement should generally never get used, since 2212 vsprintf was available in both System V and BSD 2.11. (There may 2213 be some cross-compilation or embedded set-ups where it is needed, 2214 however.) 2215 2216 If you encounter a problem in this function, it's probably a symptom 2217 that Configure failed to detect your system's vprintf() function. 2218 See the section on "item vsprintf" in the INSTALL file. 2219 2220 This version may compile on systems with BSD-ish <stdio.h>, 2221 but probably won't on others. 2222 */ 2223 2224 #ifdef USE_CHAR_VSPRINTF 2225 char * 2226 #else 2227 int 2228 #endif 2229 vsprintf(char *dest, const char *pat, void *args) 2230 { 2231 FILE fakebuf; 2232 2233 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) 2234 FILE_ptr(&fakebuf) = (STDCHAR *) dest; 2235 FILE_cnt(&fakebuf) = 32767; 2236 #else 2237 /* These probably won't compile -- If you really need 2238 this, you'll have to figure out some other method. */ 2239 fakebuf._ptr = dest; 2240 fakebuf._cnt = 32767; 2241 #endif 2242 #ifndef _IOSTRG 2243 #define _IOSTRG 0 2244 #endif 2245 fakebuf._flag = _IOWRT|_IOSTRG; 2246 _doprnt(pat, args, &fakebuf); /* what a kludge */ 2247 #if defined(STDIO_PTR_LVALUE) 2248 *(FILE_ptr(&fakebuf)++) = '\0'; 2249 #else 2250 /* PerlIO has probably #defined away fputc, but we want it here. */ 2251 # ifdef fputc 2252 # undef fputc /* XXX Should really restore it later */ 2253 # endif 2254 (void)fputc('\0', &fakebuf); 2255 #endif 2256 #ifdef USE_CHAR_VSPRINTF 2257 return(dest); 2258 #else 2259 return 0; /* perl doesn't use return value */ 2260 #endif 2261 } 2262 2263 #endif /* HAS_VPRINTF */ 2264 2265 PerlIO * 2266 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) 2267 { 2268 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) 2269 dVAR; 2270 int p[2]; 2271 I32 This, that; 2272 Pid_t pid; 2273 SV *sv; 2274 I32 did_pipes = 0; 2275 int pp[2]; 2276 2277 PERL_ARGS_ASSERT_MY_POPEN_LIST; 2278 2279 PERL_FLUSHALL_FOR_CHILD; 2280 This = (*mode == 'w'); 2281 that = !This; 2282 if (TAINTING_get) { 2283 taint_env(); 2284 taint_proper("Insecure %s%s", "EXEC"); 2285 } 2286 if (PerlProc_pipe(p) < 0) 2287 return NULL; 2288 /* Try for another pipe pair for error return */ 2289 if (PerlProc_pipe(pp) >= 0) 2290 did_pipes = 1; 2291 while ((pid = PerlProc_fork()) < 0) { 2292 if (errno != EAGAIN) { 2293 PerlLIO_close(p[This]); 2294 PerlLIO_close(p[that]); 2295 if (did_pipes) { 2296 PerlLIO_close(pp[0]); 2297 PerlLIO_close(pp[1]); 2298 } 2299 return NULL; 2300 } 2301 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); 2302 sleep(5); 2303 } 2304 if (pid == 0) { 2305 /* Child */ 2306 #undef THIS 2307 #undef THAT 2308 #define THIS that 2309 #define THAT This 2310 /* Close parent's end of error status pipe (if any) */ 2311 if (did_pipes) { 2312 PerlLIO_close(pp[0]); 2313 #if defined(HAS_FCNTL) && defined(F_SETFD) 2314 /* Close error pipe automatically if exec works */ 2315 fcntl(pp[1], F_SETFD, FD_CLOEXEC); 2316 #endif 2317 } 2318 /* Now dup our end of _the_ pipe to right position */ 2319 if (p[THIS] != (*mode == 'r')) { 2320 PerlLIO_dup2(p[THIS], *mode == 'r'); 2321 PerlLIO_close(p[THIS]); 2322 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 2323 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ 2324 } 2325 else 2326 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ 2327 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2328 /* No automatic close - do it by hand */ 2329 # ifndef NOFILE 2330 # define NOFILE 20 2331 # endif 2332 { 2333 int fd; 2334 2335 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { 2336 if (fd != pp[1]) 2337 PerlLIO_close(fd); 2338 } 2339 } 2340 #endif 2341 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes); 2342 PerlProc__exit(1); 2343 #undef THIS 2344 #undef THAT 2345 } 2346 /* Parent */ 2347 do_execfree(); /* free any memory malloced by child on fork */ 2348 if (did_pipes) 2349 PerlLIO_close(pp[1]); 2350 /* Keep the lower of the two fd numbers */ 2351 if (p[that] < p[This]) { 2352 PerlLIO_dup2(p[This], p[that]); 2353 PerlLIO_close(p[This]); 2354 p[This] = p[that]; 2355 } 2356 else 2357 PerlLIO_close(p[that]); /* close child's end of pipe */ 2358 2359 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2360 SvUPGRADE(sv,SVt_IV); 2361 SvIV_set(sv, pid); 2362 PL_forkprocess = pid; 2363 /* If we managed to get status pipe check for exec fail */ 2364 if (did_pipes && pid > 0) { 2365 int errkid; 2366 unsigned n = 0; 2367 SSize_t n1; 2368 2369 while (n < sizeof(int)) { 2370 n1 = PerlLIO_read(pp[0], 2371 (void*)(((char*)&errkid)+n), 2372 (sizeof(int)) - n); 2373 if (n1 <= 0) 2374 break; 2375 n += n1; 2376 } 2377 PerlLIO_close(pp[0]); 2378 did_pipes = 0; 2379 if (n) { /* Error */ 2380 int pid2, status; 2381 PerlLIO_close(p[This]); 2382 if (n != sizeof(int)) 2383 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); 2384 do { 2385 pid2 = wait4pid(pid, &status, 0); 2386 } while (pid2 == -1 && errno == EINTR); 2387 errno = errkid; /* Propagate errno from kid */ 2388 return NULL; 2389 } 2390 } 2391 if (did_pipes) 2392 PerlLIO_close(pp[0]); 2393 return PerlIO_fdopen(p[This], mode); 2394 #else 2395 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */ 2396 return my_syspopen4(aTHX_ NULL, mode, n, args); 2397 # else 2398 Perl_croak(aTHX_ "List form of piped open not implemented"); 2399 return (PerlIO *) NULL; 2400 # endif 2401 #endif 2402 } 2403 2404 /* VMS' my_popen() is in VMS.c, same with OS/2. */ 2405 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) 2406 PerlIO * 2407 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2408 { 2409 dVAR; 2410 int p[2]; 2411 I32 This, that; 2412 Pid_t pid; 2413 SV *sv; 2414 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); 2415 I32 did_pipes = 0; 2416 int pp[2]; 2417 2418 PERL_ARGS_ASSERT_MY_POPEN; 2419 2420 PERL_FLUSHALL_FOR_CHILD; 2421 #ifdef OS2 2422 if (doexec) { 2423 return my_syspopen(aTHX_ cmd,mode); 2424 } 2425 #endif 2426 This = (*mode == 'w'); 2427 that = !This; 2428 if (doexec && TAINTING_get) { 2429 taint_env(); 2430 taint_proper("Insecure %s%s", "EXEC"); 2431 } 2432 if (PerlProc_pipe(p) < 0) 2433 return NULL; 2434 if (doexec && PerlProc_pipe(pp) >= 0) 2435 did_pipes = 1; 2436 while ((pid = PerlProc_fork()) < 0) { 2437 if (errno != EAGAIN) { 2438 PerlLIO_close(p[This]); 2439 PerlLIO_close(p[that]); 2440 if (did_pipes) { 2441 PerlLIO_close(pp[0]); 2442 PerlLIO_close(pp[1]); 2443 } 2444 if (!doexec) 2445 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); 2446 return NULL; 2447 } 2448 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); 2449 sleep(5); 2450 } 2451 if (pid == 0) { 2452 2453 #undef THIS 2454 #undef THAT 2455 #define THIS that 2456 #define THAT This 2457 if (did_pipes) { 2458 PerlLIO_close(pp[0]); 2459 #if defined(HAS_FCNTL) && defined(F_SETFD) 2460 fcntl(pp[1], F_SETFD, FD_CLOEXEC); 2461 #endif 2462 } 2463 if (p[THIS] != (*mode == 'r')) { 2464 PerlLIO_dup2(p[THIS], *mode == 'r'); 2465 PerlLIO_close(p[THIS]); 2466 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 2467 PerlLIO_close(p[THAT]); 2468 } 2469 else 2470 PerlLIO_close(p[THAT]); 2471 #ifndef OS2 2472 if (doexec) { 2473 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2474 #ifndef NOFILE 2475 #define NOFILE 20 2476 #endif 2477 { 2478 int fd; 2479 2480 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) 2481 if (fd != pp[1]) 2482 PerlLIO_close(fd); 2483 } 2484 #endif 2485 /* may or may not use the shell */ 2486 do_exec3(cmd, pp[1], did_pipes); 2487 PerlProc__exit(1); 2488 } 2489 #endif /* defined OS2 */ 2490 2491 #ifdef PERLIO_USING_CRLF 2492 /* Since we circumvent IO layers when we manipulate low-level 2493 filedescriptors directly, need to manually switch to the 2494 default, binary, low-level mode; see PerlIOBuf_open(). */ 2495 PerlLIO_setmode((*mode == 'r'), O_BINARY); 2496 #endif 2497 PL_forkprocess = 0; 2498 #ifdef PERL_USES_PL_PIDSTATUS 2499 hv_clear(PL_pidstatus); /* we have no children */ 2500 #endif 2501 return NULL; 2502 #undef THIS 2503 #undef THAT 2504 } 2505 do_execfree(); /* free any memory malloced by child on vfork */ 2506 if (did_pipes) 2507 PerlLIO_close(pp[1]); 2508 if (p[that] < p[This]) { 2509 PerlLIO_dup2(p[This], p[that]); 2510 PerlLIO_close(p[This]); 2511 p[This] = p[that]; 2512 } 2513 else 2514 PerlLIO_close(p[that]); 2515 2516 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2517 SvUPGRADE(sv,SVt_IV); 2518 SvIV_set(sv, pid); 2519 PL_forkprocess = pid; 2520 if (did_pipes && pid > 0) { 2521 int errkid; 2522 unsigned n = 0; 2523 SSize_t n1; 2524 2525 while (n < sizeof(int)) { 2526 n1 = PerlLIO_read(pp[0], 2527 (void*)(((char*)&errkid)+n), 2528 (sizeof(int)) - n); 2529 if (n1 <= 0) 2530 break; 2531 n += n1; 2532 } 2533 PerlLIO_close(pp[0]); 2534 did_pipes = 0; 2535 if (n) { /* Error */ 2536 int pid2, status; 2537 PerlLIO_close(p[This]); 2538 if (n != sizeof(int)) 2539 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); 2540 do { 2541 pid2 = wait4pid(pid, &status, 0); 2542 } while (pid2 == -1 && errno == EINTR); 2543 errno = errkid; /* Propagate errno from kid */ 2544 return NULL; 2545 } 2546 } 2547 if (did_pipes) 2548 PerlLIO_close(pp[0]); 2549 return PerlIO_fdopen(p[This], mode); 2550 } 2551 #else 2552 #if defined(DJGPP) 2553 FILE *djgpp_popen(); 2554 PerlIO * 2555 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2556 { 2557 PERL_FLUSHALL_FOR_CHILD; 2558 /* Call system's popen() to get a FILE *, then import it. 2559 used 0 for 2nd parameter to PerlIO_importFILE; 2560 apparently not used 2561 */ 2562 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); 2563 } 2564 #else 2565 #if defined(__LIBCATAMOUNT__) 2566 PerlIO * 2567 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2568 { 2569 return NULL; 2570 } 2571 #endif 2572 #endif 2573 2574 #endif /* !DOSISH */ 2575 2576 /* this is called in parent before the fork() */ 2577 void 2578 Perl_atfork_lock(void) 2579 { 2580 dVAR; 2581 #if defined(USE_ITHREADS) 2582 /* locks must be held in locking order (if any) */ 2583 # ifdef USE_PERLIO 2584 MUTEX_LOCK(&PL_perlio_mutex); 2585 # endif 2586 # ifdef MYMALLOC 2587 MUTEX_LOCK(&PL_malloc_mutex); 2588 # endif 2589 OP_REFCNT_LOCK; 2590 #endif 2591 } 2592 2593 /* this is called in both parent and child after the fork() */ 2594 void 2595 Perl_atfork_unlock(void) 2596 { 2597 dVAR; 2598 #if defined(USE_ITHREADS) 2599 /* locks must be released in same order as in atfork_lock() */ 2600 # ifdef USE_PERLIO 2601 MUTEX_UNLOCK(&PL_perlio_mutex); 2602 # endif 2603 # ifdef MYMALLOC 2604 MUTEX_UNLOCK(&PL_malloc_mutex); 2605 # endif 2606 OP_REFCNT_UNLOCK; 2607 #endif 2608 } 2609 2610 Pid_t 2611 Perl_my_fork(void) 2612 { 2613 #if defined(HAS_FORK) 2614 Pid_t pid; 2615 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK) 2616 atfork_lock(); 2617 pid = fork(); 2618 atfork_unlock(); 2619 #else 2620 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork() 2621 * handlers elsewhere in the code */ 2622 pid = fork(); 2623 #endif 2624 return pid; 2625 #else 2626 /* this "canna happen" since nothing should be calling here if !HAS_FORK */ 2627 Perl_croak_nocontext("fork() not available"); 2628 return 0; 2629 #endif /* HAS_FORK */ 2630 } 2631 2632 #ifndef HAS_DUP2 2633 int 2634 dup2(int oldfd, int newfd) 2635 { 2636 #if defined(HAS_FCNTL) && defined(F_DUPFD) 2637 if (oldfd == newfd) 2638 return oldfd; 2639 PerlLIO_close(newfd); 2640 return fcntl(oldfd, F_DUPFD, newfd); 2641 #else 2642 #define DUP2_MAX_FDS 256 2643 int fdtmp[DUP2_MAX_FDS]; 2644 I32 fdx = 0; 2645 int fd; 2646 2647 if (oldfd == newfd) 2648 return oldfd; 2649 PerlLIO_close(newfd); 2650 /* good enough for low fd's... */ 2651 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) { 2652 if (fdx >= DUP2_MAX_FDS) { 2653 PerlLIO_close(fd); 2654 fd = -1; 2655 break; 2656 } 2657 fdtmp[fdx++] = fd; 2658 } 2659 while (fdx > 0) 2660 PerlLIO_close(fdtmp[--fdx]); 2661 return fd; 2662 #endif 2663 } 2664 #endif 2665 2666 #ifndef PERL_MICRO 2667 #ifdef HAS_SIGACTION 2668 2669 Sighandler_t 2670 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2671 { 2672 dVAR; 2673 struct sigaction act, oact; 2674 2675 #ifdef USE_ITHREADS 2676 /* only "parent" interpreter can diddle signals */ 2677 if (PL_curinterp != aTHX) 2678 return (Sighandler_t) SIG_ERR; 2679 #endif 2680 2681 act.sa_handler = (void(*)(int))handler; 2682 sigemptyset(&act.sa_mask); 2683 act.sa_flags = 0; 2684 #ifdef SA_RESTART 2685 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 2686 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2687 #endif 2688 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 2689 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) 2690 act.sa_flags |= SA_NOCLDWAIT; 2691 #endif 2692 if (sigaction(signo, &act, &oact) == -1) 2693 return (Sighandler_t) SIG_ERR; 2694 else 2695 return (Sighandler_t) oact.sa_handler; 2696 } 2697 2698 Sighandler_t 2699 Perl_rsignal_state(pTHX_ int signo) 2700 { 2701 struct sigaction oact; 2702 PERL_UNUSED_CONTEXT; 2703 2704 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) 2705 return (Sighandler_t) SIG_ERR; 2706 else 2707 return (Sighandler_t) oact.sa_handler; 2708 } 2709 2710 int 2711 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2712 { 2713 dVAR; 2714 struct sigaction act; 2715 2716 PERL_ARGS_ASSERT_RSIGNAL_SAVE; 2717 2718 #ifdef USE_ITHREADS 2719 /* only "parent" interpreter can diddle signals */ 2720 if (PL_curinterp != aTHX) 2721 return -1; 2722 #endif 2723 2724 act.sa_handler = (void(*)(int))handler; 2725 sigemptyset(&act.sa_mask); 2726 act.sa_flags = 0; 2727 #ifdef SA_RESTART 2728 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 2729 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2730 #endif 2731 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 2732 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) 2733 act.sa_flags |= SA_NOCLDWAIT; 2734 #endif 2735 return sigaction(signo, &act, save); 2736 } 2737 2738 int 2739 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2740 { 2741 dVAR; 2742 #ifdef USE_ITHREADS 2743 /* only "parent" interpreter can diddle signals */ 2744 if (PL_curinterp != aTHX) 2745 return -1; 2746 #endif 2747 2748 return sigaction(signo, save, (struct sigaction *)NULL); 2749 } 2750 2751 #else /* !HAS_SIGACTION */ 2752 2753 Sighandler_t 2754 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2755 { 2756 #if defined(USE_ITHREADS) && !defined(WIN32) 2757 /* only "parent" interpreter can diddle signals */ 2758 if (PL_curinterp != aTHX) 2759 return (Sighandler_t) SIG_ERR; 2760 #endif 2761 2762 return PerlProc_signal(signo, handler); 2763 } 2764 2765 static Signal_t 2766 sig_trap(int signo) 2767 { 2768 dVAR; 2769 PL_sig_trapped++; 2770 } 2771 2772 Sighandler_t 2773 Perl_rsignal_state(pTHX_ int signo) 2774 { 2775 dVAR; 2776 Sighandler_t oldsig; 2777 2778 #if defined(USE_ITHREADS) && !defined(WIN32) 2779 /* only "parent" interpreter can diddle signals */ 2780 if (PL_curinterp != aTHX) 2781 return (Sighandler_t) SIG_ERR; 2782 #endif 2783 2784 PL_sig_trapped = 0; 2785 oldsig = PerlProc_signal(signo, sig_trap); 2786 PerlProc_signal(signo, oldsig); 2787 if (PL_sig_trapped) 2788 PerlProc_kill(PerlProc_getpid(), signo); 2789 return oldsig; 2790 } 2791 2792 int 2793 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2794 { 2795 #if defined(USE_ITHREADS) && !defined(WIN32) 2796 /* only "parent" interpreter can diddle signals */ 2797 if (PL_curinterp != aTHX) 2798 return -1; 2799 #endif 2800 *save = PerlProc_signal(signo, handler); 2801 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0; 2802 } 2803 2804 int 2805 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2806 { 2807 #if defined(USE_ITHREADS) && !defined(WIN32) 2808 /* only "parent" interpreter can diddle signals */ 2809 if (PL_curinterp != aTHX) 2810 return -1; 2811 #endif 2812 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0; 2813 } 2814 2815 #endif /* !HAS_SIGACTION */ 2816 #endif /* !PERL_MICRO */ 2817 2818 /* VMS' my_pclose() is in VMS.c; same with OS/2 */ 2819 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) 2820 I32 2821 Perl_my_pclose(pTHX_ PerlIO *ptr) 2822 { 2823 dVAR; 2824 int status; 2825 SV **svp; 2826 Pid_t pid; 2827 Pid_t pid2 = 0; 2828 bool close_failed; 2829 dSAVEDERRNO; 2830 const int fd = PerlIO_fileno(ptr); 2831 bool should_wait; 2832 2833 svp = av_fetch(PL_fdpid,fd,TRUE); 2834 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; 2835 SvREFCNT_dec(*svp); 2836 *svp = NULL; 2837 2838 #if defined(USE_PERLIO) 2839 /* Find out whether the refcount is low enough for us to wait for the 2840 child proc without blocking. */ 2841 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0; 2842 #else 2843 should_wait = pid > 0; 2844 #endif 2845 2846 #ifdef OS2 2847 if (pid == -1) { /* Opened by popen. */ 2848 return my_syspclose(ptr); 2849 } 2850 #endif 2851 close_failed = (PerlIO_close(ptr) == EOF); 2852 SAVE_ERRNO; 2853 if (should_wait) do { 2854 pid2 = wait4pid(pid, &status, 0); 2855 } while (pid2 == -1 && errno == EINTR); 2856 if (close_failed) { 2857 RESTORE_ERRNO; 2858 return -1; 2859 } 2860 return( 2861 should_wait 2862 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status) 2863 : 0 2864 ); 2865 } 2866 #else 2867 #if defined(__LIBCATAMOUNT__) 2868 I32 2869 Perl_my_pclose(pTHX_ PerlIO *ptr) 2870 { 2871 return -1; 2872 } 2873 #endif 2874 #endif /* !DOSISH */ 2875 2876 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__) 2877 I32 2878 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) 2879 { 2880 dVAR; 2881 I32 result = 0; 2882 PERL_ARGS_ASSERT_WAIT4PID; 2883 #ifdef PERL_USES_PL_PIDSTATUS 2884 if (!pid) { 2885 /* PERL_USES_PL_PIDSTATUS is only defined when neither 2886 waitpid() nor wait4() is available, or on OS/2, which 2887 doesn't appear to support waiting for a progress group 2888 member, so we can only treat a 0 pid as an unknown child. 2889 */ 2890 errno = ECHILD; 2891 return -1; 2892 } 2893 { 2894 if (pid > 0) { 2895 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the 2896 pid, rather than a string form. */ 2897 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE); 2898 if (svp && *svp != &PL_sv_undef) { 2899 *statusp = SvIVX(*svp); 2900 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t), 2901 G_DISCARD); 2902 return pid; 2903 } 2904 } 2905 else { 2906 HE *entry; 2907 2908 hv_iterinit(PL_pidstatus); 2909 if ((entry = hv_iternext(PL_pidstatus))) { 2910 SV * const sv = hv_iterval(PL_pidstatus,entry); 2911 I32 len; 2912 const char * const spid = hv_iterkey(entry,&len); 2913 2914 assert (len == sizeof(Pid_t)); 2915 memcpy((char *)&pid, spid, len); 2916 *statusp = SvIVX(sv); 2917 /* The hash iterator is currently on this entry, so simply 2918 calling hv_delete would trigger the lazy delete, which on 2919 aggregate does more work, beacuse next call to hv_iterinit() 2920 would spot the flag, and have to call the delete routine, 2921 while in the meantime any new entries can't re-use that 2922 memory. */ 2923 hv_iterinit(PL_pidstatus); 2924 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD); 2925 return pid; 2926 } 2927 } 2928 } 2929 #endif 2930 #ifdef HAS_WAITPID 2931 # ifdef HAS_WAITPID_RUNTIME 2932 if (!HAS_WAITPID_RUNTIME) 2933 goto hard_way; 2934 # endif 2935 result = PerlProc_waitpid(pid,statusp,flags); 2936 goto finish; 2937 #endif 2938 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) 2939 result = wait4(pid,statusp,flags,NULL); 2940 goto finish; 2941 #endif 2942 #ifdef PERL_USES_PL_PIDSTATUS 2943 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME) 2944 hard_way: 2945 #endif 2946 { 2947 if (flags) 2948 Perl_croak(aTHX_ "Can't do waitpid with flags"); 2949 else { 2950 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) 2951 pidgone(result,*statusp); 2952 if (result < 0) 2953 *statusp = -1; 2954 } 2955 } 2956 #endif 2957 #if defined(HAS_WAITPID) || defined(HAS_WAIT4) 2958 finish: 2959 #endif 2960 if (result < 0 && errno == EINTR) { 2961 PERL_ASYNC_CHECK(); 2962 errno = EINTR; /* reset in case a signal handler changed $! */ 2963 } 2964 return result; 2965 } 2966 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */ 2967 2968 #ifdef PERL_USES_PL_PIDSTATUS 2969 void 2970 S_pidgone(pTHX_ Pid_t pid, int status) 2971 { 2972 SV *sv; 2973 2974 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE); 2975 SvUPGRADE(sv,SVt_IV); 2976 SvIV_set(sv, status); 2977 return; 2978 } 2979 #endif 2980 2981 #if defined(OS2) 2982 int pclose(); 2983 #ifdef HAS_FORK 2984 int /* Cannot prototype with I32 2985 in os2ish.h. */ 2986 my_syspclose(PerlIO *ptr) 2987 #else 2988 I32 2989 Perl_my_pclose(pTHX_ PerlIO *ptr) 2990 #endif 2991 { 2992 /* Needs work for PerlIO ! */ 2993 FILE * const f = PerlIO_findFILE(ptr); 2994 const I32 result = pclose(f); 2995 PerlIO_releaseFILE(ptr,f); 2996 return result; 2997 } 2998 #endif 2999 3000 #if defined(DJGPP) 3001 int djgpp_pclose(); 3002 I32 3003 Perl_my_pclose(pTHX_ PerlIO *ptr) 3004 { 3005 /* Needs work for PerlIO ! */ 3006 FILE * const f = PerlIO_findFILE(ptr); 3007 I32 result = djgpp_pclose(f); 3008 result = (result << 8) & 0xff00; 3009 PerlIO_releaseFILE(ptr,f); 3010 return result; 3011 } 3012 #endif 3013 3014 #define PERL_REPEATCPY_LINEAR 4 3015 void 3016 Perl_repeatcpy(char *to, const char *from, I32 len, IV count) 3017 { 3018 PERL_ARGS_ASSERT_REPEATCPY; 3019 3020 assert(len >= 0); 3021 3022 if (count < 0) 3023 croak_memory_wrap(); 3024 3025 if (len == 1) 3026 memset(to, *from, count); 3027 else if (count) { 3028 char *p = to; 3029 IV items, linear, half; 3030 3031 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR; 3032 for (items = 0; items < linear; ++items) { 3033 const char *q = from; 3034 IV todo; 3035 for (todo = len; todo > 0; todo--) 3036 *p++ = *q++; 3037 } 3038 3039 half = count / 2; 3040 while (items <= half) { 3041 IV size = items * len; 3042 memcpy(p, to, size); 3043 p += size; 3044 items *= 2; 3045 } 3046 3047 if (count > items) 3048 memcpy(p, to, (count - items) * len); 3049 } 3050 } 3051 3052 #ifndef HAS_RENAME 3053 I32 3054 Perl_same_dirent(pTHX_ const char *a, const char *b) 3055 { 3056 char *fa = strrchr(a,'/'); 3057 char *fb = strrchr(b,'/'); 3058 Stat_t tmpstatbuf1; 3059 Stat_t tmpstatbuf2; 3060 SV * const tmpsv = sv_newmortal(); 3061 3062 PERL_ARGS_ASSERT_SAME_DIRENT; 3063 3064 if (fa) 3065 fa++; 3066 else 3067 fa = a; 3068 if (fb) 3069 fb++; 3070 else 3071 fb = b; 3072 if (strNE(a,b)) 3073 return FALSE; 3074 if (fa == a) 3075 sv_setpvs(tmpsv, "."); 3076 else 3077 sv_setpvn(tmpsv, a, fa - a); 3078 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) 3079 return FALSE; 3080 if (fb == b) 3081 sv_setpvs(tmpsv, "."); 3082 else 3083 sv_setpvn(tmpsv, b, fb - b); 3084 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) 3085 return FALSE; 3086 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && 3087 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; 3088 } 3089 #endif /* !HAS_RENAME */ 3090 3091 char* 3092 Perl_find_script(pTHX_ const char *scriptname, bool dosearch, 3093 const char *const *const search_ext, I32 flags) 3094 { 3095 dVAR; 3096 const char *xfound = NULL; 3097 char *xfailed = NULL; 3098 char tmpbuf[MAXPATHLEN]; 3099 char *s; 3100 I32 len = 0; 3101 int retval; 3102 char *bufend; 3103 #if defined(DOSISH) && !defined(OS2) 3104 # define SEARCH_EXTS ".bat", ".cmd", NULL 3105 # define MAX_EXT_LEN 4 3106 #endif 3107 #ifdef OS2 3108 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL 3109 # define MAX_EXT_LEN 4 3110 #endif 3111 #ifdef VMS 3112 # define SEARCH_EXTS ".pl", ".com", NULL 3113 # define MAX_EXT_LEN 4 3114 #endif 3115 /* additional extensions to try in each dir if scriptname not found */ 3116 #ifdef SEARCH_EXTS 3117 static const char *const exts[] = { SEARCH_EXTS }; 3118 const char *const *const ext = search_ext ? search_ext : exts; 3119 int extidx = 0, i = 0; 3120 const char *curext = NULL; 3121 #else 3122 PERL_UNUSED_ARG(search_ext); 3123 # define MAX_EXT_LEN 0 3124 #endif 3125 3126 PERL_ARGS_ASSERT_FIND_SCRIPT; 3127 3128 /* 3129 * If dosearch is true and if scriptname does not contain path 3130 * delimiters, search the PATH for scriptname. 3131 * 3132 * If SEARCH_EXTS is also defined, will look for each 3133 * scriptname{SEARCH_EXTS} whenever scriptname is not found 3134 * while searching the PATH. 3135 * 3136 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search 3137 * proceeds as follows: 3138 * If DOSISH or VMSISH: 3139 * + look for ./scriptname{,.foo,.bar} 3140 * + search the PATH for scriptname{,.foo,.bar} 3141 * 3142 * If !DOSISH: 3143 * + look *only* in the PATH for scriptname{,.foo,.bar} (note 3144 * this will not look in '.' if it's not in the PATH) 3145 */ 3146 tmpbuf[0] = '\0'; 3147 3148 #ifdef VMS 3149 # ifdef ALWAYS_DEFTYPES 3150 len = strlen(scriptname); 3151 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { 3152 int idx = 0, deftypes = 1; 3153 bool seen_dot = 1; 3154 3155 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL); 3156 # else 3157 if (dosearch) { 3158 int idx = 0, deftypes = 1; 3159 bool seen_dot = 1; 3160 3161 const int hasdir = (strpbrk(scriptname,":[</") != NULL); 3162 # endif 3163 /* The first time through, just add SEARCH_EXTS to whatever we 3164 * already have, so we can check for default file types. */ 3165 while (deftypes || 3166 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) 3167 { 3168 if (deftypes) { 3169 deftypes = 0; 3170 *tmpbuf = '\0'; 3171 } 3172 if ((strlen(tmpbuf) + strlen(scriptname) 3173 + MAX_EXT_LEN) >= sizeof tmpbuf) 3174 continue; /* don't search dir with too-long name */ 3175 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf)); 3176 #else /* !VMS */ 3177 3178 #ifdef DOSISH 3179 if (strEQ(scriptname, "-")) 3180 dosearch = 0; 3181 if (dosearch) { /* Look in '.' first. */ 3182 const char *cur = scriptname; 3183 #ifdef SEARCH_EXTS 3184 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ 3185 while (ext[i]) 3186 if (strEQ(ext[i++],curext)) { 3187 extidx = -1; /* already has an ext */ 3188 break; 3189 } 3190 do { 3191 #endif 3192 DEBUG_p(PerlIO_printf(Perl_debug_log, 3193 "Looking for %s\n",cur)); 3194 if (PerlLIO_stat(cur,&PL_statbuf) >= 0 3195 && !S_ISDIR(PL_statbuf.st_mode)) { 3196 dosearch = 0; 3197 scriptname = cur; 3198 #ifdef SEARCH_EXTS 3199 break; 3200 #endif 3201 } 3202 #ifdef SEARCH_EXTS 3203 if (cur == scriptname) { 3204 len = strlen(scriptname); 3205 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) 3206 break; 3207 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf)); 3208 cur = tmpbuf; 3209 } 3210 } while (extidx >= 0 && ext[extidx] /* try an extension? */ 3211 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)); 3212 #endif 3213 } 3214 #endif 3215 3216 if (dosearch && !strchr(scriptname, '/') 3217 #ifdef DOSISH 3218 && !strchr(scriptname, '\\') 3219 #endif 3220 && (s = PerlEnv_getenv("PATH"))) 3221 { 3222 bool seen_dot = 0; 3223 3224 bufend = s + strlen(s); 3225 while (s < bufend) { 3226 # ifdef DOSISH 3227 for (len = 0; *s 3228 && *s != ';'; len++, s++) { 3229 if (len < sizeof tmpbuf) 3230 tmpbuf[len] = *s; 3231 } 3232 if (len < sizeof tmpbuf) 3233 tmpbuf[len] = '\0'; 3234 # else 3235 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, 3236 ':', 3237 &len); 3238 # endif 3239 if (s < bufend) 3240 s++; 3241 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) 3242 continue; /* don't search dir with too-long name */ 3243 if (len 3244 # ifdef DOSISH 3245 && tmpbuf[len - 1] != '/' 3246 && tmpbuf[len - 1] != '\\' 3247 # endif 3248 ) 3249 tmpbuf[len++] = '/'; 3250 if (len == 2 && tmpbuf[0] == '.') 3251 seen_dot = 1; 3252 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len); 3253 #endif /* !VMS */ 3254 3255 #ifdef SEARCH_EXTS 3256 len = strlen(tmpbuf); 3257 if (extidx > 0) /* reset after previous loop */ 3258 extidx = 0; 3259 do { 3260 #endif 3261 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); 3262 retval = PerlLIO_stat(tmpbuf,&PL_statbuf); 3263 if (S_ISDIR(PL_statbuf.st_mode)) { 3264 retval = -1; 3265 } 3266 #ifdef SEARCH_EXTS 3267 } while ( retval < 0 /* not there */ 3268 && extidx>=0 && ext[extidx] /* try an extension? */ 3269 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len) 3270 ); 3271 #endif 3272 if (retval < 0) 3273 continue; 3274 if (S_ISREG(PL_statbuf.st_mode) 3275 && cando(S_IRUSR,TRUE,&PL_statbuf) 3276 #if !defined(DOSISH) 3277 && cando(S_IXUSR,TRUE,&PL_statbuf) 3278 #endif 3279 ) 3280 { 3281 xfound = tmpbuf; /* bingo! */ 3282 break; 3283 } 3284 if (!xfailed) 3285 xfailed = savepv(tmpbuf); 3286 } 3287 #ifndef DOSISH 3288 if (!xfound && !seen_dot && !xfailed && 3289 (PerlLIO_stat(scriptname,&PL_statbuf) < 0 3290 || S_ISDIR(PL_statbuf.st_mode))) 3291 #endif 3292 seen_dot = 1; /* Disable message. */ 3293 if (!xfound) { 3294 if (flags & 1) { /* do or die? */ 3295 /* diag_listed_as: Can't execute %s */ 3296 Perl_croak(aTHX_ "Can't %s %s%s%s", 3297 (xfailed ? "execute" : "find"), 3298 (xfailed ? xfailed : scriptname), 3299 (xfailed ? "" : " on PATH"), 3300 (xfailed || seen_dot) ? "" : ", '.' not in PATH"); 3301 } 3302 scriptname = NULL; 3303 } 3304 Safefree(xfailed); 3305 scriptname = xfound; 3306 } 3307 return (scriptname ? savepv(scriptname) : NULL); 3308 } 3309 3310 #ifndef PERL_GET_CONTEXT_DEFINED 3311 3312 void * 3313 Perl_get_context(void) 3314 { 3315 dVAR; 3316 #if defined(USE_ITHREADS) 3317 # ifdef OLD_PTHREADS_API 3318 pthread_addr_t t; 3319 int error = pthread_getspecific(PL_thr_key, &t) 3320 if (error) 3321 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error); 3322 return (void*)t; 3323 # else 3324 # ifdef I_MACH_CTHREADS 3325 return (void*)cthread_data(cthread_self()); 3326 # else 3327 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); 3328 # endif 3329 # endif 3330 #else 3331 return (void*)NULL; 3332 #endif 3333 } 3334 3335 void 3336 Perl_set_context(void *t) 3337 { 3338 dVAR; 3339 PERL_ARGS_ASSERT_SET_CONTEXT; 3340 #if defined(USE_ITHREADS) 3341 # ifdef I_MACH_CTHREADS 3342 cthread_set_data(cthread_self(), t); 3343 # else 3344 { 3345 const int error = pthread_setspecific(PL_thr_key, t); 3346 if (error) 3347 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error); 3348 } 3349 # endif 3350 #else 3351 PERL_UNUSED_ARG(t); 3352 #endif 3353 } 3354 3355 #endif /* !PERL_GET_CONTEXT_DEFINED */ 3356 3357 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) 3358 struct perl_vars * 3359 Perl_GetVars(pTHX) 3360 { 3361 return &PL_Vars; 3362 } 3363 #endif 3364 3365 char ** 3366 Perl_get_op_names(pTHX) 3367 { 3368 PERL_UNUSED_CONTEXT; 3369 return (char **)PL_op_name; 3370 } 3371 3372 char ** 3373 Perl_get_op_descs(pTHX) 3374 { 3375 PERL_UNUSED_CONTEXT; 3376 return (char **)PL_op_desc; 3377 } 3378 3379 const char * 3380 Perl_get_no_modify(pTHX) 3381 { 3382 PERL_UNUSED_CONTEXT; 3383 return PL_no_modify; 3384 } 3385 3386 U32 * 3387 Perl_get_opargs(pTHX) 3388 { 3389 PERL_UNUSED_CONTEXT; 3390 return (U32 *)PL_opargs; 3391 } 3392 3393 PPADDR_t* 3394 Perl_get_ppaddr(pTHX) 3395 { 3396 dVAR; 3397 PERL_UNUSED_CONTEXT; 3398 return (PPADDR_t*)PL_ppaddr; 3399 } 3400 3401 #ifndef HAS_GETENV_LEN 3402 char * 3403 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) 3404 { 3405 char * const env_trans = PerlEnv_getenv(env_elem); 3406 PERL_UNUSED_CONTEXT; 3407 PERL_ARGS_ASSERT_GETENV_LEN; 3408 if (env_trans) 3409 *len = strlen(env_trans); 3410 return env_trans; 3411 } 3412 #endif 3413 3414 3415 MGVTBL* 3416 Perl_get_vtbl(pTHX_ int vtbl_id) 3417 { 3418 PERL_UNUSED_CONTEXT; 3419 3420 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) 3421 ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id; 3422 } 3423 3424 I32 3425 Perl_my_fflush_all(pTHX) 3426 { 3427 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) 3428 return PerlIO_flush(NULL); 3429 #else 3430 # if defined(HAS__FWALK) 3431 extern int fflush(FILE *); 3432 /* undocumented, unprototyped, but very useful BSDism */ 3433 extern void _fwalk(int (*)(FILE *)); 3434 _fwalk(&fflush); 3435 return 0; 3436 # else 3437 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) 3438 long open_max = -1; 3439 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX 3440 open_max = PERL_FFLUSH_ALL_FOPEN_MAX; 3441 # else 3442 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) 3443 open_max = sysconf(_SC_OPEN_MAX); 3444 # else 3445 # ifdef FOPEN_MAX 3446 open_max = FOPEN_MAX; 3447 # else 3448 # ifdef OPEN_MAX 3449 open_max = OPEN_MAX; 3450 # else 3451 # ifdef _NFILE 3452 open_max = _NFILE; 3453 # endif 3454 # endif 3455 # endif 3456 # endif 3457 # endif 3458 if (open_max > 0) { 3459 long i; 3460 for (i = 0; i < open_max; i++) 3461 if (STDIO_STREAM_ARRAY[i]._file >= 0 && 3462 STDIO_STREAM_ARRAY[i]._file < open_max && 3463 STDIO_STREAM_ARRAY[i]._flag) 3464 PerlIO_flush(&STDIO_STREAM_ARRAY[i]); 3465 return 0; 3466 } 3467 # endif 3468 SETERRNO(EBADF,RMS_IFI); 3469 return EOF; 3470 # endif 3471 #endif 3472 } 3473 3474 void 3475 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) 3476 { 3477 if (ckWARN(WARN_IO)) { 3478 HEK * const name 3479 = gv && (isGV_with_GP(gv)) 3480 ? GvENAME_HEK((gv)) 3481 : NULL; 3482 const char * const direction = have == '>' ? "out" : "in"; 3483 3484 if (name && HEK_LEN(name)) 3485 Perl_warner(aTHX_ packWARN(WARN_IO), 3486 "Filehandle %"HEKf" opened only for %sput", 3487 name, direction); 3488 else 3489 Perl_warner(aTHX_ packWARN(WARN_IO), 3490 "Filehandle opened only for %sput", direction); 3491 } 3492 } 3493 3494 void 3495 Perl_report_evil_fh(pTHX_ const GV *gv) 3496 { 3497 const IO *io = gv ? GvIO(gv) : NULL; 3498 const PERL_BITFIELD16 op = PL_op->op_type; 3499 const char *vile; 3500 I32 warn_type; 3501 3502 if (io && IoTYPE(io) == IoTYPE_CLOSED) { 3503 vile = "closed"; 3504 warn_type = WARN_CLOSED; 3505 } 3506 else { 3507 vile = "unopened"; 3508 warn_type = WARN_UNOPENED; 3509 } 3510 3511 if (ckWARN(warn_type)) { 3512 SV * const name 3513 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ? 3514 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL; 3515 const char * const pars = 3516 (const char *)(OP_IS_FILETEST(op) ? "" : "()"); 3517 const char * const func = 3518 (const char *) 3519 (op == OP_READLINE || op == OP_RCATLINE 3520 ? "readline" : /* "<HANDLE>" not nice */ 3521 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ 3522 PL_op_desc[op]); 3523 const char * const type = 3524 (const char *) 3525 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) 3526 ? "socket" : "filehandle"); 3527 const bool have_name = name && SvCUR(name); 3528 Perl_warner(aTHX_ packWARN(warn_type), 3529 "%s%s on %s %s%s%"SVf, func, pars, vile, type, 3530 have_name ? " " : "", 3531 SVfARG(have_name ? name : &PL_sv_no)); 3532 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3533 Perl_warner( 3534 aTHX_ packWARN(warn_type), 3535 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n", 3536 func, pars, have_name ? " " : "", 3537 SVfARG(have_name ? name : &PL_sv_no) 3538 ); 3539 } 3540 } 3541 3542 /* To workaround core dumps from the uninitialised tm_zone we get the 3543 * system to give us a reasonable struct to copy. This fix means that 3544 * strftime uses the tm_zone and tm_gmtoff values returned by 3545 * localtime(time()). That should give the desired result most of the 3546 * time. But probably not always! 3547 * 3548 * This does not address tzname aspects of NETaa14816. 3549 * 3550 */ 3551 3552 #ifdef __GLIBC__ 3553 # ifndef STRUCT_TM_HASZONE 3554 # define STRUCT_TM_HASZONE 3555 # endif 3556 #endif 3557 3558 #ifdef STRUCT_TM_HASZONE /* Backward compat */ 3559 # ifndef HAS_TM_TM_ZONE 3560 # define HAS_TM_TM_ZONE 3561 # endif 3562 #endif 3563 3564 void 3565 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ 3566 { 3567 #ifdef HAS_TM_TM_ZONE 3568 Time_t now; 3569 const struct tm* my_tm; 3570 PERL_ARGS_ASSERT_INIT_TM; 3571 (void)time(&now); 3572 my_tm = localtime(&now); 3573 if (my_tm) 3574 Copy(my_tm, ptm, 1, struct tm); 3575 #else 3576 PERL_ARGS_ASSERT_INIT_TM; 3577 PERL_UNUSED_ARG(ptm); 3578 #endif 3579 } 3580 3581 /* 3582 * mini_mktime - normalise struct tm values without the localtime() 3583 * semantics (and overhead) of mktime(). 3584 */ 3585 void 3586 Perl_mini_mktime(pTHX_ struct tm *ptm) 3587 { 3588 int yearday; 3589 int secs; 3590 int month, mday, year, jday; 3591 int odd_cent, odd_year; 3592 PERL_UNUSED_CONTEXT; 3593 3594 PERL_ARGS_ASSERT_MINI_MKTIME; 3595 3596 #define DAYS_PER_YEAR 365 3597 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) 3598 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) 3599 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) 3600 #define SECS_PER_HOUR (60*60) 3601 #define SECS_PER_DAY (24*SECS_PER_HOUR) 3602 /* parentheses deliberately absent on these two, otherwise they don't work */ 3603 #define MONTH_TO_DAYS 153/5 3604 #define DAYS_TO_MONTH 5/153 3605 /* offset to bias by March (month 4) 1st between month/mday & year finding */ 3606 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1) 3607 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ 3608 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ 3609 3610 /* 3611 * Year/day algorithm notes: 3612 * 3613 * With a suitable offset for numeric value of the month, one can find 3614 * an offset into the year by considering months to have 30.6 (153/5) days, 3615 * using integer arithmetic (i.e., with truncation). To avoid too much 3616 * messing about with leap days, we consider January and February to be 3617 * the 13th and 14th month of the previous year. After that transformation, 3618 * we need the month index we use to be high by 1 from 'normal human' usage, 3619 * so the month index values we use run from 4 through 15. 3620 * 3621 * Given that, and the rules for the Gregorian calendar (leap years are those 3622 * divisible by 4 unless also divisible by 100, when they must be divisible 3623 * by 400 instead), we can simply calculate the number of days since some 3624 * arbitrary 'beginning of time' by futzing with the (adjusted) year number, 3625 * the days we derive from our month index, and adding in the day of the 3626 * month. The value used here is not adjusted for the actual origin which 3627 * it normally would use (1 January A.D. 1), since we're not exposing it. 3628 * We're only building the value so we can turn around and get the 3629 * normalised values for the year, month, day-of-month, and day-of-year. 3630 * 3631 * For going backward, we need to bias the value we're using so that we find 3632 * the right year value. (Basically, we don't want the contribution of 3633 * March 1st to the number to apply while deriving the year). Having done 3634 * that, we 'count up' the contribution to the year number by accounting for 3635 * full quadracenturies (400-year periods) with their extra leap days, plus 3636 * the contribution from full centuries (to avoid counting in the lost leap 3637 * days), plus the contribution from full quad-years (to count in the normal 3638 * leap days), plus the leftover contribution from any non-leap years. 3639 * At this point, if we were working with an actual leap day, we'll have 0 3640 * days left over. This is also true for March 1st, however. So, we have 3641 * to special-case that result, and (earlier) keep track of the 'odd' 3642 * century and year contributions. If we got 4 extra centuries in a qcent, 3643 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. 3644 * Otherwise, we add back in the earlier bias we removed (the 123 from 3645 * figuring in March 1st), find the month index (integer division by 30.6), 3646 * and the remainder is the day-of-month. We then have to convert back to 3647 * 'real' months (including fixing January and February from being 14/15 in 3648 * the previous year to being in the proper year). After that, to get 3649 * tm_yday, we work with the normalised year and get a new yearday value for 3650 * January 1st, which we subtract from the yearday value we had earlier, 3651 * representing the date we've re-built. This is done from January 1 3652 * because tm_yday is 0-origin. 3653 * 3654 * Since POSIX time routines are only guaranteed to work for times since the 3655 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm 3656 * applies Gregorian calendar rules even to dates before the 16th century 3657 * doesn't bother me. Besides, you'd need cultural context for a given 3658 * date to know whether it was Julian or Gregorian calendar, and that's 3659 * outside the scope for this routine. Since we convert back based on the 3660 * same rules we used to build the yearday, you'll only get strange results 3661 * for input which needed normalising, or for the 'odd' century years which 3662 * were leap years in the Julian calendar but not in the Gregorian one. 3663 * I can live with that. 3664 * 3665 * This algorithm also fails to handle years before A.D. 1 gracefully, but 3666 * that's still outside the scope for POSIX time manipulation, so I don't 3667 * care. 3668 */ 3669 3670 year = 1900 + ptm->tm_year; 3671 month = ptm->tm_mon; 3672 mday = ptm->tm_mday; 3673 jday = 0; 3674 if (month >= 2) 3675 month+=2; 3676 else 3677 month+=14, year--; 3678 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; 3679 yearday += month*MONTH_TO_DAYS + mday + jday; 3680 /* 3681 * Note that we don't know when leap-seconds were or will be, 3682 * so we have to trust the user if we get something which looks 3683 * like a sensible leap-second. Wild values for seconds will 3684 * be rationalised, however. 3685 */ 3686 if ((unsigned) ptm->tm_sec <= 60) { 3687 secs = 0; 3688 } 3689 else { 3690 secs = ptm->tm_sec; 3691 ptm->tm_sec = 0; 3692 } 3693 secs += 60 * ptm->tm_min; 3694 secs += SECS_PER_HOUR * ptm->tm_hour; 3695 if (secs < 0) { 3696 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { 3697 /* got negative remainder, but need positive time */ 3698 /* back off an extra day to compensate */ 3699 yearday += (secs/SECS_PER_DAY)-1; 3700 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); 3701 } 3702 else { 3703 yearday += (secs/SECS_PER_DAY); 3704 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); 3705 } 3706 } 3707 else if (secs >= SECS_PER_DAY) { 3708 yearday += (secs/SECS_PER_DAY); 3709 secs %= SECS_PER_DAY; 3710 } 3711 ptm->tm_hour = secs/SECS_PER_HOUR; 3712 secs %= SECS_PER_HOUR; 3713 ptm->tm_min = secs/60; 3714 secs %= 60; 3715 ptm->tm_sec += secs; 3716 /* done with time of day effects */ 3717 /* 3718 * The algorithm for yearday has (so far) left it high by 428. 3719 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to 3720 * bias it by 123 while trying to figure out what year it 3721 * really represents. Even with this tweak, the reverse 3722 * translation fails for years before A.D. 0001. 3723 * It would still fail for Feb 29, but we catch that one below. 3724 */ 3725 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ 3726 yearday -= YEAR_ADJUST; 3727 year = (yearday / DAYS_PER_QCENT) * 400; 3728 yearday %= DAYS_PER_QCENT; 3729 odd_cent = yearday / DAYS_PER_CENT; 3730 year += odd_cent * 100; 3731 yearday %= DAYS_PER_CENT; 3732 year += (yearday / DAYS_PER_QYEAR) * 4; 3733 yearday %= DAYS_PER_QYEAR; 3734 odd_year = yearday / DAYS_PER_YEAR; 3735 year += odd_year; 3736 yearday %= DAYS_PER_YEAR; 3737 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ 3738 month = 1; 3739 yearday = 29; 3740 } 3741 else { 3742 yearday += YEAR_ADJUST; /* recover March 1st crock */ 3743 month = yearday*DAYS_TO_MONTH; 3744 yearday -= month*MONTH_TO_DAYS; 3745 /* recover other leap-year adjustment */ 3746 if (month > 13) { 3747 month-=14; 3748 year++; 3749 } 3750 else { 3751 month-=2; 3752 } 3753 } 3754 ptm->tm_year = year - 1900; 3755 if (yearday) { 3756 ptm->tm_mday = yearday; 3757 ptm->tm_mon = month; 3758 } 3759 else { 3760 ptm->tm_mday = 31; 3761 ptm->tm_mon = month - 1; 3762 } 3763 /* re-build yearday based on Jan 1 to get tm_yday */ 3764 year--; 3765 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; 3766 yearday += 14*MONTH_TO_DAYS + 1; 3767 ptm->tm_yday = jday - yearday; 3768 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; 3769 } 3770 3771 char * 3772 Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) 3773 { 3774 #ifdef HAS_STRFTIME 3775 char *buf; 3776 int buflen; 3777 struct tm mytm; 3778 int len; 3779 3780 PERL_ARGS_ASSERT_MY_STRFTIME; 3781 3782 init_tm(&mytm); /* XXX workaround - see init_tm() above */ 3783 mytm.tm_sec = sec; 3784 mytm.tm_min = min; 3785 mytm.tm_hour = hour; 3786 mytm.tm_mday = mday; 3787 mytm.tm_mon = mon; 3788 mytm.tm_year = year; 3789 mytm.tm_wday = wday; 3790 mytm.tm_yday = yday; 3791 mytm.tm_isdst = isdst; 3792 mini_mktime(&mytm); 3793 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */ 3794 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE)) 3795 STMT_START { 3796 struct tm mytm2; 3797 mytm2 = mytm; 3798 mktime(&mytm2); 3799 #ifdef HAS_TM_TM_GMTOFF 3800 mytm.tm_gmtoff = mytm2.tm_gmtoff; 3801 #endif 3802 #ifdef HAS_TM_TM_ZONE 3803 mytm.tm_zone = mytm2.tm_zone; 3804 #endif 3805 } STMT_END; 3806 #endif 3807 buflen = 64; 3808 Newx(buf, buflen, char); 3809 3810 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */ 3811 len = strftime(buf, buflen, fmt, &mytm); 3812 GCC_DIAG_RESTORE; 3813 3814 /* 3815 ** The following is needed to handle to the situation where 3816 ** tmpbuf overflows. Basically we want to allocate a buffer 3817 ** and try repeatedly. The reason why it is so complicated 3818 ** is that getting a return value of 0 from strftime can indicate 3819 ** one of the following: 3820 ** 1. buffer overflowed, 3821 ** 2. illegal conversion specifier, or 3822 ** 3. the format string specifies nothing to be returned(not 3823 ** an error). This could be because format is an empty string 3824 ** or it specifies %p that yields an empty string in some locale. 3825 ** If there is a better way to make it portable, go ahead by 3826 ** all means. 3827 */ 3828 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0')) 3829 return buf; 3830 else { 3831 /* Possibly buf overflowed - try again with a bigger buf */ 3832 const int fmtlen = strlen(fmt); 3833 int bufsize = fmtlen + buflen; 3834 3835 Renew(buf, bufsize, char); 3836 while (buf) { 3837 3838 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */ 3839 buflen = strftime(buf, bufsize, fmt, &mytm); 3840 GCC_DIAG_RESTORE; 3841 3842 if (buflen > 0 && buflen < bufsize) 3843 break; 3844 /* heuristic to prevent out-of-memory errors */ 3845 if (bufsize > 100*fmtlen) { 3846 Safefree(buf); 3847 buf = NULL; 3848 break; 3849 } 3850 bufsize *= 2; 3851 Renew(buf, bufsize, char); 3852 } 3853 return buf; 3854 } 3855 #else 3856 Perl_croak(aTHX_ "panic: no strftime"); 3857 return NULL; 3858 #endif 3859 } 3860 3861 3862 #define SV_CWD_RETURN_UNDEF \ 3863 sv_setsv(sv, &PL_sv_undef); \ 3864 return FALSE 3865 3866 #define SV_CWD_ISDOT(dp) \ 3867 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ 3868 (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) 3869 3870 /* 3871 =head1 Miscellaneous Functions 3872 3873 =for apidoc getcwd_sv 3874 3875 Fill the sv with current working directory 3876 3877 =cut 3878 */ 3879 3880 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. 3881 * rewritten again by dougm, optimized for use with xs TARG, and to prefer 3882 * getcwd(3) if available 3883 * Comments from the orignal: 3884 * This is a faster version of getcwd. It's also more dangerous 3885 * because you might chdir out of a directory that you can't chdir 3886 * back into. */ 3887 3888 int 3889 Perl_getcwd_sv(pTHX_ SV *sv) 3890 { 3891 #ifndef PERL_MICRO 3892 dVAR; 3893 SvTAINTED_on(sv); 3894 3895 PERL_ARGS_ASSERT_GETCWD_SV; 3896 3897 #ifdef HAS_GETCWD 3898 { 3899 char buf[MAXPATHLEN]; 3900 3901 /* Some getcwd()s automatically allocate a buffer of the given 3902 * size from the heap if they are given a NULL buffer pointer. 3903 * The problem is that this behaviour is not portable. */ 3904 if (getcwd(buf, sizeof(buf) - 1)) { 3905 sv_setpv(sv, buf); 3906 return TRUE; 3907 } 3908 else { 3909 sv_setsv(sv, &PL_sv_undef); 3910 return FALSE; 3911 } 3912 } 3913 3914 #else 3915 3916 Stat_t statbuf; 3917 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; 3918 int pathlen=0; 3919 Direntry_t *dp; 3920 3921 SvUPGRADE(sv, SVt_PV); 3922 3923 if (PerlLIO_lstat(".", &statbuf) < 0) { 3924 SV_CWD_RETURN_UNDEF; 3925 } 3926 3927 orig_cdev = statbuf.st_dev; 3928 orig_cino = statbuf.st_ino; 3929 cdev = orig_cdev; 3930 cino = orig_cino; 3931 3932 for (;;) { 3933 DIR *dir; 3934 int namelen; 3935 odev = cdev; 3936 oino = cino; 3937 3938 if (PerlDir_chdir("..") < 0) { 3939 SV_CWD_RETURN_UNDEF; 3940 } 3941 if (PerlLIO_stat(".", &statbuf) < 0) { 3942 SV_CWD_RETURN_UNDEF; 3943 } 3944 3945 cdev = statbuf.st_dev; 3946 cino = statbuf.st_ino; 3947 3948 if (odev == cdev && oino == cino) { 3949 break; 3950 } 3951 if (!(dir = PerlDir_open("."))) { 3952 SV_CWD_RETURN_UNDEF; 3953 } 3954 3955 while ((dp = PerlDir_read(dir)) != NULL) { 3956 #ifdef DIRNAMLEN 3957 namelen = dp->d_namlen; 3958 #else 3959 namelen = strlen(dp->d_name); 3960 #endif 3961 /* skip . and .. */ 3962 if (SV_CWD_ISDOT(dp)) { 3963 continue; 3964 } 3965 3966 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { 3967 SV_CWD_RETURN_UNDEF; 3968 } 3969 3970 tdev = statbuf.st_dev; 3971 tino = statbuf.st_ino; 3972 if (tino == oino && tdev == odev) { 3973 break; 3974 } 3975 } 3976 3977 if (!dp) { 3978 SV_CWD_RETURN_UNDEF; 3979 } 3980 3981 if (pathlen + namelen + 1 >= MAXPATHLEN) { 3982 SV_CWD_RETURN_UNDEF; 3983 } 3984 3985 SvGROW(sv, pathlen + namelen + 1); 3986 3987 if (pathlen) { 3988 /* shift down */ 3989 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char); 3990 } 3991 3992 /* prepend current directory to the front */ 3993 *SvPVX(sv) = '/'; 3994 Move(dp->d_name, SvPVX(sv)+1, namelen, char); 3995 pathlen += (namelen + 1); 3996 3997 #ifdef VOID_CLOSEDIR 3998 PerlDir_close(dir); 3999 #else 4000 if (PerlDir_close(dir) < 0) { 4001 SV_CWD_RETURN_UNDEF; 4002 } 4003 #endif 4004 } 4005 4006 if (pathlen) { 4007 SvCUR_set(sv, pathlen); 4008 *SvEND(sv) = '\0'; 4009 SvPOK_only(sv); 4010 4011 if (PerlDir_chdir(SvPVX_const(sv)) < 0) { 4012 SV_CWD_RETURN_UNDEF; 4013 } 4014 } 4015 if (PerlLIO_stat(".", &statbuf) < 0) { 4016 SV_CWD_RETURN_UNDEF; 4017 } 4018 4019 cdev = statbuf.st_dev; 4020 cino = statbuf.st_ino; 4021 4022 if (cdev != orig_cdev || cino != orig_cino) { 4023 Perl_croak(aTHX_ "Unstable directory path, " 4024 "current directory changed unexpectedly"); 4025 } 4026 4027 return TRUE; 4028 #endif 4029 4030 #else 4031 return FALSE; 4032 #endif 4033 } 4034 4035 #include "vutil.c" 4036 4037 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) 4038 # define EMULATE_SOCKETPAIR_UDP 4039 #endif 4040 4041 #ifdef EMULATE_SOCKETPAIR_UDP 4042 static int 4043 S_socketpair_udp (int fd[2]) { 4044 dTHX; 4045 /* Fake a datagram socketpair using UDP to localhost. */ 4046 int sockets[2] = {-1, -1}; 4047 struct sockaddr_in addresses[2]; 4048 int i; 4049 Sock_size_t size = sizeof(struct sockaddr_in); 4050 unsigned short port; 4051 int got; 4052 4053 memset(&addresses, 0, sizeof(addresses)); 4054 i = 1; 4055 do { 4056 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET); 4057 if (sockets[i] == -1) 4058 goto tidy_up_and_fail; 4059 4060 addresses[i].sin_family = AF_INET; 4061 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK); 4062 addresses[i].sin_port = 0; /* kernel choses port. */ 4063 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i], 4064 sizeof(struct sockaddr_in)) == -1) 4065 goto tidy_up_and_fail; 4066 } while (i--); 4067 4068 /* Now have 2 UDP sockets. Find out which port each is connected to, and 4069 for each connect the other socket to it. */ 4070 i = 1; 4071 do { 4072 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i], 4073 &size) == -1) 4074 goto tidy_up_and_fail; 4075 if (size != sizeof(struct sockaddr_in)) 4076 goto abort_tidy_up_and_fail; 4077 /* !1 is 0, !0 is 1 */ 4078 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], 4079 sizeof(struct sockaddr_in)) == -1) 4080 goto tidy_up_and_fail; 4081 } while (i--); 4082 4083 /* Now we have 2 sockets connected to each other. I don't trust some other 4084 process not to have already sent a packet to us (by random) so send 4085 a packet from each to the other. */ 4086 i = 1; 4087 do { 4088 /* I'm going to send my own port number. As a short. 4089 (Who knows if someone somewhere has sin_port as a bitfield and needs 4090 this routine. (I'm assuming crays have socketpair)) */ 4091 port = addresses[i].sin_port; 4092 got = PerlLIO_write(sockets[i], &port, sizeof(port)); 4093 if (got != sizeof(port)) { 4094 if (got == -1) 4095 goto tidy_up_and_fail; 4096 goto abort_tidy_up_and_fail; 4097 } 4098 } while (i--); 4099 4100 /* Packets sent. I don't trust them to have arrived though. 4101 (As I understand it Solaris TCP stack is multithreaded. Non-blocking 4102 connect to localhost will use a second kernel thread. In 2.6 the 4103 first thread running the connect() returns before the second completes, 4104 so EINPROGRESS> In 2.7 the improved stack is faster and connect() 4105 returns 0. Poor programs have tripped up. One poor program's authors' 4106 had a 50-1 reverse stock split. Not sure how connected these were.) 4107 So I don't trust someone not to have an unpredictable UDP stack. 4108 */ 4109 4110 { 4111 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ 4112 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; 4113 fd_set rset; 4114 4115 FD_ZERO(&rset); 4116 FD_SET((unsigned int)sockets[0], &rset); 4117 FD_SET((unsigned int)sockets[1], &rset); 4118 4119 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor); 4120 if (got != 2 || !FD_ISSET(sockets[0], &rset) 4121 || !FD_ISSET(sockets[1], &rset)) { 4122 /* I hope this is portable and appropriate. */ 4123 if (got == -1) 4124 goto tidy_up_and_fail; 4125 goto abort_tidy_up_and_fail; 4126 } 4127 } 4128 4129 /* And the paranoia department even now doesn't trust it to have arrive 4130 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */ 4131 { 4132 struct sockaddr_in readfrom; 4133 unsigned short buffer[2]; 4134 4135 i = 1; 4136 do { 4137 #ifdef MSG_DONTWAIT 4138 got = PerlSock_recvfrom(sockets[i], (char *) &buffer, 4139 sizeof(buffer), MSG_DONTWAIT, 4140 (struct sockaddr *) &readfrom, &size); 4141 #else 4142 got = PerlSock_recvfrom(sockets[i], (char *) &buffer, 4143 sizeof(buffer), 0, 4144 (struct sockaddr *) &readfrom, &size); 4145 #endif 4146 4147 if (got == -1) 4148 goto tidy_up_and_fail; 4149 if (got != sizeof(port) 4150 || size != sizeof(struct sockaddr_in) 4151 /* Check other socket sent us its port. */ 4152 || buffer[0] != (unsigned short) addresses[!i].sin_port 4153 /* Check kernel says we got the datagram from that socket */ 4154 || readfrom.sin_family != addresses[!i].sin_family 4155 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr 4156 || readfrom.sin_port != addresses[!i].sin_port) 4157 goto abort_tidy_up_and_fail; 4158 } while (i--); 4159 } 4160 /* My caller (my_socketpair) has validated that this is non-NULL */ 4161 fd[0] = sockets[0]; 4162 fd[1] = sockets[1]; 4163 /* I hereby declare this connection open. May God bless all who cross 4164 her. */ 4165 return 0; 4166 4167 abort_tidy_up_and_fail: 4168 errno = ECONNABORTED; 4169 tidy_up_and_fail: 4170 { 4171 dSAVE_ERRNO; 4172 if (sockets[0] != -1) 4173 PerlLIO_close(sockets[0]); 4174 if (sockets[1] != -1) 4175 PerlLIO_close(sockets[1]); 4176 RESTORE_ERRNO; 4177 return -1; 4178 } 4179 } 4180 #endif /* EMULATE_SOCKETPAIR_UDP */ 4181 4182 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) 4183 int 4184 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { 4185 /* Stevens says that family must be AF_LOCAL, protocol 0. 4186 I'm going to enforce that, then ignore it, and use TCP (or UDP). */ 4187 dTHXa(NULL); 4188 int listener = -1; 4189 int connector = -1; 4190 int acceptor = -1; 4191 struct sockaddr_in listen_addr; 4192 struct sockaddr_in connect_addr; 4193 Sock_size_t size; 4194 4195 if (protocol 4196 #ifdef AF_UNIX 4197 || family != AF_UNIX 4198 #endif 4199 ) { 4200 errno = EAFNOSUPPORT; 4201 return -1; 4202 } 4203 if (!fd) { 4204 errno = EINVAL; 4205 return -1; 4206 } 4207 4208 #ifdef EMULATE_SOCKETPAIR_UDP 4209 if (type == SOCK_DGRAM) 4210 return S_socketpair_udp(fd); 4211 #endif 4212 4213 aTHXa(PERL_GET_THX); 4214 listener = PerlSock_socket(AF_INET, type, 0); 4215 if (listener == -1) 4216 return -1; 4217 memset(&listen_addr, 0, sizeof(listen_addr)); 4218 listen_addr.sin_family = AF_INET; 4219 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); 4220 listen_addr.sin_port = 0; /* kernel choses port. */ 4221 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr, 4222 sizeof(listen_addr)) == -1) 4223 goto tidy_up_and_fail; 4224 if (PerlSock_listen(listener, 1) == -1) 4225 goto tidy_up_and_fail; 4226 4227 connector = PerlSock_socket(AF_INET, type, 0); 4228 if (connector == -1) 4229 goto tidy_up_and_fail; 4230 /* We want to find out the port number to connect to. */ 4231 size = sizeof(connect_addr); 4232 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr, 4233 &size) == -1) 4234 goto tidy_up_and_fail; 4235 if (size != sizeof(connect_addr)) 4236 goto abort_tidy_up_and_fail; 4237 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr, 4238 sizeof(connect_addr)) == -1) 4239 goto tidy_up_and_fail; 4240 4241 size = sizeof(listen_addr); 4242 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr, 4243 &size); 4244 if (acceptor == -1) 4245 goto tidy_up_and_fail; 4246 if (size != sizeof(listen_addr)) 4247 goto abort_tidy_up_and_fail; 4248 PerlLIO_close(listener); 4249 /* Now check we are talking to ourself by matching port and host on the 4250 two sockets. */ 4251 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr, 4252 &size) == -1) 4253 goto tidy_up_and_fail; 4254 if (size != sizeof(connect_addr) 4255 || listen_addr.sin_family != connect_addr.sin_family 4256 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr 4257 || listen_addr.sin_port != connect_addr.sin_port) { 4258 goto abort_tidy_up_and_fail; 4259 } 4260 fd[0] = connector; 4261 fd[1] = acceptor; 4262 return 0; 4263 4264 abort_tidy_up_and_fail: 4265 #ifdef ECONNABORTED 4266 errno = ECONNABORTED; /* This would be the standard thing to do. */ 4267 #else 4268 # ifdef ECONNREFUSED 4269 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */ 4270 # else 4271 errno = ETIMEDOUT; /* Desperation time. */ 4272 # endif 4273 #endif 4274 tidy_up_and_fail: 4275 { 4276 dSAVE_ERRNO; 4277 if (listener != -1) 4278 PerlLIO_close(listener); 4279 if (connector != -1) 4280 PerlLIO_close(connector); 4281 if (acceptor != -1) 4282 PerlLIO_close(acceptor); 4283 RESTORE_ERRNO; 4284 return -1; 4285 } 4286 } 4287 #else 4288 /* In any case have a stub so that there's code corresponding 4289 * to the my_socketpair in embed.fnc. */ 4290 int 4291 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { 4292 #ifdef HAS_SOCKETPAIR 4293 return socketpair(family, type, protocol, fd); 4294 #else 4295 return -1; 4296 #endif 4297 } 4298 #endif 4299 4300 /* 4301 4302 =for apidoc sv_nosharing 4303 4304 Dummy routine which "shares" an SV when there is no sharing module present. 4305 Or "locks" it. Or "unlocks" it. In other 4306 words, ignores its single SV argument. 4307 Exists to avoid test for a NULL function pointer and because it could 4308 potentially warn under some level of strict-ness. 4309 4310 =cut 4311 */ 4312 4313 void 4314 Perl_sv_nosharing(pTHX_ SV *sv) 4315 { 4316 PERL_UNUSED_CONTEXT; 4317 PERL_UNUSED_ARG(sv); 4318 } 4319 4320 /* 4321 4322 =for apidoc sv_destroyable 4323 4324 Dummy routine which reports that object can be destroyed when there is no 4325 sharing module present. It ignores its single SV argument, and returns 4326 'true'. Exists to avoid test for a NULL function pointer and because it 4327 could potentially warn under some level of strict-ness. 4328 4329 =cut 4330 */ 4331 4332 bool 4333 Perl_sv_destroyable(pTHX_ SV *sv) 4334 { 4335 PERL_UNUSED_CONTEXT; 4336 PERL_UNUSED_ARG(sv); 4337 return TRUE; 4338 } 4339 4340 U32 4341 Perl_parse_unicode_opts(pTHX_ const char **popt) 4342 { 4343 const char *p = *popt; 4344 U32 opt = 0; 4345 4346 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS; 4347 4348 if (*p) { 4349 if (isDIGIT(*p)) { 4350 opt = (U32) atoi(p); 4351 while (isDIGIT(*p)) 4352 p++; 4353 if (*p && *p != '\n' && *p != '\r') { 4354 if(isSPACE(*p)) goto the_end_of_the_opts_parser; 4355 else 4356 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); 4357 } 4358 } 4359 else { 4360 for (; *p; p++) { 4361 switch (*p) { 4362 case PERL_UNICODE_STDIN: 4363 opt |= PERL_UNICODE_STDIN_FLAG; break; 4364 case PERL_UNICODE_STDOUT: 4365 opt |= PERL_UNICODE_STDOUT_FLAG; break; 4366 case PERL_UNICODE_STDERR: 4367 opt |= PERL_UNICODE_STDERR_FLAG; break; 4368 case PERL_UNICODE_STD: 4369 opt |= PERL_UNICODE_STD_FLAG; break; 4370 case PERL_UNICODE_IN: 4371 opt |= PERL_UNICODE_IN_FLAG; break; 4372 case PERL_UNICODE_OUT: 4373 opt |= PERL_UNICODE_OUT_FLAG; break; 4374 case PERL_UNICODE_INOUT: 4375 opt |= PERL_UNICODE_INOUT_FLAG; break; 4376 case PERL_UNICODE_LOCALE: 4377 opt |= PERL_UNICODE_LOCALE_FLAG; break; 4378 case PERL_UNICODE_ARGV: 4379 opt |= PERL_UNICODE_ARGV_FLAG; break; 4380 case PERL_UNICODE_UTF8CACHEASSERT: 4381 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break; 4382 default: 4383 if (*p != '\n' && *p != '\r') { 4384 if(isSPACE(*p)) goto the_end_of_the_opts_parser; 4385 else 4386 Perl_croak(aTHX_ 4387 "Unknown Unicode option letter '%c'", *p); 4388 } 4389 } 4390 } 4391 } 4392 } 4393 else 4394 opt = PERL_UNICODE_DEFAULT_FLAGS; 4395 4396 the_end_of_the_opts_parser: 4397 4398 if (opt & ~PERL_UNICODE_ALL_FLAGS) 4399 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf, 4400 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); 4401 4402 *popt = p; 4403 4404 return opt; 4405 } 4406 4407 #ifdef VMS 4408 # include <starlet.h> 4409 #endif 4410 4411 U32 4412 Perl_seed(pTHX) 4413 { 4414 #if defined(__OpenBSD__) 4415 return arc4random(); 4416 #else 4417 dVAR; 4418 /* 4419 * This is really just a quick hack which grabs various garbage 4420 * values. It really should be a real hash algorithm which 4421 * spreads the effect of every input bit onto every output bit, 4422 * if someone who knows about such things would bother to write it. 4423 * Might be a good idea to add that function to CORE as well. 4424 * No numbers below come from careful analysis or anything here, 4425 * except they are primes and SEED_C1 > 1E6 to get a full-width 4426 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should 4427 * probably be bigger too. 4428 */ 4429 #if RANDBITS > 16 4430 # define SEED_C1 1000003 4431 #define SEED_C4 73819 4432 #else 4433 # define SEED_C1 25747 4434 #define SEED_C4 20639 4435 #endif 4436 #define SEED_C2 3 4437 #define SEED_C3 269 4438 #define SEED_C5 26107 4439 4440 #ifndef PERL_NO_DEV_RANDOM 4441 int fd; 4442 #endif 4443 U32 u; 4444 #ifdef VMS 4445 /* when[] = (low 32 bits, high 32 bits) of time since epoch 4446 * in 100-ns units, typically incremented ever 10 ms. */ 4447 unsigned int when[2]; 4448 #else 4449 # ifdef HAS_GETTIMEOFDAY 4450 struct timeval when; 4451 # else 4452 Time_t when; 4453 # endif 4454 #endif 4455 4456 /* This test is an escape hatch, this symbol isn't set by Configure. */ 4457 #ifndef PERL_NO_DEV_RANDOM 4458 #ifndef PERL_RANDOM_DEVICE 4459 /* /dev/random isn't used by default because reads from it will block 4460 * if there isn't enough entropy available. You can compile with 4461 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there 4462 * is enough real entropy to fill the seed. */ 4463 # define PERL_RANDOM_DEVICE "/dev/urandom" 4464 #endif 4465 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); 4466 if (fd != -1) { 4467 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u) 4468 u = 0; 4469 PerlLIO_close(fd); 4470 if (u) 4471 return u; 4472 } 4473 #endif 4474 4475 #ifdef VMS 4476 _ckvmssts(sys$gettim(when)); 4477 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; 4478 #else 4479 # ifdef HAS_GETTIMEOFDAY 4480 PerlProc_gettimeofday(&when,NULL); 4481 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; 4482 # else 4483 (void)time(&when); 4484 u = (U32)SEED_C1 * when; 4485 # endif 4486 #endif 4487 u += SEED_C3 * (U32)PerlProc_getpid(); 4488 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); 4489 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ 4490 u += SEED_C5 * (U32)PTR2UV(&when); 4491 #endif 4492 return u; 4493 #endif 4494 } 4495 4496 void 4497 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer) 4498 { 4499 dVAR; 4500 const char *env_pv; 4501 unsigned long i; 4502 4503 PERL_ARGS_ASSERT_GET_HASH_SEED; 4504 4505 env_pv= PerlEnv_getenv("PERL_HASH_SEED"); 4506 4507 if ( env_pv ) 4508 #ifndef USE_HASH_SEED_EXPLICIT 4509 { 4510 /* ignore leading spaces */ 4511 while (isSPACE(*env_pv)) 4512 env_pv++; 4513 #ifdef USE_PERL_PERTURB_KEYS 4514 /* if they set it to "0" we disable key traversal randomization completely */ 4515 if (strEQ(env_pv,"0")) { 4516 PL_hash_rand_bits_enabled= 0; 4517 } else { 4518 /* otherwise switch to deterministic mode */ 4519 PL_hash_rand_bits_enabled= 2; 4520 } 4521 #endif 4522 /* ignore a leading 0x... if it is there */ 4523 if (env_pv[0] == '0' && env_pv[1] == 'x') 4524 env_pv += 2; 4525 4526 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) { 4527 seed_buffer[i] = READ_XDIGIT(env_pv) << 4; 4528 if ( isXDIGIT(*env_pv)) { 4529 seed_buffer[i] |= READ_XDIGIT(env_pv); 4530 } 4531 } 4532 while (isSPACE(*env_pv)) 4533 env_pv++; 4534 4535 if (*env_pv && !isXDIGIT(*env_pv)) { 4536 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n"); 4537 } 4538 /* should we check for unparsed crap? */ 4539 /* should we warn about unused hex? */ 4540 /* should we warn about insufficient hex? */ 4541 } 4542 else 4543 #endif 4544 { 4545 (void)seedDrand01((Rand_seed_t)seed()); 4546 4547 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) { 4548 seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1)); 4549 } 4550 } 4551 #ifdef USE_PERL_PERTURB_KEYS 4552 { /* initialize PL_hash_rand_bits from the hash seed. 4553 * This value is highly volatile, it is updated every 4554 * hash insert, and is used as part of hash bucket chain 4555 * randomization and hash iterator randomization. */ 4556 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */ 4557 for( i = 0; i < sizeof(UV) ; i++ ) { 4558 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES]; 4559 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8); 4560 } 4561 } 4562 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS"); 4563 if (env_pv) { 4564 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) { 4565 PL_hash_rand_bits_enabled= 0; 4566 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) { 4567 PL_hash_rand_bits_enabled= 1; 4568 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) { 4569 PL_hash_rand_bits_enabled= 2; 4570 } else { 4571 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv); 4572 } 4573 } 4574 #endif 4575 } 4576 4577 #ifdef PERL_GLOBAL_STRUCT 4578 4579 #define PERL_GLOBAL_STRUCT_INIT 4580 #include "opcode.h" /* the ppaddr and check */ 4581 4582 struct perl_vars * 4583 Perl_init_global_struct(pTHX) 4584 { 4585 struct perl_vars *plvarsp = NULL; 4586 # ifdef PERL_GLOBAL_STRUCT 4587 const IV nppaddr = C_ARRAY_LENGTH(Gppaddr); 4588 const IV ncheck = C_ARRAY_LENGTH(Gcheck); 4589 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4590 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */ 4591 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); 4592 if (!plvarsp) 4593 exit(1); 4594 # else 4595 plvarsp = PL_VarsPtr; 4596 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */ 4597 # undef PERLVAR 4598 # undef PERLVARA 4599 # undef PERLVARI 4600 # undef PERLVARIC 4601 # define PERLVAR(prefix,var,type) /**/ 4602 # define PERLVARA(prefix,var,n,type) /**/ 4603 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init; 4604 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init; 4605 # include "perlvars.h" 4606 # undef PERLVAR 4607 # undef PERLVARA 4608 # undef PERLVARI 4609 # undef PERLVARIC 4610 # ifdef PERL_GLOBAL_STRUCT 4611 plvarsp->Gppaddr = 4612 (Perl_ppaddr_t*) 4613 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); 4614 if (!plvarsp->Gppaddr) 4615 exit(1); 4616 plvarsp->Gcheck = 4617 (Perl_check_t*) 4618 PerlMem_malloc(ncheck * sizeof(Perl_check_t)); 4619 if (!plvarsp->Gcheck) 4620 exit(1); 4621 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 4622 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t); 4623 # endif 4624 # ifdef PERL_SET_VARS 4625 PERL_SET_VARS(plvarsp); 4626 # endif 4627 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4628 plvarsp->Gsv_placeholder.sv_flags = 0; 4629 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed)); 4630 # endif 4631 # undef PERL_GLOBAL_STRUCT_INIT 4632 # endif 4633 return plvarsp; 4634 } 4635 4636 #endif /* PERL_GLOBAL_STRUCT */ 4637 4638 #ifdef PERL_GLOBAL_STRUCT 4639 4640 void 4641 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) 4642 { 4643 int veto = plvarsp->Gveto_cleanup; 4644 4645 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT; 4646 # ifdef PERL_GLOBAL_STRUCT 4647 # ifdef PERL_UNSET_VARS 4648 PERL_UNSET_VARS(plvarsp); 4649 # endif 4650 if (veto) 4651 return; 4652 free(plvarsp->Gppaddr); 4653 free(plvarsp->Gcheck); 4654 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4655 free(plvarsp); 4656 # endif 4657 # endif 4658 } 4659 4660 #endif /* PERL_GLOBAL_STRUCT */ 4661 4662 #ifdef PERL_MEM_LOG 4663 4664 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the 4665 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also 4666 * given, and you supply your own implementation. 4667 * 4668 * The default implementation reads a single env var, PERL_MEM_LOG, 4669 * expecting one or more of the following: 4670 * 4671 * \d+ - fd fd to write to : must be 1st (atoi) 4672 * 'm' - memlog was PERL_MEM_LOG=1 4673 * 's' - svlog was PERL_SV_LOG=1 4674 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 4675 * 4676 * This makes the logger controllable enough that it can reasonably be 4677 * added to the system perl. 4678 */ 4679 4680 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer 4681 * the Perl_mem_log_...() will use (either via sprintf or snprintf). 4682 */ 4683 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 4684 4685 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...() 4686 * writes to. In the default logger, this is settable at runtime. 4687 */ 4688 #ifndef PERL_MEM_LOG_FD 4689 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */ 4690 #endif 4691 4692 #ifndef PERL_MEM_LOG_NOIMPL 4693 4694 # ifdef DEBUG_LEAKING_SCALARS 4695 # define SV_LOG_SERIAL_FMT " [%lu]" 4696 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial 4697 # else 4698 # define SV_LOG_SERIAL_FMT 4699 # define _SV_LOG_SERIAL_ARG(sv) 4700 # endif 4701 4702 static void 4703 S_mem_log_common(enum mem_log_type mlt, const UV n, 4704 const UV typesize, const char *type_name, const SV *sv, 4705 Malloc_t oldalloc, Malloc_t newalloc, 4706 const char *filename, const int linenumber, 4707 const char *funcname) 4708 { 4709 const char *pmlenv; 4710 4711 PERL_ARGS_ASSERT_MEM_LOG_COMMON; 4712 4713 pmlenv = PerlEnv_getenv("PERL_MEM_LOG"); 4714 if (!pmlenv) 4715 return; 4716 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s')) 4717 { 4718 /* We can't use SVs or PerlIO for obvious reasons, 4719 * so we'll use stdio and low-level IO instead. */ 4720 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; 4721 4722 # ifdef HAS_GETTIMEOFDAY 4723 # define MEM_LOG_TIME_FMT "%10d.%06d: " 4724 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec 4725 struct timeval tv; 4726 gettimeofday(&tv, 0); 4727 # else 4728 # define MEM_LOG_TIME_FMT "%10d: " 4729 # define MEM_LOG_TIME_ARG (int)when 4730 Time_t when; 4731 (void)time(&when); 4732 # endif 4733 /* If there are other OS specific ways of hires time than 4734 * gettimeofday() (see ext/Time-HiRes), the easiest way is 4735 * probably that they would be used to fill in the struct 4736 * timeval. */ 4737 { 4738 STRLEN len; 4739 int fd = atoi(pmlenv); 4740 if (!fd) 4741 fd = PERL_MEM_LOG_FD; 4742 4743 if (strchr(pmlenv, 't')) { 4744 len = my_snprintf(buf, sizeof(buf), 4745 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); 4746 PerlLIO_write(fd, buf, len); 4747 } 4748 switch (mlt) { 4749 case MLT_ALLOC: 4750 len = my_snprintf(buf, sizeof(buf), 4751 "alloc: %s:%d:%s: %"IVdf" %"UVuf 4752 " %s = %"IVdf": %"UVxf"\n", 4753 filename, linenumber, funcname, n, typesize, 4754 type_name, n * typesize, PTR2UV(newalloc)); 4755 break; 4756 case MLT_REALLOC: 4757 len = my_snprintf(buf, sizeof(buf), 4758 "realloc: %s:%d:%s: %"IVdf" %"UVuf 4759 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n", 4760 filename, linenumber, funcname, n, typesize, 4761 type_name, n * typesize, PTR2UV(oldalloc), 4762 PTR2UV(newalloc)); 4763 break; 4764 case MLT_FREE: 4765 len = my_snprintf(buf, sizeof(buf), 4766 "free: %s:%d:%s: %"UVxf"\n", 4767 filename, linenumber, funcname, 4768 PTR2UV(oldalloc)); 4769 break; 4770 case MLT_NEW_SV: 4771 case MLT_DEL_SV: 4772 len = my_snprintf(buf, sizeof(buf), 4773 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n", 4774 mlt == MLT_NEW_SV ? "new" : "del", 4775 filename, linenumber, funcname, 4776 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv)); 4777 break; 4778 default: 4779 len = 0; 4780 } 4781 PerlLIO_write(fd, buf, len); 4782 } 4783 } 4784 } 4785 #endif /* !PERL_MEM_LOG_NOIMPL */ 4786 4787 #ifndef PERL_MEM_LOG_NOIMPL 4788 # define \ 4789 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \ 4790 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) 4791 #else 4792 /* this is suboptimal, but bug compatible. User is providing their 4793 own implementation, but is getting these functions anyway, and they 4794 do nothing. But _NOIMPL users should be able to cope or fix */ 4795 # define \ 4796 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \ 4797 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */ 4798 #endif 4799 4800 Malloc_t 4801 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, 4802 Malloc_t newalloc, 4803 const char *filename, const int linenumber, 4804 const char *funcname) 4805 { 4806 mem_log_common_if(MLT_ALLOC, n, typesize, type_name, 4807 NULL, NULL, newalloc, 4808 filename, linenumber, funcname); 4809 return newalloc; 4810 } 4811 4812 Malloc_t 4813 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, 4814 Malloc_t oldalloc, Malloc_t newalloc, 4815 const char *filename, const int linenumber, 4816 const char *funcname) 4817 { 4818 mem_log_common_if(MLT_REALLOC, n, typesize, type_name, 4819 NULL, oldalloc, newalloc, 4820 filename, linenumber, funcname); 4821 return newalloc; 4822 } 4823 4824 Malloc_t 4825 Perl_mem_log_free(Malloc_t oldalloc, 4826 const char *filename, const int linenumber, 4827 const char *funcname) 4828 { 4829 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 4830 filename, linenumber, funcname); 4831 return oldalloc; 4832 } 4833 4834 void 4835 Perl_mem_log_new_sv(const SV *sv, 4836 const char *filename, const int linenumber, 4837 const char *funcname) 4838 { 4839 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, 4840 filename, linenumber, funcname); 4841 } 4842 4843 void 4844 Perl_mem_log_del_sv(const SV *sv, 4845 const char *filename, const int linenumber, 4846 const char *funcname) 4847 { 4848 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, 4849 filename, linenumber, funcname); 4850 } 4851 4852 #endif /* PERL_MEM_LOG */ 4853 4854 /* 4855 =for apidoc my_sprintf 4856 4857 The C library C<sprintf>, wrapped if necessary, to ensure that it will return 4858 the length of the string written to the buffer. Only rare pre-ANSI systems 4859 need the wrapper function - usually this is a direct call to C<sprintf>. 4860 4861 =cut 4862 */ 4863 #ifndef SPRINTF_RETURNS_STRLEN 4864 int 4865 Perl_my_sprintf(char *buffer, const char* pat, ...) 4866 { 4867 va_list args; 4868 PERL_ARGS_ASSERT_MY_SPRINTF; 4869 va_start(args, pat); 4870 vsprintf(buffer, pat, args); 4871 va_end(args); 4872 return strlen(buffer); 4873 } 4874 #endif 4875 4876 /* 4877 =for apidoc my_snprintf 4878 4879 The C library C<snprintf> functionality, if available and 4880 standards-compliant (uses C<vsnprintf>, actually). However, if the 4881 C<vsnprintf> is not available, will unfortunately use the unsafe 4882 C<vsprintf> which can overrun the buffer (there is an overrun check, 4883 but that may be too late). Consider using C<sv_vcatpvf> instead, or 4884 getting C<vsnprintf>. 4885 4886 =cut 4887 */ 4888 int 4889 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) 4890 { 4891 int retval; 4892 va_list ap; 4893 PERL_ARGS_ASSERT_MY_SNPRINTF; 4894 va_start(ap, format); 4895 #ifdef HAS_VSNPRINTF 4896 retval = vsnprintf(buffer, len, format, ap); 4897 #else 4898 retval = vsprintf(buffer, format, ap); 4899 #endif 4900 va_end(ap); 4901 /* vsprintf() shows failure with < 0 */ 4902 if (retval < 0 4903 #ifdef HAS_VSNPRINTF 4904 /* vsnprintf() shows failure with >= len */ 4905 || 4906 (len > 0 && (Size_t)retval >= len) 4907 #endif 4908 ) 4909 Perl_croak_nocontext("panic: my_snprintf buffer overflow"); 4910 return retval; 4911 } 4912 4913 /* 4914 =for apidoc my_vsnprintf 4915 4916 The C library C<vsnprintf> if available and standards-compliant. 4917 However, if if the C<vsnprintf> is not available, will unfortunately 4918 use the unsafe C<vsprintf> which can overrun the buffer (there is an 4919 overrun check, but that may be too late). Consider using 4920 C<sv_vcatpvf> instead, or getting C<vsnprintf>. 4921 4922 =cut 4923 */ 4924 int 4925 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) 4926 { 4927 int retval; 4928 #ifdef NEED_VA_COPY 4929 va_list apc; 4930 4931 PERL_ARGS_ASSERT_MY_VSNPRINTF; 4932 4933 Perl_va_copy(ap, apc); 4934 # ifdef HAS_VSNPRINTF 4935 retval = vsnprintf(buffer, len, format, apc); 4936 # else 4937 retval = vsprintf(buffer, format, apc); 4938 # endif 4939 va_end(apc); 4940 #else 4941 # ifdef HAS_VSNPRINTF 4942 retval = vsnprintf(buffer, len, format, ap); 4943 # else 4944 retval = vsprintf(buffer, format, ap); 4945 # endif 4946 #endif /* #ifdef NEED_VA_COPY */ 4947 /* vsprintf() shows failure with < 0 */ 4948 if (retval < 0 4949 #ifdef HAS_VSNPRINTF 4950 /* vsnprintf() shows failure with >= len */ 4951 || 4952 (len > 0 && (Size_t)retval >= len) 4953 #endif 4954 ) 4955 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); 4956 return retval; 4957 } 4958 4959 void 4960 Perl_my_clearenv(pTHX) 4961 { 4962 dVAR; 4963 #if ! defined(PERL_MICRO) 4964 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32) 4965 PerlEnv_clearenv(); 4966 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */ 4967 # if defined(USE_ENVIRON_ARRAY) 4968 # if defined(USE_ITHREADS) 4969 /* only the parent thread can clobber the process environment */ 4970 if (PL_curinterp == aTHX) 4971 # endif /* USE_ITHREADS */ 4972 { 4973 # if ! defined(PERL_USE_SAFE_PUTENV) 4974 if ( !PL_use_safe_putenv) { 4975 I32 i; 4976 if (environ == PL_origenviron) 4977 environ = (char**)safesysmalloc(sizeof(char*)); 4978 else 4979 for (i = 0; environ[i]; i++) 4980 (void)safesysfree(environ[i]); 4981 } 4982 environ[0] = NULL; 4983 # else /* PERL_USE_SAFE_PUTENV */ 4984 # if defined(HAS_CLEARENV) 4985 (void)clearenv(); 4986 # elif defined(HAS_UNSETENV) 4987 int bsiz = 80; /* Most envvar names will be shorter than this. */ 4988 char *buf = (char*)safesysmalloc(bsiz); 4989 while (*environ != NULL) { 4990 char *e = strchr(*environ, '='); 4991 int l = e ? e - *environ : (int)strlen(*environ); 4992 if (bsiz < l + 1) { 4993 (void)safesysfree(buf); 4994 bsiz = l + 1; /* + 1 for the \0. */ 4995 buf = (char*)safesysmalloc(bsiz); 4996 } 4997 memcpy(buf, *environ, l); 4998 buf[l] = '\0'; 4999 (void)unsetenv(buf); 5000 } 5001 (void)safesysfree(buf); 5002 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */ 5003 /* Just null environ and accept the leakage. */ 5004 *environ = NULL; 5005 # endif /* HAS_CLEARENV || HAS_UNSETENV */ 5006 # endif /* ! PERL_USE_SAFE_PUTENV */ 5007 } 5008 # endif /* USE_ENVIRON_ARRAY */ 5009 # endif /* PERL_IMPLICIT_SYS || WIN32 */ 5010 #endif /* PERL_MICRO */ 5011 } 5012 5013 #ifdef PERL_IMPLICIT_CONTEXT 5014 5015 /* Implements the MY_CXT_INIT macro. The first time a module is loaded, 5016 the global PL_my_cxt_index is incremented, and that value is assigned to 5017 that module's static my_cxt_index (who's address is passed as an arg). 5018 Then, for each interpreter this function is called for, it makes sure a 5019 void* slot is available to hang the static data off, by allocating or 5020 extending the interpreter's PL_my_cxt_list array */ 5021 5022 #ifndef PERL_GLOBAL_STRUCT_PRIVATE 5023 void * 5024 Perl_my_cxt_init(pTHX_ int *index, size_t size) 5025 { 5026 dVAR; 5027 void *p; 5028 PERL_ARGS_ASSERT_MY_CXT_INIT; 5029 if (*index == -1) { 5030 /* this module hasn't been allocated an index yet */ 5031 #if defined(USE_ITHREADS) 5032 MUTEX_LOCK(&PL_my_ctx_mutex); 5033 #endif 5034 *index = PL_my_cxt_index++; 5035 #if defined(USE_ITHREADS) 5036 MUTEX_UNLOCK(&PL_my_ctx_mutex); 5037 #endif 5038 } 5039 5040 /* make sure the array is big enough */ 5041 if (PL_my_cxt_size <= *index) { 5042 if (PL_my_cxt_size) { 5043 while (PL_my_cxt_size <= *index) 5044 PL_my_cxt_size *= 2; 5045 Renew(PL_my_cxt_list, PL_my_cxt_size, void *); 5046 } 5047 else { 5048 PL_my_cxt_size = 16; 5049 Newx(PL_my_cxt_list, PL_my_cxt_size, void *); 5050 } 5051 } 5052 /* newSV() allocates one more than needed */ 5053 p = (void*)SvPVX(newSV(size-1)); 5054 PL_my_cxt_list[*index] = p; 5055 Zero(p, size, char); 5056 return p; 5057 } 5058 5059 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ 5060 5061 int 5062 Perl_my_cxt_index(pTHX_ const char *my_cxt_key) 5063 { 5064 dVAR; 5065 int index; 5066 5067 PERL_ARGS_ASSERT_MY_CXT_INDEX; 5068 5069 for (index = 0; index < PL_my_cxt_index; index++) { 5070 const char *key = PL_my_cxt_keys[index]; 5071 /* try direct pointer compare first - there are chances to success, 5072 * and it's much faster. 5073 */ 5074 if ((key == my_cxt_key) || strEQ(key, my_cxt_key)) 5075 return index; 5076 } 5077 return -1; 5078 } 5079 5080 void * 5081 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) 5082 { 5083 dVAR; 5084 void *p; 5085 int index; 5086 5087 PERL_ARGS_ASSERT_MY_CXT_INIT; 5088 5089 index = Perl_my_cxt_index(aTHX_ my_cxt_key); 5090 if (index == -1) { 5091 /* this module hasn't been allocated an index yet */ 5092 #if defined(USE_ITHREADS) 5093 MUTEX_LOCK(&PL_my_ctx_mutex); 5094 #endif 5095 index = PL_my_cxt_index++; 5096 #if defined(USE_ITHREADS) 5097 MUTEX_UNLOCK(&PL_my_ctx_mutex); 5098 #endif 5099 } 5100 5101 /* make sure the array is big enough */ 5102 if (PL_my_cxt_size <= index) { 5103 int old_size = PL_my_cxt_size; 5104 int i; 5105 if (PL_my_cxt_size) { 5106 while (PL_my_cxt_size <= index) 5107 PL_my_cxt_size *= 2; 5108 Renew(PL_my_cxt_list, PL_my_cxt_size, void *); 5109 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *); 5110 } 5111 else { 5112 PL_my_cxt_size = 16; 5113 Newx(PL_my_cxt_list, PL_my_cxt_size, void *); 5114 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); 5115 } 5116 for (i = old_size; i < PL_my_cxt_size; i++) { 5117 PL_my_cxt_keys[i] = 0; 5118 PL_my_cxt_list[i] = 0; 5119 } 5120 } 5121 PL_my_cxt_keys[index] = my_cxt_key; 5122 /* newSV() allocates one more than needed */ 5123 p = (void*)SvPVX(newSV(size-1)); 5124 PL_my_cxt_list[index] = p; 5125 Zero(p, size, char); 5126 return p; 5127 } 5128 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ 5129 #endif /* PERL_IMPLICIT_CONTEXT */ 5130 5131 void 5132 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, 5133 STRLEN xs_len) 5134 { 5135 SV *sv; 5136 const char *vn = NULL; 5137 SV *const module = PL_stack_base[ax]; 5138 5139 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK; 5140 5141 if (items >= 2) /* version supplied as bootstrap arg */ 5142 sv = PL_stack_base[ax + 1]; 5143 else { 5144 /* XXX GV_ADDWARN */ 5145 vn = "XS_VERSION"; 5146 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); 5147 if (!sv || !SvOK(sv)) { 5148 vn = "VERSION"; 5149 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); 5150 } 5151 } 5152 if (sv) { 5153 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP); 5154 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version") 5155 ? sv : sv_2mortal(new_version(sv)); 5156 xssv = upg_version(xssv, 0); 5157 if ( vcmp(pmsv,xssv) ) { 5158 SV *string = vstringify(xssv); 5159 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf 5160 " does not match ", module, string); 5161 5162 SvREFCNT_dec(string); 5163 string = vstringify(pmsv); 5164 5165 if (vn) { 5166 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn, 5167 string); 5168 } else { 5169 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string); 5170 } 5171 SvREFCNT_dec(string); 5172 5173 Perl_sv_2mortal(aTHX_ xpt); 5174 Perl_croak_sv(aTHX_ xpt); 5175 } 5176 } 5177 } 5178 5179 void 5180 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p, 5181 STRLEN api_len) 5182 { 5183 SV *xpt = NULL; 5184 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP); 5185 SV *runver; 5186 5187 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK; 5188 5189 /* This might croak */ 5190 compver = upg_version(compver, 0); 5191 /* This should never croak */ 5192 runver = new_version(PL_apiversion); 5193 if (vcmp(compver, runver)) { 5194 SV *compver_string = vstringify(compver); 5195 SV *runver_string = vstringify(runver); 5196 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf 5197 " of %"SVf" does not match %"SVf, 5198 compver_string, module, runver_string); 5199 Perl_sv_2mortal(aTHX_ xpt); 5200 5201 SvREFCNT_dec(compver_string); 5202 SvREFCNT_dec(runver_string); 5203 } 5204 SvREFCNT_dec(runver); 5205 if (xpt) 5206 Perl_croak_sv(aTHX_ xpt); 5207 } 5208 5209 /* 5210 =for apidoc my_strlcat 5211 5212 The C library C<strlcat> if available, or a Perl implementation of it. 5213 This operates on C C<NUL>-terminated strings. 5214 5215 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at 5216 most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate, 5217 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in 5218 practice this should not happen as it means that either C<size> is incorrect or 5219 that C<dst> is not a proper C<NUL>-terminated string). 5220 5221 Note that C<size> is the full size of the destination buffer and 5222 the result is guaranteed to be C<NUL>-terminated if there is room. Note that 5223 room for the C<NUL> should be included in C<size>. 5224 5225 =cut 5226 5227 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat 5228 */ 5229 #ifndef HAS_STRLCAT 5230 Size_t 5231 Perl_my_strlcat(char *dst, const char *src, Size_t size) 5232 { 5233 Size_t used, length, copy; 5234 5235 used = strlen(dst); 5236 length = strlen(src); 5237 if (size > 0 && used < size - 1) { 5238 copy = (length >= size - used) ? size - used - 1 : length; 5239 memcpy(dst + used, src, copy); 5240 dst[used + copy] = '\0'; 5241 } 5242 return used + length; 5243 } 5244 #endif 5245 5246 5247 /* 5248 =for apidoc my_strlcpy 5249 5250 The C library C<strlcpy> if available, or a Perl implementation of it. 5251 This operates on C C<NUL>-terminated strings. 5252 5253 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src> 5254 to C<dst>, C<NUL>-terminating the result if C<size> is not 0. 5255 5256 =cut 5257 5258 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy 5259 */ 5260 #ifndef HAS_STRLCPY 5261 Size_t 5262 Perl_my_strlcpy(char *dst, const char *src, Size_t size) 5263 { 5264 Size_t length, copy; 5265 5266 length = strlen(src); 5267 if (size > 0) { 5268 copy = (length >= size) ? size - 1 : length; 5269 memcpy(dst, src, copy); 5270 dst[copy] = '\0'; 5271 } 5272 return length; 5273 } 5274 #endif 5275 5276 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500) 5277 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */ 5278 long _ftol( double ); /* Defined by VC6 C libs. */ 5279 long _ftol2( double dblSource ) { return _ftol( dblSource ); } 5280 #endif 5281 5282 PERL_STATIC_INLINE bool 5283 S_gv_has_usable_name(pTHX_ GV *gv) 5284 { 5285 GV **gvp; 5286 return GvSTASH(gv) 5287 && HvENAME(GvSTASH(gv)) 5288 && (gvp = (GV **)hv_fetchhek( 5289 GvSTASH(gv), GvNAME_HEK(gv), 0 5290 )) 5291 && *gvp == gv; 5292 } 5293 5294 void 5295 Perl_get_db_sub(pTHX_ SV **svp, CV *cv) 5296 { 5297 dVAR; 5298 SV * const dbsv = GvSVn(PL_DBsub); 5299 const bool save_taint = TAINT_get; 5300 5301 /* When we are called from pp_goto (svp is null), 5302 * we do not care about using dbsv to call CV; 5303 * it's for informational purposes only. 5304 */ 5305 5306 PERL_ARGS_ASSERT_GET_DB_SUB; 5307 5308 TAINT_set(FALSE); 5309 save_item(dbsv); 5310 if (!PERLDB_SUB_NN) { 5311 GV *gv = CvGV(cv); 5312 5313 if (gv && !svp) { 5314 gv_efullname3(dbsv, gv, NULL); 5315 } 5316 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || !gv 5317 || strEQ(GvNAME(gv), "END") 5318 || ( /* Could be imported, and old sub redefined. */ 5319 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) 5320 && 5321 !( (SvTYPE(*svp) == SVt_PVGV) 5322 && (GvCV((const GV *)*svp) == cv) 5323 /* Use GV from the stack as a fallback. */ 5324 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) 5325 ) 5326 ) 5327 ) { 5328 /* GV is potentially non-unique, or contain different CV. */ 5329 SV * const tmp = newRV(MUTABLE_SV(cv)); 5330 sv_setsv(dbsv, tmp); 5331 SvREFCNT_dec(tmp); 5332 } 5333 else { 5334 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); 5335 sv_catpvs(dbsv, "::"); 5336 sv_catpvn_flags( 5337 dbsv, GvNAME(gv), GvNAMELEN(gv), 5338 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES 5339 ); 5340 } 5341 } 5342 else { 5343 const int type = SvTYPE(dbsv); 5344 if (type < SVt_PVIV && type != SVt_IV) 5345 sv_upgrade(dbsv, SVt_PVIV); 5346 (void)SvIOK_on(dbsv); 5347 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ 5348 } 5349 SvSETMAGIC(dbsv); 5350 TAINT_IF(save_taint); 5351 #ifdef NO_TAINT_SUPPORT 5352 PERL_UNUSED_VAR(save_taint); 5353 #endif 5354 } 5355 5356 int 5357 Perl_my_dirfd(pTHX_ DIR * dir) { 5358 5359 /* Most dirfd implementations have problems when passed NULL. */ 5360 if(!dir) 5361 return -1; 5362 #ifdef HAS_DIRFD 5363 return dirfd(dir); 5364 #elif defined(HAS_DIR_DD_FD) 5365 return dir->dd_fd; 5366 #else 5367 Perl_die(aTHX_ PL_no_func, "dirfd"); 5368 assert(0); /* NOT REACHED */ 5369 return 0; 5370 #endif 5371 } 5372 5373 REGEXP * 5374 Perl_get_re_arg(pTHX_ SV *sv) { 5375 5376 if (sv) { 5377 if (SvMAGICAL(sv)) 5378 mg_get(sv); 5379 if (SvROK(sv)) 5380 sv = MUTABLE_SV(SvRV(sv)); 5381 if (SvTYPE(sv) == SVt_REGEXP) 5382 return (REGEXP*) sv; 5383 } 5384 5385 return NULL; 5386 } 5387 5388 /* 5389 * This code is derived from drand48() implementation from FreeBSD, 5390 * found in lib/libc/gen/_rand48.c. 5391 * 5392 * The U64 implementation is original, based on the POSIX 5393 * specification for drand48(). 5394 */ 5395 5396 /* 5397 * Copyright (c) 1993 Martin Birgmeier 5398 * All rights reserved. 5399 * 5400 * You may redistribute unmodified or modified versions of this source 5401 * code provided that the above copyright notice and this and the 5402 * following conditions are retained. 5403 * 5404 * This software is provided ``as is'', and comes with no warranties 5405 * of any kind. I shall in no event be liable for anything that happens 5406 * to anyone/anything when using this software. 5407 */ 5408 5409 #define FREEBSD_DRAND48_SEED_0 (0x330e) 5410 5411 #ifdef PERL_DRAND48_QUAD 5412 5413 #define DRAND48_MULT U64_CONST(0x5deece66d) 5414 #define DRAND48_ADD 0xb 5415 #define DRAND48_MASK U64_CONST(0xffffffffffff) 5416 5417 #else 5418 5419 #define FREEBSD_DRAND48_SEED_1 (0xabcd) 5420 #define FREEBSD_DRAND48_SEED_2 (0x1234) 5421 #define FREEBSD_DRAND48_MULT_0 (0xe66d) 5422 #define FREEBSD_DRAND48_MULT_1 (0xdeec) 5423 #define FREEBSD_DRAND48_MULT_2 (0x0005) 5424 #define FREEBSD_DRAND48_ADD (0x000b) 5425 5426 const unsigned short _rand48_mult[3] = { 5427 FREEBSD_DRAND48_MULT_0, 5428 FREEBSD_DRAND48_MULT_1, 5429 FREEBSD_DRAND48_MULT_2 5430 }; 5431 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD; 5432 5433 #endif 5434 5435 void 5436 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed) 5437 { 5438 PERL_ARGS_ASSERT_DRAND48_INIT_R; 5439 5440 #ifdef PERL_DRAND48_QUAD 5441 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16); 5442 #else 5443 random_state->seed[0] = FREEBSD_DRAND48_SEED_0; 5444 random_state->seed[1] = (U16) seed; 5445 random_state->seed[2] = (U16) (seed >> 16); 5446 #endif 5447 } 5448 5449 double 5450 Perl_drand48_r(perl_drand48_t *random_state) 5451 { 5452 PERL_ARGS_ASSERT_DRAND48_R; 5453 5454 #ifdef PERL_DRAND48_QUAD 5455 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD) 5456 & DRAND48_MASK; 5457 5458 return ldexp((double)*random_state, -48); 5459 #else 5460 { 5461 U32 accu; 5462 U16 temp[2]; 5463 5464 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0] 5465 + (U32) _rand48_add; 5466 temp[0] = (U16) accu; /* lower 16 bits */ 5467 accu >>= sizeof(U16) * 8; 5468 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1] 5469 + (U32) _rand48_mult[1] * (U32) random_state->seed[0]; 5470 temp[1] = (U16) accu; /* middle 16 bits */ 5471 accu >>= sizeof(U16) * 8; 5472 accu += _rand48_mult[0] * random_state->seed[2] 5473 + _rand48_mult[1] * random_state->seed[1] 5474 + _rand48_mult[2] * random_state->seed[0]; 5475 random_state->seed[0] = temp[0]; 5476 random_state->seed[1] = temp[1]; 5477 random_state->seed[2] = (U16) accu; 5478 5479 return ldexp((double) random_state->seed[0], -48) + 5480 ldexp((double) random_state->seed[1], -32) + 5481 ldexp((double) random_state->seed[2], -16); 5482 } 5483 #endif 5484 } 5485 5486 5487 /* 5488 * Local variables: 5489 * c-indentation-style: bsd 5490 * c-basic-offset: 4 5491 * indent-tabs-mode: nil 5492 * End: 5493 * 5494 * ex: set ts=8 sts=4 sw=4 et: 5495 */ 5496