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 (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { 1881 SV * const msv = vmess(pat, args); 1882 1883 invoke_exception_hook(msv, FALSE); 1884 die_unwind(msv); 1885 } 1886 else { 1887 Perl_vwarn(aTHX_ pat, args); 1888 } 1889 } 1890 1891 /* implements the ckWARN? macros */ 1892 1893 bool 1894 Perl_ckwarn(pTHX_ U32 w) 1895 { 1896 dVAR; 1897 /* If lexical warnings have not been set, use $^W. */ 1898 if (isLEXWARN_off) 1899 return PL_dowarn & G_WARN_ON; 1900 1901 return ckwarn_common(w); 1902 } 1903 1904 /* implements the ckWARN?_d macro */ 1905 1906 bool 1907 Perl_ckwarn_d(pTHX_ U32 w) 1908 { 1909 dVAR; 1910 /* If lexical warnings have not been set then default classes warn. */ 1911 if (isLEXWARN_off) 1912 return TRUE; 1913 1914 return ckwarn_common(w); 1915 } 1916 1917 static bool 1918 S_ckwarn_common(pTHX_ U32 w) 1919 { 1920 if (PL_curcop->cop_warnings == pWARN_ALL) 1921 return TRUE; 1922 1923 if (PL_curcop->cop_warnings == pWARN_NONE) 1924 return FALSE; 1925 1926 /* Check the assumption that at least the first slot is non-zero. */ 1927 assert(unpackWARN1(w)); 1928 1929 /* Check the assumption that it is valid to stop as soon as a zero slot is 1930 seen. */ 1931 if (!unpackWARN2(w)) { 1932 assert(!unpackWARN3(w)); 1933 assert(!unpackWARN4(w)); 1934 } else if (!unpackWARN3(w)) { 1935 assert(!unpackWARN4(w)); 1936 } 1937 1938 /* Right, dealt with all the special cases, which are implemented as non- 1939 pointers, so there is a pointer to a real warnings mask. */ 1940 do { 1941 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))) 1942 return TRUE; 1943 } while (w >>= WARNshift); 1944 1945 return FALSE; 1946 } 1947 1948 /* Set buffer=NULL to get a new one. */ 1949 STRLEN * 1950 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, 1951 STRLEN size) { 1952 const MEM_SIZE len_wanted = 1953 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize); 1954 PERL_UNUSED_CONTEXT; 1955 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD; 1956 1957 buffer = (STRLEN*) 1958 (specialWARN(buffer) ? 1959 PerlMemShared_malloc(len_wanted) : 1960 PerlMemShared_realloc(buffer, len_wanted)); 1961 buffer[0] = size; 1962 Copy(bits, (buffer + 1), size, char); 1963 if (size < WARNsize) 1964 Zero((char *)(buffer + 1) + size, WARNsize - size, char); 1965 return buffer; 1966 } 1967 1968 /* since we've already done strlen() for both nam and val 1969 * we can use that info to make things faster than 1970 * sprintf(s, "%s=%s", nam, val) 1971 */ 1972 #define my_setenv_format(s, nam, nlen, val, vlen) \ 1973 Copy(nam, s, nlen, char); \ 1974 *(s+nlen) = '='; \ 1975 Copy(val, s+(nlen+1), vlen, char); \ 1976 *(s+(nlen+1+vlen)) = '\0' 1977 1978 #ifdef USE_ENVIRON_ARRAY 1979 /* VMS' my_setenv() is in vms.c */ 1980 #if !defined(WIN32) && !defined(NETWARE) 1981 void 1982 Perl_my_setenv(pTHX_ const char *nam, const char *val) 1983 { 1984 dVAR; 1985 #ifdef USE_ITHREADS 1986 /* only parent thread can modify process environment */ 1987 if (PL_curinterp == aTHX) 1988 #endif 1989 { 1990 #ifndef PERL_USE_SAFE_PUTENV 1991 if (!PL_use_safe_putenv) { 1992 /* most putenv()s leak, so we manipulate environ directly */ 1993 I32 i; 1994 const I32 len = strlen(nam); 1995 int nlen, vlen; 1996 1997 /* where does it go? */ 1998 for (i = 0; environ[i]; i++) { 1999 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') 2000 break; 2001 } 2002 2003 if (environ == PL_origenviron) { /* need we copy environment? */ 2004 I32 j; 2005 I32 max; 2006 char **tmpenv; 2007 2008 max = i; 2009 while (environ[max]) 2010 max++; 2011 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); 2012 for (j=0; j<max; j++) { /* copy environment */ 2013 const int len = strlen(environ[j]); 2014 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char)); 2015 Copy(environ[j], tmpenv[j], len+1, char); 2016 } 2017 tmpenv[max] = NULL; 2018 environ = tmpenv; /* tell exec where it is now */ 2019 } 2020 if (!val) { 2021 safesysfree(environ[i]); 2022 while (environ[i]) { 2023 environ[i] = environ[i+1]; 2024 i++; 2025 } 2026 return; 2027 } 2028 if (!environ[i]) { /* does not exist yet */ 2029 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*)); 2030 environ[i+1] = NULL; /* make sure it's null terminated */ 2031 } 2032 else 2033 safesysfree(environ[i]); 2034 nlen = strlen(nam); 2035 vlen = strlen(val); 2036 2037 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char)); 2038 /* all that work just for this */ 2039 my_setenv_format(environ[i], nam, nlen, val, vlen); 2040 } else { 2041 # endif 2042 /* This next branch should only be called #if defined(HAS_SETENV), but 2043 Configure doesn't test for that yet. For Solaris, setenv() and unsetenv() 2044 were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient. 2045 */ 2046 # if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) 2047 # if defined(HAS_UNSETENV) 2048 if (val == NULL) { 2049 (void)unsetenv(nam); 2050 } else { 2051 (void)setenv(nam, val, 1); 2052 } 2053 # else /* ! HAS_UNSETENV */ 2054 (void)setenv(nam, val, 1); 2055 # endif /* HAS_UNSETENV */ 2056 # else 2057 # if defined(HAS_UNSETENV) 2058 if (val == NULL) { 2059 if (environ) /* old glibc can crash with null environ */ 2060 (void)unsetenv(nam); 2061 } else { 2062 const int nlen = strlen(nam); 2063 const int vlen = strlen(val); 2064 char * const new_env = 2065 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); 2066 my_setenv_format(new_env, nam, nlen, val, vlen); 2067 (void)putenv(new_env); 2068 } 2069 # else /* ! HAS_UNSETENV */ 2070 char *new_env; 2071 const int nlen = strlen(nam); 2072 int vlen; 2073 if (!val) { 2074 val = ""; 2075 } 2076 vlen = strlen(val); 2077 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); 2078 /* all that work just for this */ 2079 my_setenv_format(new_env, nam, nlen, val, vlen); 2080 (void)putenv(new_env); 2081 # endif /* HAS_UNSETENV */ 2082 # endif /* __CYGWIN__ */ 2083 #ifndef PERL_USE_SAFE_PUTENV 2084 } 2085 #endif 2086 } 2087 } 2088 2089 #else /* WIN32 || NETWARE */ 2090 2091 void 2092 Perl_my_setenv(pTHX_ const char *nam, const char *val) 2093 { 2094 dVAR; 2095 char *envstr; 2096 const int nlen = strlen(nam); 2097 int vlen; 2098 2099 if (!val) { 2100 val = ""; 2101 } 2102 vlen = strlen(val); 2103 Newx(envstr, nlen+vlen+2, char); 2104 my_setenv_format(envstr, nam, nlen, val, vlen); 2105 (void)PerlEnv_putenv(envstr); 2106 Safefree(envstr); 2107 } 2108 2109 #endif /* WIN32 || NETWARE */ 2110 2111 #endif /* !VMS */ 2112 2113 #ifdef UNLINK_ALL_VERSIONS 2114 I32 2115 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ 2116 { 2117 I32 retries = 0; 2118 2119 PERL_ARGS_ASSERT_UNLNK; 2120 2121 while (PerlLIO_unlink(f) >= 0) 2122 retries++; 2123 return retries ? 0 : -1; 2124 } 2125 #endif 2126 2127 /* this is a drop-in replacement for bcopy() */ 2128 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) 2129 char * 2130 Perl_my_bcopy(const char *from, char *to, I32 len) 2131 { 2132 char * const retval = to; 2133 2134 PERL_ARGS_ASSERT_MY_BCOPY; 2135 2136 assert(len >= 0); 2137 2138 if (from - to >= 0) { 2139 while (len--) 2140 *to++ = *from++; 2141 } 2142 else { 2143 to += len; 2144 from += len; 2145 while (len--) 2146 *(--to) = *(--from); 2147 } 2148 return retval; 2149 } 2150 #endif 2151 2152 /* this is a drop-in replacement for memset() */ 2153 #ifndef HAS_MEMSET 2154 void * 2155 Perl_my_memset(char *loc, I32 ch, I32 len) 2156 { 2157 char * const retval = loc; 2158 2159 PERL_ARGS_ASSERT_MY_MEMSET; 2160 2161 assert(len >= 0); 2162 2163 while (len--) 2164 *loc++ = ch; 2165 return retval; 2166 } 2167 #endif 2168 2169 /* this is a drop-in replacement for bzero() */ 2170 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) 2171 char * 2172 Perl_my_bzero(char *loc, I32 len) 2173 { 2174 char * const retval = loc; 2175 2176 PERL_ARGS_ASSERT_MY_BZERO; 2177 2178 assert(len >= 0); 2179 2180 while (len--) 2181 *loc++ = 0; 2182 return retval; 2183 } 2184 #endif 2185 2186 /* this is a drop-in replacement for memcmp() */ 2187 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) 2188 I32 2189 Perl_my_memcmp(const char *s1, const char *s2, I32 len) 2190 { 2191 const U8 *a = (const U8 *)s1; 2192 const U8 *b = (const U8 *)s2; 2193 I32 tmp; 2194 2195 PERL_ARGS_ASSERT_MY_MEMCMP; 2196 2197 assert(len >= 0); 2198 2199 while (len--) { 2200 if ((tmp = *a++ - *b++)) 2201 return tmp; 2202 } 2203 return 0; 2204 } 2205 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ 2206 2207 #ifndef HAS_VPRINTF 2208 /* This vsprintf replacement should generally never get used, since 2209 vsprintf was available in both System V and BSD 2.11. (There may 2210 be some cross-compilation or embedded set-ups where it is needed, 2211 however.) 2212 2213 If you encounter a problem in this function, it's probably a symptom 2214 that Configure failed to detect your system's vprintf() function. 2215 See the section on "item vsprintf" in the INSTALL file. 2216 2217 This version may compile on systems with BSD-ish <stdio.h>, 2218 but probably won't on others. 2219 */ 2220 2221 #ifdef USE_CHAR_VSPRINTF 2222 char * 2223 #else 2224 int 2225 #endif 2226 vsprintf(char *dest, const char *pat, void *args) 2227 { 2228 FILE fakebuf; 2229 2230 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) 2231 FILE_ptr(&fakebuf) = (STDCHAR *) dest; 2232 FILE_cnt(&fakebuf) = 32767; 2233 #else 2234 /* These probably won't compile -- If you really need 2235 this, you'll have to figure out some other method. */ 2236 fakebuf._ptr = dest; 2237 fakebuf._cnt = 32767; 2238 #endif 2239 #ifndef _IOSTRG 2240 #define _IOSTRG 0 2241 #endif 2242 fakebuf._flag = _IOWRT|_IOSTRG; 2243 _doprnt(pat, args, &fakebuf); /* what a kludge */ 2244 #if defined(STDIO_PTR_LVALUE) 2245 *(FILE_ptr(&fakebuf)++) = '\0'; 2246 #else 2247 /* PerlIO has probably #defined away fputc, but we want it here. */ 2248 # ifdef fputc 2249 # undef fputc /* XXX Should really restore it later */ 2250 # endif 2251 (void)fputc('\0', &fakebuf); 2252 #endif 2253 #ifdef USE_CHAR_VSPRINTF 2254 return(dest); 2255 #else 2256 return 0; /* perl doesn't use return value */ 2257 #endif 2258 } 2259 2260 #endif /* HAS_VPRINTF */ 2261 2262 PerlIO * 2263 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) 2264 { 2265 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) 2266 dVAR; 2267 int p[2]; 2268 I32 This, that; 2269 Pid_t pid; 2270 SV *sv; 2271 I32 did_pipes = 0; 2272 int pp[2]; 2273 2274 PERL_ARGS_ASSERT_MY_POPEN_LIST; 2275 2276 PERL_FLUSHALL_FOR_CHILD; 2277 This = (*mode == 'w'); 2278 that = !This; 2279 if (TAINTING_get) { 2280 taint_env(); 2281 taint_proper("Insecure %s%s", "EXEC"); 2282 } 2283 if (PerlProc_pipe(p) < 0) 2284 return NULL; 2285 /* Try for another pipe pair for error return */ 2286 if (PerlProc_pipe(pp) >= 0) 2287 did_pipes = 1; 2288 while ((pid = PerlProc_fork()) < 0) { 2289 if (errno != EAGAIN) { 2290 PerlLIO_close(p[This]); 2291 PerlLIO_close(p[that]); 2292 if (did_pipes) { 2293 PerlLIO_close(pp[0]); 2294 PerlLIO_close(pp[1]); 2295 } 2296 return NULL; 2297 } 2298 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); 2299 sleep(5); 2300 } 2301 if (pid == 0) { 2302 /* Child */ 2303 #undef THIS 2304 #undef THAT 2305 #define THIS that 2306 #define THAT This 2307 /* Close parent's end of error status pipe (if any) */ 2308 if (did_pipes) { 2309 PerlLIO_close(pp[0]); 2310 #if defined(HAS_FCNTL) && defined(F_SETFD) 2311 /* Close error pipe automatically if exec works */ 2312 fcntl(pp[1], F_SETFD, FD_CLOEXEC); 2313 #endif 2314 } 2315 /* Now dup our end of _the_ pipe to right position */ 2316 if (p[THIS] != (*mode == 'r')) { 2317 PerlLIO_dup2(p[THIS], *mode == 'r'); 2318 PerlLIO_close(p[THIS]); 2319 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 2320 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ 2321 } 2322 else 2323 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ 2324 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2325 /* No automatic close - do it by hand */ 2326 # ifndef NOFILE 2327 # define NOFILE 20 2328 # endif 2329 { 2330 int fd; 2331 2332 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { 2333 if (fd != pp[1]) 2334 PerlLIO_close(fd); 2335 } 2336 } 2337 #endif 2338 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes); 2339 PerlProc__exit(1); 2340 #undef THIS 2341 #undef THAT 2342 } 2343 /* Parent */ 2344 do_execfree(); /* free any memory malloced by child on fork */ 2345 if (did_pipes) 2346 PerlLIO_close(pp[1]); 2347 /* Keep the lower of the two fd numbers */ 2348 if (p[that] < p[This]) { 2349 PerlLIO_dup2(p[This], p[that]); 2350 PerlLIO_close(p[This]); 2351 p[This] = p[that]; 2352 } 2353 else 2354 PerlLIO_close(p[that]); /* close child's end of pipe */ 2355 2356 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2357 SvUPGRADE(sv,SVt_IV); 2358 SvIV_set(sv, pid); 2359 PL_forkprocess = pid; 2360 /* If we managed to get status pipe check for exec fail */ 2361 if (did_pipes && pid > 0) { 2362 int errkid; 2363 unsigned n = 0; 2364 SSize_t n1; 2365 2366 while (n < sizeof(int)) { 2367 n1 = PerlLIO_read(pp[0], 2368 (void*)(((char*)&errkid)+n), 2369 (sizeof(int)) - n); 2370 if (n1 <= 0) 2371 break; 2372 n += n1; 2373 } 2374 PerlLIO_close(pp[0]); 2375 did_pipes = 0; 2376 if (n) { /* Error */ 2377 int pid2, status; 2378 PerlLIO_close(p[This]); 2379 if (n != sizeof(int)) 2380 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); 2381 do { 2382 pid2 = wait4pid(pid, &status, 0); 2383 } while (pid2 == -1 && errno == EINTR); 2384 errno = errkid; /* Propagate errno from kid */ 2385 return NULL; 2386 } 2387 } 2388 if (did_pipes) 2389 PerlLIO_close(pp[0]); 2390 return PerlIO_fdopen(p[This], mode); 2391 #else 2392 # ifdef OS2 /* Same, without fork()ing and all extra overhead... */ 2393 return my_syspopen4(aTHX_ NULL, mode, n, args); 2394 # else 2395 Perl_croak(aTHX_ "List form of piped open not implemented"); 2396 return (PerlIO *) NULL; 2397 # endif 2398 #endif 2399 } 2400 2401 /* VMS' my_popen() is in VMS.c, same with OS/2. */ 2402 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) 2403 PerlIO * 2404 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2405 { 2406 dVAR; 2407 int p[2]; 2408 I32 This, that; 2409 Pid_t pid; 2410 SV *sv; 2411 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); 2412 I32 did_pipes = 0; 2413 int pp[2]; 2414 2415 PERL_ARGS_ASSERT_MY_POPEN; 2416 2417 PERL_FLUSHALL_FOR_CHILD; 2418 #ifdef OS2 2419 if (doexec) { 2420 return my_syspopen(aTHX_ cmd,mode); 2421 } 2422 #endif 2423 This = (*mode == 'w'); 2424 that = !This; 2425 if (doexec && TAINTING_get) { 2426 taint_env(); 2427 taint_proper("Insecure %s%s", "EXEC"); 2428 } 2429 if (PerlProc_pipe(p) < 0) 2430 return NULL; 2431 if (doexec && PerlProc_pipe(pp) >= 0) 2432 did_pipes = 1; 2433 while ((pid = PerlProc_fork()) < 0) { 2434 if (errno != EAGAIN) { 2435 PerlLIO_close(p[This]); 2436 PerlLIO_close(p[that]); 2437 if (did_pipes) { 2438 PerlLIO_close(pp[0]); 2439 PerlLIO_close(pp[1]); 2440 } 2441 if (!doexec) 2442 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); 2443 return NULL; 2444 } 2445 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); 2446 sleep(5); 2447 } 2448 if (pid == 0) { 2449 2450 #undef THIS 2451 #undef THAT 2452 #define THIS that 2453 #define THAT This 2454 if (did_pipes) { 2455 PerlLIO_close(pp[0]); 2456 #if defined(HAS_FCNTL) && defined(F_SETFD) 2457 fcntl(pp[1], F_SETFD, FD_CLOEXEC); 2458 #endif 2459 } 2460 if (p[THIS] != (*mode == 'r')) { 2461 PerlLIO_dup2(p[THIS], *mode == 'r'); 2462 PerlLIO_close(p[THIS]); 2463 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 2464 PerlLIO_close(p[THAT]); 2465 } 2466 else 2467 PerlLIO_close(p[THAT]); 2468 #ifndef OS2 2469 if (doexec) { 2470 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2471 #ifndef NOFILE 2472 #define NOFILE 20 2473 #endif 2474 { 2475 int fd; 2476 2477 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) 2478 if (fd != pp[1]) 2479 PerlLIO_close(fd); 2480 } 2481 #endif 2482 /* may or may not use the shell */ 2483 do_exec3(cmd, pp[1], did_pipes); 2484 PerlProc__exit(1); 2485 } 2486 #endif /* defined OS2 */ 2487 2488 #ifdef PERLIO_USING_CRLF 2489 /* Since we circumvent IO layers when we manipulate low-level 2490 filedescriptors directly, need to manually switch to the 2491 default, binary, low-level mode; see PerlIOBuf_open(). */ 2492 PerlLIO_setmode((*mode == 'r'), O_BINARY); 2493 #endif 2494 PL_forkprocess = 0; 2495 #ifdef PERL_USES_PL_PIDSTATUS 2496 hv_clear(PL_pidstatus); /* we have no children */ 2497 #endif 2498 return NULL; 2499 #undef THIS 2500 #undef THAT 2501 } 2502 do_execfree(); /* free any memory malloced by child on vfork */ 2503 if (did_pipes) 2504 PerlLIO_close(pp[1]); 2505 if (p[that] < p[This]) { 2506 PerlLIO_dup2(p[This], p[that]); 2507 PerlLIO_close(p[This]); 2508 p[This] = p[that]; 2509 } 2510 else 2511 PerlLIO_close(p[that]); 2512 2513 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2514 SvUPGRADE(sv,SVt_IV); 2515 SvIV_set(sv, pid); 2516 PL_forkprocess = pid; 2517 if (did_pipes && pid > 0) { 2518 int errkid; 2519 unsigned n = 0; 2520 SSize_t n1; 2521 2522 while (n < sizeof(int)) { 2523 n1 = PerlLIO_read(pp[0], 2524 (void*)(((char*)&errkid)+n), 2525 (sizeof(int)) - n); 2526 if (n1 <= 0) 2527 break; 2528 n += n1; 2529 } 2530 PerlLIO_close(pp[0]); 2531 did_pipes = 0; 2532 if (n) { /* Error */ 2533 int pid2, status; 2534 PerlLIO_close(p[This]); 2535 if (n != sizeof(int)) 2536 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); 2537 do { 2538 pid2 = wait4pid(pid, &status, 0); 2539 } while (pid2 == -1 && errno == EINTR); 2540 errno = errkid; /* Propagate errno from kid */ 2541 return NULL; 2542 } 2543 } 2544 if (did_pipes) 2545 PerlLIO_close(pp[0]); 2546 return PerlIO_fdopen(p[This], mode); 2547 } 2548 #else 2549 #if defined(DJGPP) 2550 FILE *djgpp_popen(); 2551 PerlIO * 2552 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2553 { 2554 PERL_FLUSHALL_FOR_CHILD; 2555 /* Call system's popen() to get a FILE *, then import it. 2556 used 0 for 2nd parameter to PerlIO_importFILE; 2557 apparently not used 2558 */ 2559 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); 2560 } 2561 #else 2562 #if defined(__LIBCATAMOUNT__) 2563 PerlIO * 2564 Perl_my_popen(pTHX_ const char *cmd, const char *mode) 2565 { 2566 return NULL; 2567 } 2568 #endif 2569 #endif 2570 2571 #endif /* !DOSISH */ 2572 2573 /* this is called in parent before the fork() */ 2574 void 2575 Perl_atfork_lock(void) 2576 { 2577 dVAR; 2578 #if defined(USE_ITHREADS) 2579 /* locks must be held in locking order (if any) */ 2580 # ifdef USE_PERLIO 2581 MUTEX_LOCK(&PL_perlio_mutex); 2582 # endif 2583 # ifdef MYMALLOC 2584 MUTEX_LOCK(&PL_malloc_mutex); 2585 # endif 2586 OP_REFCNT_LOCK; 2587 #endif 2588 } 2589 2590 /* this is called in both parent and child after the fork() */ 2591 void 2592 Perl_atfork_unlock(void) 2593 { 2594 dVAR; 2595 #if defined(USE_ITHREADS) 2596 /* locks must be released in same order as in atfork_lock() */ 2597 # ifdef USE_PERLIO 2598 MUTEX_UNLOCK(&PL_perlio_mutex); 2599 # endif 2600 # ifdef MYMALLOC 2601 MUTEX_UNLOCK(&PL_malloc_mutex); 2602 # endif 2603 OP_REFCNT_UNLOCK; 2604 #endif 2605 } 2606 2607 Pid_t 2608 Perl_my_fork(void) 2609 { 2610 #if defined(HAS_FORK) 2611 Pid_t pid; 2612 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK) 2613 atfork_lock(); 2614 pid = fork(); 2615 atfork_unlock(); 2616 #else 2617 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork() 2618 * handlers elsewhere in the code */ 2619 pid = fork(); 2620 #endif 2621 return pid; 2622 #else 2623 /* this "canna happen" since nothing should be calling here if !HAS_FORK */ 2624 Perl_croak_nocontext("fork() not available"); 2625 return 0; 2626 #endif /* HAS_FORK */ 2627 } 2628 2629 #ifndef HAS_DUP2 2630 int 2631 dup2(int oldfd, int newfd) 2632 { 2633 #if defined(HAS_FCNTL) && defined(F_DUPFD) 2634 if (oldfd == newfd) 2635 return oldfd; 2636 PerlLIO_close(newfd); 2637 return fcntl(oldfd, F_DUPFD, newfd); 2638 #else 2639 #define DUP2_MAX_FDS 256 2640 int fdtmp[DUP2_MAX_FDS]; 2641 I32 fdx = 0; 2642 int fd; 2643 2644 if (oldfd == newfd) 2645 return oldfd; 2646 PerlLIO_close(newfd); 2647 /* good enough for low fd's... */ 2648 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) { 2649 if (fdx >= DUP2_MAX_FDS) { 2650 PerlLIO_close(fd); 2651 fd = -1; 2652 break; 2653 } 2654 fdtmp[fdx++] = fd; 2655 } 2656 while (fdx > 0) 2657 PerlLIO_close(fdtmp[--fdx]); 2658 return fd; 2659 #endif 2660 } 2661 #endif 2662 2663 #ifndef PERL_MICRO 2664 #ifdef HAS_SIGACTION 2665 2666 Sighandler_t 2667 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2668 { 2669 dVAR; 2670 struct sigaction act, oact; 2671 2672 #ifdef USE_ITHREADS 2673 /* only "parent" interpreter can diddle signals */ 2674 if (PL_curinterp != aTHX) 2675 return (Sighandler_t) SIG_ERR; 2676 #endif 2677 2678 act.sa_handler = (void(*)(int))handler; 2679 sigemptyset(&act.sa_mask); 2680 act.sa_flags = 0; 2681 #ifdef SA_RESTART 2682 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 2683 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2684 #endif 2685 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 2686 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) 2687 act.sa_flags |= SA_NOCLDWAIT; 2688 #endif 2689 if (sigaction(signo, &act, &oact) == -1) 2690 return (Sighandler_t) SIG_ERR; 2691 else 2692 return (Sighandler_t) oact.sa_handler; 2693 } 2694 2695 Sighandler_t 2696 Perl_rsignal_state(pTHX_ int signo) 2697 { 2698 struct sigaction oact; 2699 PERL_UNUSED_CONTEXT; 2700 2701 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) 2702 return (Sighandler_t) SIG_ERR; 2703 else 2704 return (Sighandler_t) oact.sa_handler; 2705 } 2706 2707 int 2708 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2709 { 2710 dVAR; 2711 struct sigaction act; 2712 2713 PERL_ARGS_ASSERT_RSIGNAL_SAVE; 2714 2715 #ifdef USE_ITHREADS 2716 /* only "parent" interpreter can diddle signals */ 2717 if (PL_curinterp != aTHX) 2718 return -1; 2719 #endif 2720 2721 act.sa_handler = (void(*)(int))handler; 2722 sigemptyset(&act.sa_mask); 2723 act.sa_flags = 0; 2724 #ifdef SA_RESTART 2725 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 2726 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2727 #endif 2728 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 2729 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) 2730 act.sa_flags |= SA_NOCLDWAIT; 2731 #endif 2732 return sigaction(signo, &act, save); 2733 } 2734 2735 int 2736 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2737 { 2738 dVAR; 2739 #ifdef USE_ITHREADS 2740 /* only "parent" interpreter can diddle signals */ 2741 if (PL_curinterp != aTHX) 2742 return -1; 2743 #endif 2744 2745 return sigaction(signo, save, (struct sigaction *)NULL); 2746 } 2747 2748 #else /* !HAS_SIGACTION */ 2749 2750 Sighandler_t 2751 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2752 { 2753 #if defined(USE_ITHREADS) && !defined(WIN32) 2754 /* only "parent" interpreter can diddle signals */ 2755 if (PL_curinterp != aTHX) 2756 return (Sighandler_t) SIG_ERR; 2757 #endif 2758 2759 return PerlProc_signal(signo, handler); 2760 } 2761 2762 static Signal_t 2763 sig_trap(int signo) 2764 { 2765 dVAR; 2766 PL_sig_trapped++; 2767 } 2768 2769 Sighandler_t 2770 Perl_rsignal_state(pTHX_ int signo) 2771 { 2772 dVAR; 2773 Sighandler_t oldsig; 2774 2775 #if defined(USE_ITHREADS) && !defined(WIN32) 2776 /* only "parent" interpreter can diddle signals */ 2777 if (PL_curinterp != aTHX) 2778 return (Sighandler_t) SIG_ERR; 2779 #endif 2780 2781 PL_sig_trapped = 0; 2782 oldsig = PerlProc_signal(signo, sig_trap); 2783 PerlProc_signal(signo, oldsig); 2784 if (PL_sig_trapped) 2785 PerlProc_kill(PerlProc_getpid(), signo); 2786 return oldsig; 2787 } 2788 2789 int 2790 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2791 { 2792 #if defined(USE_ITHREADS) && !defined(WIN32) 2793 /* only "parent" interpreter can diddle signals */ 2794 if (PL_curinterp != aTHX) 2795 return -1; 2796 #endif 2797 *save = PerlProc_signal(signo, handler); 2798 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0; 2799 } 2800 2801 int 2802 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2803 { 2804 #if defined(USE_ITHREADS) && !defined(WIN32) 2805 /* only "parent" interpreter can diddle signals */ 2806 if (PL_curinterp != aTHX) 2807 return -1; 2808 #endif 2809 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0; 2810 } 2811 2812 #endif /* !HAS_SIGACTION */ 2813 #endif /* !PERL_MICRO */ 2814 2815 /* VMS' my_pclose() is in VMS.c; same with OS/2 */ 2816 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) 2817 I32 2818 Perl_my_pclose(pTHX_ PerlIO *ptr) 2819 { 2820 dVAR; 2821 int status; 2822 SV **svp; 2823 Pid_t pid; 2824 Pid_t pid2 = 0; 2825 bool close_failed; 2826 dSAVEDERRNO; 2827 const int fd = PerlIO_fileno(ptr); 2828 bool should_wait; 2829 2830 svp = av_fetch(PL_fdpid,fd,TRUE); 2831 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; 2832 SvREFCNT_dec(*svp); 2833 *svp = NULL; 2834 2835 #if defined(USE_PERLIO) 2836 /* Find out whether the refcount is low enough for us to wait for the 2837 child proc without blocking. */ 2838 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0; 2839 #else 2840 should_wait = pid > 0; 2841 #endif 2842 2843 #ifdef OS2 2844 if (pid == -1) { /* Opened by popen. */ 2845 return my_syspclose(ptr); 2846 } 2847 #endif 2848 close_failed = (PerlIO_close(ptr) == EOF); 2849 SAVE_ERRNO; 2850 if (should_wait) do { 2851 pid2 = wait4pid(pid, &status, 0); 2852 } while (pid2 == -1 && errno == EINTR); 2853 if (close_failed) { 2854 RESTORE_ERRNO; 2855 return -1; 2856 } 2857 return( 2858 should_wait 2859 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status) 2860 : 0 2861 ); 2862 } 2863 #else 2864 #if defined(__LIBCATAMOUNT__) 2865 I32 2866 Perl_my_pclose(pTHX_ PerlIO *ptr) 2867 { 2868 return -1; 2869 } 2870 #endif 2871 #endif /* !DOSISH */ 2872 2873 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__) 2874 I32 2875 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) 2876 { 2877 dVAR; 2878 I32 result = 0; 2879 PERL_ARGS_ASSERT_WAIT4PID; 2880 #ifdef PERL_USES_PL_PIDSTATUS 2881 if (!pid) { 2882 /* PERL_USES_PL_PIDSTATUS is only defined when neither 2883 waitpid() nor wait4() is available, or on OS/2, which 2884 doesn't appear to support waiting for a progress group 2885 member, so we can only treat a 0 pid as an unknown child. 2886 */ 2887 errno = ECHILD; 2888 return -1; 2889 } 2890 { 2891 if (pid > 0) { 2892 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the 2893 pid, rather than a string form. */ 2894 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE); 2895 if (svp && *svp != &PL_sv_undef) { 2896 *statusp = SvIVX(*svp); 2897 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t), 2898 G_DISCARD); 2899 return pid; 2900 } 2901 } 2902 else { 2903 HE *entry; 2904 2905 hv_iterinit(PL_pidstatus); 2906 if ((entry = hv_iternext(PL_pidstatus))) { 2907 SV * const sv = hv_iterval(PL_pidstatus,entry); 2908 I32 len; 2909 const char * const spid = hv_iterkey(entry,&len); 2910 2911 assert (len == sizeof(Pid_t)); 2912 memcpy((char *)&pid, spid, len); 2913 *statusp = SvIVX(sv); 2914 /* The hash iterator is currently on this entry, so simply 2915 calling hv_delete would trigger the lazy delete, which on 2916 aggregate does more work, beacuse next call to hv_iterinit() 2917 would spot the flag, and have to call the delete routine, 2918 while in the meantime any new entries can't re-use that 2919 memory. */ 2920 hv_iterinit(PL_pidstatus); 2921 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD); 2922 return pid; 2923 } 2924 } 2925 } 2926 #endif 2927 #ifdef HAS_WAITPID 2928 # ifdef HAS_WAITPID_RUNTIME 2929 if (!HAS_WAITPID_RUNTIME) 2930 goto hard_way; 2931 # endif 2932 result = PerlProc_waitpid(pid,statusp,flags); 2933 goto finish; 2934 #endif 2935 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) 2936 result = wait4(pid,statusp,flags,NULL); 2937 goto finish; 2938 #endif 2939 #ifdef PERL_USES_PL_PIDSTATUS 2940 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME) 2941 hard_way: 2942 #endif 2943 { 2944 if (flags) 2945 Perl_croak(aTHX_ "Can't do waitpid with flags"); 2946 else { 2947 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) 2948 pidgone(result,*statusp); 2949 if (result < 0) 2950 *statusp = -1; 2951 } 2952 } 2953 #endif 2954 #if defined(HAS_WAITPID) || defined(HAS_WAIT4) 2955 finish: 2956 #endif 2957 if (result < 0 && errno == EINTR) { 2958 PERL_ASYNC_CHECK(); 2959 errno = EINTR; /* reset in case a signal handler changed $! */ 2960 } 2961 return result; 2962 } 2963 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */ 2964 2965 #ifdef PERL_USES_PL_PIDSTATUS 2966 void 2967 S_pidgone(pTHX_ Pid_t pid, int status) 2968 { 2969 SV *sv; 2970 2971 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE); 2972 SvUPGRADE(sv,SVt_IV); 2973 SvIV_set(sv, status); 2974 return; 2975 } 2976 #endif 2977 2978 #if defined(OS2) 2979 int pclose(); 2980 #ifdef HAS_FORK 2981 int /* Cannot prototype with I32 2982 in os2ish.h. */ 2983 my_syspclose(PerlIO *ptr) 2984 #else 2985 I32 2986 Perl_my_pclose(pTHX_ PerlIO *ptr) 2987 #endif 2988 { 2989 /* Needs work for PerlIO ! */ 2990 FILE * const f = PerlIO_findFILE(ptr); 2991 const I32 result = pclose(f); 2992 PerlIO_releaseFILE(ptr,f); 2993 return result; 2994 } 2995 #endif 2996 2997 #if defined(DJGPP) 2998 int djgpp_pclose(); 2999 I32 3000 Perl_my_pclose(pTHX_ PerlIO *ptr) 3001 { 3002 /* Needs work for PerlIO ! */ 3003 FILE * const f = PerlIO_findFILE(ptr); 3004 I32 result = djgpp_pclose(f); 3005 result = (result << 8) & 0xff00; 3006 PerlIO_releaseFILE(ptr,f); 3007 return result; 3008 } 3009 #endif 3010 3011 #define PERL_REPEATCPY_LINEAR 4 3012 void 3013 Perl_repeatcpy(char *to, const char *from, I32 len, IV count) 3014 { 3015 PERL_ARGS_ASSERT_REPEATCPY; 3016 3017 assert(len >= 0); 3018 3019 if (count < 0) 3020 croak_memory_wrap(); 3021 3022 if (len == 1) 3023 memset(to, *from, count); 3024 else if (count) { 3025 char *p = to; 3026 IV items, linear, half; 3027 3028 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR; 3029 for (items = 0; items < linear; ++items) { 3030 const char *q = from; 3031 IV todo; 3032 for (todo = len; todo > 0; todo--) 3033 *p++ = *q++; 3034 } 3035 3036 half = count / 2; 3037 while (items <= half) { 3038 IV size = items * len; 3039 memcpy(p, to, size); 3040 p += size; 3041 items *= 2; 3042 } 3043 3044 if (count > items) 3045 memcpy(p, to, (count - items) * len); 3046 } 3047 } 3048 3049 #ifndef HAS_RENAME 3050 I32 3051 Perl_same_dirent(pTHX_ const char *a, const char *b) 3052 { 3053 char *fa = strrchr(a,'/'); 3054 char *fb = strrchr(b,'/'); 3055 Stat_t tmpstatbuf1; 3056 Stat_t tmpstatbuf2; 3057 SV * const tmpsv = sv_newmortal(); 3058 3059 PERL_ARGS_ASSERT_SAME_DIRENT; 3060 3061 if (fa) 3062 fa++; 3063 else 3064 fa = a; 3065 if (fb) 3066 fb++; 3067 else 3068 fb = b; 3069 if (strNE(a,b)) 3070 return FALSE; 3071 if (fa == a) 3072 sv_setpvs(tmpsv, "."); 3073 else 3074 sv_setpvn(tmpsv, a, fa - a); 3075 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) 3076 return FALSE; 3077 if (fb == b) 3078 sv_setpvs(tmpsv, "."); 3079 else 3080 sv_setpvn(tmpsv, b, fb - b); 3081 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) 3082 return FALSE; 3083 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && 3084 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; 3085 } 3086 #endif /* !HAS_RENAME */ 3087 3088 char* 3089 Perl_find_script(pTHX_ const char *scriptname, bool dosearch, 3090 const char *const *const search_ext, I32 flags) 3091 { 3092 dVAR; 3093 const char *xfound = NULL; 3094 char *xfailed = NULL; 3095 char tmpbuf[MAXPATHLEN]; 3096 char *s; 3097 I32 len = 0; 3098 int retval; 3099 char *bufend; 3100 #if defined(DOSISH) && !defined(OS2) 3101 # define SEARCH_EXTS ".bat", ".cmd", NULL 3102 # define MAX_EXT_LEN 4 3103 #endif 3104 #ifdef OS2 3105 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL 3106 # define MAX_EXT_LEN 4 3107 #endif 3108 #ifdef VMS 3109 # define SEARCH_EXTS ".pl", ".com", NULL 3110 # define MAX_EXT_LEN 4 3111 #endif 3112 /* additional extensions to try in each dir if scriptname not found */ 3113 #ifdef SEARCH_EXTS 3114 static const char *const exts[] = { SEARCH_EXTS }; 3115 const char *const *const ext = search_ext ? search_ext : exts; 3116 int extidx = 0, i = 0; 3117 const char *curext = NULL; 3118 #else 3119 PERL_UNUSED_ARG(search_ext); 3120 # define MAX_EXT_LEN 0 3121 #endif 3122 3123 PERL_ARGS_ASSERT_FIND_SCRIPT; 3124 3125 /* 3126 * If dosearch is true and if scriptname does not contain path 3127 * delimiters, search the PATH for scriptname. 3128 * 3129 * If SEARCH_EXTS is also defined, will look for each 3130 * scriptname{SEARCH_EXTS} whenever scriptname is not found 3131 * while searching the PATH. 3132 * 3133 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search 3134 * proceeds as follows: 3135 * If DOSISH or VMSISH: 3136 * + look for ./scriptname{,.foo,.bar} 3137 * + search the PATH for scriptname{,.foo,.bar} 3138 * 3139 * If !DOSISH: 3140 * + look *only* in the PATH for scriptname{,.foo,.bar} (note 3141 * this will not look in '.' if it's not in the PATH) 3142 */ 3143 tmpbuf[0] = '\0'; 3144 3145 #ifdef VMS 3146 # ifdef ALWAYS_DEFTYPES 3147 len = strlen(scriptname); 3148 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { 3149 int idx = 0, deftypes = 1; 3150 bool seen_dot = 1; 3151 3152 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL); 3153 # else 3154 if (dosearch) { 3155 int idx = 0, deftypes = 1; 3156 bool seen_dot = 1; 3157 3158 const int hasdir = (strpbrk(scriptname,":[</") != NULL); 3159 # endif 3160 /* The first time through, just add SEARCH_EXTS to whatever we 3161 * already have, so we can check for default file types. */ 3162 while (deftypes || 3163 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) 3164 { 3165 if (deftypes) { 3166 deftypes = 0; 3167 *tmpbuf = '\0'; 3168 } 3169 if ((strlen(tmpbuf) + strlen(scriptname) 3170 + MAX_EXT_LEN) >= sizeof tmpbuf) 3171 continue; /* don't search dir with too-long name */ 3172 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf)); 3173 #else /* !VMS */ 3174 3175 #ifdef DOSISH 3176 if (strEQ(scriptname, "-")) 3177 dosearch = 0; 3178 if (dosearch) { /* Look in '.' first. */ 3179 const char *cur = scriptname; 3180 #ifdef SEARCH_EXTS 3181 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ 3182 while (ext[i]) 3183 if (strEQ(ext[i++],curext)) { 3184 extidx = -1; /* already has an ext */ 3185 break; 3186 } 3187 do { 3188 #endif 3189 DEBUG_p(PerlIO_printf(Perl_debug_log, 3190 "Looking for %s\n",cur)); 3191 if (PerlLIO_stat(cur,&PL_statbuf) >= 0 3192 && !S_ISDIR(PL_statbuf.st_mode)) { 3193 dosearch = 0; 3194 scriptname = cur; 3195 #ifdef SEARCH_EXTS 3196 break; 3197 #endif 3198 } 3199 #ifdef SEARCH_EXTS 3200 if (cur == scriptname) { 3201 len = strlen(scriptname); 3202 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) 3203 break; 3204 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf)); 3205 cur = tmpbuf; 3206 } 3207 } while (extidx >= 0 && ext[extidx] /* try an extension? */ 3208 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)); 3209 #endif 3210 } 3211 #endif 3212 3213 if (dosearch && !strchr(scriptname, '/') 3214 #ifdef DOSISH 3215 && !strchr(scriptname, '\\') 3216 #endif 3217 && (s = PerlEnv_getenv("PATH"))) 3218 { 3219 bool seen_dot = 0; 3220 3221 bufend = s + strlen(s); 3222 while (s < bufend) { 3223 # ifdef DOSISH 3224 for (len = 0; *s 3225 && *s != ';'; len++, s++) { 3226 if (len < sizeof tmpbuf) 3227 tmpbuf[len] = *s; 3228 } 3229 if (len < sizeof tmpbuf) 3230 tmpbuf[len] = '\0'; 3231 # else 3232 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, 3233 ':', 3234 &len); 3235 # endif 3236 if (s < bufend) 3237 s++; 3238 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) 3239 continue; /* don't search dir with too-long name */ 3240 if (len 3241 # ifdef DOSISH 3242 && tmpbuf[len - 1] != '/' 3243 && tmpbuf[len - 1] != '\\' 3244 # endif 3245 ) 3246 tmpbuf[len++] = '/'; 3247 if (len == 2 && tmpbuf[0] == '.') 3248 seen_dot = 1; 3249 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len); 3250 #endif /* !VMS */ 3251 3252 #ifdef SEARCH_EXTS 3253 len = strlen(tmpbuf); 3254 if (extidx > 0) /* reset after previous loop */ 3255 extidx = 0; 3256 do { 3257 #endif 3258 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); 3259 retval = PerlLIO_stat(tmpbuf,&PL_statbuf); 3260 if (S_ISDIR(PL_statbuf.st_mode)) { 3261 retval = -1; 3262 } 3263 #ifdef SEARCH_EXTS 3264 } while ( retval < 0 /* not there */ 3265 && extidx>=0 && ext[extidx] /* try an extension? */ 3266 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len) 3267 ); 3268 #endif 3269 if (retval < 0) 3270 continue; 3271 if (S_ISREG(PL_statbuf.st_mode) 3272 && cando(S_IRUSR,TRUE,&PL_statbuf) 3273 #if !defined(DOSISH) 3274 && cando(S_IXUSR,TRUE,&PL_statbuf) 3275 #endif 3276 ) 3277 { 3278 xfound = tmpbuf; /* bingo! */ 3279 break; 3280 } 3281 if (!xfailed) 3282 xfailed = savepv(tmpbuf); 3283 } 3284 #ifndef DOSISH 3285 if (!xfound && !seen_dot && !xfailed && 3286 (PerlLIO_stat(scriptname,&PL_statbuf) < 0 3287 || S_ISDIR(PL_statbuf.st_mode))) 3288 #endif 3289 seen_dot = 1; /* Disable message. */ 3290 if (!xfound) { 3291 if (flags & 1) { /* do or die? */ 3292 /* diag_listed_as: Can't execute %s */ 3293 Perl_croak(aTHX_ "Can't %s %s%s%s", 3294 (xfailed ? "execute" : "find"), 3295 (xfailed ? xfailed : scriptname), 3296 (xfailed ? "" : " on PATH"), 3297 (xfailed || seen_dot) ? "" : ", '.' not in PATH"); 3298 } 3299 scriptname = NULL; 3300 } 3301 Safefree(xfailed); 3302 scriptname = xfound; 3303 } 3304 return (scriptname ? savepv(scriptname) : NULL); 3305 } 3306 3307 #ifndef PERL_GET_CONTEXT_DEFINED 3308 3309 void * 3310 Perl_get_context(void) 3311 { 3312 dVAR; 3313 #if defined(USE_ITHREADS) 3314 # ifdef OLD_PTHREADS_API 3315 pthread_addr_t t; 3316 int error = pthread_getspecific(PL_thr_key, &t) 3317 if (error) 3318 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error); 3319 return (void*)t; 3320 # else 3321 # ifdef I_MACH_CTHREADS 3322 return (void*)cthread_data(cthread_self()); 3323 # else 3324 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); 3325 # endif 3326 # endif 3327 #else 3328 return (void*)NULL; 3329 #endif 3330 } 3331 3332 void 3333 Perl_set_context(void *t) 3334 { 3335 dVAR; 3336 PERL_ARGS_ASSERT_SET_CONTEXT; 3337 #if defined(USE_ITHREADS) 3338 # ifdef I_MACH_CTHREADS 3339 cthread_set_data(cthread_self(), t); 3340 # else 3341 { 3342 const int error = pthread_setspecific(PL_thr_key, t); 3343 if (error) 3344 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error); 3345 } 3346 # endif 3347 #else 3348 PERL_UNUSED_ARG(t); 3349 #endif 3350 } 3351 3352 #endif /* !PERL_GET_CONTEXT_DEFINED */ 3353 3354 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) 3355 struct perl_vars * 3356 Perl_GetVars(pTHX) 3357 { 3358 return &PL_Vars; 3359 } 3360 #endif 3361 3362 char ** 3363 Perl_get_op_names(pTHX) 3364 { 3365 PERL_UNUSED_CONTEXT; 3366 return (char **)PL_op_name; 3367 } 3368 3369 char ** 3370 Perl_get_op_descs(pTHX) 3371 { 3372 PERL_UNUSED_CONTEXT; 3373 return (char **)PL_op_desc; 3374 } 3375 3376 const char * 3377 Perl_get_no_modify(pTHX) 3378 { 3379 PERL_UNUSED_CONTEXT; 3380 return PL_no_modify; 3381 } 3382 3383 U32 * 3384 Perl_get_opargs(pTHX) 3385 { 3386 PERL_UNUSED_CONTEXT; 3387 return (U32 *)PL_opargs; 3388 } 3389 3390 PPADDR_t* 3391 Perl_get_ppaddr(pTHX) 3392 { 3393 dVAR; 3394 PERL_UNUSED_CONTEXT; 3395 return (PPADDR_t*)PL_ppaddr; 3396 } 3397 3398 #ifndef HAS_GETENV_LEN 3399 char * 3400 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) 3401 { 3402 char * const env_trans = PerlEnv_getenv(env_elem); 3403 PERL_UNUSED_CONTEXT; 3404 PERL_ARGS_ASSERT_GETENV_LEN; 3405 if (env_trans) 3406 *len = strlen(env_trans); 3407 return env_trans; 3408 } 3409 #endif 3410 3411 3412 MGVTBL* 3413 Perl_get_vtbl(pTHX_ int vtbl_id) 3414 { 3415 PERL_UNUSED_CONTEXT; 3416 3417 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) 3418 ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id; 3419 } 3420 3421 I32 3422 Perl_my_fflush_all(pTHX) 3423 { 3424 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) 3425 return PerlIO_flush(NULL); 3426 #else 3427 # if defined(HAS__FWALK) 3428 extern int fflush(FILE *); 3429 /* undocumented, unprototyped, but very useful BSDism */ 3430 extern void _fwalk(int (*)(FILE *)); 3431 _fwalk(&fflush); 3432 return 0; 3433 # else 3434 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) 3435 long open_max = -1; 3436 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX 3437 open_max = PERL_FFLUSH_ALL_FOPEN_MAX; 3438 # else 3439 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) 3440 open_max = sysconf(_SC_OPEN_MAX); 3441 # else 3442 # ifdef FOPEN_MAX 3443 open_max = FOPEN_MAX; 3444 # else 3445 # ifdef OPEN_MAX 3446 open_max = OPEN_MAX; 3447 # else 3448 # ifdef _NFILE 3449 open_max = _NFILE; 3450 # endif 3451 # endif 3452 # endif 3453 # endif 3454 # endif 3455 if (open_max > 0) { 3456 long i; 3457 for (i = 0; i < open_max; i++) 3458 if (STDIO_STREAM_ARRAY[i]._file >= 0 && 3459 STDIO_STREAM_ARRAY[i]._file < open_max && 3460 STDIO_STREAM_ARRAY[i]._flag) 3461 PerlIO_flush(&STDIO_STREAM_ARRAY[i]); 3462 return 0; 3463 } 3464 # endif 3465 SETERRNO(EBADF,RMS_IFI); 3466 return EOF; 3467 # endif 3468 #endif 3469 } 3470 3471 void 3472 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) 3473 { 3474 if (ckWARN(WARN_IO)) { 3475 HEK * const name 3476 = gv && (isGV_with_GP(gv)) 3477 ? GvENAME_HEK((gv)) 3478 : NULL; 3479 const char * const direction = have == '>' ? "out" : "in"; 3480 3481 if (name && HEK_LEN(name)) 3482 Perl_warner(aTHX_ packWARN(WARN_IO), 3483 "Filehandle %"HEKf" opened only for %sput", 3484 name, direction); 3485 else 3486 Perl_warner(aTHX_ packWARN(WARN_IO), 3487 "Filehandle opened only for %sput", direction); 3488 } 3489 } 3490 3491 void 3492 Perl_report_evil_fh(pTHX_ const GV *gv) 3493 { 3494 const IO *io = gv ? GvIO(gv) : NULL; 3495 const PERL_BITFIELD16 op = PL_op->op_type; 3496 const char *vile; 3497 I32 warn_type; 3498 3499 if (io && IoTYPE(io) == IoTYPE_CLOSED) { 3500 vile = "closed"; 3501 warn_type = WARN_CLOSED; 3502 } 3503 else { 3504 vile = "unopened"; 3505 warn_type = WARN_UNOPENED; 3506 } 3507 3508 if (ckWARN(warn_type)) { 3509 SV * const name 3510 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ? 3511 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL; 3512 const char * const pars = 3513 (const char *)(OP_IS_FILETEST(op) ? "" : "()"); 3514 const char * const func = 3515 (const char *) 3516 (op == OP_READLINE || op == OP_RCATLINE 3517 ? "readline" : /* "<HANDLE>" not nice */ 3518 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ 3519 PL_op_desc[op]); 3520 const char * const type = 3521 (const char *) 3522 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) 3523 ? "socket" : "filehandle"); 3524 const bool have_name = name && SvCUR(name); 3525 Perl_warner(aTHX_ packWARN(warn_type), 3526 "%s%s on %s %s%s%"SVf, func, pars, vile, type, 3527 have_name ? " " : "", 3528 SVfARG(have_name ? name : &PL_sv_no)); 3529 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3530 Perl_warner( 3531 aTHX_ packWARN(warn_type), 3532 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n", 3533 func, pars, have_name ? " " : "", 3534 SVfARG(have_name ? name : &PL_sv_no) 3535 ); 3536 } 3537 } 3538 3539 /* To workaround core dumps from the uninitialised tm_zone we get the 3540 * system to give us a reasonable struct to copy. This fix means that 3541 * strftime uses the tm_zone and tm_gmtoff values returned by 3542 * localtime(time()). That should give the desired result most of the 3543 * time. But probably not always! 3544 * 3545 * This does not address tzname aspects of NETaa14816. 3546 * 3547 */ 3548 3549 #ifdef __GLIBC__ 3550 # ifndef STRUCT_TM_HASZONE 3551 # define STRUCT_TM_HASZONE 3552 # endif 3553 #endif 3554 3555 #ifdef STRUCT_TM_HASZONE /* Backward compat */ 3556 # ifndef HAS_TM_TM_ZONE 3557 # define HAS_TM_TM_ZONE 3558 # endif 3559 #endif 3560 3561 void 3562 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ 3563 { 3564 #ifdef HAS_TM_TM_ZONE 3565 Time_t now; 3566 const struct tm* my_tm; 3567 PERL_ARGS_ASSERT_INIT_TM; 3568 (void)time(&now); 3569 my_tm = localtime(&now); 3570 if (my_tm) 3571 Copy(my_tm, ptm, 1, struct tm); 3572 #else 3573 PERL_ARGS_ASSERT_INIT_TM; 3574 PERL_UNUSED_ARG(ptm); 3575 #endif 3576 } 3577 3578 /* 3579 * mini_mktime - normalise struct tm values without the localtime() 3580 * semantics (and overhead) of mktime(). 3581 */ 3582 void 3583 Perl_mini_mktime(pTHX_ struct tm *ptm) 3584 { 3585 int yearday; 3586 int secs; 3587 int month, mday, year, jday; 3588 int odd_cent, odd_year; 3589 PERL_UNUSED_CONTEXT; 3590 3591 PERL_ARGS_ASSERT_MINI_MKTIME; 3592 3593 #define DAYS_PER_YEAR 365 3594 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) 3595 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) 3596 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) 3597 #define SECS_PER_HOUR (60*60) 3598 #define SECS_PER_DAY (24*SECS_PER_HOUR) 3599 /* parentheses deliberately absent on these two, otherwise they don't work */ 3600 #define MONTH_TO_DAYS 153/5 3601 #define DAYS_TO_MONTH 5/153 3602 /* offset to bias by March (month 4) 1st between month/mday & year finding */ 3603 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1) 3604 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ 3605 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ 3606 3607 /* 3608 * Year/day algorithm notes: 3609 * 3610 * With a suitable offset for numeric value of the month, one can find 3611 * an offset into the year by considering months to have 30.6 (153/5) days, 3612 * using integer arithmetic (i.e., with truncation). To avoid too much 3613 * messing about with leap days, we consider January and February to be 3614 * the 13th and 14th month of the previous year. After that transformation, 3615 * we need the month index we use to be high by 1 from 'normal human' usage, 3616 * so the month index values we use run from 4 through 15. 3617 * 3618 * Given that, and the rules for the Gregorian calendar (leap years are those 3619 * divisible by 4 unless also divisible by 100, when they must be divisible 3620 * by 400 instead), we can simply calculate the number of days since some 3621 * arbitrary 'beginning of time' by futzing with the (adjusted) year number, 3622 * the days we derive from our month index, and adding in the day of the 3623 * month. The value used here is not adjusted for the actual origin which 3624 * it normally would use (1 January A.D. 1), since we're not exposing it. 3625 * We're only building the value so we can turn around and get the 3626 * normalised values for the year, month, day-of-month, and day-of-year. 3627 * 3628 * For going backward, we need to bias the value we're using so that we find 3629 * the right year value. (Basically, we don't want the contribution of 3630 * March 1st to the number to apply while deriving the year). Having done 3631 * that, we 'count up' the contribution to the year number by accounting for 3632 * full quadracenturies (400-year periods) with their extra leap days, plus 3633 * the contribution from full centuries (to avoid counting in the lost leap 3634 * days), plus the contribution from full quad-years (to count in the normal 3635 * leap days), plus the leftover contribution from any non-leap years. 3636 * At this point, if we were working with an actual leap day, we'll have 0 3637 * days left over. This is also true for March 1st, however. So, we have 3638 * to special-case that result, and (earlier) keep track of the 'odd' 3639 * century and year contributions. If we got 4 extra centuries in a qcent, 3640 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. 3641 * Otherwise, we add back in the earlier bias we removed (the 123 from 3642 * figuring in March 1st), find the month index (integer division by 30.6), 3643 * and the remainder is the day-of-month. We then have to convert back to 3644 * 'real' months (including fixing January and February from being 14/15 in 3645 * the previous year to being in the proper year). After that, to get 3646 * tm_yday, we work with the normalised year and get a new yearday value for 3647 * January 1st, which we subtract from the yearday value we had earlier, 3648 * representing the date we've re-built. This is done from January 1 3649 * because tm_yday is 0-origin. 3650 * 3651 * Since POSIX time routines are only guaranteed to work for times since the 3652 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm 3653 * applies Gregorian calendar rules even to dates before the 16th century 3654 * doesn't bother me. Besides, you'd need cultural context for a given 3655 * date to know whether it was Julian or Gregorian calendar, and that's 3656 * outside the scope for this routine. Since we convert back based on the 3657 * same rules we used to build the yearday, you'll only get strange results 3658 * for input which needed normalising, or for the 'odd' century years which 3659 * were leap years in the Julian calendar but not in the Gregorian one. 3660 * I can live with that. 3661 * 3662 * This algorithm also fails to handle years before A.D. 1 gracefully, but 3663 * that's still outside the scope for POSIX time manipulation, so I don't 3664 * care. 3665 */ 3666 3667 year = 1900 + ptm->tm_year; 3668 month = ptm->tm_mon; 3669 mday = ptm->tm_mday; 3670 jday = 0; 3671 if (month >= 2) 3672 month+=2; 3673 else 3674 month+=14, year--; 3675 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; 3676 yearday += month*MONTH_TO_DAYS + mday + jday; 3677 /* 3678 * Note that we don't know when leap-seconds were or will be, 3679 * so we have to trust the user if we get something which looks 3680 * like a sensible leap-second. Wild values for seconds will 3681 * be rationalised, however. 3682 */ 3683 if ((unsigned) ptm->tm_sec <= 60) { 3684 secs = 0; 3685 } 3686 else { 3687 secs = ptm->tm_sec; 3688 ptm->tm_sec = 0; 3689 } 3690 secs += 60 * ptm->tm_min; 3691 secs += SECS_PER_HOUR * ptm->tm_hour; 3692 if (secs < 0) { 3693 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { 3694 /* got negative remainder, but need positive time */ 3695 /* back off an extra day to compensate */ 3696 yearday += (secs/SECS_PER_DAY)-1; 3697 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); 3698 } 3699 else { 3700 yearday += (secs/SECS_PER_DAY); 3701 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); 3702 } 3703 } 3704 else if (secs >= SECS_PER_DAY) { 3705 yearday += (secs/SECS_PER_DAY); 3706 secs %= SECS_PER_DAY; 3707 } 3708 ptm->tm_hour = secs/SECS_PER_HOUR; 3709 secs %= SECS_PER_HOUR; 3710 ptm->tm_min = secs/60; 3711 secs %= 60; 3712 ptm->tm_sec += secs; 3713 /* done with time of day effects */ 3714 /* 3715 * The algorithm for yearday has (so far) left it high by 428. 3716 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to 3717 * bias it by 123 while trying to figure out what year it 3718 * really represents. Even with this tweak, the reverse 3719 * translation fails for years before A.D. 0001. 3720 * It would still fail for Feb 29, but we catch that one below. 3721 */ 3722 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ 3723 yearday -= YEAR_ADJUST; 3724 year = (yearday / DAYS_PER_QCENT) * 400; 3725 yearday %= DAYS_PER_QCENT; 3726 odd_cent = yearday / DAYS_PER_CENT; 3727 year += odd_cent * 100; 3728 yearday %= DAYS_PER_CENT; 3729 year += (yearday / DAYS_PER_QYEAR) * 4; 3730 yearday %= DAYS_PER_QYEAR; 3731 odd_year = yearday / DAYS_PER_YEAR; 3732 year += odd_year; 3733 yearday %= DAYS_PER_YEAR; 3734 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ 3735 month = 1; 3736 yearday = 29; 3737 } 3738 else { 3739 yearday += YEAR_ADJUST; /* recover March 1st crock */ 3740 month = yearday*DAYS_TO_MONTH; 3741 yearday -= month*MONTH_TO_DAYS; 3742 /* recover other leap-year adjustment */ 3743 if (month > 13) { 3744 month-=14; 3745 year++; 3746 } 3747 else { 3748 month-=2; 3749 } 3750 } 3751 ptm->tm_year = year - 1900; 3752 if (yearday) { 3753 ptm->tm_mday = yearday; 3754 ptm->tm_mon = month; 3755 } 3756 else { 3757 ptm->tm_mday = 31; 3758 ptm->tm_mon = month - 1; 3759 } 3760 /* re-build yearday based on Jan 1 to get tm_yday */ 3761 year--; 3762 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; 3763 yearday += 14*MONTH_TO_DAYS + 1; 3764 ptm->tm_yday = jday - yearday; 3765 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; 3766 } 3767 3768 char * 3769 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) 3770 { 3771 #ifdef HAS_STRFTIME 3772 char *buf; 3773 int buflen; 3774 struct tm mytm; 3775 int len; 3776 3777 PERL_ARGS_ASSERT_MY_STRFTIME; 3778 3779 init_tm(&mytm); /* XXX workaround - see init_tm() above */ 3780 mytm.tm_sec = sec; 3781 mytm.tm_min = min; 3782 mytm.tm_hour = hour; 3783 mytm.tm_mday = mday; 3784 mytm.tm_mon = mon; 3785 mytm.tm_year = year; 3786 mytm.tm_wday = wday; 3787 mytm.tm_yday = yday; 3788 mytm.tm_isdst = isdst; 3789 mini_mktime(&mytm); 3790 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */ 3791 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE)) 3792 STMT_START { 3793 struct tm mytm2; 3794 mytm2 = mytm; 3795 mktime(&mytm2); 3796 #ifdef HAS_TM_TM_GMTOFF 3797 mytm.tm_gmtoff = mytm2.tm_gmtoff; 3798 #endif 3799 #ifdef HAS_TM_TM_ZONE 3800 mytm.tm_zone = mytm2.tm_zone; 3801 #endif 3802 } STMT_END; 3803 #endif 3804 buflen = 64; 3805 Newx(buf, buflen, char); 3806 3807 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */ 3808 len = strftime(buf, buflen, fmt, &mytm); 3809 GCC_DIAG_RESTORE; 3810 3811 /* 3812 ** The following is needed to handle to the situation where 3813 ** tmpbuf overflows. Basically we want to allocate a buffer 3814 ** and try repeatedly. The reason why it is so complicated 3815 ** is that getting a return value of 0 from strftime can indicate 3816 ** one of the following: 3817 ** 1. buffer overflowed, 3818 ** 2. illegal conversion specifier, or 3819 ** 3. the format string specifies nothing to be returned(not 3820 ** an error). This could be because format is an empty string 3821 ** or it specifies %p that yields an empty string in some locale. 3822 ** If there is a better way to make it portable, go ahead by 3823 ** all means. 3824 */ 3825 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0')) 3826 return buf; 3827 else { 3828 /* Possibly buf overflowed - try again with a bigger buf */ 3829 const int fmtlen = strlen(fmt); 3830 int bufsize = fmtlen + buflen; 3831 3832 Renew(buf, bufsize, char); 3833 while (buf) { 3834 3835 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */ 3836 buflen = strftime(buf, bufsize, fmt, &mytm); 3837 GCC_DIAG_RESTORE; 3838 3839 if (buflen > 0 && buflen < bufsize) 3840 break; 3841 /* heuristic to prevent out-of-memory errors */ 3842 if (bufsize > 100*fmtlen) { 3843 Safefree(buf); 3844 buf = NULL; 3845 break; 3846 } 3847 bufsize *= 2; 3848 Renew(buf, bufsize, char); 3849 } 3850 return buf; 3851 } 3852 #else 3853 Perl_croak(aTHX_ "panic: no strftime"); 3854 return NULL; 3855 #endif 3856 } 3857 3858 3859 #define SV_CWD_RETURN_UNDEF \ 3860 sv_setsv(sv, &PL_sv_undef); \ 3861 return FALSE 3862 3863 #define SV_CWD_ISDOT(dp) \ 3864 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ 3865 (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) 3866 3867 /* 3868 =head1 Miscellaneous Functions 3869 3870 =for apidoc getcwd_sv 3871 3872 Fill the sv with current working directory 3873 3874 =cut 3875 */ 3876 3877 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. 3878 * rewritten again by dougm, optimized for use with xs TARG, and to prefer 3879 * getcwd(3) if available 3880 * Comments from the orignal: 3881 * This is a faster version of getcwd. It's also more dangerous 3882 * because you might chdir out of a directory that you can't chdir 3883 * back into. */ 3884 3885 int 3886 Perl_getcwd_sv(pTHX_ SV *sv) 3887 { 3888 #ifndef PERL_MICRO 3889 dVAR; 3890 SvTAINTED_on(sv); 3891 3892 PERL_ARGS_ASSERT_GETCWD_SV; 3893 3894 #ifdef HAS_GETCWD 3895 { 3896 char buf[MAXPATHLEN]; 3897 3898 /* Some getcwd()s automatically allocate a buffer of the given 3899 * size from the heap if they are given a NULL buffer pointer. 3900 * The problem is that this behaviour is not portable. */ 3901 if (getcwd(buf, sizeof(buf) - 1)) { 3902 sv_setpv(sv, buf); 3903 return TRUE; 3904 } 3905 else { 3906 sv_setsv(sv, &PL_sv_undef); 3907 return FALSE; 3908 } 3909 } 3910 3911 #else 3912 3913 Stat_t statbuf; 3914 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; 3915 int pathlen=0; 3916 Direntry_t *dp; 3917 3918 SvUPGRADE(sv, SVt_PV); 3919 3920 if (PerlLIO_lstat(".", &statbuf) < 0) { 3921 SV_CWD_RETURN_UNDEF; 3922 } 3923 3924 orig_cdev = statbuf.st_dev; 3925 orig_cino = statbuf.st_ino; 3926 cdev = orig_cdev; 3927 cino = orig_cino; 3928 3929 for (;;) { 3930 DIR *dir; 3931 int namelen; 3932 odev = cdev; 3933 oino = cino; 3934 3935 if (PerlDir_chdir("..") < 0) { 3936 SV_CWD_RETURN_UNDEF; 3937 } 3938 if (PerlLIO_stat(".", &statbuf) < 0) { 3939 SV_CWD_RETURN_UNDEF; 3940 } 3941 3942 cdev = statbuf.st_dev; 3943 cino = statbuf.st_ino; 3944 3945 if (odev == cdev && oino == cino) { 3946 break; 3947 } 3948 if (!(dir = PerlDir_open("."))) { 3949 SV_CWD_RETURN_UNDEF; 3950 } 3951 3952 while ((dp = PerlDir_read(dir)) != NULL) { 3953 #ifdef DIRNAMLEN 3954 namelen = dp->d_namlen; 3955 #else 3956 namelen = strlen(dp->d_name); 3957 #endif 3958 /* skip . and .. */ 3959 if (SV_CWD_ISDOT(dp)) { 3960 continue; 3961 } 3962 3963 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { 3964 SV_CWD_RETURN_UNDEF; 3965 } 3966 3967 tdev = statbuf.st_dev; 3968 tino = statbuf.st_ino; 3969 if (tino == oino && tdev == odev) { 3970 break; 3971 } 3972 } 3973 3974 if (!dp) { 3975 SV_CWD_RETURN_UNDEF; 3976 } 3977 3978 if (pathlen + namelen + 1 >= MAXPATHLEN) { 3979 SV_CWD_RETURN_UNDEF; 3980 } 3981 3982 SvGROW(sv, pathlen + namelen + 1); 3983 3984 if (pathlen) { 3985 /* shift down */ 3986 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char); 3987 } 3988 3989 /* prepend current directory to the front */ 3990 *SvPVX(sv) = '/'; 3991 Move(dp->d_name, SvPVX(sv)+1, namelen, char); 3992 pathlen += (namelen + 1); 3993 3994 #ifdef VOID_CLOSEDIR 3995 PerlDir_close(dir); 3996 #else 3997 if (PerlDir_close(dir) < 0) { 3998 SV_CWD_RETURN_UNDEF; 3999 } 4000 #endif 4001 } 4002 4003 if (pathlen) { 4004 SvCUR_set(sv, pathlen); 4005 *SvEND(sv) = '\0'; 4006 SvPOK_only(sv); 4007 4008 if (PerlDir_chdir(SvPVX_const(sv)) < 0) { 4009 SV_CWD_RETURN_UNDEF; 4010 } 4011 } 4012 if (PerlLIO_stat(".", &statbuf) < 0) { 4013 SV_CWD_RETURN_UNDEF; 4014 } 4015 4016 cdev = statbuf.st_dev; 4017 cino = statbuf.st_ino; 4018 4019 if (cdev != orig_cdev || cino != orig_cino) { 4020 Perl_croak(aTHX_ "Unstable directory path, " 4021 "current directory changed unexpectedly"); 4022 } 4023 4024 return TRUE; 4025 #endif 4026 4027 #else 4028 return FALSE; 4029 #endif 4030 } 4031 4032 #include "vutil.c" 4033 4034 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) 4035 # define EMULATE_SOCKETPAIR_UDP 4036 #endif 4037 4038 #ifdef EMULATE_SOCKETPAIR_UDP 4039 static int 4040 S_socketpair_udp (int fd[2]) { 4041 dTHX; 4042 /* Fake a datagram socketpair using UDP to localhost. */ 4043 int sockets[2] = {-1, -1}; 4044 struct sockaddr_in addresses[2]; 4045 int i; 4046 Sock_size_t size = sizeof(struct sockaddr_in); 4047 unsigned short port; 4048 int got; 4049 4050 memset(&addresses, 0, sizeof(addresses)); 4051 i = 1; 4052 do { 4053 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET); 4054 if (sockets[i] == -1) 4055 goto tidy_up_and_fail; 4056 4057 addresses[i].sin_family = AF_INET; 4058 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK); 4059 addresses[i].sin_port = 0; /* kernel choses port. */ 4060 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i], 4061 sizeof(struct sockaddr_in)) == -1) 4062 goto tidy_up_and_fail; 4063 } while (i--); 4064 4065 /* Now have 2 UDP sockets. Find out which port each is connected to, and 4066 for each connect the other socket to it. */ 4067 i = 1; 4068 do { 4069 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i], 4070 &size) == -1) 4071 goto tidy_up_and_fail; 4072 if (size != sizeof(struct sockaddr_in)) 4073 goto abort_tidy_up_and_fail; 4074 /* !1 is 0, !0 is 1 */ 4075 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], 4076 sizeof(struct sockaddr_in)) == -1) 4077 goto tidy_up_and_fail; 4078 } while (i--); 4079 4080 /* Now we have 2 sockets connected to each other. I don't trust some other 4081 process not to have already sent a packet to us (by random) so send 4082 a packet from each to the other. */ 4083 i = 1; 4084 do { 4085 /* I'm going to send my own port number. As a short. 4086 (Who knows if someone somewhere has sin_port as a bitfield and needs 4087 this routine. (I'm assuming crays have socketpair)) */ 4088 port = addresses[i].sin_port; 4089 got = PerlLIO_write(sockets[i], &port, sizeof(port)); 4090 if (got != sizeof(port)) { 4091 if (got == -1) 4092 goto tidy_up_and_fail; 4093 goto abort_tidy_up_and_fail; 4094 } 4095 } while (i--); 4096 4097 /* Packets sent. I don't trust them to have arrived though. 4098 (As I understand it Solaris TCP stack is multithreaded. Non-blocking 4099 connect to localhost will use a second kernel thread. In 2.6 the 4100 first thread running the connect() returns before the second completes, 4101 so EINPROGRESS> In 2.7 the improved stack is faster and connect() 4102 returns 0. Poor programs have tripped up. One poor program's authors' 4103 had a 50-1 reverse stock split. Not sure how connected these were.) 4104 So I don't trust someone not to have an unpredictable UDP stack. 4105 */ 4106 4107 { 4108 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ 4109 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; 4110 fd_set rset; 4111 4112 FD_ZERO(&rset); 4113 FD_SET((unsigned int)sockets[0], &rset); 4114 FD_SET((unsigned int)sockets[1], &rset); 4115 4116 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor); 4117 if (got != 2 || !FD_ISSET(sockets[0], &rset) 4118 || !FD_ISSET(sockets[1], &rset)) { 4119 /* I hope this is portable and appropriate. */ 4120 if (got == -1) 4121 goto tidy_up_and_fail; 4122 goto abort_tidy_up_and_fail; 4123 } 4124 } 4125 4126 /* And the paranoia department even now doesn't trust it to have arrive 4127 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */ 4128 { 4129 struct sockaddr_in readfrom; 4130 unsigned short buffer[2]; 4131 4132 i = 1; 4133 do { 4134 #ifdef MSG_DONTWAIT 4135 got = PerlSock_recvfrom(sockets[i], (char *) &buffer, 4136 sizeof(buffer), MSG_DONTWAIT, 4137 (struct sockaddr *) &readfrom, &size); 4138 #else 4139 got = PerlSock_recvfrom(sockets[i], (char *) &buffer, 4140 sizeof(buffer), 0, 4141 (struct sockaddr *) &readfrom, &size); 4142 #endif 4143 4144 if (got == -1) 4145 goto tidy_up_and_fail; 4146 if (got != sizeof(port) 4147 || size != sizeof(struct sockaddr_in) 4148 /* Check other socket sent us its port. */ 4149 || buffer[0] != (unsigned short) addresses[!i].sin_port 4150 /* Check kernel says we got the datagram from that socket */ 4151 || readfrom.sin_family != addresses[!i].sin_family 4152 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr 4153 || readfrom.sin_port != addresses[!i].sin_port) 4154 goto abort_tidy_up_and_fail; 4155 } while (i--); 4156 } 4157 /* My caller (my_socketpair) has validated that this is non-NULL */ 4158 fd[0] = sockets[0]; 4159 fd[1] = sockets[1]; 4160 /* I hereby declare this connection open. May God bless all who cross 4161 her. */ 4162 return 0; 4163 4164 abort_tidy_up_and_fail: 4165 errno = ECONNABORTED; 4166 tidy_up_and_fail: 4167 { 4168 dSAVE_ERRNO; 4169 if (sockets[0] != -1) 4170 PerlLIO_close(sockets[0]); 4171 if (sockets[1] != -1) 4172 PerlLIO_close(sockets[1]); 4173 RESTORE_ERRNO; 4174 return -1; 4175 } 4176 } 4177 #endif /* EMULATE_SOCKETPAIR_UDP */ 4178 4179 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) 4180 int 4181 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { 4182 /* Stevens says that family must be AF_LOCAL, protocol 0. 4183 I'm going to enforce that, then ignore it, and use TCP (or UDP). */ 4184 dTHXa(NULL); 4185 int listener = -1; 4186 int connector = -1; 4187 int acceptor = -1; 4188 struct sockaddr_in listen_addr; 4189 struct sockaddr_in connect_addr; 4190 Sock_size_t size; 4191 4192 if (protocol 4193 #ifdef AF_UNIX 4194 || family != AF_UNIX 4195 #endif 4196 ) { 4197 errno = EAFNOSUPPORT; 4198 return -1; 4199 } 4200 if (!fd) { 4201 errno = EINVAL; 4202 return -1; 4203 } 4204 4205 #ifdef EMULATE_SOCKETPAIR_UDP 4206 if (type == SOCK_DGRAM) 4207 return S_socketpair_udp(fd); 4208 #endif 4209 4210 aTHXa(PERL_GET_THX); 4211 listener = PerlSock_socket(AF_INET, type, 0); 4212 if (listener == -1) 4213 return -1; 4214 memset(&listen_addr, 0, sizeof(listen_addr)); 4215 listen_addr.sin_family = AF_INET; 4216 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); 4217 listen_addr.sin_port = 0; /* kernel choses port. */ 4218 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr, 4219 sizeof(listen_addr)) == -1) 4220 goto tidy_up_and_fail; 4221 if (PerlSock_listen(listener, 1) == -1) 4222 goto tidy_up_and_fail; 4223 4224 connector = PerlSock_socket(AF_INET, type, 0); 4225 if (connector == -1) 4226 goto tidy_up_and_fail; 4227 /* We want to find out the port number to connect to. */ 4228 size = sizeof(connect_addr); 4229 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr, 4230 &size) == -1) 4231 goto tidy_up_and_fail; 4232 if (size != sizeof(connect_addr)) 4233 goto abort_tidy_up_and_fail; 4234 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr, 4235 sizeof(connect_addr)) == -1) 4236 goto tidy_up_and_fail; 4237 4238 size = sizeof(listen_addr); 4239 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr, 4240 &size); 4241 if (acceptor == -1) 4242 goto tidy_up_and_fail; 4243 if (size != sizeof(listen_addr)) 4244 goto abort_tidy_up_and_fail; 4245 PerlLIO_close(listener); 4246 /* Now check we are talking to ourself by matching port and host on the 4247 two sockets. */ 4248 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr, 4249 &size) == -1) 4250 goto tidy_up_and_fail; 4251 if (size != sizeof(connect_addr) 4252 || listen_addr.sin_family != connect_addr.sin_family 4253 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr 4254 || listen_addr.sin_port != connect_addr.sin_port) { 4255 goto abort_tidy_up_and_fail; 4256 } 4257 fd[0] = connector; 4258 fd[1] = acceptor; 4259 return 0; 4260 4261 abort_tidy_up_and_fail: 4262 #ifdef ECONNABORTED 4263 errno = ECONNABORTED; /* This would be the standard thing to do. */ 4264 #else 4265 # ifdef ECONNREFUSED 4266 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */ 4267 # else 4268 errno = ETIMEDOUT; /* Desperation time. */ 4269 # endif 4270 #endif 4271 tidy_up_and_fail: 4272 { 4273 dSAVE_ERRNO; 4274 if (listener != -1) 4275 PerlLIO_close(listener); 4276 if (connector != -1) 4277 PerlLIO_close(connector); 4278 if (acceptor != -1) 4279 PerlLIO_close(acceptor); 4280 RESTORE_ERRNO; 4281 return -1; 4282 } 4283 } 4284 #else 4285 /* In any case have a stub so that there's code corresponding 4286 * to the my_socketpair in embed.fnc. */ 4287 int 4288 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { 4289 #ifdef HAS_SOCKETPAIR 4290 return socketpair(family, type, protocol, fd); 4291 #else 4292 return -1; 4293 #endif 4294 } 4295 #endif 4296 4297 /* 4298 4299 =for apidoc sv_nosharing 4300 4301 Dummy routine which "shares" an SV when there is no sharing module present. 4302 Or "locks" it. Or "unlocks" it. In other 4303 words, ignores its single SV argument. 4304 Exists to avoid test for a NULL function pointer and because it could 4305 potentially warn under some level of strict-ness. 4306 4307 =cut 4308 */ 4309 4310 void 4311 Perl_sv_nosharing(pTHX_ SV *sv) 4312 { 4313 PERL_UNUSED_CONTEXT; 4314 PERL_UNUSED_ARG(sv); 4315 } 4316 4317 /* 4318 4319 =for apidoc sv_destroyable 4320 4321 Dummy routine which reports that object can be destroyed when there is no 4322 sharing module present. It ignores its single SV argument, and returns 4323 'true'. Exists to avoid test for a NULL function pointer and because it 4324 could potentially warn under some level of strict-ness. 4325 4326 =cut 4327 */ 4328 4329 bool 4330 Perl_sv_destroyable(pTHX_ SV *sv) 4331 { 4332 PERL_UNUSED_CONTEXT; 4333 PERL_UNUSED_ARG(sv); 4334 return TRUE; 4335 } 4336 4337 U32 4338 Perl_parse_unicode_opts(pTHX_ const char **popt) 4339 { 4340 const char *p = *popt; 4341 U32 opt = 0; 4342 4343 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS; 4344 4345 if (*p) { 4346 if (isDIGIT(*p)) { 4347 opt = (U32) atoi(p); 4348 while (isDIGIT(*p)) 4349 p++; 4350 if (*p && *p != '\n' && *p != '\r') { 4351 if(isSPACE(*p)) goto the_end_of_the_opts_parser; 4352 else 4353 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); 4354 } 4355 } 4356 else { 4357 for (; *p; p++) { 4358 switch (*p) { 4359 case PERL_UNICODE_STDIN: 4360 opt |= PERL_UNICODE_STDIN_FLAG; break; 4361 case PERL_UNICODE_STDOUT: 4362 opt |= PERL_UNICODE_STDOUT_FLAG; break; 4363 case PERL_UNICODE_STDERR: 4364 opt |= PERL_UNICODE_STDERR_FLAG; break; 4365 case PERL_UNICODE_STD: 4366 opt |= PERL_UNICODE_STD_FLAG; break; 4367 case PERL_UNICODE_IN: 4368 opt |= PERL_UNICODE_IN_FLAG; break; 4369 case PERL_UNICODE_OUT: 4370 opt |= PERL_UNICODE_OUT_FLAG; break; 4371 case PERL_UNICODE_INOUT: 4372 opt |= PERL_UNICODE_INOUT_FLAG; break; 4373 case PERL_UNICODE_LOCALE: 4374 opt |= PERL_UNICODE_LOCALE_FLAG; break; 4375 case PERL_UNICODE_ARGV: 4376 opt |= PERL_UNICODE_ARGV_FLAG; break; 4377 case PERL_UNICODE_UTF8CACHEASSERT: 4378 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break; 4379 default: 4380 if (*p != '\n' && *p != '\r') { 4381 if(isSPACE(*p)) goto the_end_of_the_opts_parser; 4382 else 4383 Perl_croak(aTHX_ 4384 "Unknown Unicode option letter '%c'", *p); 4385 } 4386 } 4387 } 4388 } 4389 } 4390 else 4391 opt = PERL_UNICODE_DEFAULT_FLAGS; 4392 4393 the_end_of_the_opts_parser: 4394 4395 if (opt & ~PERL_UNICODE_ALL_FLAGS) 4396 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf, 4397 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); 4398 4399 *popt = p; 4400 4401 return opt; 4402 } 4403 4404 #ifdef VMS 4405 # include <starlet.h> 4406 #endif 4407 4408 U32 4409 Perl_seed(pTHX) 4410 { 4411 dVAR; 4412 /* 4413 * This is really just a quick hack which grabs various garbage 4414 * values. It really should be a real hash algorithm which 4415 * spreads the effect of every input bit onto every output bit, 4416 * if someone who knows about such things would bother to write it. 4417 * Might be a good idea to add that function to CORE as well. 4418 * No numbers below come from careful analysis or anything here, 4419 * except they are primes and SEED_C1 > 1E6 to get a full-width 4420 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should 4421 * probably be bigger too. 4422 */ 4423 #if RANDBITS > 16 4424 # define SEED_C1 1000003 4425 #define SEED_C4 73819 4426 #else 4427 # define SEED_C1 25747 4428 #define SEED_C4 20639 4429 #endif 4430 #define SEED_C2 3 4431 #define SEED_C3 269 4432 #define SEED_C5 26107 4433 4434 #ifndef PERL_NO_DEV_RANDOM 4435 int fd; 4436 #endif 4437 U32 u; 4438 #ifdef VMS 4439 /* when[] = (low 32 bits, high 32 bits) of time since epoch 4440 * in 100-ns units, typically incremented ever 10 ms. */ 4441 unsigned int when[2]; 4442 #else 4443 # ifdef HAS_GETTIMEOFDAY 4444 struct timeval when; 4445 # else 4446 Time_t when; 4447 # endif 4448 #endif 4449 4450 /* This test is an escape hatch, this symbol isn't set by Configure. */ 4451 #ifndef PERL_NO_DEV_RANDOM 4452 #ifndef PERL_RANDOM_DEVICE 4453 /* /dev/random isn't used by default because reads from it will block 4454 * if there isn't enough entropy available. You can compile with 4455 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there 4456 * is enough real entropy to fill the seed. */ 4457 # define PERL_RANDOM_DEVICE "/dev/urandom" 4458 #endif 4459 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); 4460 if (fd != -1) { 4461 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u) 4462 u = 0; 4463 PerlLIO_close(fd); 4464 if (u) 4465 return u; 4466 } 4467 #endif 4468 4469 #ifdef VMS 4470 _ckvmssts(sys$gettim(when)); 4471 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; 4472 #else 4473 # ifdef HAS_GETTIMEOFDAY 4474 PerlProc_gettimeofday(&when,NULL); 4475 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; 4476 # else 4477 (void)time(&when); 4478 u = (U32)SEED_C1 * when; 4479 # endif 4480 #endif 4481 u += SEED_C3 * (U32)PerlProc_getpid(); 4482 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); 4483 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ 4484 u += SEED_C5 * (U32)PTR2UV(&when); 4485 #endif 4486 return u; 4487 } 4488 4489 void 4490 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer) 4491 { 4492 dVAR; 4493 const char *env_pv; 4494 unsigned long i; 4495 4496 PERL_ARGS_ASSERT_GET_HASH_SEED; 4497 4498 env_pv= PerlEnv_getenv("PERL_HASH_SEED"); 4499 4500 if ( env_pv ) 4501 #ifndef USE_HASH_SEED_EXPLICIT 4502 { 4503 /* ignore leading spaces */ 4504 while (isSPACE(*env_pv)) 4505 env_pv++; 4506 #ifdef USE_PERL_PERTURB_KEYS 4507 /* if they set it to "0" we disable key traversal randomization completely */ 4508 if (strEQ(env_pv,"0")) { 4509 PL_hash_rand_bits_enabled= 0; 4510 } else { 4511 /* otherwise switch to deterministic mode */ 4512 PL_hash_rand_bits_enabled= 2; 4513 } 4514 #endif 4515 /* ignore a leading 0x... if it is there */ 4516 if (env_pv[0] == '0' && env_pv[1] == 'x') 4517 env_pv += 2; 4518 4519 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) { 4520 seed_buffer[i] = READ_XDIGIT(env_pv) << 4; 4521 if ( isXDIGIT(*env_pv)) { 4522 seed_buffer[i] |= READ_XDIGIT(env_pv); 4523 } 4524 } 4525 while (isSPACE(*env_pv)) 4526 env_pv++; 4527 4528 if (*env_pv && !isXDIGIT(*env_pv)) { 4529 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n"); 4530 } 4531 /* should we check for unparsed crap? */ 4532 /* should we warn about unused hex? */ 4533 /* should we warn about insufficient hex? */ 4534 } 4535 else 4536 #endif 4537 { 4538 (void)seedDrand01((Rand_seed_t)seed()); 4539 4540 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) { 4541 seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1)); 4542 } 4543 } 4544 #ifdef USE_PERL_PERTURB_KEYS 4545 { /* initialize PL_hash_rand_bits from the hash seed. 4546 * This value is highly volatile, it is updated every 4547 * hash insert, and is used as part of hash bucket chain 4548 * randomization and hash iterator randomization. */ 4549 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */ 4550 for( i = 0; i < sizeof(UV) ; i++ ) { 4551 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES]; 4552 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8); 4553 } 4554 } 4555 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS"); 4556 if (env_pv) { 4557 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) { 4558 PL_hash_rand_bits_enabled= 0; 4559 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) { 4560 PL_hash_rand_bits_enabled= 1; 4561 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) { 4562 PL_hash_rand_bits_enabled= 2; 4563 } else { 4564 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv); 4565 } 4566 } 4567 #endif 4568 } 4569 4570 #ifdef PERL_GLOBAL_STRUCT 4571 4572 #define PERL_GLOBAL_STRUCT_INIT 4573 #include "opcode.h" /* the ppaddr and check */ 4574 4575 struct perl_vars * 4576 Perl_init_global_struct(pTHX) 4577 { 4578 struct perl_vars *plvarsp = NULL; 4579 # ifdef PERL_GLOBAL_STRUCT 4580 const IV nppaddr = C_ARRAY_LENGTH(Gppaddr); 4581 const IV ncheck = C_ARRAY_LENGTH(Gcheck); 4582 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4583 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */ 4584 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); 4585 if (!plvarsp) 4586 exit(1); 4587 # else 4588 plvarsp = PL_VarsPtr; 4589 # endif /* PERL_GLOBAL_STRUCT_PRIVATE */ 4590 # undef PERLVAR 4591 # undef PERLVARA 4592 # undef PERLVARI 4593 # undef PERLVARIC 4594 # define PERLVAR(prefix,var,type) /**/ 4595 # define PERLVARA(prefix,var,n,type) /**/ 4596 # define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init; 4597 # define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init; 4598 # include "perlvars.h" 4599 # undef PERLVAR 4600 # undef PERLVARA 4601 # undef PERLVARI 4602 # undef PERLVARIC 4603 # ifdef PERL_GLOBAL_STRUCT 4604 plvarsp->Gppaddr = 4605 (Perl_ppaddr_t*) 4606 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); 4607 if (!plvarsp->Gppaddr) 4608 exit(1); 4609 plvarsp->Gcheck = 4610 (Perl_check_t*) 4611 PerlMem_malloc(ncheck * sizeof(Perl_check_t)); 4612 if (!plvarsp->Gcheck) 4613 exit(1); 4614 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 4615 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t); 4616 # endif 4617 # ifdef PERL_SET_VARS 4618 PERL_SET_VARS(plvarsp); 4619 # endif 4620 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4621 plvarsp->Gsv_placeholder.sv_flags = 0; 4622 memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed)); 4623 # endif 4624 # undef PERL_GLOBAL_STRUCT_INIT 4625 # endif 4626 return plvarsp; 4627 } 4628 4629 #endif /* PERL_GLOBAL_STRUCT */ 4630 4631 #ifdef PERL_GLOBAL_STRUCT 4632 4633 void 4634 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) 4635 { 4636 int veto = plvarsp->Gveto_cleanup; 4637 4638 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT; 4639 # ifdef PERL_GLOBAL_STRUCT 4640 # ifdef PERL_UNSET_VARS 4641 PERL_UNSET_VARS(plvarsp); 4642 # endif 4643 if (veto) 4644 return; 4645 free(plvarsp->Gppaddr); 4646 free(plvarsp->Gcheck); 4647 # ifdef PERL_GLOBAL_STRUCT_PRIVATE 4648 free(plvarsp); 4649 # endif 4650 # endif 4651 } 4652 4653 #endif /* PERL_GLOBAL_STRUCT */ 4654 4655 #ifdef PERL_MEM_LOG 4656 4657 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the 4658 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also 4659 * given, and you supply your own implementation. 4660 * 4661 * The default implementation reads a single env var, PERL_MEM_LOG, 4662 * expecting one or more of the following: 4663 * 4664 * \d+ - fd fd to write to : must be 1st (atoi) 4665 * 'm' - memlog was PERL_MEM_LOG=1 4666 * 's' - svlog was PERL_SV_LOG=1 4667 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 4668 * 4669 * This makes the logger controllable enough that it can reasonably be 4670 * added to the system perl. 4671 */ 4672 4673 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer 4674 * the Perl_mem_log_...() will use (either via sprintf or snprintf). 4675 */ 4676 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 4677 4678 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...() 4679 * writes to. In the default logger, this is settable at runtime. 4680 */ 4681 #ifndef PERL_MEM_LOG_FD 4682 # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */ 4683 #endif 4684 4685 #ifndef PERL_MEM_LOG_NOIMPL 4686 4687 # ifdef DEBUG_LEAKING_SCALARS 4688 # define SV_LOG_SERIAL_FMT " [%lu]" 4689 # define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial 4690 # else 4691 # define SV_LOG_SERIAL_FMT 4692 # define _SV_LOG_SERIAL_ARG(sv) 4693 # endif 4694 4695 static void 4696 S_mem_log_common(enum mem_log_type mlt, const UV n, 4697 const UV typesize, const char *type_name, const SV *sv, 4698 Malloc_t oldalloc, Malloc_t newalloc, 4699 const char *filename, const int linenumber, 4700 const char *funcname) 4701 { 4702 const char *pmlenv; 4703 4704 PERL_ARGS_ASSERT_MEM_LOG_COMMON; 4705 4706 pmlenv = PerlEnv_getenv("PERL_MEM_LOG"); 4707 if (!pmlenv) 4708 return; 4709 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s')) 4710 { 4711 /* We can't use SVs or PerlIO for obvious reasons, 4712 * so we'll use stdio and low-level IO instead. */ 4713 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; 4714 4715 # ifdef HAS_GETTIMEOFDAY 4716 # define MEM_LOG_TIME_FMT "%10d.%06d: " 4717 # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec 4718 struct timeval tv; 4719 gettimeofday(&tv, 0); 4720 # else 4721 # define MEM_LOG_TIME_FMT "%10d: " 4722 # define MEM_LOG_TIME_ARG (int)when 4723 Time_t when; 4724 (void)time(&when); 4725 # endif 4726 /* If there are other OS specific ways of hires time than 4727 * gettimeofday() (see ext/Time-HiRes), the easiest way is 4728 * probably that they would be used to fill in the struct 4729 * timeval. */ 4730 { 4731 STRLEN len; 4732 int fd = atoi(pmlenv); 4733 if (!fd) 4734 fd = PERL_MEM_LOG_FD; 4735 4736 if (strchr(pmlenv, 't')) { 4737 len = my_snprintf(buf, sizeof(buf), 4738 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); 4739 PerlLIO_write(fd, buf, len); 4740 } 4741 switch (mlt) { 4742 case MLT_ALLOC: 4743 len = my_snprintf(buf, sizeof(buf), 4744 "alloc: %s:%d:%s: %"IVdf" %"UVuf 4745 " %s = %"IVdf": %"UVxf"\n", 4746 filename, linenumber, funcname, n, typesize, 4747 type_name, n * typesize, PTR2UV(newalloc)); 4748 break; 4749 case MLT_REALLOC: 4750 len = my_snprintf(buf, sizeof(buf), 4751 "realloc: %s:%d:%s: %"IVdf" %"UVuf 4752 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n", 4753 filename, linenumber, funcname, n, typesize, 4754 type_name, n * typesize, PTR2UV(oldalloc), 4755 PTR2UV(newalloc)); 4756 break; 4757 case MLT_FREE: 4758 len = my_snprintf(buf, sizeof(buf), 4759 "free: %s:%d:%s: %"UVxf"\n", 4760 filename, linenumber, funcname, 4761 PTR2UV(oldalloc)); 4762 break; 4763 case MLT_NEW_SV: 4764 case MLT_DEL_SV: 4765 len = my_snprintf(buf, sizeof(buf), 4766 "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n", 4767 mlt == MLT_NEW_SV ? "new" : "del", 4768 filename, linenumber, funcname, 4769 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv)); 4770 break; 4771 default: 4772 len = 0; 4773 } 4774 PerlLIO_write(fd, buf, len); 4775 } 4776 } 4777 } 4778 #endif /* !PERL_MEM_LOG_NOIMPL */ 4779 4780 #ifndef PERL_MEM_LOG_NOIMPL 4781 # define \ 4782 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \ 4783 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) 4784 #else 4785 /* this is suboptimal, but bug compatible. User is providing their 4786 own implementation, but is getting these functions anyway, and they 4787 do nothing. But _NOIMPL users should be able to cope or fix */ 4788 # define \ 4789 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \ 4790 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */ 4791 #endif 4792 4793 Malloc_t 4794 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, 4795 Malloc_t newalloc, 4796 const char *filename, const int linenumber, 4797 const char *funcname) 4798 { 4799 mem_log_common_if(MLT_ALLOC, n, typesize, type_name, 4800 NULL, NULL, newalloc, 4801 filename, linenumber, funcname); 4802 return newalloc; 4803 } 4804 4805 Malloc_t 4806 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, 4807 Malloc_t oldalloc, Malloc_t newalloc, 4808 const char *filename, const int linenumber, 4809 const char *funcname) 4810 { 4811 mem_log_common_if(MLT_REALLOC, n, typesize, type_name, 4812 NULL, oldalloc, newalloc, 4813 filename, linenumber, funcname); 4814 return newalloc; 4815 } 4816 4817 Malloc_t 4818 Perl_mem_log_free(Malloc_t oldalloc, 4819 const char *filename, const int linenumber, 4820 const char *funcname) 4821 { 4822 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 4823 filename, linenumber, funcname); 4824 return oldalloc; 4825 } 4826 4827 void 4828 Perl_mem_log_new_sv(const SV *sv, 4829 const char *filename, const int linenumber, 4830 const char *funcname) 4831 { 4832 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, 4833 filename, linenumber, funcname); 4834 } 4835 4836 void 4837 Perl_mem_log_del_sv(const SV *sv, 4838 const char *filename, const int linenumber, 4839 const char *funcname) 4840 { 4841 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, 4842 filename, linenumber, funcname); 4843 } 4844 4845 #endif /* PERL_MEM_LOG */ 4846 4847 /* 4848 =for apidoc my_sprintf 4849 4850 The C library C<sprintf>, wrapped if necessary, to ensure that it will return 4851 the length of the string written to the buffer. Only rare pre-ANSI systems 4852 need the wrapper function - usually this is a direct call to C<sprintf>. 4853 4854 =cut 4855 */ 4856 #ifndef SPRINTF_RETURNS_STRLEN 4857 int 4858 Perl_my_sprintf(char *buffer, const char* pat, ...) 4859 { 4860 va_list args; 4861 PERL_ARGS_ASSERT_MY_SPRINTF; 4862 va_start(args, pat); 4863 vsprintf(buffer, pat, args); 4864 va_end(args); 4865 return strlen(buffer); 4866 } 4867 #endif 4868 4869 /* 4870 =for apidoc my_snprintf 4871 4872 The C library C<snprintf> functionality, if available and 4873 standards-compliant (uses C<vsnprintf>, actually). However, if the 4874 C<vsnprintf> is not available, will unfortunately use the unsafe 4875 C<vsprintf> which can overrun the buffer (there is an overrun check, 4876 but that may be too late). Consider using C<sv_vcatpvf> instead, or 4877 getting C<vsnprintf>. 4878 4879 =cut 4880 */ 4881 int 4882 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) 4883 { 4884 int retval; 4885 va_list ap; 4886 PERL_ARGS_ASSERT_MY_SNPRINTF; 4887 va_start(ap, format); 4888 #ifdef HAS_VSNPRINTF 4889 retval = vsnprintf(buffer, len, format, ap); 4890 #else 4891 retval = vsprintf(buffer, format, ap); 4892 #endif 4893 va_end(ap); 4894 /* vsprintf() shows failure with < 0 */ 4895 if (retval < 0 4896 #ifdef HAS_VSNPRINTF 4897 /* vsnprintf() shows failure with >= len */ 4898 || 4899 (len > 0 && (Size_t)retval >= len) 4900 #endif 4901 ) 4902 Perl_croak_nocontext("panic: my_snprintf buffer overflow"); 4903 return retval; 4904 } 4905 4906 /* 4907 =for apidoc my_vsnprintf 4908 4909 The C library C<vsnprintf> if available and standards-compliant. 4910 However, if if the C<vsnprintf> is not available, will unfortunately 4911 use the unsafe C<vsprintf> which can overrun the buffer (there is an 4912 overrun check, but that may be too late). Consider using 4913 C<sv_vcatpvf> instead, or getting C<vsnprintf>. 4914 4915 =cut 4916 */ 4917 int 4918 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) 4919 { 4920 int retval; 4921 #ifdef NEED_VA_COPY 4922 va_list apc; 4923 4924 PERL_ARGS_ASSERT_MY_VSNPRINTF; 4925 4926 Perl_va_copy(ap, apc); 4927 # ifdef HAS_VSNPRINTF 4928 retval = vsnprintf(buffer, len, format, apc); 4929 # else 4930 retval = vsprintf(buffer, format, apc); 4931 # endif 4932 va_end(apc); 4933 #else 4934 # ifdef HAS_VSNPRINTF 4935 retval = vsnprintf(buffer, len, format, ap); 4936 # else 4937 retval = vsprintf(buffer, format, ap); 4938 # endif 4939 #endif /* #ifdef NEED_VA_COPY */ 4940 /* vsprintf() shows failure with < 0 */ 4941 if (retval < 0 4942 #ifdef HAS_VSNPRINTF 4943 /* vsnprintf() shows failure with >= len */ 4944 || 4945 (len > 0 && (Size_t)retval >= len) 4946 #endif 4947 ) 4948 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); 4949 return retval; 4950 } 4951 4952 void 4953 Perl_my_clearenv(pTHX) 4954 { 4955 dVAR; 4956 #if ! defined(PERL_MICRO) 4957 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32) 4958 PerlEnv_clearenv(); 4959 # else /* ! (PERL_IMPLICIT_SYS || WIN32) */ 4960 # if defined(USE_ENVIRON_ARRAY) 4961 # if defined(USE_ITHREADS) 4962 /* only the parent thread can clobber the process environment */ 4963 if (PL_curinterp == aTHX) 4964 # endif /* USE_ITHREADS */ 4965 { 4966 # if ! defined(PERL_USE_SAFE_PUTENV) 4967 if ( !PL_use_safe_putenv) { 4968 I32 i; 4969 if (environ == PL_origenviron) 4970 environ = (char**)safesysmalloc(sizeof(char*)); 4971 else 4972 for (i = 0; environ[i]; i++) 4973 (void)safesysfree(environ[i]); 4974 } 4975 environ[0] = NULL; 4976 # else /* PERL_USE_SAFE_PUTENV */ 4977 # if defined(HAS_CLEARENV) 4978 (void)clearenv(); 4979 # elif defined(HAS_UNSETENV) 4980 int bsiz = 80; /* Most envvar names will be shorter than this. */ 4981 char *buf = (char*)safesysmalloc(bsiz); 4982 while (*environ != NULL) { 4983 char *e = strchr(*environ, '='); 4984 int l = e ? e - *environ : (int)strlen(*environ); 4985 if (bsiz < l + 1) { 4986 (void)safesysfree(buf); 4987 bsiz = l + 1; /* + 1 for the \0. */ 4988 buf = (char*)safesysmalloc(bsiz); 4989 } 4990 memcpy(buf, *environ, l); 4991 buf[l] = '\0'; 4992 (void)unsetenv(buf); 4993 } 4994 (void)safesysfree(buf); 4995 # else /* ! HAS_CLEARENV && ! HAS_UNSETENV */ 4996 /* Just null environ and accept the leakage. */ 4997 *environ = NULL; 4998 # endif /* HAS_CLEARENV || HAS_UNSETENV */ 4999 # endif /* ! PERL_USE_SAFE_PUTENV */ 5000 } 5001 # endif /* USE_ENVIRON_ARRAY */ 5002 # endif /* PERL_IMPLICIT_SYS || WIN32 */ 5003 #endif /* PERL_MICRO */ 5004 } 5005 5006 #ifdef PERL_IMPLICIT_CONTEXT 5007 5008 /* Implements the MY_CXT_INIT macro. The first time a module is loaded, 5009 the global PL_my_cxt_index is incremented, and that value is assigned to 5010 that module's static my_cxt_index (who's address is passed as an arg). 5011 Then, for each interpreter this function is called for, it makes sure a 5012 void* slot is available to hang the static data off, by allocating or 5013 extending the interpreter's PL_my_cxt_list array */ 5014 5015 #ifndef PERL_GLOBAL_STRUCT_PRIVATE 5016 void * 5017 Perl_my_cxt_init(pTHX_ int *index, size_t size) 5018 { 5019 dVAR; 5020 void *p; 5021 PERL_ARGS_ASSERT_MY_CXT_INIT; 5022 if (*index == -1) { 5023 /* this module hasn't been allocated an index yet */ 5024 #if defined(USE_ITHREADS) 5025 MUTEX_LOCK(&PL_my_ctx_mutex); 5026 #endif 5027 *index = PL_my_cxt_index++; 5028 #if defined(USE_ITHREADS) 5029 MUTEX_UNLOCK(&PL_my_ctx_mutex); 5030 #endif 5031 } 5032 5033 /* make sure the array is big enough */ 5034 if (PL_my_cxt_size <= *index) { 5035 if (PL_my_cxt_size) { 5036 while (PL_my_cxt_size <= *index) 5037 PL_my_cxt_size *= 2; 5038 Renew(PL_my_cxt_list, PL_my_cxt_size, void *); 5039 } 5040 else { 5041 PL_my_cxt_size = 16; 5042 Newx(PL_my_cxt_list, PL_my_cxt_size, void *); 5043 } 5044 } 5045 /* newSV() allocates one more than needed */ 5046 p = (void*)SvPVX(newSV(size-1)); 5047 PL_my_cxt_list[*index] = p; 5048 Zero(p, size, char); 5049 return p; 5050 } 5051 5052 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ 5053 5054 int 5055 Perl_my_cxt_index(pTHX_ const char *my_cxt_key) 5056 { 5057 dVAR; 5058 int index; 5059 5060 PERL_ARGS_ASSERT_MY_CXT_INDEX; 5061 5062 for (index = 0; index < PL_my_cxt_index; index++) { 5063 const char *key = PL_my_cxt_keys[index]; 5064 /* try direct pointer compare first - there are chances to success, 5065 * and it's much faster. 5066 */ 5067 if ((key == my_cxt_key) || strEQ(key, my_cxt_key)) 5068 return index; 5069 } 5070 return -1; 5071 } 5072 5073 void * 5074 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) 5075 { 5076 dVAR; 5077 void *p; 5078 int index; 5079 5080 PERL_ARGS_ASSERT_MY_CXT_INIT; 5081 5082 index = Perl_my_cxt_index(aTHX_ my_cxt_key); 5083 if (index == -1) { 5084 /* this module hasn't been allocated an index yet */ 5085 #if defined(USE_ITHREADS) 5086 MUTEX_LOCK(&PL_my_ctx_mutex); 5087 #endif 5088 index = PL_my_cxt_index++; 5089 #if defined(USE_ITHREADS) 5090 MUTEX_UNLOCK(&PL_my_ctx_mutex); 5091 #endif 5092 } 5093 5094 /* make sure the array is big enough */ 5095 if (PL_my_cxt_size <= index) { 5096 int old_size = PL_my_cxt_size; 5097 int i; 5098 if (PL_my_cxt_size) { 5099 while (PL_my_cxt_size <= index) 5100 PL_my_cxt_size *= 2; 5101 Renew(PL_my_cxt_list, PL_my_cxt_size, void *); 5102 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *); 5103 } 5104 else { 5105 PL_my_cxt_size = 16; 5106 Newx(PL_my_cxt_list, PL_my_cxt_size, void *); 5107 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); 5108 } 5109 for (i = old_size; i < PL_my_cxt_size; i++) { 5110 PL_my_cxt_keys[i] = 0; 5111 PL_my_cxt_list[i] = 0; 5112 } 5113 } 5114 PL_my_cxt_keys[index] = my_cxt_key; 5115 /* newSV() allocates one more than needed */ 5116 p = (void*)SvPVX(newSV(size-1)); 5117 PL_my_cxt_list[index] = p; 5118 Zero(p, size, char); 5119 return p; 5120 } 5121 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ 5122 #endif /* PERL_IMPLICIT_CONTEXT */ 5123 5124 void 5125 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, 5126 STRLEN xs_len) 5127 { 5128 SV *sv; 5129 const char *vn = NULL; 5130 SV *const module = PL_stack_base[ax]; 5131 5132 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK; 5133 5134 if (items >= 2) /* version supplied as bootstrap arg */ 5135 sv = PL_stack_base[ax + 1]; 5136 else { 5137 /* XXX GV_ADDWARN */ 5138 vn = "XS_VERSION"; 5139 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); 5140 if (!sv || !SvOK(sv)) { 5141 vn = "VERSION"; 5142 sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); 5143 } 5144 } 5145 if (sv) { 5146 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP); 5147 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version") 5148 ? sv : sv_2mortal(new_version(sv)); 5149 xssv = upg_version(xssv, 0); 5150 if ( vcmp(pmsv,xssv) ) { 5151 SV *string = vstringify(xssv); 5152 SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf 5153 " does not match ", module, string); 5154 5155 SvREFCNT_dec(string); 5156 string = vstringify(pmsv); 5157 5158 if (vn) { 5159 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn, 5160 string); 5161 } else { 5162 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string); 5163 } 5164 SvREFCNT_dec(string); 5165 5166 Perl_sv_2mortal(aTHX_ xpt); 5167 Perl_croak_sv(aTHX_ xpt); 5168 } 5169 } 5170 } 5171 5172 void 5173 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p, 5174 STRLEN api_len) 5175 { 5176 SV *xpt = NULL; 5177 SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP); 5178 SV *runver; 5179 5180 PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK; 5181 5182 /* This might croak */ 5183 compver = upg_version(compver, 0); 5184 /* This should never croak */ 5185 runver = new_version(PL_apiversion); 5186 if (vcmp(compver, runver)) { 5187 SV *compver_string = vstringify(compver); 5188 SV *runver_string = vstringify(runver); 5189 xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf 5190 " of %"SVf" does not match %"SVf, 5191 compver_string, module, runver_string); 5192 Perl_sv_2mortal(aTHX_ xpt); 5193 5194 SvREFCNT_dec(compver_string); 5195 SvREFCNT_dec(runver_string); 5196 } 5197 SvREFCNT_dec(runver); 5198 if (xpt) 5199 Perl_croak_sv(aTHX_ xpt); 5200 } 5201 5202 /* 5203 =for apidoc my_strlcat 5204 5205 The C library C<strlcat> if available, or a Perl implementation of it. 5206 This operates on C C<NUL>-terminated strings. 5207 5208 C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at 5209 most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate, 5210 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in 5211 practice this should not happen as it means that either C<size> is incorrect or 5212 that C<dst> is not a proper C<NUL>-terminated string). 5213 5214 Note that C<size> is the full size of the destination buffer and 5215 the result is guaranteed to be C<NUL>-terminated if there is room. Note that 5216 room for the C<NUL> should be included in C<size>. 5217 5218 =cut 5219 5220 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat 5221 */ 5222 #ifndef HAS_STRLCAT 5223 Size_t 5224 Perl_my_strlcat(char *dst, const char *src, Size_t size) 5225 { 5226 Size_t used, length, copy; 5227 5228 used = strlen(dst); 5229 length = strlen(src); 5230 if (size > 0 && used < size - 1) { 5231 copy = (length >= size - used) ? size - used - 1 : length; 5232 memcpy(dst + used, src, copy); 5233 dst[used + copy] = '\0'; 5234 } 5235 return used + length; 5236 } 5237 #endif 5238 5239 5240 /* 5241 =for apidoc my_strlcpy 5242 5243 The C library C<strlcpy> if available, or a Perl implementation of it. 5244 This operates on C C<NUL>-terminated strings. 5245 5246 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src> 5247 to C<dst>, C<NUL>-terminating the result if C<size> is not 0. 5248 5249 =cut 5250 5251 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy 5252 */ 5253 #ifndef HAS_STRLCPY 5254 Size_t 5255 Perl_my_strlcpy(char *dst, const char *src, Size_t size) 5256 { 5257 Size_t length, copy; 5258 5259 length = strlen(src); 5260 if (size > 0) { 5261 copy = (length >= size) ? size - 1 : length; 5262 memcpy(dst, src, copy); 5263 dst[copy] = '\0'; 5264 } 5265 return length; 5266 } 5267 #endif 5268 5269 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500) 5270 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */ 5271 long _ftol( double ); /* Defined by VC6 C libs. */ 5272 long _ftol2( double dblSource ) { return _ftol( dblSource ); } 5273 #endif 5274 5275 PERL_STATIC_INLINE bool 5276 S_gv_has_usable_name(pTHX_ GV *gv) 5277 { 5278 GV **gvp; 5279 return GvSTASH(gv) 5280 && HvENAME(GvSTASH(gv)) 5281 && (gvp = (GV **)hv_fetchhek( 5282 GvSTASH(gv), GvNAME_HEK(gv), 0 5283 )) 5284 && *gvp == gv; 5285 } 5286 5287 void 5288 Perl_get_db_sub(pTHX_ SV **svp, CV *cv) 5289 { 5290 dVAR; 5291 SV * const dbsv = GvSVn(PL_DBsub); 5292 const bool save_taint = TAINT_get; 5293 5294 /* When we are called from pp_goto (svp is null), 5295 * we do not care about using dbsv to call CV; 5296 * it's for informational purposes only. 5297 */ 5298 5299 PERL_ARGS_ASSERT_GET_DB_SUB; 5300 5301 TAINT_set(FALSE); 5302 save_item(dbsv); 5303 if (!PERLDB_SUB_NN) { 5304 GV *gv = CvGV(cv); 5305 5306 if (!svp) { 5307 gv_efullname3(dbsv, gv, NULL); 5308 } 5309 else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) 5310 || strEQ(GvNAME(gv), "END") 5311 || ( /* Could be imported, and old sub redefined. */ 5312 (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) 5313 && 5314 !( (SvTYPE(*svp) == SVt_PVGV) 5315 && (GvCV((const GV *)*svp) == cv) 5316 /* Use GV from the stack as a fallback. */ 5317 && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) 5318 ) 5319 ) 5320 ) { 5321 /* GV is potentially non-unique, or contain different CV. */ 5322 SV * const tmp = newRV(MUTABLE_SV(cv)); 5323 sv_setsv(dbsv, tmp); 5324 SvREFCNT_dec(tmp); 5325 } 5326 else { 5327 sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); 5328 sv_catpvs(dbsv, "::"); 5329 sv_catpvn_flags( 5330 dbsv, GvNAME(gv), GvNAMELEN(gv), 5331 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES 5332 ); 5333 } 5334 } 5335 else { 5336 const int type = SvTYPE(dbsv); 5337 if (type < SVt_PVIV && type != SVt_IV) 5338 sv_upgrade(dbsv, SVt_PVIV); 5339 (void)SvIOK_on(dbsv); 5340 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ 5341 } 5342 SvSETMAGIC(dbsv); 5343 TAINT_IF(save_taint); 5344 #ifdef NO_TAINT_SUPPORT 5345 PERL_UNUSED_VAR(save_taint); 5346 #endif 5347 } 5348 5349 int 5350 Perl_my_dirfd(pTHX_ DIR * dir) { 5351 5352 /* Most dirfd implementations have problems when passed NULL. */ 5353 if(!dir) 5354 return -1; 5355 #ifdef HAS_DIRFD 5356 return dirfd(dir); 5357 #elif defined(HAS_DIR_DD_FD) 5358 return dir->dd_fd; 5359 #else 5360 Perl_die(aTHX_ PL_no_func, "dirfd"); 5361 assert(0); /* NOT REACHED */ 5362 return 0; 5363 #endif 5364 } 5365 5366 REGEXP * 5367 Perl_get_re_arg(pTHX_ SV *sv) { 5368 5369 if (sv) { 5370 if (SvMAGICAL(sv)) 5371 mg_get(sv); 5372 if (SvROK(sv)) 5373 sv = MUTABLE_SV(SvRV(sv)); 5374 if (SvTYPE(sv) == SVt_REGEXP) 5375 return (REGEXP*) sv; 5376 } 5377 5378 return NULL; 5379 } 5380 5381 /* 5382 * This code is derived from drand48() implementation from FreeBSD, 5383 * found in lib/libc/gen/_rand48.c. 5384 * 5385 * The U64 implementation is original, based on the POSIX 5386 * specification for drand48(). 5387 */ 5388 5389 /* 5390 * Copyright (c) 1993 Martin Birgmeier 5391 * All rights reserved. 5392 * 5393 * You may redistribute unmodified or modified versions of this source 5394 * code provided that the above copyright notice and this and the 5395 * following conditions are retained. 5396 * 5397 * This software is provided ``as is'', and comes with no warranties 5398 * of any kind. I shall in no event be liable for anything that happens 5399 * to anyone/anything when using this software. 5400 */ 5401 5402 #define FREEBSD_DRAND48_SEED_0 (0x330e) 5403 5404 #ifdef PERL_DRAND48_QUAD 5405 5406 #define DRAND48_MULT U64_CONST(0x5deece66d) 5407 #define DRAND48_ADD 0xb 5408 #define DRAND48_MASK U64_CONST(0xffffffffffff) 5409 5410 #else 5411 5412 #define FREEBSD_DRAND48_SEED_1 (0xabcd) 5413 #define FREEBSD_DRAND48_SEED_2 (0x1234) 5414 #define FREEBSD_DRAND48_MULT_0 (0xe66d) 5415 #define FREEBSD_DRAND48_MULT_1 (0xdeec) 5416 #define FREEBSD_DRAND48_MULT_2 (0x0005) 5417 #define FREEBSD_DRAND48_ADD (0x000b) 5418 5419 const unsigned short _rand48_mult[3] = { 5420 FREEBSD_DRAND48_MULT_0, 5421 FREEBSD_DRAND48_MULT_1, 5422 FREEBSD_DRAND48_MULT_2 5423 }; 5424 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD; 5425 5426 #endif 5427 5428 void 5429 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed) 5430 { 5431 PERL_ARGS_ASSERT_DRAND48_INIT_R; 5432 5433 #ifdef PERL_DRAND48_QUAD 5434 *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16); 5435 #else 5436 random_state->seed[0] = FREEBSD_DRAND48_SEED_0; 5437 random_state->seed[1] = (U16) seed; 5438 random_state->seed[2] = (U16) (seed >> 16); 5439 #endif 5440 } 5441 5442 double 5443 Perl_drand48_r(perl_drand48_t *random_state) 5444 { 5445 PERL_ARGS_ASSERT_DRAND48_R; 5446 5447 #ifdef PERL_DRAND48_QUAD 5448 *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD) 5449 & DRAND48_MASK; 5450 5451 return ldexp((double)*random_state, -48); 5452 #else 5453 { 5454 U32 accu; 5455 U16 temp[2]; 5456 5457 accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0] 5458 + (U32) _rand48_add; 5459 temp[0] = (U16) accu; /* lower 16 bits */ 5460 accu >>= sizeof(U16) * 8; 5461 accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1] 5462 + (U32) _rand48_mult[1] * (U32) random_state->seed[0]; 5463 temp[1] = (U16) accu; /* middle 16 bits */ 5464 accu >>= sizeof(U16) * 8; 5465 accu += _rand48_mult[0] * random_state->seed[2] 5466 + _rand48_mult[1] * random_state->seed[1] 5467 + _rand48_mult[2] * random_state->seed[0]; 5468 random_state->seed[0] = temp[0]; 5469 random_state->seed[1] = temp[1]; 5470 random_state->seed[2] = (U16) accu; 5471 5472 return ldexp((double) random_state->seed[0], -48) + 5473 ldexp((double) random_state->seed[1], -32) + 5474 ldexp((double) random_state->seed[2], -16); 5475 } 5476 #endif 5477 } 5478 5479 5480 /* 5481 * Local variables: 5482 * c-indentation-style: bsd 5483 * c-basic-offset: 4 5484 * indent-tabs-mode: nil 5485 * End: 5486 * 5487 * ex: set ts=8 sts=4 sw=4 et: 5488 */ 5489