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