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