1 /* util.c 2 * 3 * Copyright (c) 1991-2002, Larry Wall 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 /* 11 * "Very useful, no doubt, that was to Saruman; yet it seems that he was 12 * not content." --Gandalf 13 */ 14 15 #include "EXTERN.h" 16 #define PERL_IN_UTIL_C 17 #include "perl.h" 18 19 #ifndef PERL_MICRO 20 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) 21 #include <signal.h> 22 #endif 23 24 #ifndef SIG_ERR 25 # define SIG_ERR ((Sighandler_t) -1) 26 #endif 27 #endif 28 29 #ifdef I_SYS_WAIT 30 # include <sys/wait.h> 31 #endif 32 33 #ifdef HAS_SELECT 34 # ifdef I_SYS_SELECT 35 # include <sys/select.h> 36 # endif 37 #endif 38 39 #define FLUSH 40 41 #ifdef LEAKTEST 42 43 long xcount[MAXXCOUNT]; 44 long lastxcount[MAXXCOUNT]; 45 long xycount[MAXXCOUNT][MAXYCOUNT]; 46 long lastxycount[MAXXCOUNT][MAXYCOUNT]; 47 48 #endif 49 50 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) 51 # define FD_CLOEXEC 1 /* NeXT needs this */ 52 #endif 53 54 /* NOTE: Do not call the next three routines directly. Use the macros 55 * in handy.h, so that we can easily redefine everything to do tracking of 56 * allocated hunks back to the original New to track down any memory leaks. 57 * XXX This advice seems to be widely ignored :-( --AD August 1996. 58 */ 59 60 /* paranoid version of system's malloc() */ 61 62 Malloc_t 63 Perl_safesysmalloc(MEM_SIZE size) 64 { 65 dTHX; 66 Malloc_t ptr; 67 #ifdef HAS_64K_LIMIT 68 if (size > 0xffff) { 69 PerlIO_printf(Perl_error_log, 70 "Allocation too large: %lx\n", size) FLUSH; 71 my_exit(1); 72 } 73 #endif /* HAS_64K_LIMIT */ 74 #ifdef DEBUGGING 75 if ((long)size < 0) 76 Perl_croak_nocontext("panic: malloc"); 77 #endif 78 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ 79 PERL_ALLOC_CHECK(ptr); 80 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 81 if (ptr != Nullch) 82 return ptr; 83 else if (PL_nomemok) 84 return Nullch; 85 else { 86 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; 87 my_exit(1); 88 return Nullch; 89 } 90 /*NOTREACHED*/ 91 } 92 93 /* paranoid version of system's realloc() */ 94 95 Malloc_t 96 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) 97 { 98 dTHX; 99 Malloc_t ptr; 100 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO) 101 Malloc_t PerlMem_realloc(); 102 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ 103 104 #ifdef HAS_64K_LIMIT 105 if (size > 0xffff) { 106 PerlIO_printf(Perl_error_log, 107 "Reallocation too large: %lx\n", size) FLUSH; 108 my_exit(1); 109 } 110 #endif /* HAS_64K_LIMIT */ 111 if (!size) { 112 safesysfree(where); 113 return NULL; 114 } 115 116 if (!where) 117 return safesysmalloc(size); 118 #ifdef DEBUGGING 119 if ((long)size < 0) 120 Perl_croak_nocontext("panic: realloc"); 121 #endif 122 ptr = (Malloc_t)PerlMem_realloc(where,size); 123 PERL_ALLOC_CHECK(ptr); 124 125 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); 126 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 127 128 if (ptr != Nullch) 129 return ptr; 130 else if (PL_nomemok) 131 return Nullch; 132 else { 133 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; 134 my_exit(1); 135 return Nullch; 136 } 137 /*NOTREACHED*/ 138 } 139 140 /* safe version of system's free() */ 141 142 Free_t 143 Perl_safesysfree(Malloc_t where) 144 { 145 #ifdef PERL_IMPLICIT_SYS 146 dTHX; 147 #endif 148 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); 149 if (where) { 150 /*SUPPRESS 701*/ 151 PerlMem_free(where); 152 } 153 } 154 155 /* safe version of system's calloc() */ 156 157 Malloc_t 158 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) 159 { 160 dTHX; 161 Malloc_t ptr; 162 163 #ifdef HAS_64K_LIMIT 164 if (size * count > 0xffff) { 165 PerlIO_printf(Perl_error_log, 166 "Allocation too large: %lx\n", size * count) FLUSH; 167 my_exit(1); 168 } 169 #endif /* HAS_64K_LIMIT */ 170 #ifdef DEBUGGING 171 if ((long)size < 0 || (long)count < 0) 172 Perl_croak_nocontext("panic: calloc"); 173 #endif 174 size *= count; 175 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ 176 PERL_ALLOC_CHECK(ptr); 177 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size)); 178 if (ptr != Nullch) { 179 memset((void*)ptr, 0, size); 180 return ptr; 181 } 182 else if (PL_nomemok) 183 return Nullch; 184 else { 185 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; 186 my_exit(1); 187 return Nullch; 188 } 189 /*NOTREACHED*/ 190 } 191 192 #ifdef LEAKTEST 193 194 struct mem_test_strut { 195 union { 196 long type; 197 char c[2]; 198 } u; 199 long size; 200 }; 201 202 # define ALIGN sizeof(struct mem_test_strut) 203 204 # define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size) 205 # define typeof_chunk(ch) \ 206 (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100) 207 # define set_typeof_chunk(ch,t) \ 208 (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100) 209 #define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \ 210 ? MAXYCOUNT - 1 \ 211 : ( (size) > 40 \ 212 ? ((size) - 1)/8 + 5 \ 213 : ((size) - 1)/4)) 214 215 Malloc_t 216 Perl_safexmalloc(I32 x, MEM_SIZE size) 217 { 218 register char* where = (char*)safemalloc(size + ALIGN); 219 220 xcount[x] += size; 221 xycount[x][SIZE_TO_Y(size)]++; 222 set_typeof_chunk(where, x); 223 sizeof_chunk(where) = size; 224 return (Malloc_t)(where + ALIGN); 225 } 226 227 Malloc_t 228 Perl_safexrealloc(Malloc_t wh, MEM_SIZE size) 229 { 230 char *where = (char*)wh; 231 232 if (!wh) 233 return safexmalloc(0,size); 234 235 { 236 MEM_SIZE old = sizeof_chunk(where - ALIGN); 237 int t = typeof_chunk(where - ALIGN); 238 register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN); 239 240 xycount[t][SIZE_TO_Y(old)]--; 241 xycount[t][SIZE_TO_Y(size)]++; 242 xcount[t] += size - old; 243 sizeof_chunk(new) = size; 244 return (Malloc_t)(new + ALIGN); 245 } 246 } 247 248 void 249 Perl_safexfree(Malloc_t wh) 250 { 251 I32 x; 252 char *where = (char*)wh; 253 MEM_SIZE size; 254 255 if (!where) 256 return; 257 where -= ALIGN; 258 size = sizeof_chunk(where); 259 x = where[0] + 100 * where[1]; 260 xcount[x] -= size; 261 xycount[x][SIZE_TO_Y(size)]--; 262 safefree(where); 263 } 264 265 Malloc_t 266 Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size) 267 { 268 register char * where = (char*)safexmalloc(x, size * count + ALIGN); 269 xcount[x] += size; 270 xycount[x][SIZE_TO_Y(size)]++; 271 memset((void*)(where + ALIGN), 0, size * count); 272 set_typeof_chunk(where, x); 273 sizeof_chunk(where) = size; 274 return (Malloc_t)(where + ALIGN); 275 } 276 277 STATIC void 278 S_xstat(pTHX_ int flag) 279 { 280 register I32 i, j, total = 0; 281 I32 subtot[MAXYCOUNT]; 282 283 for (j = 0; j < MAXYCOUNT; j++) { 284 subtot[j] = 0; 285 } 286 287 PerlIO_printf(Perl_debug_log, " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total); 288 for (i = 0; i < MAXXCOUNT; i++) { 289 total += xcount[i]; 290 for (j = 0; j < MAXYCOUNT; j++) { 291 subtot[j] += xycount[i][j]; 292 } 293 if (flag == 0 294 ? xcount[i] /* Have something */ 295 : (flag == 2 296 ? xcount[i] != lastxcount[i] /* Changed */ 297 : xcount[i] > lastxcount[i])) { /* Growed */ 298 PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100, 299 flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]); 300 lastxcount[i] = xcount[i]; 301 for (j = 0; j < MAXYCOUNT; j++) { 302 if ( flag == 0 303 ? xycount[i][j] /* Have something */ 304 : (flag == 2 305 ? xycount[i][j] != lastxycount[i][j] /* Changed */ 306 : xycount[i][j] > lastxycount[i][j])) { /* Growed */ 307 PerlIO_printf(Perl_debug_log,"%3ld ", 308 flag == 2 309 ? xycount[i][j] - lastxycount[i][j] 310 : xycount[i][j]); 311 lastxycount[i][j] = xycount[i][j]; 312 } else { 313 PerlIO_printf(Perl_debug_log, " . ", xycount[i][j]); 314 } 315 } 316 PerlIO_printf(Perl_debug_log, "\n"); 317 } 318 } 319 if (flag != 2) { 320 PerlIO_printf(Perl_debug_log, "Total %7ld ", total); 321 for (j = 0; j < MAXYCOUNT; j++) { 322 if (subtot[j]) { 323 PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]); 324 } else { 325 PerlIO_printf(Perl_debug_log, " . "); 326 } 327 } 328 PerlIO_printf(Perl_debug_log, "\n"); 329 } 330 } 331 332 #endif /* LEAKTEST */ 333 334 /* These must be defined when not using Perl's malloc for binary 335 * compatibility */ 336 337 #ifndef MYMALLOC 338 339 Malloc_t Perl_malloc (MEM_SIZE nbytes) 340 { 341 dTHXs; 342 return (Malloc_t)PerlMem_malloc(nbytes); 343 } 344 345 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) 346 { 347 dTHXs; 348 return (Malloc_t)PerlMem_calloc(elements, size); 349 } 350 351 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) 352 { 353 dTHXs; 354 return (Malloc_t)PerlMem_realloc(where, nbytes); 355 } 356 357 Free_t Perl_mfree (Malloc_t where) 358 { 359 dTHXs; 360 PerlMem_free(where); 361 } 362 363 #endif 364 365 /* copy a string up to some (non-backslashed) delimiter, if any */ 366 367 char * 368 Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen) 369 { 370 register I32 tolen; 371 for (tolen = 0; from < fromend; from++, tolen++) { 372 if (*from == '\\') { 373 if (from[1] == delim) 374 from++; 375 else { 376 if (to < toend) 377 *to++ = *from; 378 tolen++; 379 from++; 380 } 381 } 382 else if (*from == delim) 383 break; 384 if (to < toend) 385 *to++ = *from; 386 } 387 if (to < toend) 388 *to = '\0'; 389 *retlen = tolen; 390 return from; 391 } 392 393 /* return ptr to little string in big string, NULL if not found */ 394 /* This routine was donated by Corey Satten. */ 395 396 char * 397 Perl_instr(pTHX_ register const char *big, register const char *little) 398 { 399 register const char *s, *x; 400 register I32 first; 401 402 if (!little) 403 return (char*)big; 404 first = *little++; 405 if (!first) 406 return (char*)big; 407 while (*big) { 408 if (*big++ != first) 409 continue; 410 for (x=big,s=little; *s; /**/ ) { 411 if (!*x) 412 return Nullch; 413 if (*s++ != *x++) { 414 s--; 415 break; 416 } 417 } 418 if (!*s) 419 return (char*)(big-1); 420 } 421 return Nullch; 422 } 423 424 /* same as instr but allow embedded nulls */ 425 426 char * 427 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend) 428 { 429 register const char *s, *x; 430 register I32 first = *little; 431 register const char *littleend = lend; 432 433 if (!first && little >= littleend) 434 return (char*)big; 435 if (bigend - big < littleend - little) 436 return Nullch; 437 bigend -= littleend - little++; 438 while (big <= bigend) { 439 if (*big++ != first) 440 continue; 441 for (x=big,s=little; s < littleend; /**/ ) { 442 if (*s++ != *x++) { 443 s--; 444 break; 445 } 446 } 447 if (s >= littleend) 448 return (char*)(big-1); 449 } 450 return Nullch; 451 } 452 453 /* reverse of the above--find last substring */ 454 455 char * 456 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend) 457 { 458 register const char *bigbeg; 459 register const char *s, *x; 460 register I32 first = *little; 461 register const char *littleend = lend; 462 463 if (!first && little >= littleend) 464 return (char*)bigend; 465 bigbeg = big; 466 big = bigend - (littleend - little++); 467 while (big >= bigbeg) { 468 if (*big-- != first) 469 continue; 470 for (x=big+2,s=little; s < littleend; /**/ ) { 471 if (*s++ != *x++) { 472 s--; 473 break; 474 } 475 } 476 if (s >= littleend) 477 return (char*)(big+1); 478 } 479 return Nullch; 480 } 481 482 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/ 483 484 /* As a space optimization, we do not compile tables for strings of length 485 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are 486 special-cased in fbm_instr(). 487 488 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ 489 490 /* 491 =head1 Miscellaneous Functions 492 493 =for apidoc fbm_compile 494 495 Analyses the string in order to make fast searches on it using fbm_instr() 496 -- the Boyer-Moore algorithm. 497 498 =cut 499 */ 500 501 void 502 Perl_fbm_compile(pTHX_ SV *sv, U32 flags) 503 { 504 register U8 *s; 505 register U8 *table; 506 register U32 i; 507 STRLEN len; 508 I32 rarest = 0; 509 U32 frequency = 256; 510 511 if (flags & FBMcf_TAIL) 512 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ 513 s = (U8*)SvPV_force(sv, len); 514 (void)SvUPGRADE(sv, SVt_PVBM); 515 if (len == 0) /* TAIL might be on a zero-length string. */ 516 return; 517 if (len > 2) { 518 U8 mlen; 519 unsigned char *sb; 520 521 if (len > 255) 522 mlen = 255; 523 else 524 mlen = (U8)len; 525 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET); 526 table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET); 527 s = table - 1 - FBM_TABLE_OFFSET; /* last char */ 528 memset((void*)table, mlen, 256); 529 table[-1] = (U8)flags; 530 i = 0; 531 sb = s - mlen + 1; /* first char (maybe) */ 532 while (s >= sb) { 533 if (table[*s] == mlen) 534 table[*s] = (U8)i; 535 s--, i++; 536 } 537 } 538 sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */ 539 SvVALID_on(sv); 540 541 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ 542 for (i = 0; i < len; i++) { 543 if (PL_freq[s[i]] < frequency) { 544 rarest = i; 545 frequency = PL_freq[s[i]]; 546 } 547 } 548 BmRARE(sv) = s[rarest]; 549 BmPREVIOUS(sv) = (U16)rarest; 550 BmUSEFUL(sv) = 100; /* Initial value */ 551 if (flags & FBMcf_TAIL) 552 SvTAIL_on(sv); 553 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n", 554 BmRARE(sv),BmPREVIOUS(sv))); 555 } 556 557 /* If SvTAIL(littlestr), it has a fake '\n' at end. */ 558 /* If SvTAIL is actually due to \Z or \z, this gives false positives 559 if multiline */ 560 561 /* 562 =for apidoc fbm_instr 563 564 Returns the location of the SV in the string delimited by C<str> and 565 C<strend>. It returns C<Nullch> if the string can't be found. The C<sv> 566 does not have to be fbm_compiled, but the search will not be as fast 567 then. 568 569 =cut 570 */ 571 572 char * 573 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags) 574 { 575 register unsigned char *s; 576 STRLEN l; 577 register unsigned char *little = (unsigned char *)SvPV(littlestr,l); 578 register STRLEN littlelen = l; 579 register I32 multiline = flags & FBMrf_MULTILINE; 580 581 if ((STRLEN)(bigend - big) < littlelen) { 582 if ( SvTAIL(littlestr) 583 && ((STRLEN)(bigend - big) == littlelen - 1) 584 && (littlelen == 1 585 || (*big == *little && 586 memEQ((char *)big, (char *)little, littlelen - 1)))) 587 return (char*)big; 588 return Nullch; 589 } 590 591 if (littlelen <= 2) { /* Special-cased */ 592 593 if (littlelen == 1) { 594 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ 595 /* Know that bigend != big. */ 596 if (bigend[-1] == '\n') 597 return (char *)(bigend - 1); 598 return (char *) bigend; 599 } 600 s = big; 601 while (s < bigend) { 602 if (*s == *little) 603 return (char *)s; 604 s++; 605 } 606 if (SvTAIL(littlestr)) 607 return (char *) bigend; 608 return Nullch; 609 } 610 if (!littlelen) 611 return (char*)big; /* Cannot be SvTAIL! */ 612 613 /* littlelen is 2 */ 614 if (SvTAIL(littlestr) && !multiline) { 615 if (bigend[-1] == '\n' && bigend[-2] == *little) 616 return (char*)bigend - 2; 617 if (bigend[-1] == *little) 618 return (char*)bigend - 1; 619 return Nullch; 620 } 621 { 622 /* This should be better than FBM if c1 == c2, and almost 623 as good otherwise: maybe better since we do less indirection. 624 And we save a lot of memory by caching no table. */ 625 register unsigned char c1 = little[0]; 626 register unsigned char c2 = little[1]; 627 628 s = big + 1; 629 bigend--; 630 if (c1 != c2) { 631 while (s <= bigend) { 632 if (s[0] == c2) { 633 if (s[-1] == c1) 634 return (char*)s - 1; 635 s += 2; 636 continue; 637 } 638 next_chars: 639 if (s[0] == c1) { 640 if (s == bigend) 641 goto check_1char_anchor; 642 if (s[1] == c2) 643 return (char*)s; 644 else { 645 s++; 646 goto next_chars; 647 } 648 } 649 else 650 s += 2; 651 } 652 goto check_1char_anchor; 653 } 654 /* Now c1 == c2 */ 655 while (s <= bigend) { 656 if (s[0] == c1) { 657 if (s[-1] == c1) 658 return (char*)s - 1; 659 if (s == bigend) 660 goto check_1char_anchor; 661 if (s[1] == c1) 662 return (char*)s; 663 s += 3; 664 } 665 else 666 s += 2; 667 } 668 } 669 check_1char_anchor: /* One char and anchor! */ 670 if (SvTAIL(littlestr) && (*bigend == *little)) 671 return (char *)bigend; /* bigend is already decremented. */ 672 return Nullch; 673 } 674 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ 675 s = bigend - littlelen; 676 if (s >= big && bigend[-1] == '\n' && *s == *little 677 /* Automatically of length > 2 */ 678 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) 679 { 680 return (char*)s; /* how sweet it is */ 681 } 682 if (s[1] == *little 683 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) 684 { 685 return (char*)s + 1; /* how sweet it is */ 686 } 687 return Nullch; 688 } 689 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { 690 char *b = ninstr((char*)big,(char*)bigend, 691 (char*)little, (char*)little + littlelen); 692 693 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ 694 /* Chop \n from littlestr: */ 695 s = bigend - littlelen + 1; 696 if (*s == *little 697 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) 698 { 699 return (char*)s; 700 } 701 return Nullch; 702 } 703 return b; 704 } 705 706 { /* Do actual FBM. */ 707 register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; 708 register unsigned char *oldlittle; 709 710 if (littlelen > (STRLEN)(bigend - big)) 711 return Nullch; 712 --littlelen; /* Last char found by table lookup */ 713 714 s = big + littlelen; 715 little += littlelen; /* last char */ 716 oldlittle = little; 717 if (s < bigend) { 718 register I32 tmp; 719 720 top2: 721 /*SUPPRESS 560*/ 722 if ((tmp = table[*s])) { 723 if ((s += tmp) < bigend) 724 goto top2; 725 goto check_end; 726 } 727 else { /* less expensive than calling strncmp() */ 728 register unsigned char *olds = s; 729 730 tmp = littlelen; 731 732 while (tmp--) { 733 if (*--s == *--little) 734 continue; 735 s = olds + 1; /* here we pay the price for failure */ 736 little = oldlittle; 737 if (s < bigend) /* fake up continue to outer loop */ 738 goto top2; 739 goto check_end; 740 } 741 return (char *)s; 742 } 743 } 744 check_end: 745 if ( s == bigend && (table[-1] & FBMcf_TAIL) 746 && memEQ((char *)(bigend - littlelen), 747 (char *)(oldlittle - littlelen), littlelen) ) 748 return (char*)bigend - littlelen; 749 return Nullch; 750 } 751 } 752 753 /* start_shift, end_shift are positive quantities which give offsets 754 of ends of some substring of bigstr. 755 If `last' we want the last occurrence. 756 old_posp is the way of communication between consequent calls if 757 the next call needs to find the . 758 The initial *old_posp should be -1. 759 760 Note that we take into account SvTAIL, so one can get extra 761 optimizations if _ALL flag is set. 762 */ 763 764 /* If SvTAIL is actually due to \Z or \z, this gives false positives 765 if PL_multiline. In fact if !PL_multiline the authoritative answer 766 is not supported yet. */ 767 768 char * 769 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) 770 { 771 register unsigned char *s, *x; 772 register unsigned char *big; 773 register I32 pos; 774 register I32 previous; 775 register I32 first; 776 register unsigned char *little; 777 register I32 stop_pos; 778 register unsigned char *littleend; 779 I32 found = 0; 780 781 if (*old_posp == -1 782 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 783 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { 784 cant_find: 785 if ( BmRARE(littlestr) == '\n' 786 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { 787 little = (unsigned char *)(SvPVX(littlestr)); 788 littleend = little + SvCUR(littlestr); 789 first = *little++; 790 goto check_tail; 791 } 792 return Nullch; 793 } 794 795 little = (unsigned char *)(SvPVX(littlestr)); 796 littleend = little + SvCUR(littlestr); 797 first = *little++; 798 /* The value of pos we can start at: */ 799 previous = BmPREVIOUS(littlestr); 800 big = (unsigned char *)(SvPVX(bigstr)); 801 /* The value of pos we can stop at: */ 802 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); 803 if (previous + start_shift > stop_pos) { 804 /* 805 stop_pos does not include SvTAIL in the count, so this check is incorrect 806 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19 807 */ 808 #if 0 809 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ 810 goto check_tail; 811 #endif 812 return Nullch; 813 } 814 while (pos < previous + start_shift) { 815 if (!(pos += PL_screamnext[pos])) 816 goto cant_find; 817 } 818 big -= previous; 819 do { 820 if (pos >= stop_pos) break; 821 if (big[pos] != first) 822 continue; 823 for (x=big+pos+1,s=little; s < littleend; /**/ ) { 824 if (*s++ != *x++) { 825 s--; 826 break; 827 } 828 } 829 if (s == littleend) { 830 *old_posp = pos; 831 if (!last) return (char *)(big+pos); 832 found = 1; 833 } 834 } while ( pos += PL_screamnext[pos] ); 835 if (last && found) 836 return (char *)(big+(*old_posp)); 837 check_tail: 838 if (!SvTAIL(littlestr) || (end_shift > 0)) 839 return Nullch; 840 /* Ignore the trailing "\n". This code is not microoptimized */ 841 big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr)); 842 stop_pos = littleend - little; /* Actual littlestr len */ 843 if (stop_pos == 0) 844 return (char*)big; 845 big -= stop_pos; 846 if (*big == first 847 && ((stop_pos == 1) || 848 memEQ((char *)(big + 1), (char *)little, stop_pos - 1))) 849 return (char*)big; 850 return Nullch; 851 } 852 853 I32 854 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) 855 { 856 register U8 *a = (U8 *)s1; 857 register U8 *b = (U8 *)s2; 858 while (len--) { 859 if (*a != *b && *a != PL_fold[*b]) 860 return 1; 861 a++,b++; 862 } 863 return 0; 864 } 865 866 I32 867 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) 868 { 869 register U8 *a = (U8 *)s1; 870 register U8 *b = (U8 *)s2; 871 while (len--) { 872 if (*a != *b && *a != PL_fold_locale[*b]) 873 return 1; 874 a++,b++; 875 } 876 return 0; 877 } 878 879 /* copy a string to a safe spot */ 880 881 /* 882 =head1 Memory Management 883 884 =for apidoc savepv 885 886 Perl's version of C<strdup()>. Returns a pointer to a newly allocated 887 string which is a duplicate of C<pv>. The size of the string is 888 determined by C<strlen()>. The memory allocated for the new string can 889 be freed with the C<Safefree()> function. 890 891 =cut 892 */ 893 894 char * 895 Perl_savepv(pTHX_ const char *pv) 896 { 897 register char *newaddr = Nullch; 898 if (pv) { 899 New(902,newaddr,strlen(pv)+1,char); 900 (void)strcpy(newaddr,pv); 901 } 902 return newaddr; 903 } 904 905 /* same thing but with a known length */ 906 907 /* 908 =for apidoc savepvn 909 910 Perl's version of what C<strndup()> would be if it existed. Returns a 911 pointer to a newly allocated string which is a duplicate of the first 912 C<len> bytes from C<pv>. The memory allocated for the new string can be 913 freed with the C<Safefree()> function. 914 915 =cut 916 */ 917 918 char * 919 Perl_savepvn(pTHX_ const char *pv, register I32 len) 920 { 921 register char *newaddr; 922 923 New(903,newaddr,len+1,char); 924 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ 925 if (pv) { 926 Copy(pv,newaddr,len,char); /* might not be null terminated */ 927 newaddr[len] = '\0'; /* is now */ 928 } 929 else { 930 Zero(newaddr,len+1,char); 931 } 932 return newaddr; 933 } 934 935 /* 936 =for apidoc savesharedpv 937 938 A version of C<savepv()> which allocates the duplicate string in memory 939 which is shared between threads. 940 941 =cut 942 */ 943 char * 944 Perl_savesharedpv(pTHX_ const char *pv) 945 { 946 register char *newaddr = Nullch; 947 if (pv) { 948 newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1); 949 (void)strcpy(newaddr,pv); 950 } 951 return newaddr; 952 } 953 954 955 956 /* the SV for Perl_form() and mess() is not kept in an arena */ 957 958 STATIC SV * 959 S_mess_alloc(pTHX) 960 { 961 SV *sv; 962 XPVMG *any; 963 964 if (!PL_dirty) 965 return sv_2mortal(newSVpvn("",0)); 966 967 if (PL_mess_sv) 968 return PL_mess_sv; 969 970 /* Create as PVMG now, to avoid any upgrading later */ 971 New(905, sv, 1, SV); 972 Newz(905, any, 1, XPVMG); 973 SvFLAGS(sv) = SVt_PVMG; 974 SvANY(sv) = (void*)any; 975 SvREFCNT(sv) = 1 << 30; /* practically infinite */ 976 PL_mess_sv = sv; 977 return sv; 978 } 979 980 #if defined(PERL_IMPLICIT_CONTEXT) 981 char * 982 Perl_form_nocontext(const char* pat, ...) 983 { 984 dTHX; 985 char *retval; 986 va_list args; 987 va_start(args, pat); 988 retval = vform(pat, &args); 989 va_end(args); 990 return retval; 991 } 992 #endif /* PERL_IMPLICIT_CONTEXT */ 993 994 /* 995 =head1 Miscellaneous Functions 996 =for apidoc form 997 998 Takes a sprintf-style format pattern and conventional 999 (non-SV) arguments and returns the formatted string. 1000 1001 (char *) Perl_form(pTHX_ const char* pat, ...) 1002 1003 can be used any place a string (char *) is required: 1004 1005 char * s = Perl_form("%d.%d",major,minor); 1006 1007 Uses a single private buffer so if you want to format several strings you 1008 must explicitly copy the earlier strings away (and free the copies when you 1009 are done). 1010 1011 =cut 1012 */ 1013 1014 char * 1015 Perl_form(pTHX_ const char* pat, ...) 1016 { 1017 char *retval; 1018 va_list args; 1019 va_start(args, pat); 1020 retval = vform(pat, &args); 1021 va_end(args); 1022 return retval; 1023 } 1024 1025 char * 1026 Perl_vform(pTHX_ const char *pat, va_list *args) 1027 { 1028 SV *sv = mess_alloc(); 1029 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); 1030 return SvPVX(sv); 1031 } 1032 1033 #if defined(PERL_IMPLICIT_CONTEXT) 1034 SV * 1035 Perl_mess_nocontext(const char *pat, ...) 1036 { 1037 dTHX; 1038 SV *retval; 1039 va_list args; 1040 va_start(args, pat); 1041 retval = vmess(pat, &args); 1042 va_end(args); 1043 return retval; 1044 } 1045 #endif /* PERL_IMPLICIT_CONTEXT */ 1046 1047 SV * 1048 Perl_mess(pTHX_ const char *pat, ...) 1049 { 1050 SV *retval; 1051 va_list args; 1052 va_start(args, pat); 1053 retval = vmess(pat, &args); 1054 va_end(args); 1055 return retval; 1056 } 1057 1058 STATIC COP* 1059 S_closest_cop(pTHX_ COP *cop, OP *o) 1060 { 1061 /* Look for PL_op starting from o. cop is the last COP we've seen. */ 1062 1063 if (!o || o == PL_op) return cop; 1064 1065 if (o->op_flags & OPf_KIDS) { 1066 OP *kid; 1067 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 1068 { 1069 COP *new_cop; 1070 1071 /* If the OP_NEXTSTATE has been optimised away we can still use it 1072 * the get the file and line number. */ 1073 1074 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) 1075 cop = (COP *)kid; 1076 1077 /* Keep searching, and return when we've found something. */ 1078 1079 new_cop = closest_cop(cop, kid); 1080 if (new_cop) return new_cop; 1081 } 1082 } 1083 1084 /* Nothing found. */ 1085 1086 return 0; 1087 } 1088 1089 SV * 1090 Perl_vmess(pTHX_ const char *pat, va_list *args) 1091 { 1092 SV *sv = mess_alloc(); 1093 static char dgd[] = " during global destruction.\n"; 1094 COP *cop; 1095 1096 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); 1097 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { 1098 1099 /* 1100 * Try and find the file and line for PL_op. This will usually be 1101 * PL_curcop, but it might be a cop that has been optimised away. We 1102 * can try to find such a cop by searching through the optree starting 1103 * from the sibling of PL_curcop. 1104 */ 1105 1106 cop = closest_cop(PL_curcop, PL_curcop->op_sibling); 1107 if (!cop) cop = PL_curcop; 1108 1109 if (CopLINE(cop)) 1110 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, 1111 OutCopFILE(cop), (IV)CopLINE(cop)); 1112 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { 1113 bool line_mode = (RsSIMPLE(PL_rs) && 1114 SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); 1115 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, 1116 PL_last_in_gv == PL_argvgv ? 1117 "" : GvNAME(PL_last_in_gv), 1118 line_mode ? "line" : "chunk", 1119 (IV)IoLINES(GvIOp(PL_last_in_gv))); 1120 } 1121 #ifdef USE_5005THREADS 1122 if (thr->tid) 1123 Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid); 1124 #endif 1125 sv_catpv(sv, PL_dirty ? dgd : ".\n"); 1126 } 1127 return sv; 1128 } 1129 1130 OP * 1131 Perl_vdie(pTHX_ const char* pat, va_list *args) 1132 { 1133 char *message; 1134 int was_in_eval = PL_in_eval; 1135 HV *stash; 1136 GV *gv; 1137 CV *cv; 1138 SV *msv; 1139 STRLEN msglen; 1140 1141 DEBUG_S(PerlIO_printf(Perl_debug_log, 1142 "%p: die: curstack = %p, mainstack = %p\n", 1143 thr, PL_curstack, PL_mainstack)); 1144 1145 if (pat) { 1146 msv = vmess(pat, args); 1147 if (PL_errors && SvCUR(PL_errors)) { 1148 sv_catsv(PL_errors, msv); 1149 message = SvPV(PL_errors, msglen); 1150 SvCUR_set(PL_errors, 0); 1151 } 1152 else 1153 message = SvPV(msv,msglen); 1154 } 1155 else { 1156 message = Nullch; 1157 msglen = 0; 1158 } 1159 1160 DEBUG_S(PerlIO_printf(Perl_debug_log, 1161 "%p: die: message = %s\ndiehook = %p\n", 1162 thr, message, PL_diehook)); 1163 if (PL_diehook) { 1164 /* sv_2cv might call Perl_croak() */ 1165 SV *olddiehook = PL_diehook; 1166 ENTER; 1167 SAVESPTR(PL_diehook); 1168 PL_diehook = Nullsv; 1169 cv = sv_2cv(olddiehook, &stash, &gv, 0); 1170 LEAVE; 1171 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1172 dSP; 1173 SV *msg; 1174 1175 ENTER; 1176 save_re_context(); 1177 if (message) { 1178 msg = newSVpvn(message, msglen); 1179 SvREADONLY_on(msg); 1180 SAVEFREESV(msg); 1181 } 1182 else { 1183 msg = ERRSV; 1184 } 1185 1186 PUSHSTACKi(PERLSI_DIEHOOK); 1187 PUSHMARK(SP); 1188 XPUSHs(msg); 1189 PUTBACK; 1190 call_sv((SV*)cv, G_DISCARD); 1191 POPSTACK; 1192 LEAVE; 1193 } 1194 } 1195 1196 PL_restartop = die_where(message, msglen); 1197 DEBUG_S(PerlIO_printf(Perl_debug_log, 1198 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", 1199 thr, PL_restartop, was_in_eval, PL_top_env)); 1200 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) 1201 JMPENV_JUMP(3); 1202 return PL_restartop; 1203 } 1204 1205 #if defined(PERL_IMPLICIT_CONTEXT) 1206 OP * 1207 Perl_die_nocontext(const char* pat, ...) 1208 { 1209 dTHX; 1210 OP *o; 1211 va_list args; 1212 va_start(args, pat); 1213 o = vdie(pat, &args); 1214 va_end(args); 1215 return o; 1216 } 1217 #endif /* PERL_IMPLICIT_CONTEXT */ 1218 1219 OP * 1220 Perl_die(pTHX_ const char* pat, ...) 1221 { 1222 OP *o; 1223 va_list args; 1224 va_start(args, pat); 1225 o = vdie(pat, &args); 1226 va_end(args); 1227 return o; 1228 } 1229 1230 void 1231 Perl_vcroak(pTHX_ const char* pat, va_list *args) 1232 { 1233 char *message; 1234 HV *stash; 1235 GV *gv; 1236 CV *cv; 1237 SV *msv; 1238 STRLEN msglen; 1239 1240 if (pat) { 1241 msv = vmess(pat, args); 1242 if (PL_errors && SvCUR(PL_errors)) { 1243 sv_catsv(PL_errors, msv); 1244 message = SvPV(PL_errors, msglen); 1245 SvCUR_set(PL_errors, 0); 1246 } 1247 else 1248 message = SvPV(msv,msglen); 1249 } 1250 else { 1251 message = Nullch; 1252 msglen = 0; 1253 } 1254 1255 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", 1256 PTR2UV(thr), message)); 1257 1258 if (PL_diehook) { 1259 /* sv_2cv might call Perl_croak() */ 1260 SV *olddiehook = PL_diehook; 1261 ENTER; 1262 SAVESPTR(PL_diehook); 1263 PL_diehook = Nullsv; 1264 cv = sv_2cv(olddiehook, &stash, &gv, 0); 1265 LEAVE; 1266 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1267 dSP; 1268 SV *msg; 1269 1270 ENTER; 1271 save_re_context(); 1272 if (message) { 1273 msg = newSVpvn(message, msglen); 1274 SvREADONLY_on(msg); 1275 SAVEFREESV(msg); 1276 } 1277 else { 1278 msg = ERRSV; 1279 } 1280 1281 PUSHSTACKi(PERLSI_DIEHOOK); 1282 PUSHMARK(SP); 1283 XPUSHs(msg); 1284 PUTBACK; 1285 call_sv((SV*)cv, G_DISCARD); 1286 POPSTACK; 1287 LEAVE; 1288 } 1289 } 1290 if (PL_in_eval) { 1291 PL_restartop = die_where(message, msglen); 1292 JMPENV_JUMP(3); 1293 } 1294 else if (!message) 1295 message = SvPVx(ERRSV, msglen); 1296 1297 { 1298 #ifdef USE_SFIO 1299 /* SFIO can really mess with your errno */ 1300 int e = errno; 1301 #endif 1302 PerlIO *serr = Perl_error_log; 1303 1304 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); 1305 (void)PerlIO_flush(serr); 1306 #ifdef USE_SFIO 1307 errno = e; 1308 #endif 1309 } 1310 my_failure_exit(); 1311 } 1312 1313 #if defined(PERL_IMPLICIT_CONTEXT) 1314 void 1315 Perl_croak_nocontext(const char *pat, ...) 1316 { 1317 dTHX; 1318 va_list args; 1319 va_start(args, pat); 1320 vcroak(pat, &args); 1321 /* NOTREACHED */ 1322 va_end(args); 1323 } 1324 #endif /* PERL_IMPLICIT_CONTEXT */ 1325 1326 /* 1327 =head1 Warning and Dieing 1328 1329 =for apidoc croak 1330 1331 This is the XSUB-writer's interface to Perl's C<die> function. 1332 Normally use this function the same way you use the C C<printf> 1333 function. See C<warn>. 1334 1335 If you want to throw an exception object, assign the object to 1336 C<$@> and then pass C<Nullch> to croak(): 1337 1338 errsv = get_sv("@", TRUE); 1339 sv_setsv(errsv, exception_object); 1340 croak(Nullch); 1341 1342 =cut 1343 */ 1344 1345 void 1346 Perl_croak(pTHX_ const char *pat, ...) 1347 { 1348 va_list args; 1349 va_start(args, pat); 1350 vcroak(pat, &args); 1351 /* NOTREACHED */ 1352 va_end(args); 1353 } 1354 1355 void 1356 Perl_vwarn(pTHX_ const char* pat, va_list *args) 1357 { 1358 char *message; 1359 HV *stash; 1360 GV *gv; 1361 CV *cv; 1362 SV *msv; 1363 STRLEN msglen; 1364 IO *io; 1365 MAGIC *mg; 1366 1367 msv = vmess(pat, args); 1368 message = SvPV(msv, msglen); 1369 1370 if (PL_warnhook) { 1371 /* sv_2cv might call Perl_warn() */ 1372 SV *oldwarnhook = PL_warnhook; 1373 ENTER; 1374 SAVESPTR(PL_warnhook); 1375 PL_warnhook = Nullsv; 1376 cv = sv_2cv(oldwarnhook, &stash, &gv, 0); 1377 LEAVE; 1378 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1379 dSP; 1380 SV *msg; 1381 1382 ENTER; 1383 save_re_context(); 1384 msg = newSVpvn(message, msglen); 1385 SvREADONLY_on(msg); 1386 SAVEFREESV(msg); 1387 1388 PUSHSTACKi(PERLSI_WARNHOOK); 1389 PUSHMARK(SP); 1390 XPUSHs(msg); 1391 PUTBACK; 1392 call_sv((SV*)cv, G_DISCARD); 1393 POPSTACK; 1394 LEAVE; 1395 return; 1396 } 1397 } 1398 1399 /* if STDERR is tied, use it instead */ 1400 if (PL_stderrgv && (io = GvIOp(PL_stderrgv)) 1401 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { 1402 dSP; ENTER; 1403 PUSHMARK(SP); 1404 XPUSHs(SvTIED_obj((SV*)io, mg)); 1405 XPUSHs(sv_2mortal(newSVpvn(message, msglen))); 1406 PUTBACK; 1407 call_method("PRINT", G_SCALAR); 1408 LEAVE; 1409 return; 1410 } 1411 1412 { 1413 PerlIO *serr = Perl_error_log; 1414 1415 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); 1416 #ifdef LEAKTEST 1417 DEBUG_L(*message == '!' 1418 ? (xstat(message[1]=='!' 1419 ? (message[2]=='!' ? 2 : 1) 1420 : 0) 1421 , 0) 1422 : 0); 1423 #endif 1424 (void)PerlIO_flush(serr); 1425 } 1426 } 1427 1428 #if defined(PERL_IMPLICIT_CONTEXT) 1429 void 1430 Perl_warn_nocontext(const char *pat, ...) 1431 { 1432 dTHX; 1433 va_list args; 1434 va_start(args, pat); 1435 vwarn(pat, &args); 1436 va_end(args); 1437 } 1438 #endif /* PERL_IMPLICIT_CONTEXT */ 1439 1440 /* 1441 =for apidoc warn 1442 1443 This is the XSUB-writer's interface to Perl's C<warn> function. Use this 1444 function the same way you use the C C<printf> function. See 1445 C<croak>. 1446 1447 =cut 1448 */ 1449 1450 void 1451 Perl_warn(pTHX_ const char *pat, ...) 1452 { 1453 va_list args; 1454 va_start(args, pat); 1455 vwarn(pat, &args); 1456 va_end(args); 1457 } 1458 1459 #if defined(PERL_IMPLICIT_CONTEXT) 1460 void 1461 Perl_warner_nocontext(U32 err, const char *pat, ...) 1462 { 1463 dTHX; 1464 va_list args; 1465 va_start(args, pat); 1466 vwarner(err, pat, &args); 1467 va_end(args); 1468 } 1469 #endif /* PERL_IMPLICIT_CONTEXT */ 1470 1471 void 1472 Perl_warner(pTHX_ U32 err, const char* pat,...) 1473 { 1474 va_list args; 1475 va_start(args, pat); 1476 vwarner(err, pat, &args); 1477 va_end(args); 1478 } 1479 1480 void 1481 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) 1482 { 1483 char *message; 1484 HV *stash; 1485 GV *gv; 1486 CV *cv; 1487 SV *msv; 1488 STRLEN msglen; 1489 1490 msv = vmess(pat, args); 1491 message = SvPV(msv, msglen); 1492 1493 if (ckDEAD(err)) { 1494 #ifdef USE_5005THREADS 1495 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message)); 1496 #endif /* USE_5005THREADS */ 1497 if (PL_diehook) { 1498 /* sv_2cv might call Perl_croak() */ 1499 SV *olddiehook = PL_diehook; 1500 ENTER; 1501 SAVESPTR(PL_diehook); 1502 PL_diehook = Nullsv; 1503 cv = sv_2cv(olddiehook, &stash, &gv, 0); 1504 LEAVE; 1505 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1506 dSP; 1507 SV *msg; 1508 1509 ENTER; 1510 save_re_context(); 1511 msg = newSVpvn(message, msglen); 1512 SvREADONLY_on(msg); 1513 SAVEFREESV(msg); 1514 1515 PUSHSTACKi(PERLSI_DIEHOOK); 1516 PUSHMARK(sp); 1517 XPUSHs(msg); 1518 PUTBACK; 1519 call_sv((SV*)cv, G_DISCARD); 1520 POPSTACK; 1521 LEAVE; 1522 } 1523 } 1524 if (PL_in_eval) { 1525 PL_restartop = die_where(message, msglen); 1526 JMPENV_JUMP(3); 1527 } 1528 { 1529 PerlIO *serr = Perl_error_log; 1530 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); 1531 (void)PerlIO_flush(serr); 1532 } 1533 my_failure_exit(); 1534 1535 } 1536 else { 1537 if (PL_warnhook) { 1538 /* sv_2cv might call Perl_warn() */ 1539 SV *oldwarnhook = PL_warnhook; 1540 ENTER; 1541 SAVESPTR(PL_warnhook); 1542 PL_warnhook = Nullsv; 1543 cv = sv_2cv(oldwarnhook, &stash, &gv, 0); 1544 LEAVE; 1545 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1546 dSP; 1547 SV *msg; 1548 1549 ENTER; 1550 save_re_context(); 1551 msg = newSVpvn(message, msglen); 1552 SvREADONLY_on(msg); 1553 SAVEFREESV(msg); 1554 1555 PUSHSTACKi(PERLSI_WARNHOOK); 1556 PUSHMARK(sp); 1557 XPUSHs(msg); 1558 PUTBACK; 1559 call_sv((SV*)cv, G_DISCARD); 1560 POPSTACK; 1561 LEAVE; 1562 return; 1563 } 1564 } 1565 { 1566 PerlIO *serr = Perl_error_log; 1567 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); 1568 #ifdef LEAKTEST 1569 DEBUG_L(*message == '!' 1570 ? (xstat(message[1]=='!' 1571 ? (message[2]=='!' ? 2 : 1) 1572 : 0) 1573 , 0) 1574 : 0); 1575 #endif 1576 (void)PerlIO_flush(serr); 1577 } 1578 } 1579 } 1580 1581 /* since we've already done strlen() for both nam and val 1582 * we can use that info to make things faster than 1583 * sprintf(s, "%s=%s", nam, val) 1584 */ 1585 #define my_setenv_format(s, nam, nlen, val, vlen) \ 1586 Copy(nam, s, nlen, char); \ 1587 *(s+nlen) = '='; \ 1588 Copy(val, s+(nlen+1), vlen, char); \ 1589 *(s+(nlen+1+vlen)) = '\0' 1590 1591 #ifdef USE_ENVIRON_ARRAY 1592 /* VMS' my_setenv() is in vms.c */ 1593 #if !defined(WIN32) && !defined(NETWARE) 1594 void 1595 Perl_my_setenv(pTHX_ char *nam, char *val) 1596 { 1597 #ifdef USE_ITHREADS 1598 /* only parent thread can modify process environment */ 1599 if (PL_curinterp == aTHX) 1600 #endif 1601 { 1602 #ifndef PERL_USE_SAFE_PUTENV 1603 /* most putenv()s leak, so we manipulate environ directly */ 1604 register I32 i=setenv_getix(nam); /* where does it go? */ 1605 int nlen, vlen; 1606 1607 if (environ == PL_origenviron) { /* need we copy environment? */ 1608 I32 j; 1609 I32 max; 1610 char **tmpenv; 1611 1612 /*SUPPRESS 530*/ 1613 for (max = i; environ[max]; max++) ; 1614 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); 1615 for (j=0; j<max; j++) { /* copy environment */ 1616 int len = strlen(environ[j]); 1617 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char)); 1618 Copy(environ[j], tmpenv[j], len+1, char); 1619 } 1620 tmpenv[max] = Nullch; 1621 environ = tmpenv; /* tell exec where it is now */ 1622 } 1623 if (!val) { 1624 safesysfree(environ[i]); 1625 while (environ[i]) { 1626 environ[i] = environ[i+1]; 1627 i++; 1628 } 1629 return; 1630 } 1631 if (!environ[i]) { /* does not exist yet */ 1632 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*)); 1633 environ[i+1] = Nullch; /* make sure it's null terminated */ 1634 } 1635 else 1636 safesysfree(environ[i]); 1637 nlen = strlen(nam); 1638 vlen = strlen(val); 1639 1640 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char)); 1641 /* all that work just for this */ 1642 my_setenv_format(environ[i], nam, nlen, val, vlen); 1643 1644 #else /* PERL_USE_SAFE_PUTENV */ 1645 # if defined(__CYGWIN__) || defined( EPOC) 1646 setenv(nam, val, 1); 1647 # else 1648 char *new_env; 1649 int nlen = strlen(nam), vlen; 1650 if (!val) { 1651 val = ""; 1652 } 1653 vlen = strlen(val); 1654 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); 1655 /* all that work just for this */ 1656 my_setenv_format(new_env, nam, nlen, val, vlen); 1657 (void)putenv(new_env); 1658 # endif /* __CYGWIN__ */ 1659 #endif /* PERL_USE_SAFE_PUTENV */ 1660 } 1661 } 1662 1663 #else /* WIN32 || NETWARE */ 1664 1665 void 1666 Perl_my_setenv(pTHX_ char *nam,char *val) 1667 { 1668 register char *envstr; 1669 int nlen = strlen(nam), vlen; 1670 1671 if (!val) { 1672 val = ""; 1673 } 1674 vlen = strlen(val); 1675 New(904, envstr, nlen+vlen+2, char); 1676 my_setenv_format(envstr, nam, nlen, val, vlen); 1677 (void)PerlEnv_putenv(envstr); 1678 Safefree(envstr); 1679 } 1680 1681 #endif /* WIN32 || NETWARE */ 1682 1683 I32 1684 Perl_setenv_getix(pTHX_ char *nam) 1685 { 1686 register I32 i, len = strlen(nam); 1687 1688 for (i = 0; environ[i]; i++) { 1689 if ( 1690 #ifdef WIN32 1691 strnicmp(environ[i],nam,len) == 0 1692 #else 1693 strnEQ(environ[i],nam,len) 1694 #endif 1695 && environ[i][len] == '=') 1696 break; /* strnEQ must come first to avoid */ 1697 } /* potential SEGV's */ 1698 return i; 1699 } 1700 1701 #endif /* !VMS && !EPOC*/ 1702 1703 #ifdef UNLINK_ALL_VERSIONS 1704 I32 1705 Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */ 1706 { 1707 I32 i; 1708 1709 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ; 1710 return i ? 0 : -1; 1711 } 1712 #endif 1713 1714 /* this is a drop-in replacement for bcopy() */ 1715 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) 1716 char * 1717 Perl_my_bcopy(register const char *from,register char *to,register I32 len) 1718 { 1719 char *retval = to; 1720 1721 if (from - to >= 0) { 1722 while (len--) 1723 *to++ = *from++; 1724 } 1725 else { 1726 to += len; 1727 from += len; 1728 while (len--) 1729 *(--to) = *(--from); 1730 } 1731 return retval; 1732 } 1733 #endif 1734 1735 /* this is a drop-in replacement for memset() */ 1736 #ifndef HAS_MEMSET 1737 void * 1738 Perl_my_memset(register char *loc, register I32 ch, register I32 len) 1739 { 1740 char *retval = loc; 1741 1742 while (len--) 1743 *loc++ = ch; 1744 return retval; 1745 } 1746 #endif 1747 1748 /* this is a drop-in replacement for bzero() */ 1749 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) 1750 char * 1751 Perl_my_bzero(register char *loc, register I32 len) 1752 { 1753 char *retval = loc; 1754 1755 while (len--) 1756 *loc++ = 0; 1757 return retval; 1758 } 1759 #endif 1760 1761 /* this is a drop-in replacement for memcmp() */ 1762 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) 1763 I32 1764 Perl_my_memcmp(const char *s1, const char *s2, register I32 len) 1765 { 1766 register U8 *a = (U8 *)s1; 1767 register U8 *b = (U8 *)s2; 1768 register I32 tmp; 1769 1770 while (len--) { 1771 if (tmp = *a++ - *b++) 1772 return tmp; 1773 } 1774 return 0; 1775 } 1776 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ 1777 1778 #ifndef HAS_VPRINTF 1779 1780 #ifdef USE_CHAR_VSPRINTF 1781 char * 1782 #else 1783 int 1784 #endif 1785 vsprintf(char *dest, const char *pat, char *args) 1786 { 1787 FILE fakebuf; 1788 1789 fakebuf._ptr = dest; 1790 fakebuf._cnt = 32767; 1791 #ifndef _IOSTRG 1792 #define _IOSTRG 0 1793 #endif 1794 fakebuf._flag = _IOWRT|_IOSTRG; 1795 _doprnt(pat, args, &fakebuf); /* what a kludge */ 1796 (void)putc('\0', &fakebuf); 1797 #ifdef USE_CHAR_VSPRINTF 1798 return(dest); 1799 #else 1800 return 0; /* perl doesn't use return value */ 1801 #endif 1802 } 1803 1804 #endif /* HAS_VPRINTF */ 1805 1806 #ifdef MYSWAP 1807 #if BYTEORDER != 0x4321 1808 short 1809 Perl_my_swap(pTHX_ short s) 1810 { 1811 #if (BYTEORDER & 1) == 0 1812 short result; 1813 1814 result = ((s & 255) << 8) + ((s >> 8) & 255); 1815 return result; 1816 #else 1817 return s; 1818 #endif 1819 } 1820 1821 long 1822 Perl_my_htonl(pTHX_ long l) 1823 { 1824 union { 1825 long result; 1826 char c[sizeof(long)]; 1827 } u; 1828 1829 #if BYTEORDER == 0x1234 1830 u.c[0] = (l >> 24) & 255; 1831 u.c[1] = (l >> 16) & 255; 1832 u.c[2] = (l >> 8) & 255; 1833 u.c[3] = l & 255; 1834 return u.result; 1835 #else 1836 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) 1837 Perl_croak(aTHX_ "Unknown BYTEORDER\n"); 1838 #else 1839 register I32 o; 1840 register I32 s; 1841 1842 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { 1843 u.c[o & 0xf] = (l >> s) & 255; 1844 } 1845 return u.result; 1846 #endif 1847 #endif 1848 } 1849 1850 long 1851 Perl_my_ntohl(pTHX_ long l) 1852 { 1853 union { 1854 long l; 1855 char c[sizeof(long)]; 1856 } u; 1857 1858 #if BYTEORDER == 0x1234 1859 u.c[0] = (l >> 24) & 255; 1860 u.c[1] = (l >> 16) & 255; 1861 u.c[2] = (l >> 8) & 255; 1862 u.c[3] = l & 255; 1863 return u.l; 1864 #else 1865 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) 1866 Perl_croak(aTHX_ "Unknown BYTEORDER\n"); 1867 #else 1868 register I32 o; 1869 register I32 s; 1870 1871 u.l = l; 1872 l = 0; 1873 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { 1874 l |= (u.c[o & 0xf] & 255) << s; 1875 } 1876 return l; 1877 #endif 1878 #endif 1879 } 1880 1881 #endif /* BYTEORDER != 0x4321 */ 1882 #endif /* MYSWAP */ 1883 1884 /* 1885 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. 1886 * If these functions are defined, 1887 * the BYTEORDER is neither 0x1234 nor 0x4321. 1888 * However, this is not assumed. 1889 * -DWS 1890 */ 1891 1892 #define HTOV(name,type) \ 1893 type \ 1894 name (register type n) \ 1895 { \ 1896 union { \ 1897 type value; \ 1898 char c[sizeof(type)]; \ 1899 } u; \ 1900 register I32 i; \ 1901 register I32 s; \ 1902 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ 1903 u.c[i] = (n >> s) & 0xFF; \ 1904 } \ 1905 return u.value; \ 1906 } 1907 1908 #define VTOH(name,type) \ 1909 type \ 1910 name (register type n) \ 1911 { \ 1912 union { \ 1913 type value; \ 1914 char c[sizeof(type)]; \ 1915 } u; \ 1916 register I32 i; \ 1917 register I32 s; \ 1918 u.value = n; \ 1919 n = 0; \ 1920 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ 1921 n += (u.c[i] & 0xFF) << s; \ 1922 } \ 1923 return n; \ 1924 } 1925 1926 #if defined(HAS_HTOVS) && !defined(htovs) 1927 HTOV(htovs,short) 1928 #endif 1929 #if defined(HAS_HTOVL) && !defined(htovl) 1930 HTOV(htovl,long) 1931 #endif 1932 #if defined(HAS_VTOHS) && !defined(vtohs) 1933 VTOH(vtohs,short) 1934 #endif 1935 #if defined(HAS_VTOHL) && !defined(vtohl) 1936 VTOH(vtohl,long) 1937 #endif 1938 1939 PerlIO * 1940 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) 1941 { 1942 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) 1943 int p[2]; 1944 register I32 This, that; 1945 register Pid_t pid; 1946 SV *sv; 1947 I32 did_pipes = 0; 1948 int pp[2]; 1949 1950 PERL_FLUSHALL_FOR_CHILD; 1951 This = (*mode == 'w'); 1952 that = !This; 1953 if (PL_tainting) { 1954 taint_env(); 1955 taint_proper("Insecure %s%s", "EXEC"); 1956 } 1957 if (PerlProc_pipe(p) < 0) 1958 return Nullfp; 1959 /* Try for another pipe pair for error return */ 1960 if (PerlProc_pipe(pp) >= 0) 1961 did_pipes = 1; 1962 while ((pid = PerlProc_fork()) < 0) { 1963 if (errno != EAGAIN) { 1964 PerlLIO_close(p[This]); 1965 PerlLIO_close(p[that]); 1966 if (did_pipes) { 1967 PerlLIO_close(pp[0]); 1968 PerlLIO_close(pp[1]); 1969 } 1970 return Nullfp; 1971 } 1972 sleep(5); 1973 } 1974 if (pid == 0) { 1975 /* Child */ 1976 #undef THIS 1977 #undef THAT 1978 #define THIS that 1979 #define THAT This 1980 /* Close parent's end of error status pipe (if any) */ 1981 if (did_pipes) { 1982 PerlLIO_close(pp[0]); 1983 #if defined(HAS_FCNTL) && defined(F_SETFD) 1984 /* Close error pipe automatically if exec works */ 1985 fcntl(pp[1], F_SETFD, FD_CLOEXEC); 1986 #endif 1987 } 1988 /* Now dup our end of _the_ pipe to right position */ 1989 if (p[THIS] != (*mode == 'r')) { 1990 PerlLIO_dup2(p[THIS], *mode == 'r'); 1991 PerlLIO_close(p[THIS]); 1992 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 1993 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ 1994 } 1995 else 1996 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ 1997 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 1998 /* No automatic close - do it by hand */ 1999 # ifndef NOFILE 2000 # define NOFILE 20 2001 # endif 2002 { 2003 int fd; 2004 2005 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { 2006 if (fd != pp[1]) 2007 PerlLIO_close(fd); 2008 } 2009 } 2010 #endif 2011 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes); 2012 PerlProc__exit(1); 2013 #undef THIS 2014 #undef THAT 2015 } 2016 /* Parent */ 2017 do_execfree(); /* free any memory malloced by child on fork */ 2018 if (did_pipes) 2019 PerlLIO_close(pp[1]); 2020 /* Keep the lower of the two fd numbers */ 2021 if (p[that] < p[This]) { 2022 PerlLIO_dup2(p[This], p[that]); 2023 PerlLIO_close(p[This]); 2024 p[This] = p[that]; 2025 } 2026 else 2027 PerlLIO_close(p[that]); /* close child's end of pipe */ 2028 2029 LOCK_FDPID_MUTEX; 2030 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2031 UNLOCK_FDPID_MUTEX; 2032 (void)SvUPGRADE(sv,SVt_IV); 2033 SvIVX(sv) = pid; 2034 PL_forkprocess = pid; 2035 /* If we managed to get status pipe check for exec fail */ 2036 if (did_pipes && pid > 0) { 2037 int errkid; 2038 int n = 0, n1; 2039 2040 while (n < sizeof(int)) { 2041 n1 = PerlLIO_read(pp[0], 2042 (void*)(((char*)&errkid)+n), 2043 (sizeof(int)) - n); 2044 if (n1 <= 0) 2045 break; 2046 n += n1; 2047 } 2048 PerlLIO_close(pp[0]); 2049 did_pipes = 0; 2050 if (n) { /* Error */ 2051 int pid2, status; 2052 PerlLIO_close(p[This]); 2053 if (n != sizeof(int)) 2054 Perl_croak(aTHX_ "panic: kid popen errno read"); 2055 do { 2056 pid2 = wait4pid(pid, &status, 0); 2057 } while (pid2 == -1 && errno == EINTR); 2058 errno = errkid; /* Propagate errno from kid */ 2059 return Nullfp; 2060 } 2061 } 2062 if (did_pipes) 2063 PerlLIO_close(pp[0]); 2064 return PerlIO_fdopen(p[This], mode); 2065 #else 2066 Perl_croak(aTHX_ "List form of piped open not implemented"); 2067 return (PerlIO *) NULL; 2068 #endif 2069 } 2070 2071 /* VMS' my_popen() is in VMS.c, same with OS/2. */ 2072 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) 2073 PerlIO * 2074 Perl_my_popen(pTHX_ char *cmd, char *mode) 2075 { 2076 int p[2]; 2077 register I32 This, that; 2078 register Pid_t pid; 2079 SV *sv; 2080 I32 doexec = strNE(cmd,"-"); 2081 I32 did_pipes = 0; 2082 int pp[2]; 2083 2084 PERL_FLUSHALL_FOR_CHILD; 2085 #ifdef OS2 2086 if (doexec) { 2087 return my_syspopen(aTHX_ cmd,mode); 2088 } 2089 #endif 2090 This = (*mode == 'w'); 2091 that = !This; 2092 if (doexec && PL_tainting) { 2093 taint_env(); 2094 taint_proper("Insecure %s%s", "EXEC"); 2095 } 2096 if (PerlProc_pipe(p) < 0) 2097 return Nullfp; 2098 if (doexec && PerlProc_pipe(pp) >= 0) 2099 did_pipes = 1; 2100 while ((pid = PerlProc_fork()) < 0) { 2101 if (errno != EAGAIN) { 2102 PerlLIO_close(p[This]); 2103 PerlLIO_close(p[that]); 2104 if (did_pipes) { 2105 PerlLIO_close(pp[0]); 2106 PerlLIO_close(pp[1]); 2107 } 2108 if (!doexec) 2109 Perl_croak(aTHX_ "Can't fork"); 2110 return Nullfp; 2111 } 2112 sleep(5); 2113 } 2114 if (pid == 0) { 2115 GV* tmpgv; 2116 2117 #undef THIS 2118 #undef THAT 2119 #define THIS that 2120 #define THAT This 2121 if (did_pipes) { 2122 PerlLIO_close(pp[0]); 2123 #if defined(HAS_FCNTL) && defined(F_SETFD) 2124 fcntl(pp[1], F_SETFD, FD_CLOEXEC); 2125 #endif 2126 } 2127 if (p[THIS] != (*mode == 'r')) { 2128 PerlLIO_dup2(p[THIS], *mode == 'r'); 2129 PerlLIO_close(p[THIS]); 2130 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 2131 PerlLIO_close(p[THAT]); 2132 } 2133 else 2134 PerlLIO_close(p[THAT]); 2135 #ifndef OS2 2136 if (doexec) { 2137 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2138 int fd; 2139 2140 #ifndef NOFILE 2141 #define NOFILE 20 2142 #endif 2143 { 2144 int fd; 2145 2146 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) 2147 if (fd != pp[1]) 2148 PerlLIO_close(fd); 2149 } 2150 #endif 2151 /* may or may not use the shell */ 2152 do_exec3(cmd, pp[1], did_pipes); 2153 PerlProc__exit(1); 2154 } 2155 #endif /* defined OS2 */ 2156 /*SUPPRESS 560*/ 2157 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) { 2158 SvREADONLY_off(GvSV(tmpgv)); 2159 sv_setiv(GvSV(tmpgv), PerlProc_getpid()); 2160 SvREADONLY_on(GvSV(tmpgv)); 2161 } 2162 PL_forkprocess = 0; 2163 hv_clear(PL_pidstatus); /* we have no children */ 2164 return Nullfp; 2165 #undef THIS 2166 #undef THAT 2167 } 2168 do_execfree(); /* free any memory malloced by child on vfork */ 2169 if (did_pipes) 2170 PerlLIO_close(pp[1]); 2171 if (p[that] < p[This]) { 2172 PerlLIO_dup2(p[This], p[that]); 2173 PerlLIO_close(p[This]); 2174 p[This] = p[that]; 2175 } 2176 else 2177 PerlLIO_close(p[that]); 2178 2179 LOCK_FDPID_MUTEX; 2180 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2181 UNLOCK_FDPID_MUTEX; 2182 (void)SvUPGRADE(sv,SVt_IV); 2183 SvIVX(sv) = pid; 2184 PL_forkprocess = pid; 2185 if (did_pipes && pid > 0) { 2186 int errkid; 2187 int n = 0, n1; 2188 2189 while (n < sizeof(int)) { 2190 n1 = PerlLIO_read(pp[0], 2191 (void*)(((char*)&errkid)+n), 2192 (sizeof(int)) - n); 2193 if (n1 <= 0) 2194 break; 2195 n += n1; 2196 } 2197 PerlLIO_close(pp[0]); 2198 did_pipes = 0; 2199 if (n) { /* Error */ 2200 int pid2, status; 2201 PerlLIO_close(p[This]); 2202 if (n != sizeof(int)) 2203 Perl_croak(aTHX_ "panic: kid popen errno read"); 2204 do { 2205 pid2 = wait4pid(pid, &status, 0); 2206 } while (pid2 == -1 && errno == EINTR); 2207 errno = errkid; /* Propagate errno from kid */ 2208 return Nullfp; 2209 } 2210 } 2211 if (did_pipes) 2212 PerlLIO_close(pp[0]); 2213 return PerlIO_fdopen(p[This], mode); 2214 } 2215 #else 2216 #if defined(atarist) || defined(EPOC) 2217 FILE *popen(); 2218 PerlIO * 2219 Perl_my_popen(pTHX_ char *cmd, char *mode) 2220 { 2221 PERL_FLUSHALL_FOR_CHILD; 2222 /* Call system's popen() to get a FILE *, then import it. 2223 used 0 for 2nd parameter to PerlIO_importFILE; 2224 apparently not used 2225 */ 2226 return PerlIO_importFILE(popen(cmd, mode), 0); 2227 } 2228 #else 2229 #if defined(DJGPP) 2230 FILE *djgpp_popen(); 2231 PerlIO * 2232 Perl_my_popen(pTHX_ char *cmd, char *mode) 2233 { 2234 PERL_FLUSHALL_FOR_CHILD; 2235 /* Call system's popen() to get a FILE *, then import it. 2236 used 0 for 2nd parameter to PerlIO_importFILE; 2237 apparently not used 2238 */ 2239 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); 2240 } 2241 #endif 2242 #endif 2243 2244 #endif /* !DOSISH */ 2245 2246 /* this is called in parent before the fork() */ 2247 void 2248 Perl_atfork_lock(void) 2249 { 2250 #if defined(USE_5005THREADS) || defined(USE_ITHREADS) 2251 /* locks must be held in locking order (if any) */ 2252 # ifdef MYMALLOC 2253 MUTEX_LOCK(&PL_malloc_mutex); 2254 # endif 2255 OP_REFCNT_LOCK; 2256 #endif 2257 } 2258 2259 /* this is called in both parent and child after the fork() */ 2260 void 2261 Perl_atfork_unlock(void) 2262 { 2263 #if defined(USE_5005THREADS) || defined(USE_ITHREADS) 2264 /* locks must be released in same order as in atfork_lock() */ 2265 # ifdef MYMALLOC 2266 MUTEX_UNLOCK(&PL_malloc_mutex); 2267 # endif 2268 OP_REFCNT_UNLOCK; 2269 #endif 2270 } 2271 2272 Pid_t 2273 Perl_my_fork(void) 2274 { 2275 #if defined(HAS_FORK) 2276 Pid_t pid; 2277 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK) 2278 atfork_lock(); 2279 pid = fork(); 2280 atfork_unlock(); 2281 #else 2282 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork() 2283 * handlers elsewhere in the code */ 2284 pid = fork(); 2285 #endif 2286 return pid; 2287 #else 2288 /* this "canna happen" since nothing should be calling here if !HAS_FORK */ 2289 Perl_croak_nocontext("fork() not available"); 2290 return 0; 2291 #endif /* HAS_FORK */ 2292 } 2293 2294 #ifdef DUMP_FDS 2295 void 2296 Perl_dump_fds(pTHX_ char *s) 2297 { 2298 int fd; 2299 Stat_t tmpstatbuf; 2300 2301 PerlIO_printf(Perl_debug_log,"%s", s); 2302 for (fd = 0; fd < 32; fd++) { 2303 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0) 2304 PerlIO_printf(Perl_debug_log," %d",fd); 2305 } 2306 PerlIO_printf(Perl_debug_log,"\n"); 2307 } 2308 #endif /* DUMP_FDS */ 2309 2310 #ifndef HAS_DUP2 2311 int 2312 dup2(int oldfd, int newfd) 2313 { 2314 #if defined(HAS_FCNTL) && defined(F_DUPFD) 2315 if (oldfd == newfd) 2316 return oldfd; 2317 PerlLIO_close(newfd); 2318 return fcntl(oldfd, F_DUPFD, newfd); 2319 #else 2320 #define DUP2_MAX_FDS 256 2321 int fdtmp[DUP2_MAX_FDS]; 2322 I32 fdx = 0; 2323 int fd; 2324 2325 if (oldfd == newfd) 2326 return oldfd; 2327 PerlLIO_close(newfd); 2328 /* good enough for low fd's... */ 2329 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) { 2330 if (fdx >= DUP2_MAX_FDS) { 2331 PerlLIO_close(fd); 2332 fd = -1; 2333 break; 2334 } 2335 fdtmp[fdx++] = fd; 2336 } 2337 while (fdx > 0) 2338 PerlLIO_close(fdtmp[--fdx]); 2339 return fd; 2340 #endif 2341 } 2342 #endif 2343 2344 #ifndef PERL_MICRO 2345 #ifdef HAS_SIGACTION 2346 2347 Sighandler_t 2348 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2349 { 2350 struct sigaction act, oact; 2351 2352 #ifdef USE_ITHREADS 2353 /* only "parent" interpreter can diddle signals */ 2354 if (PL_curinterp != aTHX) 2355 return SIG_ERR; 2356 #endif 2357 2358 act.sa_handler = handler; 2359 sigemptyset(&act.sa_mask); 2360 act.sa_flags = 0; 2361 #ifdef SA_RESTART 2362 #if defined(PERL_OLD_SIGNALS) 2363 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2364 #endif 2365 #endif 2366 #ifdef SA_NOCLDWAIT 2367 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) 2368 act.sa_flags |= SA_NOCLDWAIT; 2369 #endif 2370 if (sigaction(signo, &act, &oact) == -1) 2371 return SIG_ERR; 2372 else 2373 return oact.sa_handler; 2374 } 2375 2376 Sighandler_t 2377 Perl_rsignal_state(pTHX_ int signo) 2378 { 2379 struct sigaction oact; 2380 2381 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) 2382 return SIG_ERR; 2383 else 2384 return oact.sa_handler; 2385 } 2386 2387 int 2388 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2389 { 2390 struct sigaction act; 2391 2392 #ifdef USE_ITHREADS 2393 /* only "parent" interpreter can diddle signals */ 2394 if (PL_curinterp != aTHX) 2395 return -1; 2396 #endif 2397 2398 act.sa_handler = handler; 2399 sigemptyset(&act.sa_mask); 2400 act.sa_flags = 0; 2401 #ifdef SA_RESTART 2402 #if defined(PERL_OLD_SIGNALS) 2403 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2404 #endif 2405 #endif 2406 #ifdef SA_NOCLDWAIT 2407 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) 2408 act.sa_flags |= SA_NOCLDWAIT; 2409 #endif 2410 return sigaction(signo, &act, save); 2411 } 2412 2413 int 2414 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2415 { 2416 #ifdef USE_ITHREADS 2417 /* only "parent" interpreter can diddle signals */ 2418 if (PL_curinterp != aTHX) 2419 return -1; 2420 #endif 2421 2422 return sigaction(signo, save, (struct sigaction *)NULL); 2423 } 2424 2425 #else /* !HAS_SIGACTION */ 2426 2427 Sighandler_t 2428 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2429 { 2430 #if defined(USE_ITHREADS) && !defined(WIN32) 2431 /* only "parent" interpreter can diddle signals */ 2432 if (PL_curinterp != aTHX) 2433 return SIG_ERR; 2434 #endif 2435 2436 return PerlProc_signal(signo, handler); 2437 } 2438 2439 static int sig_trapped; /* XXX signals are process-wide anyway, so we 2440 ignore the implications of this for threading */ 2441 2442 static 2443 Signal_t 2444 sig_trap(int signo) 2445 { 2446 sig_trapped++; 2447 } 2448 2449 Sighandler_t 2450 Perl_rsignal_state(pTHX_ int signo) 2451 { 2452 Sighandler_t oldsig; 2453 2454 #if defined(USE_ITHREADS) && !defined(WIN32) 2455 /* only "parent" interpreter can diddle signals */ 2456 if (PL_curinterp != aTHX) 2457 return SIG_ERR; 2458 #endif 2459 2460 sig_trapped = 0; 2461 oldsig = PerlProc_signal(signo, sig_trap); 2462 PerlProc_signal(signo, oldsig); 2463 if (sig_trapped) 2464 PerlProc_kill(PerlProc_getpid(), signo); 2465 return oldsig; 2466 } 2467 2468 int 2469 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2470 { 2471 #if defined(USE_ITHREADS) && !defined(WIN32) 2472 /* only "parent" interpreter can diddle signals */ 2473 if (PL_curinterp != aTHX) 2474 return -1; 2475 #endif 2476 *save = PerlProc_signal(signo, handler); 2477 return (*save == SIG_ERR) ? -1 : 0; 2478 } 2479 2480 int 2481 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2482 { 2483 #if defined(USE_ITHREADS) && !defined(WIN32) 2484 /* only "parent" interpreter can diddle signals */ 2485 if (PL_curinterp != aTHX) 2486 return -1; 2487 #endif 2488 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0; 2489 } 2490 2491 #endif /* !HAS_SIGACTION */ 2492 #endif /* !PERL_MICRO */ 2493 2494 /* VMS' my_pclose() is in VMS.c; same with OS/2 */ 2495 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) 2496 I32 2497 Perl_my_pclose(pTHX_ PerlIO *ptr) 2498 { 2499 Sigsave_t hstat, istat, qstat; 2500 int status; 2501 SV **svp; 2502 Pid_t pid; 2503 Pid_t pid2; 2504 bool close_failed; 2505 int saved_errno = 0; 2506 #ifdef VMS 2507 int saved_vaxc_errno; 2508 #endif 2509 #ifdef WIN32 2510 int saved_win32_errno; 2511 #endif 2512 2513 LOCK_FDPID_MUTEX; 2514 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); 2515 UNLOCK_FDPID_MUTEX; 2516 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; 2517 SvREFCNT_dec(*svp); 2518 *svp = &PL_sv_undef; 2519 #ifdef OS2 2520 if (pid == -1) { /* Opened by popen. */ 2521 return my_syspclose(ptr); 2522 } 2523 #endif 2524 if ((close_failed = (PerlIO_close(ptr) == EOF))) { 2525 saved_errno = errno; 2526 #ifdef VMS 2527 saved_vaxc_errno = vaxc$errno; 2528 #endif 2529 #ifdef WIN32 2530 saved_win32_errno = GetLastError(); 2531 #endif 2532 } 2533 #ifdef UTS 2534 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ 2535 #endif 2536 #ifndef PERL_MICRO 2537 rsignal_save(SIGHUP, SIG_IGN, &hstat); 2538 rsignal_save(SIGINT, SIG_IGN, &istat); 2539 rsignal_save(SIGQUIT, SIG_IGN, &qstat); 2540 #endif 2541 do { 2542 pid2 = wait4pid(pid, &status, 0); 2543 } while (pid2 == -1 && errno == EINTR); 2544 #ifndef PERL_MICRO 2545 rsignal_restore(SIGHUP, &hstat); 2546 rsignal_restore(SIGINT, &istat); 2547 rsignal_restore(SIGQUIT, &qstat); 2548 #endif 2549 if (close_failed) { 2550 SETERRNO(saved_errno, saved_vaxc_errno); 2551 return -1; 2552 } 2553 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); 2554 } 2555 #endif /* !DOSISH */ 2556 2557 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) 2558 I32 2559 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) 2560 { 2561 I32 result; 2562 if (!pid) 2563 return -1; 2564 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) 2565 { 2566 SV *sv; 2567 SV** svp; 2568 char spid[TYPE_CHARS(int)]; 2569 2570 if (pid > 0) { 2571 sprintf(spid, "%"IVdf, (IV)pid); 2572 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); 2573 if (svp && *svp != &PL_sv_undef) { 2574 *statusp = SvIVX(*svp); 2575 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); 2576 return pid; 2577 } 2578 } 2579 else { 2580 HE *entry; 2581 2582 hv_iterinit(PL_pidstatus); 2583 if ((entry = hv_iternext(PL_pidstatus))) { 2584 SV *sv; 2585 char spid[TYPE_CHARS(int)]; 2586 2587 pid = atoi(hv_iterkey(entry,(I32*)statusp)); 2588 sv = hv_iterval(PL_pidstatus,entry); 2589 *statusp = SvIVX(sv); 2590 sprintf(spid, "%"IVdf, (IV)pid); 2591 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); 2592 return pid; 2593 } 2594 } 2595 } 2596 #endif 2597 #ifdef HAS_WAITPID 2598 # ifdef HAS_WAITPID_RUNTIME 2599 if (!HAS_WAITPID_RUNTIME) 2600 goto hard_way; 2601 # endif 2602 result = PerlProc_waitpid(pid,statusp,flags); 2603 goto finish; 2604 #endif 2605 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) 2606 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); 2607 goto finish; 2608 #endif 2609 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) 2610 hard_way: 2611 { 2612 if (flags) 2613 Perl_croak(aTHX_ "Can't do waitpid with flags"); 2614 else { 2615 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) 2616 pidgone(result,*statusp); 2617 if (result < 0) 2618 *statusp = -1; 2619 } 2620 } 2621 #endif 2622 finish: 2623 if (result < 0 && errno == EINTR) { 2624 PERL_ASYNC_CHECK(); 2625 } 2626 return result; 2627 } 2628 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */ 2629 2630 void 2631 /*SUPPRESS 590*/ 2632 Perl_pidgone(pTHX_ Pid_t pid, int status) 2633 { 2634 register SV *sv; 2635 char spid[TYPE_CHARS(int)]; 2636 2637 sprintf(spid, "%"IVdf, (IV)pid); 2638 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE); 2639 (void)SvUPGRADE(sv,SVt_IV); 2640 SvIVX(sv) = status; 2641 return; 2642 } 2643 2644 #if defined(atarist) || defined(OS2) || defined(EPOC) 2645 int pclose(); 2646 #ifdef HAS_FORK 2647 int /* Cannot prototype with I32 2648 in os2ish.h. */ 2649 my_syspclose(PerlIO *ptr) 2650 #else 2651 I32 2652 Perl_my_pclose(pTHX_ PerlIO *ptr) 2653 #endif 2654 { 2655 /* Needs work for PerlIO ! */ 2656 FILE *f = PerlIO_findFILE(ptr); 2657 I32 result = pclose(f); 2658 PerlIO_releaseFILE(ptr,f); 2659 return result; 2660 } 2661 #endif 2662 2663 #if defined(DJGPP) 2664 int djgpp_pclose(); 2665 I32 2666 Perl_my_pclose(pTHX_ PerlIO *ptr) 2667 { 2668 /* Needs work for PerlIO ! */ 2669 FILE *f = PerlIO_findFILE(ptr); 2670 I32 result = djgpp_pclose(f); 2671 result = (result << 8) & 0xff00; 2672 PerlIO_releaseFILE(ptr,f); 2673 return result; 2674 } 2675 #endif 2676 2677 void 2678 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count) 2679 { 2680 register I32 todo; 2681 register const char *frombase = from; 2682 2683 if (len == 1) { 2684 register const char c = *from; 2685 while (count-- > 0) 2686 *to++ = c; 2687 return; 2688 } 2689 while (count-- > 0) { 2690 for (todo = len; todo > 0; todo--) { 2691 *to++ = *from++; 2692 } 2693 from = frombase; 2694 } 2695 } 2696 2697 #ifndef HAS_RENAME 2698 I32 2699 Perl_same_dirent(pTHX_ char *a, char *b) 2700 { 2701 char *fa = strrchr(a,'/'); 2702 char *fb = strrchr(b,'/'); 2703 Stat_t tmpstatbuf1; 2704 Stat_t tmpstatbuf2; 2705 SV *tmpsv = sv_newmortal(); 2706 2707 if (fa) 2708 fa++; 2709 else 2710 fa = a; 2711 if (fb) 2712 fb++; 2713 else 2714 fb = b; 2715 if (strNE(a,b)) 2716 return FALSE; 2717 if (fa == a) 2718 sv_setpv(tmpsv, "."); 2719 else 2720 sv_setpvn(tmpsv, a, fa - a); 2721 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0) 2722 return FALSE; 2723 if (fb == b) 2724 sv_setpv(tmpsv, "."); 2725 else 2726 sv_setpvn(tmpsv, b, fb - b); 2727 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0) 2728 return FALSE; 2729 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && 2730 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; 2731 } 2732 #endif /* !HAS_RENAME */ 2733 2734 char* 2735 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags) 2736 { 2737 char *xfound = Nullch; 2738 char *xfailed = Nullch; 2739 char tmpbuf[MAXPATHLEN]; 2740 register char *s; 2741 I32 len = 0; 2742 int retval; 2743 #if defined(DOSISH) && !defined(OS2) && !defined(atarist) 2744 # define SEARCH_EXTS ".bat", ".cmd", NULL 2745 # define MAX_EXT_LEN 4 2746 #endif 2747 #ifdef OS2 2748 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL 2749 # define MAX_EXT_LEN 4 2750 #endif 2751 #ifdef VMS 2752 # define SEARCH_EXTS ".pl", ".com", NULL 2753 # define MAX_EXT_LEN 4 2754 #endif 2755 /* additional extensions to try in each dir if scriptname not found */ 2756 #ifdef SEARCH_EXTS 2757 char *exts[] = { SEARCH_EXTS }; 2758 char **ext = search_ext ? search_ext : exts; 2759 int extidx = 0, i = 0; 2760 char *curext = Nullch; 2761 #else 2762 # define MAX_EXT_LEN 0 2763 #endif 2764 2765 /* 2766 * If dosearch is true and if scriptname does not contain path 2767 * delimiters, search the PATH for scriptname. 2768 * 2769 * If SEARCH_EXTS is also defined, will look for each 2770 * scriptname{SEARCH_EXTS} whenever scriptname is not found 2771 * while searching the PATH. 2772 * 2773 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search 2774 * proceeds as follows: 2775 * If DOSISH or VMSISH: 2776 * + look for ./scriptname{,.foo,.bar} 2777 * + search the PATH for scriptname{,.foo,.bar} 2778 * 2779 * If !DOSISH: 2780 * + look *only* in the PATH for scriptname{,.foo,.bar} (note 2781 * this will not look in '.' if it's not in the PATH) 2782 */ 2783 tmpbuf[0] = '\0'; 2784 2785 #ifdef VMS 2786 # ifdef ALWAYS_DEFTYPES 2787 len = strlen(scriptname); 2788 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { 2789 int hasdir, idx = 0, deftypes = 1; 2790 bool seen_dot = 1; 2791 2792 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ; 2793 # else 2794 if (dosearch) { 2795 int hasdir, idx = 0, deftypes = 1; 2796 bool seen_dot = 1; 2797 2798 hasdir = (strpbrk(scriptname,":[</") != Nullch) ; 2799 # endif 2800 /* The first time through, just add SEARCH_EXTS to whatever we 2801 * already have, so we can check for default file types. */ 2802 while (deftypes || 2803 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) 2804 { 2805 if (deftypes) { 2806 deftypes = 0; 2807 *tmpbuf = '\0'; 2808 } 2809 if ((strlen(tmpbuf) + strlen(scriptname) 2810 + MAX_EXT_LEN) >= sizeof tmpbuf) 2811 continue; /* don't search dir with too-long name */ 2812 strcat(tmpbuf, scriptname); 2813 #else /* !VMS */ 2814 2815 #ifdef DOSISH 2816 if (strEQ(scriptname, "-")) 2817 dosearch = 0; 2818 if (dosearch) { /* Look in '.' first. */ 2819 char *cur = scriptname; 2820 #ifdef SEARCH_EXTS 2821 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ 2822 while (ext[i]) 2823 if (strEQ(ext[i++],curext)) { 2824 extidx = -1; /* already has an ext */ 2825 break; 2826 } 2827 do { 2828 #endif 2829 DEBUG_p(PerlIO_printf(Perl_debug_log, 2830 "Looking for %s\n",cur)); 2831 if (PerlLIO_stat(cur,&PL_statbuf) >= 0 2832 && !S_ISDIR(PL_statbuf.st_mode)) { 2833 dosearch = 0; 2834 scriptname = cur; 2835 #ifdef SEARCH_EXTS 2836 break; 2837 #endif 2838 } 2839 #ifdef SEARCH_EXTS 2840 if (cur == scriptname) { 2841 len = strlen(scriptname); 2842 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) 2843 break; 2844 cur = strcpy(tmpbuf, scriptname); 2845 } 2846 } while (extidx >= 0 && ext[extidx] /* try an extension? */ 2847 && strcpy(tmpbuf+len, ext[extidx++])); 2848 #endif 2849 } 2850 #endif 2851 2852 #ifdef MACOS_TRADITIONAL 2853 if (dosearch && !strchr(scriptname, ':') && 2854 (s = PerlEnv_getenv("Commands"))) 2855 #else 2856 if (dosearch && !strchr(scriptname, '/') 2857 #ifdef DOSISH 2858 && !strchr(scriptname, '\\') 2859 #endif 2860 && (s = PerlEnv_getenv("PATH"))) 2861 #endif 2862 { 2863 bool seen_dot = 0; 2864 2865 PL_bufend = s + strlen(s); 2866 while (s < PL_bufend) { 2867 #ifdef MACOS_TRADITIONAL 2868 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, 2869 ',', 2870 &len); 2871 #else 2872 #if defined(atarist) || defined(DOSISH) 2873 for (len = 0; *s 2874 # ifdef atarist 2875 && *s != ',' 2876 # endif 2877 && *s != ';'; len++, s++) { 2878 if (len < sizeof tmpbuf) 2879 tmpbuf[len] = *s; 2880 } 2881 if (len < sizeof tmpbuf) 2882 tmpbuf[len] = '\0'; 2883 #else /* ! (atarist || DOSISH) */ 2884 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, 2885 ':', 2886 &len); 2887 #endif /* ! (atarist || DOSISH) */ 2888 #endif /* MACOS_TRADITIONAL */ 2889 if (s < PL_bufend) 2890 s++; 2891 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) 2892 continue; /* don't search dir with too-long name */ 2893 #ifdef MACOS_TRADITIONAL 2894 if (len && tmpbuf[len - 1] != ':') 2895 tmpbuf[len++] = ':'; 2896 #else 2897 if (len 2898 #if defined(atarist) || defined(__MINT__) || defined(DOSISH) 2899 && tmpbuf[len - 1] != '/' 2900 && tmpbuf[len - 1] != '\\' 2901 #endif 2902 ) 2903 tmpbuf[len++] = '/'; 2904 if (len == 2 && tmpbuf[0] == '.') 2905 seen_dot = 1; 2906 #endif 2907 (void)strcpy(tmpbuf + len, scriptname); 2908 #endif /* !VMS */ 2909 2910 #ifdef SEARCH_EXTS 2911 len = strlen(tmpbuf); 2912 if (extidx > 0) /* reset after previous loop */ 2913 extidx = 0; 2914 do { 2915 #endif 2916 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); 2917 retval = PerlLIO_stat(tmpbuf,&PL_statbuf); 2918 if (S_ISDIR(PL_statbuf.st_mode)) { 2919 retval = -1; 2920 } 2921 #ifdef SEARCH_EXTS 2922 } while ( retval < 0 /* not there */ 2923 && extidx>=0 && ext[extidx] /* try an extension? */ 2924 && strcpy(tmpbuf+len, ext[extidx++]) 2925 ); 2926 #endif 2927 if (retval < 0) 2928 continue; 2929 if (S_ISREG(PL_statbuf.st_mode) 2930 && cando(S_IRUSR,TRUE,&PL_statbuf) 2931 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL) 2932 && cando(S_IXUSR,TRUE,&PL_statbuf) 2933 #endif 2934 ) 2935 { 2936 xfound = tmpbuf; /* bingo! */ 2937 break; 2938 } 2939 if (!xfailed) 2940 xfailed = savepv(tmpbuf); 2941 } 2942 #ifndef DOSISH 2943 if (!xfound && !seen_dot && !xfailed && 2944 (PerlLIO_stat(scriptname,&PL_statbuf) < 0 2945 || S_ISDIR(PL_statbuf.st_mode))) 2946 #endif 2947 seen_dot = 1; /* Disable message. */ 2948 if (!xfound) { 2949 if (flags & 1) { /* do or die? */ 2950 Perl_croak(aTHX_ "Can't %s %s%s%s", 2951 (xfailed ? "execute" : "find"), 2952 (xfailed ? xfailed : scriptname), 2953 (xfailed ? "" : " on PATH"), 2954 (xfailed || seen_dot) ? "" : ", '.' not in PATH"); 2955 } 2956 scriptname = Nullch; 2957 } 2958 if (xfailed) 2959 Safefree(xfailed); 2960 scriptname = xfound; 2961 } 2962 return (scriptname ? savepv(scriptname) : Nullch); 2963 } 2964 2965 #ifndef PERL_GET_CONTEXT_DEFINED 2966 2967 void * 2968 Perl_get_context(void) 2969 { 2970 #if defined(USE_5005THREADS) || defined(USE_ITHREADS) 2971 # ifdef OLD_PTHREADS_API 2972 pthread_addr_t t; 2973 if (pthread_getspecific(PL_thr_key, &t)) 2974 Perl_croak_nocontext("panic: pthread_getspecific"); 2975 return (void*)t; 2976 # else 2977 # ifdef I_MACH_CTHREADS 2978 return (void*)cthread_data(cthread_self()); 2979 # else 2980 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); 2981 # endif 2982 # endif 2983 #else 2984 return (void*)NULL; 2985 #endif 2986 } 2987 2988 void 2989 Perl_set_context(void *t) 2990 { 2991 #if defined(USE_5005THREADS) || defined(USE_ITHREADS) 2992 # ifdef I_MACH_CTHREADS 2993 cthread_set_data(cthread_self(), t); 2994 # else 2995 if (pthread_setspecific(PL_thr_key, t)) 2996 Perl_croak_nocontext("panic: pthread_setspecific"); 2997 # endif 2998 #endif 2999 } 3000 3001 #endif /* !PERL_GET_CONTEXT_DEFINED */ 3002 3003 #ifdef USE_5005THREADS 3004 3005 #ifdef FAKE_THREADS 3006 /* Very simplistic scheduler for now */ 3007 void 3008 schedule(void) 3009 { 3010 thr = thr->i.next_run; 3011 } 3012 3013 void 3014 Perl_cond_init(pTHX_ perl_cond *cp) 3015 { 3016 *cp = 0; 3017 } 3018 3019 void 3020 Perl_cond_signal(pTHX_ perl_cond *cp) 3021 { 3022 perl_os_thread t; 3023 perl_cond cond = *cp; 3024 3025 if (!cond) 3026 return; 3027 t = cond->thread; 3028 /* Insert t in the runnable queue just ahead of us */ 3029 t->i.next_run = thr->i.next_run; 3030 thr->i.next_run->i.prev_run = t; 3031 t->i.prev_run = thr; 3032 thr->i.next_run = t; 3033 thr->i.wait_queue = 0; 3034 /* Remove from the wait queue */ 3035 *cp = cond->next; 3036 Safefree(cond); 3037 } 3038 3039 void 3040 Perl_cond_broadcast(pTHX_ perl_cond *cp) 3041 { 3042 perl_os_thread t; 3043 perl_cond cond, cond_next; 3044 3045 for (cond = *cp; cond; cond = cond_next) { 3046 t = cond->thread; 3047 /* Insert t in the runnable queue just ahead of us */ 3048 t->i.next_run = thr->i.next_run; 3049 thr->i.next_run->i.prev_run = t; 3050 t->i.prev_run = thr; 3051 thr->i.next_run = t; 3052 thr->i.wait_queue = 0; 3053 /* Remove from the wait queue */ 3054 cond_next = cond->next; 3055 Safefree(cond); 3056 } 3057 *cp = 0; 3058 } 3059 3060 void 3061 Perl_cond_wait(pTHX_ perl_cond *cp) 3062 { 3063 perl_cond cond; 3064 3065 if (thr->i.next_run == thr) 3066 Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread"); 3067 3068 New(666, cond, 1, struct perl_wait_queue); 3069 cond->thread = thr; 3070 cond->next = *cp; 3071 *cp = cond; 3072 thr->i.wait_queue = cond; 3073 /* Remove ourselves from runnable queue */ 3074 thr->i.next_run->i.prev_run = thr->i.prev_run; 3075 thr->i.prev_run->i.next_run = thr->i.next_run; 3076 } 3077 #endif /* FAKE_THREADS */ 3078 3079 MAGIC * 3080 Perl_condpair_magic(pTHX_ SV *sv) 3081 { 3082 MAGIC *mg; 3083 3084 (void)SvUPGRADE(sv, SVt_PVMG); 3085 mg = mg_find(sv, PERL_MAGIC_mutex); 3086 if (!mg) { 3087 condpair_t *cp; 3088 3089 New(53, cp, 1, condpair_t); 3090 MUTEX_INIT(&cp->mutex); 3091 COND_INIT(&cp->owner_cond); 3092 COND_INIT(&cp->cond); 3093 cp->owner = 0; 3094 LOCK_CRED_MUTEX; /* XXX need separate mutex? */ 3095 mg = mg_find(sv, PERL_MAGIC_mutex); 3096 if (mg) { 3097 /* someone else beat us to initialising it */ 3098 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ 3099 MUTEX_DESTROY(&cp->mutex); 3100 COND_DESTROY(&cp->owner_cond); 3101 COND_DESTROY(&cp->cond); 3102 Safefree(cp); 3103 } 3104 else { 3105 sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0); 3106 mg = SvMAGIC(sv); 3107 mg->mg_ptr = (char *)cp; 3108 mg->mg_len = sizeof(cp); 3109 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ 3110 DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, 3111 "%p: condpair_magic %p\n", thr, sv))); 3112 } 3113 } 3114 return mg; 3115 } 3116 3117 SV * 3118 Perl_sv_lock(pTHX_ SV *osv) 3119 { 3120 MAGIC *mg; 3121 SV *sv = osv; 3122 3123 LOCK_SV_LOCK_MUTEX; 3124 if (SvROK(sv)) { 3125 sv = SvRV(sv); 3126 } 3127 3128 mg = condpair_magic(sv); 3129 MUTEX_LOCK(MgMUTEXP(mg)); 3130 if (MgOWNER(mg) == thr) 3131 MUTEX_UNLOCK(MgMUTEXP(mg)); 3132 else { 3133 while (MgOWNER(mg)) 3134 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); 3135 MgOWNER(mg) = thr; 3136 DEBUG_S(PerlIO_printf(Perl_debug_log, 3137 "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", 3138 PTR2UV(thr), PTR2UV(sv))); 3139 MUTEX_UNLOCK(MgMUTEXP(mg)); 3140 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); 3141 } 3142 UNLOCK_SV_LOCK_MUTEX; 3143 return sv; 3144 } 3145 3146 /* 3147 * Make a new perl thread structure using t as a prototype. Some of the 3148 * fields for the new thread are copied from the prototype thread, t, 3149 * so t should not be running in perl at the time this function is 3150 * called. The use by ext/Thread/Thread.xs in core perl (where t is the 3151 * thread calling new_struct_thread) clearly satisfies this constraint. 3152 */ 3153 struct perl_thread * 3154 Perl_new_struct_thread(pTHX_ struct perl_thread *t) 3155 { 3156 #if !defined(PERL_IMPLICIT_CONTEXT) 3157 struct perl_thread *thr; 3158 #endif 3159 SV *sv; 3160 SV **svp; 3161 I32 i; 3162 3163 sv = newSVpvn("", 0); 3164 SvGROW(sv, sizeof(struct perl_thread) + 1); 3165 SvCUR_set(sv, sizeof(struct perl_thread)); 3166 thr = (Thread) SvPVX(sv); 3167 #ifdef DEBUGGING 3168 Poison(thr, 1, struct perl_thread); 3169 PL_markstack = 0; 3170 PL_scopestack = 0; 3171 PL_savestack = 0; 3172 PL_retstack = 0; 3173 PL_dirty = 0; 3174 PL_localizing = 0; 3175 Zero(&PL_hv_fetch_ent_mh, 1, HE); 3176 PL_efloatbuf = (char*)NULL; 3177 PL_efloatsize = 0; 3178 #else 3179 Zero(thr, 1, struct perl_thread); 3180 #endif 3181 3182 thr->oursv = sv; 3183 init_stacks(); 3184 3185 PL_curcop = &PL_compiling; 3186 thr->interp = t->interp; 3187 thr->cvcache = newHV(); 3188 thr->threadsv = newAV(); 3189 thr->specific = newAV(); 3190 thr->errsv = newSVpvn("", 0); 3191 thr->flags = THRf_R_JOINABLE; 3192 thr->thr_done = 0; 3193 MUTEX_INIT(&thr->mutex); 3194 3195 JMPENV_BOOTSTRAP; 3196 3197 PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */ 3198 PL_restartop = 0; 3199 3200 PL_statname = NEWSV(66,0); 3201 PL_errors = newSVpvn("", 0); 3202 PL_maxscream = -1; 3203 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); 3204 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); 3205 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); 3206 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); 3207 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); 3208 PL_regindent = 0; 3209 PL_reginterp_cnt = 0; 3210 PL_lastscream = Nullsv; 3211 PL_screamfirst = 0; 3212 PL_screamnext = 0; 3213 PL_reg_start_tmp = 0; 3214 PL_reg_start_tmpl = 0; 3215 PL_reg_poscache = Nullch; 3216 3217 PL_peepp = MEMBER_TO_FPTR(Perl_peep); 3218 3219 /* parent thread's data needs to be locked while we make copy */ 3220 MUTEX_LOCK(&t->mutex); 3221 3222 #ifdef PERL_FLEXIBLE_EXCEPTIONS 3223 PL_protect = t->Tprotect; 3224 #endif 3225 3226 PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ 3227 PL_defstash = t->Tdefstash; /* XXX maybe these should */ 3228 PL_curstash = t->Tcurstash; /* always be set to main? */ 3229 3230 PL_tainted = t->Ttainted; 3231 PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ 3232 PL_rs = newSVsv(t->Trs); 3233 PL_last_in_gv = Nullgv; 3234 PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv; 3235 PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); 3236 PL_chopset = t->Tchopset; 3237 PL_bodytarget = newSVsv(t->Tbodytarget); 3238 PL_toptarget = newSVsv(t->Ttoptarget); 3239 if (t->Tformtarget == t->Ttoptarget) 3240 PL_formtarget = PL_toptarget; 3241 else 3242 PL_formtarget = PL_bodytarget; 3243 3244 /* Initialise all per-thread SVs that the template thread used */ 3245 svp = AvARRAY(t->threadsv); 3246 for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) { 3247 if (*svp && *svp != &PL_sv_undef) { 3248 SV *sv = newSVsv(*svp); 3249 av_store(thr->threadsv, i, sv); 3250 sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1); 3251 DEBUG_S(PerlIO_printf(Perl_debug_log, 3252 "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", 3253 (IV)i, t, thr)); 3254 } 3255 } 3256 thr->threadsvp = AvARRAY(thr->threadsv); 3257 3258 MUTEX_LOCK(&PL_threads_mutex); 3259 PL_nthreads++; 3260 thr->tid = ++PL_threadnum; 3261 thr->next = t->next; 3262 thr->prev = t; 3263 t->next = thr; 3264 thr->next->prev = thr; 3265 MUTEX_UNLOCK(&PL_threads_mutex); 3266 3267 /* done copying parent's state */ 3268 MUTEX_UNLOCK(&t->mutex); 3269 3270 #ifdef HAVE_THREAD_INTERN 3271 Perl_init_thread_intern(thr); 3272 #endif /* HAVE_THREAD_INTERN */ 3273 return thr; 3274 } 3275 #endif /* USE_5005THREADS */ 3276 3277 #ifdef PERL_GLOBAL_STRUCT 3278 struct perl_vars * 3279 Perl_GetVars(pTHX) 3280 { 3281 return &PL_Vars; 3282 } 3283 #endif 3284 3285 char ** 3286 Perl_get_op_names(pTHX) 3287 { 3288 return PL_op_name; 3289 } 3290 3291 char ** 3292 Perl_get_op_descs(pTHX) 3293 { 3294 return PL_op_desc; 3295 } 3296 3297 char * 3298 Perl_get_no_modify(pTHX) 3299 { 3300 return (char*)PL_no_modify; 3301 } 3302 3303 U32 * 3304 Perl_get_opargs(pTHX) 3305 { 3306 return PL_opargs; 3307 } 3308 3309 PPADDR_t* 3310 Perl_get_ppaddr(pTHX) 3311 { 3312 return (PPADDR_t*)PL_ppaddr; 3313 } 3314 3315 #ifndef HAS_GETENV_LEN 3316 char * 3317 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) 3318 { 3319 char *env_trans = PerlEnv_getenv(env_elem); 3320 if (env_trans) 3321 *len = strlen(env_trans); 3322 return env_trans; 3323 } 3324 #endif 3325 3326 3327 MGVTBL* 3328 Perl_get_vtbl(pTHX_ int vtbl_id) 3329 { 3330 MGVTBL* result = Null(MGVTBL*); 3331 3332 switch(vtbl_id) { 3333 case want_vtbl_sv: 3334 result = &PL_vtbl_sv; 3335 break; 3336 case want_vtbl_env: 3337 result = &PL_vtbl_env; 3338 break; 3339 case want_vtbl_envelem: 3340 result = &PL_vtbl_envelem; 3341 break; 3342 case want_vtbl_sig: 3343 result = &PL_vtbl_sig; 3344 break; 3345 case want_vtbl_sigelem: 3346 result = &PL_vtbl_sigelem; 3347 break; 3348 case want_vtbl_pack: 3349 result = &PL_vtbl_pack; 3350 break; 3351 case want_vtbl_packelem: 3352 result = &PL_vtbl_packelem; 3353 break; 3354 case want_vtbl_dbline: 3355 result = &PL_vtbl_dbline; 3356 break; 3357 case want_vtbl_isa: 3358 result = &PL_vtbl_isa; 3359 break; 3360 case want_vtbl_isaelem: 3361 result = &PL_vtbl_isaelem; 3362 break; 3363 case want_vtbl_arylen: 3364 result = &PL_vtbl_arylen; 3365 break; 3366 case want_vtbl_glob: 3367 result = &PL_vtbl_glob; 3368 break; 3369 case want_vtbl_mglob: 3370 result = &PL_vtbl_mglob; 3371 break; 3372 case want_vtbl_nkeys: 3373 result = &PL_vtbl_nkeys; 3374 break; 3375 case want_vtbl_taint: 3376 result = &PL_vtbl_taint; 3377 break; 3378 case want_vtbl_substr: 3379 result = &PL_vtbl_substr; 3380 break; 3381 case want_vtbl_vec: 3382 result = &PL_vtbl_vec; 3383 break; 3384 case want_vtbl_pos: 3385 result = &PL_vtbl_pos; 3386 break; 3387 case want_vtbl_bm: 3388 result = &PL_vtbl_bm; 3389 break; 3390 case want_vtbl_fm: 3391 result = &PL_vtbl_fm; 3392 break; 3393 case want_vtbl_uvar: 3394 result = &PL_vtbl_uvar; 3395 break; 3396 #ifdef USE_5005THREADS 3397 case want_vtbl_mutex: 3398 result = &PL_vtbl_mutex; 3399 break; 3400 #endif 3401 case want_vtbl_defelem: 3402 result = &PL_vtbl_defelem; 3403 break; 3404 case want_vtbl_regexp: 3405 result = &PL_vtbl_regexp; 3406 break; 3407 case want_vtbl_regdata: 3408 result = &PL_vtbl_regdata; 3409 break; 3410 case want_vtbl_regdatum: 3411 result = &PL_vtbl_regdatum; 3412 break; 3413 #ifdef USE_LOCALE_COLLATE 3414 case want_vtbl_collxfrm: 3415 result = &PL_vtbl_collxfrm; 3416 break; 3417 #endif 3418 case want_vtbl_amagic: 3419 result = &PL_vtbl_amagic; 3420 break; 3421 case want_vtbl_amagicelem: 3422 result = &PL_vtbl_amagicelem; 3423 break; 3424 case want_vtbl_backref: 3425 result = &PL_vtbl_backref; 3426 break; 3427 } 3428 return result; 3429 } 3430 3431 I32 3432 Perl_my_fflush_all(pTHX) 3433 { 3434 #if defined(FFLUSH_NULL) 3435 return PerlIO_flush(NULL); 3436 #else 3437 # if defined(HAS__FWALK) 3438 extern int fflush(FILE *); 3439 /* undocumented, unprototyped, but very useful BSDism */ 3440 extern void _fwalk(int (*)(FILE *)); 3441 _fwalk(&fflush); 3442 return 0; 3443 # else 3444 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) 3445 long open_max = -1; 3446 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX 3447 open_max = PERL_FFLUSH_ALL_FOPEN_MAX; 3448 # else 3449 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) 3450 open_max = sysconf(_SC_OPEN_MAX); 3451 # else 3452 # ifdef FOPEN_MAX 3453 open_max = FOPEN_MAX; 3454 # else 3455 # ifdef OPEN_MAX 3456 open_max = OPEN_MAX; 3457 # else 3458 # ifdef _NFILE 3459 open_max = _NFILE; 3460 # endif 3461 # endif 3462 # endif 3463 # endif 3464 # endif 3465 if (open_max > 0) { 3466 long i; 3467 for (i = 0; i < open_max; i++) 3468 if (STDIO_STREAM_ARRAY[i]._file >= 0 && 3469 STDIO_STREAM_ARRAY[i]._file < open_max && 3470 STDIO_STREAM_ARRAY[i]._flag) 3471 PerlIO_flush(&STDIO_STREAM_ARRAY[i]); 3472 return 0; 3473 } 3474 # endif 3475 SETERRNO(EBADF,RMS$_IFI); 3476 return EOF; 3477 # endif 3478 #endif 3479 } 3480 3481 void 3482 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) 3483 { 3484 char *vile; 3485 I32 warn_type; 3486 char *func = 3487 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */ 3488 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ 3489 PL_op_desc[op]; 3490 char *pars = OP_IS_FILETEST(op) ? "" : "()"; 3491 char *type = OP_IS_SOCKET(op) || 3492 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ? 3493 "socket" : "filehandle"; 3494 char *name = NULL; 3495 3496 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) { 3497 vile = "closed"; 3498 warn_type = WARN_CLOSED; 3499 } 3500 else { 3501 vile = "unopened"; 3502 warn_type = WARN_UNOPENED; 3503 } 3504 3505 if (gv && isGV(gv)) { 3506 name = GvENAME(gv); 3507 } 3508 3509 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { 3510 if (name && *name) 3511 Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for %sput", 3512 name, 3513 (op == OP_phoney_INPUT_ONLY ? "in" : "out")); 3514 else 3515 Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle opened only for %sput", 3516 (op == OP_phoney_INPUT_ONLY ? "in" : "out")); 3517 } else if (name && *name) { 3518 Perl_warner(aTHX_ packWARN(warn_type), 3519 "%s%s on %s %s %s", func, pars, vile, type, name); 3520 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3521 Perl_warner(aTHX_ packWARN(warn_type), 3522 "\t(Are you trying to call %s%s on dirhandle %s?)\n", 3523 func, pars, name); 3524 } 3525 else { 3526 Perl_warner(aTHX_ packWARN(warn_type), 3527 "%s%s on %s %s", func, pars, vile, type); 3528 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3529 Perl_warner(aTHX_ packWARN(warn_type), 3530 "\t(Are you trying to call %s%s on dirhandle?)\n", 3531 func, pars); 3532 } 3533 } 3534 3535 #ifdef EBCDIC 3536 /* in ASCII order, not that it matters */ 3537 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; 3538 3539 int 3540 Perl_ebcdic_control(pTHX_ int ch) 3541 { 3542 if (ch > 'a') { 3543 char *ctlp; 3544 3545 if (islower(ch)) 3546 ch = toupper(ch); 3547 3548 if ((ctlp = strchr(controllablechars, ch)) == 0) { 3549 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); 3550 } 3551 3552 if (ctlp == controllablechars) 3553 return('\177'); /* DEL */ 3554 else 3555 return((unsigned char)(ctlp - controllablechars - 1)); 3556 } else { /* Want uncontrol */ 3557 if (ch == '\177' || ch == -1) 3558 return('?'); 3559 else if (ch == '\157') 3560 return('\177'); 3561 else if (ch == '\174') 3562 return('\000'); 3563 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */ 3564 return('\036'); 3565 else if (ch == '\155') 3566 return('\037'); 3567 else if (0 < ch && ch < (sizeof(controllablechars) - 1)) 3568 return(controllablechars[ch+1]); 3569 else 3570 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF); 3571 } 3572 } 3573 #endif 3574 3575 /* To workaround core dumps from the uninitialised tm_zone we get the 3576 * system to give us a reasonable struct to copy. This fix means that 3577 * strftime uses the tm_zone and tm_gmtoff values returned by 3578 * localtime(time()). That should give the desired result most of the 3579 * time. But probably not always! 3580 * 3581 * This does not address tzname aspects of NETaa14816. 3582 * 3583 */ 3584 3585 #ifdef HAS_GNULIBC 3586 # ifndef STRUCT_TM_HASZONE 3587 # define STRUCT_TM_HASZONE 3588 # endif 3589 #endif 3590 3591 #ifdef STRUCT_TM_HASZONE /* Backward compat */ 3592 # ifndef HAS_TM_TM_ZONE 3593 # define HAS_TM_TM_ZONE 3594 # endif 3595 #endif 3596 3597 void 3598 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ 3599 { 3600 #ifdef HAS_TM_TM_ZONE 3601 Time_t now; 3602 (void)time(&now); 3603 Copy(localtime(&now), ptm, 1, struct tm); 3604 #endif 3605 } 3606 3607 /* 3608 * mini_mktime - normalise struct tm values without the localtime() 3609 * semantics (and overhead) of mktime(). 3610 */ 3611 void 3612 Perl_mini_mktime(pTHX_ struct tm *ptm) 3613 { 3614 int yearday; 3615 int secs; 3616 int month, mday, year, jday; 3617 int odd_cent, odd_year; 3618 3619 #define DAYS_PER_YEAR 365 3620 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) 3621 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) 3622 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) 3623 #define SECS_PER_HOUR (60*60) 3624 #define SECS_PER_DAY (24*SECS_PER_HOUR) 3625 /* parentheses deliberately absent on these two, otherwise they don't work */ 3626 #define MONTH_TO_DAYS 153/5 3627 #define DAYS_TO_MONTH 5/153 3628 /* offset to bias by March (month 4) 1st between month/mday & year finding */ 3629 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1) 3630 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ 3631 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ 3632 3633 /* 3634 * Year/day algorithm notes: 3635 * 3636 * With a suitable offset for numeric value of the month, one can find 3637 * an offset into the year by considering months to have 30.6 (153/5) days, 3638 * using integer arithmetic (i.e., with truncation). To avoid too much 3639 * messing about with leap days, we consider January and February to be 3640 * the 13th and 14th month of the previous year. After that transformation, 3641 * we need the month index we use to be high by 1 from 'normal human' usage, 3642 * so the month index values we use run from 4 through 15. 3643 * 3644 * Given that, and the rules for the Gregorian calendar (leap years are those 3645 * divisible by 4 unless also divisible by 100, when they must be divisible 3646 * by 400 instead), we can simply calculate the number of days since some 3647 * arbitrary 'beginning of time' by futzing with the (adjusted) year number, 3648 * the days we derive from our month index, and adding in the day of the 3649 * month. The value used here is not adjusted for the actual origin which 3650 * it normally would use (1 January A.D. 1), since we're not exposing it. 3651 * We're only building the value so we can turn around and get the 3652 * normalised values for the year, month, day-of-month, and day-of-year. 3653 * 3654 * For going backward, we need to bias the value we're using so that we find 3655 * the right year value. (Basically, we don't want the contribution of 3656 * March 1st to the number to apply while deriving the year). Having done 3657 * that, we 'count up' the contribution to the year number by accounting for 3658 * full quadracenturies (400-year periods) with their extra leap days, plus 3659 * the contribution from full centuries (to avoid counting in the lost leap 3660 * days), plus the contribution from full quad-years (to count in the normal 3661 * leap days), plus the leftover contribution from any non-leap years. 3662 * At this point, if we were working with an actual leap day, we'll have 0 3663 * days left over. This is also true for March 1st, however. So, we have 3664 * to special-case that result, and (earlier) keep track of the 'odd' 3665 * century and year contributions. If we got 4 extra centuries in a qcent, 3666 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. 3667 * Otherwise, we add back in the earlier bias we removed (the 123 from 3668 * figuring in March 1st), find the month index (integer division by 30.6), 3669 * and the remainder is the day-of-month. We then have to convert back to 3670 * 'real' months (including fixing January and February from being 14/15 in 3671 * the previous year to being in the proper year). After that, to get 3672 * tm_yday, we work with the normalised year and get a new yearday value for 3673 * January 1st, which we subtract from the yearday value we had earlier, 3674 * representing the date we've re-built. This is done from January 1 3675 * because tm_yday is 0-origin. 3676 * 3677 * Since POSIX time routines are only guaranteed to work for times since the 3678 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm 3679 * applies Gregorian calendar rules even to dates before the 16th century 3680 * doesn't bother me. Besides, you'd need cultural context for a given 3681 * date to know whether it was Julian or Gregorian calendar, and that's 3682 * outside the scope for this routine. Since we convert back based on the 3683 * same rules we used to build the yearday, you'll only get strange results 3684 * for input which needed normalising, or for the 'odd' century years which 3685 * were leap years in the Julian calander but not in the Gregorian one. 3686 * I can live with that. 3687 * 3688 * This algorithm also fails to handle years before A.D. 1 gracefully, but 3689 * that's still outside the scope for POSIX time manipulation, so I don't 3690 * care. 3691 */ 3692 3693 year = 1900 + ptm->tm_year; 3694 month = ptm->tm_mon; 3695 mday = ptm->tm_mday; 3696 /* allow given yday with no month & mday to dominate the result */ 3697 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) { 3698 month = 0; 3699 mday = 0; 3700 jday = 1 + ptm->tm_yday; 3701 } 3702 else { 3703 jday = 0; 3704 } 3705 if (month >= 2) 3706 month+=2; 3707 else 3708 month+=14, year--; 3709 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; 3710 yearday += month*MONTH_TO_DAYS + mday + jday; 3711 /* 3712 * Note that we don't know when leap-seconds were or will be, 3713 * so we have to trust the user if we get something which looks 3714 * like a sensible leap-second. Wild values for seconds will 3715 * be rationalised, however. 3716 */ 3717 if ((unsigned) ptm->tm_sec <= 60) { 3718 secs = 0; 3719 } 3720 else { 3721 secs = ptm->tm_sec; 3722 ptm->tm_sec = 0; 3723 } 3724 secs += 60 * ptm->tm_min; 3725 secs += SECS_PER_HOUR * ptm->tm_hour; 3726 if (secs < 0) { 3727 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { 3728 /* got negative remainder, but need positive time */ 3729 /* back off an extra day to compensate */ 3730 yearday += (secs/SECS_PER_DAY)-1; 3731 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); 3732 } 3733 else { 3734 yearday += (secs/SECS_PER_DAY); 3735 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); 3736 } 3737 } 3738 else if (secs >= SECS_PER_DAY) { 3739 yearday += (secs/SECS_PER_DAY); 3740 secs %= SECS_PER_DAY; 3741 } 3742 ptm->tm_hour = secs/SECS_PER_HOUR; 3743 secs %= SECS_PER_HOUR; 3744 ptm->tm_min = secs/60; 3745 secs %= 60; 3746 ptm->tm_sec += secs; 3747 /* done with time of day effects */ 3748 /* 3749 * The algorithm for yearday has (so far) left it high by 428. 3750 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to 3751 * bias it by 123 while trying to figure out what year it 3752 * really represents. Even with this tweak, the reverse 3753 * translation fails for years before A.D. 0001. 3754 * It would still fail for Feb 29, but we catch that one below. 3755 */ 3756 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ 3757 yearday -= YEAR_ADJUST; 3758 year = (yearday / DAYS_PER_QCENT) * 400; 3759 yearday %= DAYS_PER_QCENT; 3760 odd_cent = yearday / DAYS_PER_CENT; 3761 year += odd_cent * 100; 3762 yearday %= DAYS_PER_CENT; 3763 year += (yearday / DAYS_PER_QYEAR) * 4; 3764 yearday %= DAYS_PER_QYEAR; 3765 odd_year = yearday / DAYS_PER_YEAR; 3766 year += odd_year; 3767 yearday %= DAYS_PER_YEAR; 3768 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ 3769 month = 1; 3770 yearday = 29; 3771 } 3772 else { 3773 yearday += YEAR_ADJUST; /* recover March 1st crock */ 3774 month = yearday*DAYS_TO_MONTH; 3775 yearday -= month*MONTH_TO_DAYS; 3776 /* recover other leap-year adjustment */ 3777 if (month > 13) { 3778 month-=14; 3779 year++; 3780 } 3781 else { 3782 month-=2; 3783 } 3784 } 3785 ptm->tm_year = year - 1900; 3786 if (yearday) { 3787 ptm->tm_mday = yearday; 3788 ptm->tm_mon = month; 3789 } 3790 else { 3791 ptm->tm_mday = 31; 3792 ptm->tm_mon = month - 1; 3793 } 3794 /* re-build yearday based on Jan 1 to get tm_yday */ 3795 year--; 3796 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; 3797 yearday += 14*MONTH_TO_DAYS + 1; 3798 ptm->tm_yday = jday - yearday; 3799 /* fix tm_wday if not overridden by caller */ 3800 if ((unsigned)ptm->tm_wday > 6) 3801 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; 3802 } 3803 3804 char * 3805 Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) 3806 { 3807 #ifdef HAS_STRFTIME 3808 char *buf; 3809 int buflen; 3810 struct tm mytm; 3811 int len; 3812 3813 init_tm(&mytm); /* XXX workaround - see init_tm() above */ 3814 mytm.tm_sec = sec; 3815 mytm.tm_min = min; 3816 mytm.tm_hour = hour; 3817 mytm.tm_mday = mday; 3818 mytm.tm_mon = mon; 3819 mytm.tm_year = year; 3820 mytm.tm_wday = wday; 3821 mytm.tm_yday = yday; 3822 mytm.tm_isdst = isdst; 3823 mini_mktime(&mytm); 3824 buflen = 64; 3825 New(0, buf, buflen, char); 3826 len = strftime(buf, buflen, fmt, &mytm); 3827 /* 3828 ** The following is needed to handle to the situation where 3829 ** tmpbuf overflows. Basically we want to allocate a buffer 3830 ** and try repeatedly. The reason why it is so complicated 3831 ** is that getting a return value of 0 from strftime can indicate 3832 ** one of the following: 3833 ** 1. buffer overflowed, 3834 ** 2. illegal conversion specifier, or 3835 ** 3. the format string specifies nothing to be returned(not 3836 ** an error). This could be because format is an empty string 3837 ** or it specifies %p that yields an empty string in some locale. 3838 ** If there is a better way to make it portable, go ahead by 3839 ** all means. 3840 */ 3841 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0')) 3842 return buf; 3843 else { 3844 /* Possibly buf overflowed - try again with a bigger buf */ 3845 int fmtlen = strlen(fmt); 3846 int bufsize = fmtlen + buflen; 3847 3848 New(0, buf, bufsize, char); 3849 while (buf) { 3850 buflen = strftime(buf, bufsize, fmt, &mytm); 3851 if (buflen > 0 && buflen < bufsize) 3852 break; 3853 /* heuristic to prevent out-of-memory errors */ 3854 if (bufsize > 100*fmtlen) { 3855 Safefree(buf); 3856 buf = NULL; 3857 break; 3858 } 3859 bufsize *= 2; 3860 Renew(buf, bufsize, char); 3861 } 3862 return buf; 3863 } 3864 #else 3865 Perl_croak(aTHX_ "panic: no strftime"); 3866 #endif 3867 } 3868 3869 3870 #define SV_CWD_RETURN_UNDEF \ 3871 sv_setsv(sv, &PL_sv_undef); \ 3872 return FALSE 3873 3874 #define SV_CWD_ISDOT(dp) \ 3875 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ 3876 (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) 3877 3878 /* 3879 =head1 Miscellaneous Functions 3880 3881 =for apidoc getcwd_sv 3882 3883 Fill the sv with current working directory 3884 3885 =cut 3886 */ 3887 3888 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. 3889 * rewritten again by dougm, optimized for use with xs TARG, and to prefer 3890 * getcwd(3) if available 3891 * Comments from the orignal: 3892 * This is a faster version of getcwd. It's also more dangerous 3893 * because you might chdir out of a directory that you can't chdir 3894 * back into. */ 3895 3896 int 3897 Perl_getcwd_sv(pTHX_ register SV *sv) 3898 { 3899 #ifndef PERL_MICRO 3900 3901 #ifndef INCOMPLETE_TAINTS 3902 SvTAINTED_on(sv); 3903 #endif 3904 3905 #ifdef HAS_GETCWD 3906 { 3907 char buf[MAXPATHLEN]; 3908 3909 /* Some getcwd()s automatically allocate a buffer of the given 3910 * size from the heap if they are given a NULL buffer pointer. 3911 * The problem is that this behaviour is not portable. */ 3912 if (getcwd(buf, sizeof(buf) - 1)) { 3913 STRLEN len = strlen(buf); 3914 sv_setpvn(sv, buf, len); 3915 return TRUE; 3916 } 3917 else { 3918 sv_setsv(sv, &PL_sv_undef); 3919 return FALSE; 3920 } 3921 } 3922 3923 #else 3924 3925 Stat_t statbuf; 3926 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; 3927 int namelen, pathlen=0; 3928 DIR *dir; 3929 Direntry_t *dp; 3930 3931 (void)SvUPGRADE(sv, SVt_PV); 3932 3933 if (PerlLIO_lstat(".", &statbuf) < 0) { 3934 SV_CWD_RETURN_UNDEF; 3935 } 3936 3937 orig_cdev = statbuf.st_dev; 3938 orig_cino = statbuf.st_ino; 3939 cdev = orig_cdev; 3940 cino = orig_cino; 3941 3942 for (;;) { 3943 odev = cdev; 3944 oino = cino; 3945 3946 if (PerlDir_chdir("..") < 0) { 3947 SV_CWD_RETURN_UNDEF; 3948 } 3949 if (PerlLIO_stat(".", &statbuf) < 0) { 3950 SV_CWD_RETURN_UNDEF; 3951 } 3952 3953 cdev = statbuf.st_dev; 3954 cino = statbuf.st_ino; 3955 3956 if (odev == cdev && oino == cino) { 3957 break; 3958 } 3959 if (!(dir = PerlDir_open("."))) { 3960 SV_CWD_RETURN_UNDEF; 3961 } 3962 3963 while ((dp = PerlDir_read(dir)) != NULL) { 3964 #ifdef DIRNAMLEN 3965 namelen = dp->d_namlen; 3966 #else 3967 namelen = strlen(dp->d_name); 3968 #endif 3969 /* skip . and .. */ 3970 if (SV_CWD_ISDOT(dp)) { 3971 continue; 3972 } 3973 3974 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { 3975 SV_CWD_RETURN_UNDEF; 3976 } 3977 3978 tdev = statbuf.st_dev; 3979 tino = statbuf.st_ino; 3980 if (tino == oino && tdev == odev) { 3981 break; 3982 } 3983 } 3984 3985 if (!dp) { 3986 SV_CWD_RETURN_UNDEF; 3987 } 3988 3989 if (pathlen + namelen + 1 >= MAXPATHLEN) { 3990 SV_CWD_RETURN_UNDEF; 3991 } 3992 3993 SvGROW(sv, pathlen + namelen + 1); 3994 3995 if (pathlen) { 3996 /* shift down */ 3997 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); 3998 } 3999 4000 /* prepend current directory to the front */ 4001 *SvPVX(sv) = '/'; 4002 Move(dp->d_name, SvPVX(sv)+1, namelen, char); 4003 pathlen += (namelen + 1); 4004 4005 #ifdef VOID_CLOSEDIR 4006 PerlDir_close(dir); 4007 #else 4008 if (PerlDir_close(dir) < 0) { 4009 SV_CWD_RETURN_UNDEF; 4010 } 4011 #endif 4012 } 4013 4014 if (pathlen) { 4015 SvCUR_set(sv, pathlen); 4016 *SvEND(sv) = '\0'; 4017 SvPOK_only(sv); 4018 4019 if (PerlDir_chdir(SvPVX(sv)) < 0) { 4020 SV_CWD_RETURN_UNDEF; 4021 } 4022 } 4023 if (PerlLIO_stat(".", &statbuf) < 0) { 4024 SV_CWD_RETURN_UNDEF; 4025 } 4026 4027 cdev = statbuf.st_dev; 4028 cino = statbuf.st_ino; 4029 4030 if (cdev != orig_cdev || cino != orig_cino) { 4031 Perl_croak(aTHX_ "Unstable directory path, " 4032 "current directory changed unexpectedly"); 4033 } 4034 4035 return TRUE; 4036 #endif 4037 4038 #else 4039 return FALSE; 4040 #endif 4041 } 4042 4043 /* 4044 =head1 SV Manipulation Functions 4045 4046 =for apidoc new_vstring 4047 4048 Returns a pointer to the next character after the parsed 4049 vstring, as well as updating the passed in sv. 4050 4051 Function must be called like 4052 4053 sv = NEWSV(92,5); 4054 s = new_vstring(s,sv); 4055 4056 The sv must already be large enough to store the vstring 4057 passed in. 4058 4059 =cut 4060 */ 4061 4062 char * 4063 Perl_new_vstring(pTHX_ char *s, SV *sv) 4064 { 4065 char *pos = s; 4066 if (*pos == 'v') pos++; /* get past 'v' */ 4067 while (isDIGIT(*pos) || *pos == '_') 4068 pos++; 4069 if (!isALPHA(*pos)) { 4070 UV rev; 4071 U8 tmpbuf[UTF8_MAXLEN+1]; 4072 U8 *tmpend; 4073 4074 if (*s == 'v') s++; /* get past 'v' */ 4075 4076 sv_setpvn(sv, "", 0); 4077 4078 for (;;) { 4079 rev = 0; 4080 { 4081 /* this is atoi() that tolerates underscores */ 4082 char *end = pos; 4083 UV mult = 1; 4084 if ( s > pos && *(s-1) == '_') { 4085 mult = 10; 4086 } 4087 while (--end >= s) { 4088 UV orev; 4089 orev = rev; 4090 rev += (*end - '0') * mult; 4091 mult *= 10; 4092 if (orev > rev && ckWARN_d(WARN_OVERFLOW)) 4093 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), 4094 "Integer overflow in decimal number"); 4095 } 4096 } 4097 #ifdef EBCDIC 4098 if (rev > 0x7FFFFFFF) 4099 Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647"); 4100 #endif 4101 /* Append native character for the rev point */ 4102 tmpend = uvchr_to_utf8(tmpbuf, rev); 4103 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); 4104 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev))) 4105 SvUTF8_on(sv); 4106 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1])) 4107 s = ++pos; 4108 else { 4109 s = pos; 4110 break; 4111 } 4112 while (isDIGIT(*pos) ) 4113 pos++; 4114 } 4115 SvPOK_on(sv); 4116 SvREADONLY_on(sv); 4117 } 4118 return s; 4119 } 4120 4121 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) 4122 # define EMULATE_SOCKETPAIR_UDP 4123 #endif 4124 4125 #ifdef EMULATE_SOCKETPAIR_UDP 4126 static int 4127 S_socketpair_udp (int fd[2]) { 4128 dTHX; 4129 /* Fake a datagram socketpair using UDP to localhost. */ 4130 int sockets[2] = {-1, -1}; 4131 struct sockaddr_in addresses[2]; 4132 int i; 4133 Sock_size_t size = sizeof (struct sockaddr_in); 4134 unsigned short port; 4135 int got; 4136 4137 memset (&addresses, 0, sizeof (addresses)); 4138 i = 1; 4139 do { 4140 sockets[i] = PerlSock_socket (AF_INET, SOCK_DGRAM, PF_INET); 4141 if (sockets[i] == -1) 4142 goto tidy_up_and_fail; 4143 4144 addresses[i].sin_family = AF_INET; 4145 addresses[i].sin_addr.s_addr = htonl (INADDR_LOOPBACK); 4146 addresses[i].sin_port = 0; /* kernel choses port. */ 4147 if (PerlSock_bind (sockets[i], (struct sockaddr *) &addresses[i], 4148 sizeof (struct sockaddr_in)) 4149 == -1) 4150 goto tidy_up_and_fail; 4151 } while (i--); 4152 4153 /* Now have 2 UDP sockets. Find out which port each is connected to, and 4154 for each connect the other socket to it. */ 4155 i = 1; 4156 do { 4157 if (PerlSock_getsockname (sockets[i], (struct sockaddr *) &addresses[i], &size) 4158 == -1) 4159 goto tidy_up_and_fail; 4160 if (size != sizeof (struct sockaddr_in)) 4161 goto abort_tidy_up_and_fail; 4162 /* !1 is 0, !0 is 1 */ 4163 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], 4164 sizeof (struct sockaddr_in)) == -1) 4165 goto tidy_up_and_fail; 4166 } while (i--); 4167 4168 /* Now we have 2 sockets connected to each other. I don't trust some other 4169 process not to have already sent a packet to us (by random) so send 4170 a packet from each to the other. */ 4171 i = 1; 4172 do { 4173 /* I'm going to send my own port number. As a short. 4174 (Who knows if someone somewhere has sin_port as a bitfield and needs 4175 this routine. (I'm assuming crays have socketpair)) */ 4176 port = addresses[i].sin_port; 4177 got = PerlLIO_write (sockets[i], &port, sizeof(port)); 4178 if (got != sizeof(port)) { 4179 if (got == -1) 4180 goto tidy_up_and_fail; 4181 goto abort_tidy_up_and_fail; 4182 } 4183 } while (i--); 4184 4185 /* Packets sent. I don't trust them to have arrived though. 4186 (As I understand it Solaris TCP stack is multithreaded. Non-blocking 4187 connect to localhost will use a second kernel thread. In 2.6 the 4188 first thread running the connect() returns before the second completes, 4189 so EINPROGRESS> In 2.7 the improved stack is faster and connect() 4190 returns 0. Poor programs have tripped up. One poor program's authors' 4191 had a 50-1 reverse stock split. Not sure how connected these were.) 4192 So I don't trust someone not to have an unpredictable UDP stack. 4193 */ 4194 4195 { 4196 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ 4197 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; 4198 fd_set rset; 4199 4200 FD_ZERO (&rset); 4201 FD_SET (sockets[0], &rset); 4202 FD_SET (sockets[1], &rset); 4203 4204 got = PerlSock_select (max + 1, &rset, NULL, NULL, &waitfor); 4205 if (got != 2 || !FD_ISSET (sockets[0], &rset) 4206 || !FD_ISSET (sockets[1], &rset)) { 4207 /* I hope this is portable and appropriate. */ 4208 if (got == -1) 4209 goto tidy_up_and_fail; 4210 goto abort_tidy_up_and_fail; 4211 } 4212 } 4213 4214 /* And the paranoia department even now doesn't trust it to have arrive 4215 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */ 4216 { 4217 struct sockaddr_in readfrom; 4218 unsigned short buffer[2]; 4219 4220 i = 1; 4221 do { 4222 #ifdef MSG_DONTWAIT 4223 got = PerlSock_recvfrom (sockets[i], (char *) &buffer, sizeof(buffer), 4224 MSG_DONTWAIT, 4225 (struct sockaddr *) &readfrom, &size); 4226 #else 4227 got = PerlSock_recvfrom (sockets[i], (char *) &buffer, sizeof(buffer), 4228 0, 4229 (struct sockaddr *) &readfrom, &size); 4230 #endif 4231 4232 if (got == -1) 4233 goto tidy_up_and_fail; 4234 if (got != sizeof(port) 4235 || size != sizeof (struct sockaddr_in) 4236 /* Check other socket sent us its port. */ 4237 || buffer[0] != (unsigned short) addresses[!i].sin_port 4238 /* Check kernel says we got the datagram from that socket. */ 4239 || readfrom.sin_family != addresses[!i].sin_family 4240 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr 4241 || readfrom.sin_port != addresses[!i].sin_port) 4242 goto abort_tidy_up_and_fail; 4243 } while (i--); 4244 } 4245 /* My caller (my_socketpair) has validated that this is non-NULL */ 4246 fd[0] = sockets[0]; 4247 fd[1] = sockets[1]; 4248 /* I hereby declare this connection open. May God bless all who cross 4249 her. */ 4250 return 0; 4251 4252 abort_tidy_up_and_fail: 4253 errno = ECONNABORTED; 4254 tidy_up_and_fail: 4255 { 4256 int save_errno = errno; 4257 if (sockets[0] != -1) 4258 PerlLIO_close (sockets[0]); 4259 if (sockets[1] != -1) 4260 PerlLIO_close (sockets[1]); 4261 errno = save_errno; 4262 return -1; 4263 } 4264 } 4265 #endif /* EMULATE_SOCKETPAIR_UDP */ 4266 4267 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) 4268 int 4269 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { 4270 /* Stevens says that family must be AF_LOCAL, protocol 0. 4271 I'm going to enforce that, then ignore it, and use TCP (or UDP). */ 4272 dTHX; 4273 int listener = -1; 4274 int connector = -1; 4275 int acceptor = -1; 4276 struct sockaddr_in listen_addr; 4277 struct sockaddr_in connect_addr; 4278 Sock_size_t size; 4279 4280 if (protocol 4281 #ifdef AF_UNIX 4282 || family != AF_UNIX 4283 #endif 4284 ) { 4285 errno = EAFNOSUPPORT; 4286 return -1; 4287 } 4288 if (!fd) { 4289 errno = EINVAL; 4290 return -1; 4291 } 4292 4293 #ifdef EMULATE_SOCKETPAIR_UDP 4294 if (type == SOCK_DGRAM) 4295 return S_socketpair_udp (fd); 4296 #endif 4297 4298 listener = PerlSock_socket (AF_INET, type, 0); 4299 if (listener == -1) 4300 return -1; 4301 memset (&listen_addr, 0, sizeof (listen_addr)); 4302 listen_addr.sin_family = AF_INET; 4303 listen_addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK); 4304 listen_addr.sin_port = 0; /* kernel choses port. */ 4305 if (PerlSock_bind (listener, (struct sockaddr *) &listen_addr, sizeof (listen_addr)) 4306 == -1) 4307 goto tidy_up_and_fail; 4308 if (PerlSock_listen(listener, 1) == -1) 4309 goto tidy_up_and_fail; 4310 4311 connector = PerlSock_socket (AF_INET, type, 0); 4312 if (connector == -1) 4313 goto tidy_up_and_fail; 4314 /* We want to find out the port number to connect to. */ 4315 size = sizeof (connect_addr); 4316 if (PerlSock_getsockname (listener, (struct sockaddr *) &connect_addr, &size) == -1) 4317 goto tidy_up_and_fail; 4318 if (size != sizeof (connect_addr)) 4319 goto abort_tidy_up_and_fail; 4320 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr, 4321 sizeof (connect_addr)) == -1) 4322 goto tidy_up_and_fail; 4323 4324 size = sizeof (listen_addr); 4325 acceptor = PerlSock_accept (listener, (struct sockaddr *) &listen_addr, &size); 4326 if (acceptor == -1) 4327 goto tidy_up_and_fail; 4328 if (size != sizeof (listen_addr)) 4329 goto abort_tidy_up_and_fail; 4330 PerlLIO_close (listener); 4331 /* Now check we are talking to ourself by matching port and host on the 4332 two sockets. */ 4333 if (PerlSock_getsockname (connector, (struct sockaddr *) &connect_addr, &size) == -1) 4334 goto tidy_up_and_fail; 4335 if (size != sizeof (connect_addr) 4336 || listen_addr.sin_family != connect_addr.sin_family 4337 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr 4338 || listen_addr.sin_port != connect_addr.sin_port) { 4339 goto abort_tidy_up_and_fail; 4340 } 4341 fd[0] = connector; 4342 fd[1] = acceptor; 4343 return 0; 4344 4345 abort_tidy_up_and_fail: 4346 errno = ECONNABORTED; /* I hope this is portable and appropriate. */ 4347 tidy_up_and_fail: 4348 { 4349 int save_errno = errno; 4350 if (listener != -1) 4351 PerlLIO_close (listener); 4352 if (connector != -1) 4353 PerlLIO_close (connector); 4354 if (acceptor != -1) 4355 PerlLIO_close (acceptor); 4356 errno = save_errno; 4357 return -1; 4358 } 4359 } 4360 #else 4361 /* In any case have a stub so that there's code corresponding 4362 * to the my_socketpair in global.sym. */ 4363 int 4364 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { 4365 #ifdef HAS_SOCKETPAIR 4366 return socketpair(family, type, protocol, fd); 4367 #else 4368 return -1; 4369 #endif 4370 } 4371 #endif 4372 4373 /* 4374 4375 =for apidoc sv_nosharing 4376 4377 Dummy routine which "shares" an SV when there is no sharing module present. 4378 Exists to avoid test for a NULL function pointer and because it could potentially warn under 4379 some level of strict-ness. 4380 4381 =cut 4382 */ 4383 4384 void 4385 Perl_sv_nosharing(pTHX_ SV *sv) 4386 { 4387 } 4388 4389 /* 4390 =for apidoc sv_nolocking 4391 4392 Dummy routine which "locks" an SV when there is no locking module present. 4393 Exists to avoid test for a NULL function pointer and because it could potentially warn under 4394 some level of strict-ness. 4395 4396 =cut 4397 */ 4398 4399 void 4400 Perl_sv_nolocking(pTHX_ SV *sv) 4401 { 4402 } 4403 4404 4405 /* 4406 =for apidoc sv_nounlocking 4407 4408 Dummy routine which "unlocks" an SV when there is no locking module present. 4409 Exists to avoid test for a NULL function pointer and because it could potentially warn under 4410 some level of strict-ness. 4411 4412 =cut 4413 */ 4414 4415 void 4416 Perl_sv_nounlocking(pTHX_ SV *sv) 4417 { 4418 } 4419 4420