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