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