1 /* util.c 2 * 3 * Copyright (c) 1991-2001, 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 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) 20 #include <signal.h> 21 #endif 22 23 #ifndef SIG_ERR 24 # define SIG_ERR ((Sighandler_t) -1) 25 #endif 26 27 #ifdef I_VFORK 28 # include <vfork.h> 29 #endif 30 31 /* Put this after #includes because fork and vfork prototypes may 32 conflict. 33 */ 34 #ifndef HAS_VFORK 35 # define vfork fork 36 #endif 37 38 #ifdef I_SYS_WAIT 39 # include <sys/wait.h> 40 #endif 41 42 #ifdef I_LOCALE 43 # include <locale.h> 44 #endif 45 46 #define FLUSH 47 48 #ifdef LEAKTEST 49 50 long xcount[MAXXCOUNT]; 51 long lastxcount[MAXXCOUNT]; 52 long xycount[MAXXCOUNT][MAXYCOUNT]; 53 long lastxycount[MAXXCOUNT][MAXYCOUNT]; 54 55 #endif 56 57 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) 58 # define FD_CLOEXEC 1 /* NeXT needs this */ 59 #endif 60 61 /* paranoid version of system's malloc() */ 62 63 /* NOTE: Do not call the next three routines directly. Use the macros 64 * in handy.h, so that we can easily redefine everything to do tracking of 65 * allocated hunks back to the original New to track down any memory leaks. 66 * XXX This advice seems to be widely ignored :-( --AD August 1996. 67 */ 68 69 Malloc_t 70 Perl_safesysmalloc(MEM_SIZE size) 71 { 72 dTHX; 73 Malloc_t ptr; 74 #ifdef HAS_64K_LIMIT 75 if (size > 0xffff) { 76 PerlIO_printf(Perl_error_log, 77 "Allocation too large: %lx\n", size) FLUSH; 78 my_exit(1); 79 } 80 #endif /* HAS_64K_LIMIT */ 81 #ifdef DEBUGGING 82 if ((long)size < 0) 83 Perl_croak_nocontext("panic: malloc"); 84 #endif 85 ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ 86 PERL_ALLOC_CHECK(ptr); 87 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 88 if (ptr != Nullch) 89 return ptr; 90 else if (PL_nomemok) 91 return Nullch; 92 else { 93 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; 94 my_exit(1); 95 return Nullch; 96 } 97 /*NOTREACHED*/ 98 } 99 100 /* paranoid version of system's realloc() */ 101 102 Malloc_t 103 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) 104 { 105 dTHX; 106 Malloc_t ptr; 107 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO) 108 Malloc_t PerlMem_realloc(); 109 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ 110 111 #ifdef HAS_64K_LIMIT 112 if (size > 0xffff) { 113 PerlIO_printf(Perl_error_log, 114 "Reallocation too large: %lx\n", size) FLUSH; 115 my_exit(1); 116 } 117 #endif /* HAS_64K_LIMIT */ 118 if (!size) { 119 safesysfree(where); 120 return NULL; 121 } 122 123 if (!where) 124 return safesysmalloc(size); 125 #ifdef DEBUGGING 126 if ((long)size < 0) 127 Perl_croak_nocontext("panic: realloc"); 128 #endif 129 ptr = PerlMem_realloc(where,size); 130 PERL_ALLOC_CHECK(ptr); 131 132 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); 133 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 134 135 if (ptr != Nullch) 136 return ptr; 137 else if (PL_nomemok) 138 return Nullch; 139 else { 140 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; 141 my_exit(1); 142 return Nullch; 143 } 144 /*NOTREACHED*/ 145 } 146 147 /* safe version of system's free() */ 148 149 Free_t 150 Perl_safesysfree(Malloc_t where) 151 { 152 #ifdef PERL_IMPLICIT_SYS 153 dTHX; 154 #endif 155 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); 156 if (where) { 157 /*SUPPRESS 701*/ 158 PerlMem_free(where); 159 } 160 } 161 162 /* safe version of system's calloc() */ 163 164 Malloc_t 165 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) 166 { 167 dTHX; 168 Malloc_t ptr; 169 170 #ifdef HAS_64K_LIMIT 171 if (size * count > 0xffff) { 172 PerlIO_printf(Perl_error_log, 173 "Allocation too large: %lx\n", size * count) FLUSH; 174 my_exit(1); 175 } 176 #endif /* HAS_64K_LIMIT */ 177 #ifdef DEBUGGING 178 if ((long)size < 0 || (long)count < 0) 179 Perl_croak_nocontext("panic: calloc"); 180 #endif 181 size *= count; 182 ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ 183 PERL_ALLOC_CHECK(ptr); 184 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)); 185 if (ptr != Nullch) { 186 memset((void*)ptr, 0, size); 187 return ptr; 188 } 189 else if (PL_nomemok) 190 return Nullch; 191 else { 192 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH; 193 my_exit(1); 194 return Nullch; 195 } 196 /*NOTREACHED*/ 197 } 198 199 #ifdef LEAKTEST 200 201 struct mem_test_strut { 202 union { 203 long type; 204 char c[2]; 205 } u; 206 long size; 207 }; 208 209 # define ALIGN sizeof(struct mem_test_strut) 210 211 # define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size) 212 # define typeof_chunk(ch) \ 213 (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100) 214 # define set_typeof_chunk(ch,t) \ 215 (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100) 216 #define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \ 217 ? MAXYCOUNT - 1 \ 218 : ( (size) > 40 \ 219 ? ((size) - 1)/8 + 5 \ 220 : ((size) - 1)/4)) 221 222 Malloc_t 223 Perl_safexmalloc(I32 x, MEM_SIZE size) 224 { 225 register char* where = (char*)safemalloc(size + ALIGN); 226 227 xcount[x] += size; 228 xycount[x][SIZE_TO_Y(size)]++; 229 set_typeof_chunk(where, x); 230 sizeof_chunk(where) = size; 231 return (Malloc_t)(where + ALIGN); 232 } 233 234 Malloc_t 235 Perl_safexrealloc(Malloc_t wh, MEM_SIZE size) 236 { 237 char *where = (char*)wh; 238 239 if (!wh) 240 return safexmalloc(0,size); 241 242 { 243 MEM_SIZE old = sizeof_chunk(where - ALIGN); 244 int t = typeof_chunk(where - ALIGN); 245 register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN); 246 247 xycount[t][SIZE_TO_Y(old)]--; 248 xycount[t][SIZE_TO_Y(size)]++; 249 xcount[t] += size - old; 250 sizeof_chunk(new) = size; 251 return (Malloc_t)(new + ALIGN); 252 } 253 } 254 255 void 256 Perl_safexfree(Malloc_t wh) 257 { 258 I32 x; 259 char *where = (char*)wh; 260 MEM_SIZE size; 261 262 if (!where) 263 return; 264 where -= ALIGN; 265 size = sizeof_chunk(where); 266 x = where[0] + 100 * where[1]; 267 xcount[x] -= size; 268 xycount[x][SIZE_TO_Y(size)]--; 269 safefree(where); 270 } 271 272 Malloc_t 273 Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size) 274 { 275 register char * where = (char*)safexmalloc(x, size * count + ALIGN); 276 xcount[x] += size; 277 xycount[x][SIZE_TO_Y(size)]++; 278 memset((void*)(where + ALIGN), 0, size * count); 279 set_typeof_chunk(where, x); 280 sizeof_chunk(where) = size; 281 return (Malloc_t)(where + ALIGN); 282 } 283 284 STATIC void 285 S_xstat(pTHX_ int flag) 286 { 287 register I32 i, j, total = 0; 288 I32 subtot[MAXYCOUNT]; 289 290 for (j = 0; j < MAXYCOUNT; j++) { 291 subtot[j] = 0; 292 } 293 294 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); 295 for (i = 0; i < MAXXCOUNT; i++) { 296 total += xcount[i]; 297 for (j = 0; j < MAXYCOUNT; j++) { 298 subtot[j] += xycount[i][j]; 299 } 300 if (flag == 0 301 ? xcount[i] /* Have something */ 302 : (flag == 2 303 ? xcount[i] != lastxcount[i] /* Changed */ 304 : xcount[i] > lastxcount[i])) { /* Growed */ 305 PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100, 306 flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]); 307 lastxcount[i] = xcount[i]; 308 for (j = 0; j < MAXYCOUNT; j++) { 309 if ( flag == 0 310 ? xycount[i][j] /* Have something */ 311 : (flag == 2 312 ? xycount[i][j] != lastxycount[i][j] /* Changed */ 313 : xycount[i][j] > lastxycount[i][j])) { /* Growed */ 314 PerlIO_printf(Perl_debug_log,"%3ld ", 315 flag == 2 316 ? xycount[i][j] - lastxycount[i][j] 317 : xycount[i][j]); 318 lastxycount[i][j] = xycount[i][j]; 319 } else { 320 PerlIO_printf(Perl_debug_log, " . ", xycount[i][j]); 321 } 322 } 323 PerlIO_printf(Perl_debug_log, "\n"); 324 } 325 } 326 if (flag != 2) { 327 PerlIO_printf(Perl_debug_log, "Total %7ld ", total); 328 for (j = 0; j < MAXYCOUNT; j++) { 329 if (subtot[j]) { 330 PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]); 331 } else { 332 PerlIO_printf(Perl_debug_log, " . "); 333 } 334 } 335 PerlIO_printf(Perl_debug_log, "\n"); 336 } 337 } 338 339 #endif /* LEAKTEST */ 340 341 /* copy a string up to some (non-backslashed) delimiter, if any */ 342 343 char * 344 Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen) 345 { 346 register I32 tolen; 347 for (tolen = 0; from < fromend; from++, tolen++) { 348 if (*from == '\\') { 349 if (from[1] == delim) 350 from++; 351 else { 352 if (to < toend) 353 *to++ = *from; 354 tolen++; 355 from++; 356 } 357 } 358 else if (*from == delim) 359 break; 360 if (to < toend) 361 *to++ = *from; 362 } 363 if (to < toend) 364 *to = '\0'; 365 *retlen = tolen; 366 return from; 367 } 368 369 /* return ptr to little string in big string, NULL if not found */ 370 /* This routine was donated by Corey Satten. */ 371 372 char * 373 Perl_instr(pTHX_ register const char *big, register const char *little) 374 { 375 register const char *s, *x; 376 register I32 first; 377 378 if (!little) 379 return (char*)big; 380 first = *little++; 381 if (!first) 382 return (char*)big; 383 while (*big) { 384 if (*big++ != first) 385 continue; 386 for (x=big,s=little; *s; /**/ ) { 387 if (!*x) 388 return Nullch; 389 if (*s++ != *x++) { 390 s--; 391 break; 392 } 393 } 394 if (!*s) 395 return (char*)(big-1); 396 } 397 return Nullch; 398 } 399 400 /* same as instr but allow embedded nulls */ 401 402 char * 403 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend) 404 { 405 register const char *s, *x; 406 register I32 first = *little; 407 register const char *littleend = lend; 408 409 if (!first && little >= littleend) 410 return (char*)big; 411 if (bigend - big < littleend - little) 412 return Nullch; 413 bigend -= littleend - little++; 414 while (big <= bigend) { 415 if (*big++ != first) 416 continue; 417 for (x=big,s=little; s < littleend; /**/ ) { 418 if (*s++ != *x++) { 419 s--; 420 break; 421 } 422 } 423 if (s >= littleend) 424 return (char*)(big-1); 425 } 426 return Nullch; 427 } 428 429 /* reverse of the above--find last substring */ 430 431 char * 432 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend) 433 { 434 register const char *bigbeg; 435 register const char *s, *x; 436 register I32 first = *little; 437 register const char *littleend = lend; 438 439 if (!first && little >= littleend) 440 return (char*)bigend; 441 bigbeg = big; 442 big = bigend - (littleend - little++); 443 while (big >= bigbeg) { 444 if (*big-- != first) 445 continue; 446 for (x=big+2,s=little; s < littleend; /**/ ) { 447 if (*s++ != *x++) { 448 s--; 449 break; 450 } 451 } 452 if (s >= littleend) 453 return (char*)(big+1); 454 } 455 return Nullch; 456 } 457 458 /* 459 * Set up for a new ctype locale. 460 */ 461 void 462 Perl_new_ctype(pTHX_ char *newctype) 463 { 464 #ifdef USE_LOCALE_CTYPE 465 466 int i; 467 468 for (i = 0; i < 256; i++) { 469 if (isUPPER_LC(i)) 470 PL_fold_locale[i] = toLOWER_LC(i); 471 else if (isLOWER_LC(i)) 472 PL_fold_locale[i] = toUPPER_LC(i); 473 else 474 PL_fold_locale[i] = i; 475 } 476 477 #endif /* USE_LOCALE_CTYPE */ 478 } 479 480 /* 481 * Standardize the locale name from a string returned by 'setlocale'. 482 * 483 * The standard return value of setlocale() is either 484 * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL 485 * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL 486 * (the space-separated values represent the various sublocales, 487 * in some unspecificed order) 488 * 489 * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n", 490 * which is harmful for further use of the string in setlocale(). 491 * 492 */ 493 STATIC char * 494 S_stdize_locale(pTHX_ char *locs) 495 { 496 char *s; 497 bool okay = TRUE; 498 499 if ((s = strchr(locs, '='))) { 500 char *t; 501 502 okay = FALSE; 503 if ((t = strchr(s, '.'))) { 504 char *u; 505 506 if ((u = strchr(t, '\n'))) { 507 508 if (u[1] == 0) { 509 STRLEN len = u - s; 510 Move(s + 1, locs, len, char); 511 locs[len] = 0; 512 okay = TRUE; 513 } 514 } 515 } 516 } 517 518 if (!okay) 519 Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs); 520 521 return locs; 522 } 523 524 /* 525 * Set up for a new collation locale. 526 */ 527 void 528 Perl_new_collate(pTHX_ char *newcoll) 529 { 530 #ifdef USE_LOCALE_COLLATE 531 532 if (! newcoll) { 533 if (PL_collation_name) { 534 ++PL_collation_ix; 535 Safefree(PL_collation_name); 536 PL_collation_name = NULL; 537 } 538 PL_collation_standard = TRUE; 539 PL_collxfrm_base = 0; 540 PL_collxfrm_mult = 2; 541 return; 542 } 543 544 if (! PL_collation_name || strNE(PL_collation_name, newcoll)) { 545 ++PL_collation_ix; 546 Safefree(PL_collation_name); 547 PL_collation_name = stdize_locale(savepv(newcoll)); 548 PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); 549 550 { 551 /* 2: at most so many chars ('a', 'b'). */ 552 /* 50: surely no system expands a char more. */ 553 #define XFRMBUFSIZE (2 * 50) 554 char xbuf[XFRMBUFSIZE]; 555 Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE); 556 Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE); 557 SSize_t mult = fb - fa; 558 if (mult < 1) 559 Perl_croak(aTHX_ "strxfrm() gets absurd"); 560 PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0; 561 PL_collxfrm_mult = mult; 562 } 563 } 564 565 #endif /* USE_LOCALE_COLLATE */ 566 } 567 568 void 569 Perl_set_numeric_radix(pTHX) 570 { 571 #ifdef USE_LOCALE_NUMERIC 572 # ifdef HAS_LOCALECONV 573 struct lconv* lc; 574 575 lc = localeconv(); 576 if (lc && lc->decimal_point) { 577 if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) { 578 SvREFCNT_dec(PL_numeric_radix_sv); 579 PL_numeric_radix_sv = 0; 580 } 581 else { 582 if (PL_numeric_radix_sv) 583 sv_setpv(PL_numeric_radix_sv, lc->decimal_point); 584 else 585 PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0); 586 } 587 } 588 else 589 PL_numeric_radix_sv = 0; 590 # endif /* HAS_LOCALECONV */ 591 #endif /* USE_LOCALE_NUMERIC */ 592 } 593 594 /* 595 * Set up for a new numeric locale. 596 */ 597 void 598 Perl_new_numeric(pTHX_ char *newnum) 599 { 600 #ifdef USE_LOCALE_NUMERIC 601 602 if (! newnum) { 603 if (PL_numeric_name) { 604 Safefree(PL_numeric_name); 605 PL_numeric_name = NULL; 606 } 607 PL_numeric_standard = TRUE; 608 PL_numeric_local = TRUE; 609 return; 610 } 611 612 if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) { 613 Safefree(PL_numeric_name); 614 PL_numeric_name = stdize_locale(savepv(newnum)); 615 PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); 616 PL_numeric_local = TRUE; 617 set_numeric_radix(); 618 } 619 620 #endif /* USE_LOCALE_NUMERIC */ 621 } 622 623 void 624 Perl_set_numeric_standard(pTHX) 625 { 626 #ifdef USE_LOCALE_NUMERIC 627 628 if (! PL_numeric_standard) { 629 setlocale(LC_NUMERIC, "C"); 630 PL_numeric_standard = TRUE; 631 PL_numeric_local = FALSE; 632 set_numeric_radix(); 633 } 634 635 #endif /* USE_LOCALE_NUMERIC */ 636 } 637 638 void 639 Perl_set_numeric_local(pTHX) 640 { 641 #ifdef USE_LOCALE_NUMERIC 642 643 if (! PL_numeric_local) { 644 setlocale(LC_NUMERIC, PL_numeric_name); 645 PL_numeric_standard = FALSE; 646 PL_numeric_local = TRUE; 647 set_numeric_radix(); 648 } 649 650 #endif /* USE_LOCALE_NUMERIC */ 651 } 652 653 /* 654 * Initialize locale awareness. 655 */ 656 int 657 Perl_init_i18nl10n(pTHX_ int printwarn) 658 { 659 int ok = 1; 660 /* returns 661 * 1 = set ok or not applicable, 662 * 0 = fallback to C locale, 663 * -1 = fallback to C locale failed 664 */ 665 666 #if defined(USE_LOCALE) 667 668 #ifdef USE_LOCALE_CTYPE 669 char *curctype = NULL; 670 #endif /* USE_LOCALE_CTYPE */ 671 #ifdef USE_LOCALE_COLLATE 672 char *curcoll = NULL; 673 #endif /* USE_LOCALE_COLLATE */ 674 #ifdef USE_LOCALE_NUMERIC 675 char *curnum = NULL; 676 #endif /* USE_LOCALE_NUMERIC */ 677 #ifdef __GLIBC__ 678 char *language = PerlEnv_getenv("LANGUAGE"); 679 #endif 680 char *lc_all = PerlEnv_getenv("LC_ALL"); 681 char *lang = PerlEnv_getenv("LANG"); 682 bool setlocale_failure = FALSE; 683 684 #ifdef LOCALE_ENVIRON_REQUIRED 685 686 /* 687 * Ultrix setlocale(..., "") fails if there are no environment 688 * variables from which to get a locale name. 689 */ 690 691 bool done = FALSE; 692 693 #ifdef LC_ALL 694 if (lang) { 695 if (setlocale(LC_ALL, "")) 696 done = TRUE; 697 else 698 setlocale_failure = TRUE; 699 } 700 if (!setlocale_failure) { 701 #ifdef USE_LOCALE_CTYPE 702 if (! (curctype = 703 setlocale(LC_CTYPE, 704 (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) 705 ? "" : Nullch))) 706 setlocale_failure = TRUE; 707 else 708 curctype = savepv(curctype); 709 #endif /* USE_LOCALE_CTYPE */ 710 #ifdef USE_LOCALE_COLLATE 711 if (! (curcoll = 712 setlocale(LC_COLLATE, 713 (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) 714 ? "" : Nullch))) 715 setlocale_failure = TRUE; 716 else 717 curcoll = savepv(curcoll); 718 #endif /* USE_LOCALE_COLLATE */ 719 #ifdef USE_LOCALE_NUMERIC 720 if (! (curnum = 721 setlocale(LC_NUMERIC, 722 (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) 723 ? "" : Nullch))) 724 setlocale_failure = TRUE; 725 else 726 curnum = savepv(curnum); 727 #endif /* USE_LOCALE_NUMERIC */ 728 } 729 730 #endif /* LC_ALL */ 731 732 #endif /* !LOCALE_ENVIRON_REQUIRED */ 733 734 #ifdef LC_ALL 735 if (! setlocale(LC_ALL, "")) 736 setlocale_failure = TRUE; 737 #endif /* LC_ALL */ 738 739 if (!setlocale_failure) { 740 #ifdef USE_LOCALE_CTYPE 741 if (! (curctype = setlocale(LC_CTYPE, ""))) 742 setlocale_failure = TRUE; 743 else 744 curctype = savepv(curctype); 745 #endif /* USE_LOCALE_CTYPE */ 746 #ifdef USE_LOCALE_COLLATE 747 if (! (curcoll = setlocale(LC_COLLATE, ""))) 748 setlocale_failure = TRUE; 749 else 750 curcoll = savepv(curcoll); 751 #endif /* USE_LOCALE_COLLATE */ 752 #ifdef USE_LOCALE_NUMERIC 753 if (! (curnum = setlocale(LC_NUMERIC, ""))) 754 setlocale_failure = TRUE; 755 else 756 curnum = savepv(curnum); 757 #endif /* USE_LOCALE_NUMERIC */ 758 } 759 760 if (setlocale_failure) { 761 char *p; 762 bool locwarn = (printwarn > 1 || 763 (printwarn && 764 (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)))); 765 766 if (locwarn) { 767 #ifdef LC_ALL 768 769 PerlIO_printf(Perl_error_log, 770 "perl: warning: Setting locale failed.\n"); 771 772 #else /* !LC_ALL */ 773 774 PerlIO_printf(Perl_error_log, 775 "perl: warning: Setting locale failed for the categories:\n\t"); 776 #ifdef USE_LOCALE_CTYPE 777 if (! curctype) 778 PerlIO_printf(Perl_error_log, "LC_CTYPE "); 779 #endif /* USE_LOCALE_CTYPE */ 780 #ifdef USE_LOCALE_COLLATE 781 if (! curcoll) 782 PerlIO_printf(Perl_error_log, "LC_COLLATE "); 783 #endif /* USE_LOCALE_COLLATE */ 784 #ifdef USE_LOCALE_NUMERIC 785 if (! curnum) 786 PerlIO_printf(Perl_error_log, "LC_NUMERIC "); 787 #endif /* USE_LOCALE_NUMERIC */ 788 PerlIO_printf(Perl_error_log, "\n"); 789 790 #endif /* LC_ALL */ 791 792 PerlIO_printf(Perl_error_log, 793 "perl: warning: Please check that your locale settings:\n"); 794 795 #ifdef __GLIBC__ 796 PerlIO_printf(Perl_error_log, 797 "\tLANGUAGE = %c%s%c,\n", 798 language ? '"' : '(', 799 language ? language : "unset", 800 language ? '"' : ')'); 801 #endif 802 803 PerlIO_printf(Perl_error_log, 804 "\tLC_ALL = %c%s%c,\n", 805 lc_all ? '"' : '(', 806 lc_all ? lc_all : "unset", 807 lc_all ? '"' : ')'); 808 809 #if defined(USE_ENVIRON_ARRAY) 810 { 811 char **e; 812 for (e = environ; *e; e++) { 813 if (strnEQ(*e, "LC_", 3) 814 && strnNE(*e, "LC_ALL=", 7) 815 && (p = strchr(*e, '='))) 816 PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n", 817 (int)(p - *e), *e, p + 1); 818 } 819 } 820 #else 821 PerlIO_printf(Perl_error_log, 822 "\t(possibly more locale environment variables)\n"); 823 #endif 824 825 PerlIO_printf(Perl_error_log, 826 "\tLANG = %c%s%c\n", 827 lang ? '"' : '(', 828 lang ? lang : "unset", 829 lang ? '"' : ')'); 830 831 PerlIO_printf(Perl_error_log, 832 " are supported and installed on your system.\n"); 833 } 834 835 #ifdef LC_ALL 836 837 if (setlocale(LC_ALL, "C")) { 838 if (locwarn) 839 PerlIO_printf(Perl_error_log, 840 "perl: warning: Falling back to the standard locale (\"C\").\n"); 841 ok = 0; 842 } 843 else { 844 if (locwarn) 845 PerlIO_printf(Perl_error_log, 846 "perl: warning: Failed to fall back to the standard locale (\"C\").\n"); 847 ok = -1; 848 } 849 850 #else /* ! LC_ALL */ 851 852 if (0 853 #ifdef USE_LOCALE_CTYPE 854 || !(curctype || setlocale(LC_CTYPE, "C")) 855 #endif /* USE_LOCALE_CTYPE */ 856 #ifdef USE_LOCALE_COLLATE 857 || !(curcoll || setlocale(LC_COLLATE, "C")) 858 #endif /* USE_LOCALE_COLLATE */ 859 #ifdef USE_LOCALE_NUMERIC 860 || !(curnum || setlocale(LC_NUMERIC, "C")) 861 #endif /* USE_LOCALE_NUMERIC */ 862 ) 863 { 864 if (locwarn) 865 PerlIO_printf(Perl_error_log, 866 "perl: warning: Cannot fall back to the standard locale (\"C\").\n"); 867 ok = -1; 868 } 869 870 #endif /* ! LC_ALL */ 871 872 #ifdef USE_LOCALE_CTYPE 873 curctype = savepv(setlocale(LC_CTYPE, Nullch)); 874 #endif /* USE_LOCALE_CTYPE */ 875 #ifdef USE_LOCALE_COLLATE 876 curcoll = savepv(setlocale(LC_COLLATE, Nullch)); 877 #endif /* USE_LOCALE_COLLATE */ 878 #ifdef USE_LOCALE_NUMERIC 879 curnum = savepv(setlocale(LC_NUMERIC, Nullch)); 880 #endif /* USE_LOCALE_NUMERIC */ 881 } 882 else { 883 884 #ifdef USE_LOCALE_CTYPE 885 new_ctype(curctype); 886 #endif /* USE_LOCALE_CTYPE */ 887 888 #ifdef USE_LOCALE_COLLATE 889 new_collate(curcoll); 890 #endif /* USE_LOCALE_COLLATE */ 891 892 #ifdef USE_LOCALE_NUMERIC 893 new_numeric(curnum); 894 #endif /* USE_LOCALE_NUMERIC */ 895 } 896 897 #endif /* USE_LOCALE */ 898 899 #ifdef USE_LOCALE_CTYPE 900 if (curctype != NULL) 901 Safefree(curctype); 902 #endif /* USE_LOCALE_CTYPE */ 903 #ifdef USE_LOCALE_COLLATE 904 if (curcoll != NULL) 905 Safefree(curcoll); 906 #endif /* USE_LOCALE_COLLATE */ 907 #ifdef USE_LOCALE_NUMERIC 908 if (curnum != NULL) 909 Safefree(curnum); 910 #endif /* USE_LOCALE_NUMERIC */ 911 return ok; 912 } 913 914 /* Backwards compatibility. */ 915 int 916 Perl_init_i18nl14n(pTHX_ int printwarn) 917 { 918 return init_i18nl10n(printwarn); 919 } 920 921 #ifdef USE_LOCALE_COLLATE 922 923 /* 924 * mem_collxfrm() is a bit like strxfrm() but with two important 925 * differences. First, it handles embedded NULs. Second, it allocates 926 * a bit more memory than needed for the transformed data itself. 927 * The real transformed data begins at offset sizeof(collationix). 928 * Please see sv_collxfrm() to see how this is used. 929 */ 930 char * 931 Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) 932 { 933 char *xbuf; 934 STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */ 935 936 /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */ 937 /* the +1 is for the terminating NUL. */ 938 939 xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1; 940 New(171, xbuf, xAlloc, char); 941 if (! xbuf) 942 goto bad; 943 944 *(U32*)xbuf = PL_collation_ix; 945 xout = sizeof(PL_collation_ix); 946 for (xin = 0; xin < len; ) { 947 SSize_t xused; 948 949 for (;;) { 950 xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout); 951 if (xused == -1) 952 goto bad; 953 if (xused < xAlloc - xout) 954 break; 955 xAlloc = (2 * xAlloc) + 1; 956 Renew(xbuf, xAlloc, char); 957 if (! xbuf) 958 goto bad; 959 } 960 961 xin += strlen(s + xin) + 1; 962 xout += xused; 963 964 /* Embedded NULs are understood but silently skipped 965 * because they make no sense in locale collation. */ 966 } 967 968 xbuf[xout] = '\0'; 969 *xlen = xout - sizeof(PL_collation_ix); 970 return xbuf; 971 972 bad: 973 Safefree(xbuf); 974 *xlen = 0; 975 return NULL; 976 } 977 978 #endif /* USE_LOCALE_COLLATE */ 979 980 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/ 981 982 /* As a space optimization, we do not compile tables for strings of length 983 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are 984 special-cased in fbm_instr(). 985 986 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ 987 988 /* 989 =for apidoc fbm_compile 990 991 Analyses the string in order to make fast searches on it using fbm_instr() 992 -- the Boyer-Moore algorithm. 993 994 =cut 995 */ 996 997 void 998 Perl_fbm_compile(pTHX_ SV *sv, U32 flags) 999 { 1000 register U8 *s; 1001 register U8 *table; 1002 register U32 i; 1003 STRLEN len; 1004 I32 rarest = 0; 1005 U32 frequency = 256; 1006 1007 if (flags & FBMcf_TAIL) 1008 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ 1009 s = (U8*)SvPV_force(sv, len); 1010 (void)SvUPGRADE(sv, SVt_PVBM); 1011 if (len == 0) /* TAIL might be on on a zero-length string. */ 1012 return; 1013 if (len > 2) { 1014 U8 mlen; 1015 unsigned char *sb; 1016 1017 if (len > 255) 1018 mlen = 255; 1019 else 1020 mlen = (U8)len; 1021 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET); 1022 table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET); 1023 s = table - 1 - FBM_TABLE_OFFSET; /* last char */ 1024 memset((void*)table, mlen, 256); 1025 table[-1] = (U8)flags; 1026 i = 0; 1027 sb = s - mlen + 1; /* first char (maybe) */ 1028 while (s >= sb) { 1029 if (table[*s] == mlen) 1030 table[*s] = (U8)i; 1031 s--, i++; 1032 } 1033 } 1034 sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ 1035 SvVALID_on(sv); 1036 1037 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ 1038 for (i = 0; i < len; i++) { 1039 if (PL_freq[s[i]] < frequency) { 1040 rarest = i; 1041 frequency = PL_freq[s[i]]; 1042 } 1043 } 1044 BmRARE(sv) = s[rarest]; 1045 BmPREVIOUS(sv) = rarest; 1046 BmUSEFUL(sv) = 100; /* Initial value */ 1047 if (flags & FBMcf_TAIL) 1048 SvTAIL_on(sv); 1049 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n", 1050 BmRARE(sv),BmPREVIOUS(sv))); 1051 } 1052 1053 /* If SvTAIL(littlestr), it has a fake '\n' at end. */ 1054 /* If SvTAIL is actually due to \Z or \z, this gives false positives 1055 if multiline */ 1056 1057 /* 1058 =for apidoc fbm_instr 1059 1060 Returns the location of the SV in the string delimited by C<str> and 1061 C<strend>. It returns C<Nullch> if the string can't be found. The C<sv> 1062 does not have to be fbm_compiled, but the search will not be as fast 1063 then. 1064 1065 =cut 1066 */ 1067 1068 char * 1069 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags) 1070 { 1071 register unsigned char *s; 1072 STRLEN l; 1073 register unsigned char *little = (unsigned char *)SvPV(littlestr,l); 1074 register STRLEN littlelen = l; 1075 register I32 multiline = flags & FBMrf_MULTILINE; 1076 1077 if (bigend - big < littlelen) { 1078 if ( SvTAIL(littlestr) 1079 && (bigend - big == littlelen - 1) 1080 && (littlelen == 1 1081 || (*big == *little && memEQ(big, little, littlelen - 1)))) 1082 return (char*)big; 1083 return Nullch; 1084 } 1085 1086 if (littlelen <= 2) { /* Special-cased */ 1087 1088 if (littlelen == 1) { 1089 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ 1090 /* Know that bigend != big. */ 1091 if (bigend[-1] == '\n') 1092 return (char *)(bigend - 1); 1093 return (char *) bigend; 1094 } 1095 s = big; 1096 while (s < bigend) { 1097 if (*s == *little) 1098 return (char *)s; 1099 s++; 1100 } 1101 if (SvTAIL(littlestr)) 1102 return (char *) bigend; 1103 return Nullch; 1104 } 1105 if (!littlelen) 1106 return (char*)big; /* Cannot be SvTAIL! */ 1107 1108 /* littlelen is 2 */ 1109 if (SvTAIL(littlestr) && !multiline) { 1110 if (bigend[-1] == '\n' && bigend[-2] == *little) 1111 return (char*)bigend - 2; 1112 if (bigend[-1] == *little) 1113 return (char*)bigend - 1; 1114 return Nullch; 1115 } 1116 { 1117 /* This should be better than FBM if c1 == c2, and almost 1118 as good otherwise: maybe better since we do less indirection. 1119 And we save a lot of memory by caching no table. */ 1120 register unsigned char c1 = little[0]; 1121 register unsigned char c2 = little[1]; 1122 1123 s = big + 1; 1124 bigend--; 1125 if (c1 != c2) { 1126 while (s <= bigend) { 1127 if (s[0] == c2) { 1128 if (s[-1] == c1) 1129 return (char*)s - 1; 1130 s += 2; 1131 continue; 1132 } 1133 next_chars: 1134 if (s[0] == c1) { 1135 if (s == bigend) 1136 goto check_1char_anchor; 1137 if (s[1] == c2) 1138 return (char*)s; 1139 else { 1140 s++; 1141 goto next_chars; 1142 } 1143 } 1144 else 1145 s += 2; 1146 } 1147 goto check_1char_anchor; 1148 } 1149 /* Now c1 == c2 */ 1150 while (s <= bigend) { 1151 if (s[0] == c1) { 1152 if (s[-1] == c1) 1153 return (char*)s - 1; 1154 if (s == bigend) 1155 goto check_1char_anchor; 1156 if (s[1] == c1) 1157 return (char*)s; 1158 s += 3; 1159 } 1160 else 1161 s += 2; 1162 } 1163 } 1164 check_1char_anchor: /* One char and anchor! */ 1165 if (SvTAIL(littlestr) && (*bigend == *little)) 1166 return (char *)bigend; /* bigend is already decremented. */ 1167 return Nullch; 1168 } 1169 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ 1170 s = bigend - littlelen; 1171 if (s >= big && bigend[-1] == '\n' && *s == *little 1172 /* Automatically of length > 2 */ 1173 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) 1174 { 1175 return (char*)s; /* how sweet it is */ 1176 } 1177 if (s[1] == *little 1178 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) 1179 { 1180 return (char*)s + 1; /* how sweet it is */ 1181 } 1182 return Nullch; 1183 } 1184 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { 1185 char *b = ninstr((char*)big,(char*)bigend, 1186 (char*)little, (char*)little + littlelen); 1187 1188 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ 1189 /* Chop \n from littlestr: */ 1190 s = bigend - littlelen + 1; 1191 if (*s == *little 1192 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) 1193 { 1194 return (char*)s; 1195 } 1196 return Nullch; 1197 } 1198 return b; 1199 } 1200 1201 { /* Do actual FBM. */ 1202 register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; 1203 register unsigned char *oldlittle; 1204 1205 if (littlelen > bigend - big) 1206 return Nullch; 1207 --littlelen; /* Last char found by table lookup */ 1208 1209 s = big + littlelen; 1210 little += littlelen; /* last char */ 1211 oldlittle = little; 1212 if (s < bigend) { 1213 register I32 tmp; 1214 1215 top2: 1216 /*SUPPRESS 560*/ 1217 if ((tmp = table[*s])) { 1218 #ifdef POINTERRIGOR 1219 if (bigend - s > tmp) { 1220 s += tmp; 1221 goto top2; 1222 } 1223 s += tmp; 1224 #else 1225 if ((s += tmp) < bigend) 1226 goto top2; 1227 #endif 1228 goto check_end; 1229 } 1230 else { /* less expensive than calling strncmp() */ 1231 register unsigned char *olds = s; 1232 1233 tmp = littlelen; 1234 1235 while (tmp--) { 1236 if (*--s == *--little) 1237 continue; 1238 s = olds + 1; /* here we pay the price for failure */ 1239 little = oldlittle; 1240 if (s < bigend) /* fake up continue to outer loop */ 1241 goto top2; 1242 goto check_end; 1243 } 1244 return (char *)s; 1245 } 1246 } 1247 check_end: 1248 if ( s == bigend && (table[-1] & FBMcf_TAIL) 1249 && memEQ(bigend - littlelen, oldlittle - littlelen, littlelen) ) 1250 return (char*)bigend - littlelen; 1251 return Nullch; 1252 } 1253 } 1254 1255 /* start_shift, end_shift are positive quantities which give offsets 1256 of ends of some substring of bigstr. 1257 If `last' we want the last occurence. 1258 old_posp is the way of communication between consequent calls if 1259 the next call needs to find the . 1260 The initial *old_posp should be -1. 1261 1262 Note that we take into account SvTAIL, so one can get extra 1263 optimizations if _ALL flag is set. 1264 */ 1265 1266 /* If SvTAIL is actually due to \Z or \z, this gives false positives 1267 if PL_multiline. In fact if !PL_multiline the autoritative answer 1268 is not supported yet. */ 1269 1270 char * 1271 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) 1272 { 1273 register unsigned char *s, *x; 1274 register unsigned char *big; 1275 register I32 pos; 1276 register I32 previous; 1277 register I32 first; 1278 register unsigned char *little; 1279 register I32 stop_pos; 1280 register unsigned char *littleend; 1281 I32 found = 0; 1282 1283 if (*old_posp == -1 1284 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 1285 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { 1286 cant_find: 1287 if ( BmRARE(littlestr) == '\n' 1288 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { 1289 little = (unsigned char *)(SvPVX(littlestr)); 1290 littleend = little + SvCUR(littlestr); 1291 first = *little++; 1292 goto check_tail; 1293 } 1294 return Nullch; 1295 } 1296 1297 little = (unsigned char *)(SvPVX(littlestr)); 1298 littleend = little + SvCUR(littlestr); 1299 first = *little++; 1300 /* The value of pos we can start at: */ 1301 previous = BmPREVIOUS(littlestr); 1302 big = (unsigned char *)(SvPVX(bigstr)); 1303 /* The value of pos we can stop at: */ 1304 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); 1305 if (previous + start_shift > stop_pos) { 1306 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ 1307 goto check_tail; 1308 return Nullch; 1309 } 1310 while (pos < previous + start_shift) { 1311 if (!(pos += PL_screamnext[pos])) 1312 goto cant_find; 1313 } 1314 #ifdef POINTERRIGOR 1315 do { 1316 if (pos >= stop_pos) break; 1317 if (big[pos-previous] != first) 1318 continue; 1319 for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { 1320 if (*s++ != *x++) { 1321 s--; 1322 break; 1323 } 1324 } 1325 if (s == littleend) { 1326 *old_posp = pos; 1327 if (!last) return (char *)(big+pos-previous); 1328 found = 1; 1329 } 1330 } while ( pos += PL_screamnext[pos] ); 1331 return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch; 1332 #else /* !POINTERRIGOR */ 1333 big -= previous; 1334 do { 1335 if (pos >= stop_pos) break; 1336 if (big[pos] != first) 1337 continue; 1338 for (x=big+pos+1,s=little; s < littleend; /**/ ) { 1339 if (*s++ != *x++) { 1340 s--; 1341 break; 1342 } 1343 } 1344 if (s == littleend) { 1345 *old_posp = pos; 1346 if (!last) return (char *)(big+pos); 1347 found = 1; 1348 } 1349 } while ( pos += PL_screamnext[pos] ); 1350 if (last && found) 1351 return (char *)(big+(*old_posp)); 1352 #endif /* POINTERRIGOR */ 1353 check_tail: 1354 if (!SvTAIL(littlestr) || (end_shift > 0)) 1355 return Nullch; 1356 /* Ignore the trailing "\n". This code is not microoptimized */ 1357 big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr)); 1358 stop_pos = littleend - little; /* Actual littlestr len */ 1359 if (stop_pos == 0) 1360 return (char*)big; 1361 big -= stop_pos; 1362 if (*big == first 1363 && ((stop_pos == 1) || memEQ(big + 1, little, stop_pos - 1))) 1364 return (char*)big; 1365 return Nullch; 1366 } 1367 1368 I32 1369 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) 1370 { 1371 register U8 *a = (U8 *)s1; 1372 register U8 *b = (U8 *)s2; 1373 while (len--) { 1374 if (*a != *b && *a != PL_fold[*b]) 1375 return 1; 1376 a++,b++; 1377 } 1378 return 0; 1379 } 1380 1381 I32 1382 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) 1383 { 1384 register U8 *a = (U8 *)s1; 1385 register U8 *b = (U8 *)s2; 1386 while (len--) { 1387 if (*a != *b && *a != PL_fold_locale[*b]) 1388 return 1; 1389 a++,b++; 1390 } 1391 return 0; 1392 } 1393 1394 /* copy a string to a safe spot */ 1395 1396 /* 1397 =for apidoc savepv 1398 1399 Copy a string to a safe spot. This does not use an SV. 1400 1401 =cut 1402 */ 1403 1404 char * 1405 Perl_savepv(pTHX_ const char *sv) 1406 { 1407 register char *newaddr; 1408 1409 New(902,newaddr,strlen(sv)+1,char); 1410 (void)strcpy(newaddr,sv); 1411 return newaddr; 1412 } 1413 1414 /* same thing but with a known length */ 1415 1416 /* 1417 =for apidoc savepvn 1418 1419 Copy a string to a safe spot. The C<len> indicates number of bytes to 1420 copy. This does not use an SV. 1421 1422 =cut 1423 */ 1424 1425 char * 1426 Perl_savepvn(pTHX_ const char *sv, register I32 len) 1427 { 1428 register char *newaddr; 1429 1430 New(903,newaddr,len+1,char); 1431 Copy(sv,newaddr,len,char); /* might not be null terminated */ 1432 newaddr[len] = '\0'; /* is now */ 1433 return newaddr; 1434 } 1435 1436 /* the SV for Perl_form() and mess() is not kept in an arena */ 1437 1438 STATIC SV * 1439 S_mess_alloc(pTHX) 1440 { 1441 SV *sv; 1442 XPVMG *any; 1443 1444 if (!PL_dirty) 1445 return sv_2mortal(newSVpvn("",0)); 1446 1447 if (PL_mess_sv) 1448 return PL_mess_sv; 1449 1450 /* Create as PVMG now, to avoid any upgrading later */ 1451 New(905, sv, 1, SV); 1452 Newz(905, any, 1, XPVMG); 1453 SvFLAGS(sv) = SVt_PVMG; 1454 SvANY(sv) = (void*)any; 1455 SvREFCNT(sv) = 1 << 30; /* practically infinite */ 1456 PL_mess_sv = sv; 1457 return sv; 1458 } 1459 1460 #if defined(PERL_IMPLICIT_CONTEXT) 1461 char * 1462 Perl_form_nocontext(const char* pat, ...) 1463 { 1464 dTHX; 1465 char *retval; 1466 va_list args; 1467 va_start(args, pat); 1468 retval = vform(pat, &args); 1469 va_end(args); 1470 return retval; 1471 } 1472 #endif /* PERL_IMPLICIT_CONTEXT */ 1473 1474 char * 1475 Perl_form(pTHX_ const char* pat, ...) 1476 { 1477 char *retval; 1478 va_list args; 1479 va_start(args, pat); 1480 retval = vform(pat, &args); 1481 va_end(args); 1482 return retval; 1483 } 1484 1485 char * 1486 Perl_vform(pTHX_ const char *pat, va_list *args) 1487 { 1488 SV *sv = mess_alloc(); 1489 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); 1490 return SvPVX(sv); 1491 } 1492 1493 #if defined(PERL_IMPLICIT_CONTEXT) 1494 SV * 1495 Perl_mess_nocontext(const char *pat, ...) 1496 { 1497 dTHX; 1498 SV *retval; 1499 va_list args; 1500 va_start(args, pat); 1501 retval = vmess(pat, &args); 1502 va_end(args); 1503 return retval; 1504 } 1505 #endif /* PERL_IMPLICIT_CONTEXT */ 1506 1507 SV * 1508 Perl_mess(pTHX_ const char *pat, ...) 1509 { 1510 SV *retval; 1511 va_list args; 1512 va_start(args, pat); 1513 retval = vmess(pat, &args); 1514 va_end(args); 1515 return retval; 1516 } 1517 1518 SV * 1519 Perl_vmess(pTHX_ const char *pat, va_list *args) 1520 { 1521 SV *sv = mess_alloc(); 1522 static char dgd[] = " during global destruction.\n"; 1523 1524 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); 1525 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { 1526 if (CopLINE(PL_curcop)) 1527 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, 1528 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); 1529 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { 1530 bool line_mode = (RsSIMPLE(PL_rs) && 1531 SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); 1532 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, 1533 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), 1534 line_mode ? "line" : "chunk", 1535 (IV)IoLINES(GvIOp(PL_last_in_gv))); 1536 } 1537 #ifdef USE_THREADS 1538 if (thr->tid) 1539 Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid); 1540 #endif 1541 sv_catpv(sv, PL_dirty ? dgd : ".\n"); 1542 } 1543 return sv; 1544 } 1545 1546 OP * 1547 Perl_vdie(pTHX_ const char* pat, va_list *args) 1548 { 1549 char *message; 1550 int was_in_eval = PL_in_eval; 1551 HV *stash; 1552 GV *gv; 1553 CV *cv; 1554 SV *msv; 1555 STRLEN msglen; 1556 1557 DEBUG_S(PerlIO_printf(Perl_debug_log, 1558 "%p: die: curstack = %p, mainstack = %p\n", 1559 thr, PL_curstack, PL_mainstack)); 1560 1561 if (pat) { 1562 msv = vmess(pat, args); 1563 if (PL_errors && SvCUR(PL_errors)) { 1564 sv_catsv(PL_errors, msv); 1565 message = SvPV(PL_errors, msglen); 1566 SvCUR_set(PL_errors, 0); 1567 } 1568 else 1569 message = SvPV(msv,msglen); 1570 } 1571 else { 1572 message = Nullch; 1573 msglen = 0; 1574 } 1575 1576 DEBUG_S(PerlIO_printf(Perl_debug_log, 1577 "%p: die: message = %s\ndiehook = %p\n", 1578 thr, message, PL_diehook)); 1579 if (PL_diehook) { 1580 /* sv_2cv might call Perl_croak() */ 1581 SV *olddiehook = PL_diehook; 1582 ENTER; 1583 SAVESPTR(PL_diehook); 1584 PL_diehook = Nullsv; 1585 cv = sv_2cv(olddiehook, &stash, &gv, 0); 1586 LEAVE; 1587 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1588 dSP; 1589 SV *msg; 1590 1591 ENTER; 1592 save_re_context(); 1593 if (message) { 1594 msg = newSVpvn(message, msglen); 1595 SvREADONLY_on(msg); 1596 SAVEFREESV(msg); 1597 } 1598 else { 1599 msg = ERRSV; 1600 } 1601 1602 PUSHSTACKi(PERLSI_DIEHOOK); 1603 PUSHMARK(SP); 1604 XPUSHs(msg); 1605 PUTBACK; 1606 call_sv((SV*)cv, G_DISCARD); 1607 POPSTACK; 1608 LEAVE; 1609 } 1610 } 1611 1612 PL_restartop = die_where(message, msglen); 1613 DEBUG_S(PerlIO_printf(Perl_debug_log, 1614 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", 1615 thr, PL_restartop, was_in_eval, PL_top_env)); 1616 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) 1617 JMPENV_JUMP(3); 1618 return PL_restartop; 1619 } 1620 1621 #if defined(PERL_IMPLICIT_CONTEXT) 1622 OP * 1623 Perl_die_nocontext(const char* pat, ...) 1624 { 1625 dTHX; 1626 OP *o; 1627 va_list args; 1628 va_start(args, pat); 1629 o = vdie(pat, &args); 1630 va_end(args); 1631 return o; 1632 } 1633 #endif /* PERL_IMPLICIT_CONTEXT */ 1634 1635 OP * 1636 Perl_die(pTHX_ const char* pat, ...) 1637 { 1638 OP *o; 1639 va_list args; 1640 va_start(args, pat); 1641 o = vdie(pat, &args); 1642 va_end(args); 1643 return o; 1644 } 1645 1646 void 1647 Perl_vcroak(pTHX_ const char* pat, va_list *args) 1648 { 1649 char *message; 1650 HV *stash; 1651 GV *gv; 1652 CV *cv; 1653 SV *msv; 1654 STRLEN msglen; 1655 1656 if (pat) { 1657 msv = vmess(pat, args); 1658 if (PL_errors && SvCUR(PL_errors)) { 1659 sv_catsv(PL_errors, msv); 1660 message = SvPV(PL_errors, msglen); 1661 SvCUR_set(PL_errors, 0); 1662 } 1663 else 1664 message = SvPV(msv,msglen); 1665 } 1666 else { 1667 message = Nullch; 1668 msglen = 0; 1669 } 1670 1671 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", 1672 PTR2UV(thr), message)); 1673 1674 if (PL_diehook) { 1675 /* sv_2cv might call Perl_croak() */ 1676 SV *olddiehook = PL_diehook; 1677 ENTER; 1678 SAVESPTR(PL_diehook); 1679 PL_diehook = Nullsv; 1680 cv = sv_2cv(olddiehook, &stash, &gv, 0); 1681 LEAVE; 1682 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1683 dSP; 1684 SV *msg; 1685 1686 ENTER; 1687 save_re_context(); 1688 if (message) { 1689 msg = newSVpvn(message, msglen); 1690 SvREADONLY_on(msg); 1691 SAVEFREESV(msg); 1692 } 1693 else { 1694 msg = ERRSV; 1695 } 1696 1697 PUSHSTACKi(PERLSI_DIEHOOK); 1698 PUSHMARK(SP); 1699 XPUSHs(msg); 1700 PUTBACK; 1701 call_sv((SV*)cv, G_DISCARD); 1702 POPSTACK; 1703 LEAVE; 1704 } 1705 } 1706 if (PL_in_eval) { 1707 PL_restartop = die_where(message, msglen); 1708 JMPENV_JUMP(3); 1709 } 1710 { 1711 #ifdef USE_SFIO 1712 /* SFIO can really mess with your errno */ 1713 int e = errno; 1714 #endif 1715 PerlIO *serr = Perl_error_log; 1716 1717 PerlIO_write(serr, message, msglen); 1718 (void)PerlIO_flush(serr); 1719 #ifdef USE_SFIO 1720 errno = e; 1721 #endif 1722 } 1723 my_failure_exit(); 1724 } 1725 1726 #if defined(PERL_IMPLICIT_CONTEXT) 1727 void 1728 Perl_croak_nocontext(const char *pat, ...) 1729 { 1730 dTHX; 1731 va_list args; 1732 va_start(args, pat); 1733 vcroak(pat, &args); 1734 /* NOTREACHED */ 1735 va_end(args); 1736 } 1737 #endif /* PERL_IMPLICIT_CONTEXT */ 1738 1739 /* 1740 =for apidoc croak 1741 1742 This is the XSUB-writer's interface to Perl's C<die> function. 1743 Normally use this function the same way you use the C C<printf> 1744 function. See C<warn>. 1745 1746 If you want to throw an exception object, assign the object to 1747 C<$@> and then pass C<Nullch> to croak(): 1748 1749 errsv = get_sv("@", TRUE); 1750 sv_setsv(errsv, exception_object); 1751 croak(Nullch); 1752 1753 =cut 1754 */ 1755 1756 void 1757 Perl_croak(pTHX_ const char *pat, ...) 1758 { 1759 va_list args; 1760 va_start(args, pat); 1761 vcroak(pat, &args); 1762 /* NOTREACHED */ 1763 va_end(args); 1764 } 1765 1766 void 1767 Perl_vwarn(pTHX_ const char* pat, va_list *args) 1768 { 1769 char *message; 1770 HV *stash; 1771 GV *gv; 1772 CV *cv; 1773 SV *msv; 1774 STRLEN msglen; 1775 1776 msv = vmess(pat, args); 1777 message = SvPV(msv, msglen); 1778 1779 if (PL_warnhook) { 1780 /* sv_2cv might call Perl_warn() */ 1781 SV *oldwarnhook = PL_warnhook; 1782 ENTER; 1783 SAVESPTR(PL_warnhook); 1784 PL_warnhook = Nullsv; 1785 cv = sv_2cv(oldwarnhook, &stash, &gv, 0); 1786 LEAVE; 1787 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1788 dSP; 1789 SV *msg; 1790 1791 ENTER; 1792 save_re_context(); 1793 msg = newSVpvn(message, msglen); 1794 SvREADONLY_on(msg); 1795 SAVEFREESV(msg); 1796 1797 PUSHSTACKi(PERLSI_WARNHOOK); 1798 PUSHMARK(SP); 1799 XPUSHs(msg); 1800 PUTBACK; 1801 call_sv((SV*)cv, G_DISCARD); 1802 POPSTACK; 1803 LEAVE; 1804 return; 1805 } 1806 } 1807 { 1808 PerlIO *serr = Perl_error_log; 1809 1810 PerlIO_write(serr, message, msglen); 1811 #ifdef LEAKTEST 1812 DEBUG_L(*message == '!' 1813 ? (xstat(message[1]=='!' 1814 ? (message[2]=='!' ? 2 : 1) 1815 : 0) 1816 , 0) 1817 : 0); 1818 #endif 1819 (void)PerlIO_flush(serr); 1820 } 1821 } 1822 1823 #if defined(PERL_IMPLICIT_CONTEXT) 1824 void 1825 Perl_warn_nocontext(const char *pat, ...) 1826 { 1827 dTHX; 1828 va_list args; 1829 va_start(args, pat); 1830 vwarn(pat, &args); 1831 va_end(args); 1832 } 1833 #endif /* PERL_IMPLICIT_CONTEXT */ 1834 1835 /* 1836 =for apidoc warn 1837 1838 This is the XSUB-writer's interface to Perl's C<warn> function. Use this 1839 function the same way you use the C C<printf> function. See 1840 C<croak>. 1841 1842 =cut 1843 */ 1844 1845 void 1846 Perl_warn(pTHX_ const char *pat, ...) 1847 { 1848 va_list args; 1849 va_start(args, pat); 1850 vwarn(pat, &args); 1851 va_end(args); 1852 } 1853 1854 #if defined(PERL_IMPLICIT_CONTEXT) 1855 void 1856 Perl_warner_nocontext(U32 err, const char *pat, ...) 1857 { 1858 dTHX; 1859 va_list args; 1860 va_start(args, pat); 1861 vwarner(err, pat, &args); 1862 va_end(args); 1863 } 1864 #endif /* PERL_IMPLICIT_CONTEXT */ 1865 1866 void 1867 Perl_warner(pTHX_ U32 err, const char* pat,...) 1868 { 1869 va_list args; 1870 va_start(args, pat); 1871 vwarner(err, pat, &args); 1872 va_end(args); 1873 } 1874 1875 void 1876 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) 1877 { 1878 char *message; 1879 HV *stash; 1880 GV *gv; 1881 CV *cv; 1882 SV *msv; 1883 STRLEN msglen; 1884 1885 msv = vmess(pat, args); 1886 message = SvPV(msv, msglen); 1887 1888 if (ckDEAD(err)) { 1889 #ifdef USE_THREADS 1890 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message)); 1891 #endif /* USE_THREADS */ 1892 if (PL_diehook) { 1893 /* sv_2cv might call Perl_croak() */ 1894 SV *olddiehook = PL_diehook; 1895 ENTER; 1896 SAVESPTR(PL_diehook); 1897 PL_diehook = Nullsv; 1898 cv = sv_2cv(olddiehook, &stash, &gv, 0); 1899 LEAVE; 1900 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1901 dSP; 1902 SV *msg; 1903 1904 ENTER; 1905 save_re_context(); 1906 msg = newSVpvn(message, msglen); 1907 SvREADONLY_on(msg); 1908 SAVEFREESV(msg); 1909 1910 PUSHSTACKi(PERLSI_DIEHOOK); 1911 PUSHMARK(sp); 1912 XPUSHs(msg); 1913 PUTBACK; 1914 call_sv((SV*)cv, G_DISCARD); 1915 POPSTACK; 1916 LEAVE; 1917 } 1918 } 1919 if (PL_in_eval) { 1920 PL_restartop = die_where(message, msglen); 1921 JMPENV_JUMP(3); 1922 } 1923 { 1924 PerlIO *serr = Perl_error_log; 1925 PerlIO_write(serr, message, msglen); 1926 (void)PerlIO_flush(serr); 1927 } 1928 my_failure_exit(); 1929 1930 } 1931 else { 1932 if (PL_warnhook) { 1933 /* sv_2cv might call Perl_warn() */ 1934 SV *oldwarnhook = PL_warnhook; 1935 ENTER; 1936 SAVESPTR(PL_warnhook); 1937 PL_warnhook = Nullsv; 1938 cv = sv_2cv(oldwarnhook, &stash, &gv, 0); 1939 LEAVE; 1940 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1941 dSP; 1942 SV *msg; 1943 1944 ENTER; 1945 save_re_context(); 1946 msg = newSVpvn(message, msglen); 1947 SvREADONLY_on(msg); 1948 SAVEFREESV(msg); 1949 1950 PUSHSTACKi(PERLSI_WARNHOOK); 1951 PUSHMARK(sp); 1952 XPUSHs(msg); 1953 PUTBACK; 1954 call_sv((SV*)cv, G_DISCARD); 1955 POPSTACK; 1956 LEAVE; 1957 return; 1958 } 1959 } 1960 { 1961 PerlIO *serr = Perl_error_log; 1962 PerlIO_write(serr, message, msglen); 1963 #ifdef LEAKTEST 1964 DEBUG_L(*message == '!' 1965 ? (xstat(message[1]=='!' 1966 ? (message[2]=='!' ? 2 : 1) 1967 : 0) 1968 , 0) 1969 : 0); 1970 #endif 1971 (void)PerlIO_flush(serr); 1972 } 1973 } 1974 } 1975 1976 #ifdef USE_ENVIRON_ARRAY 1977 /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */ 1978 #if !defined(WIN32) 1979 void 1980 Perl_my_setenv(pTHX_ char *nam, char *val) 1981 { 1982 #ifndef PERL_USE_SAFE_PUTENV 1983 /* most putenv()s leak, so we manipulate environ directly */ 1984 register I32 i=setenv_getix(nam); /* where does it go? */ 1985 1986 if (environ == PL_origenviron) { /* need we copy environment? */ 1987 I32 j; 1988 I32 max; 1989 char **tmpenv; 1990 1991 /*SUPPRESS 530*/ 1992 for (max = i; environ[max]; max++) ; 1993 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); 1994 for (j=0; j<max; j++) { /* copy environment */ 1995 tmpenv[j] = (char*)safesysmalloc((strlen(environ[j])+1)*sizeof(char)); 1996 strcpy(tmpenv[j], environ[j]); 1997 } 1998 tmpenv[max] = Nullch; 1999 environ = tmpenv; /* tell exec where it is now */ 2000 } 2001 if (!val) { 2002 safesysfree(environ[i]); 2003 while (environ[i]) { 2004 environ[i] = environ[i+1]; 2005 i++; 2006 } 2007 return; 2008 } 2009 if (!environ[i]) { /* does not exist yet */ 2010 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*)); 2011 environ[i+1] = Nullch; /* make sure it's null terminated */ 2012 } 2013 else 2014 safesysfree(environ[i]); 2015 environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char)); 2016 2017 (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ 2018 2019 #else /* PERL_USE_SAFE_PUTENV */ 2020 # if defined(__CYGWIN__) 2021 setenv(nam, val, 1); 2022 # else 2023 char *new_env; 2024 2025 new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char)); 2026 (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */ 2027 (void)putenv(new_env); 2028 # endif /* __CYGWIN__ */ 2029 #endif /* PERL_USE_SAFE_PUTENV */ 2030 } 2031 2032 #else /* WIN32 */ 2033 2034 void 2035 Perl_my_setenv(pTHX_ char *nam,char *val) 2036 { 2037 register char *envstr; 2038 STRLEN len = strlen(nam) + 3; 2039 if (!val) { 2040 val = ""; 2041 } 2042 len += strlen(val); 2043 New(904, envstr, len, char); 2044 (void)sprintf(envstr,"%s=%s",nam,val); 2045 (void)PerlEnv_putenv(envstr); 2046 Safefree(envstr); 2047 } 2048 2049 #endif /* WIN32 */ 2050 2051 I32 2052 Perl_setenv_getix(pTHX_ char *nam) 2053 { 2054 register I32 i, len = strlen(nam); 2055 2056 for (i = 0; environ[i]; i++) { 2057 if ( 2058 #ifdef WIN32 2059 strnicmp(environ[i],nam,len) == 0 2060 #else 2061 strnEQ(environ[i],nam,len) 2062 #endif 2063 && environ[i][len] == '=') 2064 break; /* strnEQ must come first to avoid */ 2065 } /* potential SEGV's */ 2066 return i; 2067 } 2068 2069 #endif /* !VMS && !EPOC*/ 2070 2071 #ifdef UNLINK_ALL_VERSIONS 2072 I32 2073 Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */ 2074 { 2075 I32 i; 2076 2077 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ; 2078 return i ? 0 : -1; 2079 } 2080 #endif 2081 2082 /* this is a drop-in replacement for bcopy() */ 2083 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) 2084 char * 2085 Perl_my_bcopy(register const char *from,register char *to,register I32 len) 2086 { 2087 char *retval = to; 2088 2089 if (from - to >= 0) { 2090 while (len--) 2091 *to++ = *from++; 2092 } 2093 else { 2094 to += len; 2095 from += len; 2096 while (len--) 2097 *(--to) = *(--from); 2098 } 2099 return retval; 2100 } 2101 #endif 2102 2103 /* this is a drop-in replacement for memset() */ 2104 #ifndef HAS_MEMSET 2105 void * 2106 Perl_my_memset(register char *loc, register I32 ch, register I32 len) 2107 { 2108 char *retval = loc; 2109 2110 while (len--) 2111 *loc++ = ch; 2112 return retval; 2113 } 2114 #endif 2115 2116 /* this is a drop-in replacement for bzero() */ 2117 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) 2118 char * 2119 Perl_my_bzero(register char *loc, register I32 len) 2120 { 2121 char *retval = loc; 2122 2123 while (len--) 2124 *loc++ = 0; 2125 return retval; 2126 } 2127 #endif 2128 2129 /* this is a drop-in replacement for memcmp() */ 2130 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) 2131 I32 2132 Perl_my_memcmp(const char *s1, const char *s2, register I32 len) 2133 { 2134 register U8 *a = (U8 *)s1; 2135 register U8 *b = (U8 *)s2; 2136 register I32 tmp; 2137 2138 while (len--) { 2139 if (tmp = *a++ - *b++) 2140 return tmp; 2141 } 2142 return 0; 2143 } 2144 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ 2145 2146 #ifndef HAS_VPRINTF 2147 2148 #ifdef USE_CHAR_VSPRINTF 2149 char * 2150 #else 2151 int 2152 #endif 2153 vsprintf(char *dest, const char *pat, char *args) 2154 { 2155 FILE fakebuf; 2156 2157 fakebuf._ptr = dest; 2158 fakebuf._cnt = 32767; 2159 #ifndef _IOSTRG 2160 #define _IOSTRG 0 2161 #endif 2162 fakebuf._flag = _IOWRT|_IOSTRG; 2163 _doprnt(pat, args, &fakebuf); /* what a kludge */ 2164 (void)putc('\0', &fakebuf); 2165 #ifdef USE_CHAR_VSPRINTF 2166 return(dest); 2167 #else 2168 return 0; /* perl doesn't use return value */ 2169 #endif 2170 } 2171 2172 #endif /* HAS_VPRINTF */ 2173 2174 #ifdef MYSWAP 2175 #if BYTEORDER != 0x4321 2176 short 2177 Perl_my_swap(pTHX_ short s) 2178 { 2179 #if (BYTEORDER & 1) == 0 2180 short result; 2181 2182 result = ((s & 255) << 8) + ((s >> 8) & 255); 2183 return result; 2184 #else 2185 return s; 2186 #endif 2187 } 2188 2189 long 2190 Perl_my_htonl(pTHX_ long l) 2191 { 2192 union { 2193 long result; 2194 char c[sizeof(long)]; 2195 } u; 2196 2197 #if BYTEORDER == 0x1234 2198 u.c[0] = (l >> 24) & 255; 2199 u.c[1] = (l >> 16) & 255; 2200 u.c[2] = (l >> 8) & 255; 2201 u.c[3] = l & 255; 2202 return u.result; 2203 #else 2204 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) 2205 Perl_croak(aTHX_ "Unknown BYTEORDER\n"); 2206 #else 2207 register I32 o; 2208 register I32 s; 2209 2210 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { 2211 u.c[o & 0xf] = (l >> s) & 255; 2212 } 2213 return u.result; 2214 #endif 2215 #endif 2216 } 2217 2218 long 2219 Perl_my_ntohl(pTHX_ long l) 2220 { 2221 union { 2222 long l; 2223 char c[sizeof(long)]; 2224 } u; 2225 2226 #if BYTEORDER == 0x1234 2227 u.c[0] = (l >> 24) & 255; 2228 u.c[1] = (l >> 16) & 255; 2229 u.c[2] = (l >> 8) & 255; 2230 u.c[3] = l & 255; 2231 return u.l; 2232 #else 2233 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) 2234 Perl_croak(aTHX_ "Unknown BYTEORDER\n"); 2235 #else 2236 register I32 o; 2237 register I32 s; 2238 2239 u.l = l; 2240 l = 0; 2241 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { 2242 l |= (u.c[o & 0xf] & 255) << s; 2243 } 2244 return l; 2245 #endif 2246 #endif 2247 } 2248 2249 #endif /* BYTEORDER != 0x4321 */ 2250 #endif /* MYSWAP */ 2251 2252 /* 2253 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. 2254 * If these functions are defined, 2255 * the BYTEORDER is neither 0x1234 nor 0x4321. 2256 * However, this is not assumed. 2257 * -DWS 2258 */ 2259 2260 #define HTOV(name,type) \ 2261 type \ 2262 name (register type n) \ 2263 { \ 2264 union { \ 2265 type value; \ 2266 char c[sizeof(type)]; \ 2267 } u; \ 2268 register I32 i; \ 2269 register I32 s; \ 2270 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ 2271 u.c[i] = (n >> s) & 0xFF; \ 2272 } \ 2273 return u.value; \ 2274 } 2275 2276 #define VTOH(name,type) \ 2277 type \ 2278 name (register type n) \ 2279 { \ 2280 union { \ 2281 type value; \ 2282 char c[sizeof(type)]; \ 2283 } u; \ 2284 register I32 i; \ 2285 register I32 s; \ 2286 u.value = n; \ 2287 n = 0; \ 2288 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ 2289 n += (u.c[i] & 0xFF) << s; \ 2290 } \ 2291 return n; \ 2292 } 2293 2294 #if defined(HAS_HTOVS) && !defined(htovs) 2295 HTOV(htovs,short) 2296 #endif 2297 #if defined(HAS_HTOVL) && !defined(htovl) 2298 HTOV(htovl,long) 2299 #endif 2300 #if defined(HAS_VTOHS) && !defined(vtohs) 2301 VTOH(vtohs,short) 2302 #endif 2303 #if defined(HAS_VTOHL) && !defined(vtohl) 2304 VTOH(vtohl,long) 2305 #endif 2306 2307 /* VMS' my_popen() is in VMS.c, same with OS/2. */ 2308 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) 2309 PerlIO * 2310 Perl_my_popen(pTHX_ char *cmd, char *mode) 2311 { 2312 int p[2]; 2313 register I32 This, that; 2314 register Pid_t pid; 2315 SV *sv; 2316 I32 doexec = strNE(cmd,"-"); 2317 I32 did_pipes = 0; 2318 int pp[2]; 2319 2320 PERL_FLUSHALL_FOR_CHILD; 2321 #ifdef OS2 2322 if (doexec) { 2323 return my_syspopen(aTHX_ cmd,mode); 2324 } 2325 #endif 2326 This = (*mode == 'w'); 2327 that = !This; 2328 if (doexec && PL_tainting) { 2329 taint_env(); 2330 taint_proper("Insecure %s%s", "EXEC"); 2331 } 2332 if (PerlProc_pipe(p) < 0) 2333 return Nullfp; 2334 if (doexec && PerlProc_pipe(pp) >= 0) 2335 did_pipes = 1; 2336 while ((pid = (doexec?vfork():fork())) < 0) { 2337 if (errno != EAGAIN) { 2338 PerlLIO_close(p[This]); 2339 if (did_pipes) { 2340 PerlLIO_close(pp[0]); 2341 PerlLIO_close(pp[1]); 2342 } 2343 if (!doexec) 2344 Perl_croak(aTHX_ "Can't fork"); 2345 return Nullfp; 2346 } 2347 sleep(5); 2348 } 2349 if (pid == 0) { 2350 GV* tmpgv; 2351 2352 #undef THIS 2353 #undef THAT 2354 #define THIS that 2355 #define THAT This 2356 PerlLIO_close(p[THAT]); 2357 if (did_pipes) { 2358 PerlLIO_close(pp[0]); 2359 #if defined(HAS_FCNTL) && defined(F_SETFD) 2360 fcntl(pp[1], F_SETFD, FD_CLOEXEC); 2361 #endif 2362 } 2363 if (p[THIS] != (*mode == 'r')) { 2364 PerlLIO_dup2(p[THIS], *mode == 'r'); 2365 PerlLIO_close(p[THIS]); 2366 } 2367 #ifndef OS2 2368 if (doexec) { 2369 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2370 int fd; 2371 2372 #ifndef NOFILE 2373 #define NOFILE 20 2374 #endif 2375 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) 2376 if (fd != pp[1]) 2377 PerlLIO_close(fd); 2378 #endif 2379 do_exec3(cmd,pp[1],did_pipes); /* may or may not use the shell */ 2380 PerlProc__exit(1); 2381 } 2382 #endif /* defined OS2 */ 2383 /*SUPPRESS 560*/ 2384 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) 2385 sv_setiv(GvSV(tmpgv), PerlProc_getpid()); 2386 PL_forkprocess = 0; 2387 hv_clear(PL_pidstatus); /* we have no children */ 2388 return Nullfp; 2389 #undef THIS 2390 #undef THAT 2391 } 2392 do_execfree(); /* free any memory malloced by child on vfork */ 2393 PerlLIO_close(p[that]); 2394 if (did_pipes) 2395 PerlLIO_close(pp[1]); 2396 if (p[that] < p[This]) { 2397 PerlLIO_dup2(p[This], p[that]); 2398 PerlLIO_close(p[This]); 2399 p[This] = p[that]; 2400 } 2401 LOCK_FDPID_MUTEX; 2402 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2403 UNLOCK_FDPID_MUTEX; 2404 (void)SvUPGRADE(sv,SVt_IV); 2405 SvIVX(sv) = pid; 2406 PL_forkprocess = pid; 2407 if (did_pipes && pid > 0) { 2408 int errkid; 2409 int n = 0, n1; 2410 2411 while (n < sizeof(int)) { 2412 n1 = PerlLIO_read(pp[0], 2413 (void*)(((char*)&errkid)+n), 2414 (sizeof(int)) - n); 2415 if (n1 <= 0) 2416 break; 2417 n += n1; 2418 } 2419 PerlLIO_close(pp[0]); 2420 did_pipes = 0; 2421 if (n) { /* Error */ 2422 if (n != sizeof(int)) 2423 Perl_croak(aTHX_ "panic: kid popen errno read"); 2424 errno = errkid; /* Propagate errno from kid */ 2425 return Nullfp; 2426 } 2427 } 2428 if (did_pipes) 2429 PerlLIO_close(pp[0]); 2430 return PerlIO_fdopen(p[This], mode); 2431 } 2432 #else 2433 #if defined(atarist) || defined(DJGPP) 2434 FILE *popen(); 2435 PerlIO * 2436 Perl_my_popen(pTHX_ char *cmd, char *mode) 2437 { 2438 /* Needs work for PerlIO ! */ 2439 /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */ 2440 PERL_FLUSHALL_FOR_CHILD; 2441 return popen(PerlIO_exportFILE(cmd, 0), mode); 2442 } 2443 #endif 2444 2445 #endif /* !DOSISH */ 2446 2447 #ifdef DUMP_FDS 2448 void 2449 Perl_dump_fds(pTHX_ char *s) 2450 { 2451 int fd; 2452 struct stat tmpstatbuf; 2453 2454 PerlIO_printf(Perl_debug_log,"%s", s); 2455 for (fd = 0; fd < 32; fd++) { 2456 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0) 2457 PerlIO_printf(Perl_debug_log," %d",fd); 2458 } 2459 PerlIO_printf(Perl_debug_log,"\n"); 2460 } 2461 #endif /* DUMP_FDS */ 2462 2463 #ifndef HAS_DUP2 2464 int 2465 dup2(int oldfd, int newfd) 2466 { 2467 #if defined(HAS_FCNTL) && defined(F_DUPFD) 2468 if (oldfd == newfd) 2469 return oldfd; 2470 PerlLIO_close(newfd); 2471 return fcntl(oldfd, F_DUPFD, newfd); 2472 #else 2473 #define DUP2_MAX_FDS 256 2474 int fdtmp[DUP2_MAX_FDS]; 2475 I32 fdx = 0; 2476 int fd; 2477 2478 if (oldfd == newfd) 2479 return oldfd; 2480 PerlLIO_close(newfd); 2481 /* good enough for low fd's... */ 2482 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) { 2483 if (fdx >= DUP2_MAX_FDS) { 2484 PerlLIO_close(fd); 2485 fd = -1; 2486 break; 2487 } 2488 fdtmp[fdx++] = fd; 2489 } 2490 while (fdx > 0) 2491 PerlLIO_close(fdtmp[--fdx]); 2492 return fd; 2493 #endif 2494 } 2495 #endif 2496 2497 2498 #ifdef HAS_SIGACTION 2499 2500 Sighandler_t 2501 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2502 { 2503 struct sigaction act, oact; 2504 2505 act.sa_handler = handler; 2506 sigemptyset(&act.sa_mask); 2507 act.sa_flags = 0; 2508 #ifdef SA_RESTART 2509 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2510 #endif 2511 #ifdef SA_NOCLDWAIT 2512 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) 2513 act.sa_flags |= SA_NOCLDWAIT; 2514 #endif 2515 if (sigaction(signo, &act, &oact) == -1) 2516 return SIG_ERR; 2517 else 2518 return oact.sa_handler; 2519 } 2520 2521 Sighandler_t 2522 Perl_rsignal_state(pTHX_ int signo) 2523 { 2524 struct sigaction oact; 2525 2526 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) 2527 return SIG_ERR; 2528 else 2529 return oact.sa_handler; 2530 } 2531 2532 int 2533 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2534 { 2535 struct sigaction act; 2536 2537 act.sa_handler = handler; 2538 sigemptyset(&act.sa_mask); 2539 act.sa_flags = 0; 2540 #ifdef SA_RESTART 2541 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2542 #endif 2543 #ifdef SA_NOCLDWAIT 2544 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) 2545 act.sa_flags |= SA_NOCLDWAIT; 2546 #endif 2547 return sigaction(signo, &act, save); 2548 } 2549 2550 int 2551 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2552 { 2553 return sigaction(signo, save, (struct sigaction *)NULL); 2554 } 2555 2556 #else /* !HAS_SIGACTION */ 2557 2558 Sighandler_t 2559 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2560 { 2561 return PerlProc_signal(signo, handler); 2562 } 2563 2564 static int sig_trapped; 2565 2566 static 2567 Signal_t 2568 sig_trap(int signo) 2569 { 2570 sig_trapped++; 2571 } 2572 2573 Sighandler_t 2574 Perl_rsignal_state(pTHX_ int signo) 2575 { 2576 Sighandler_t oldsig; 2577 2578 sig_trapped = 0; 2579 oldsig = PerlProc_signal(signo, sig_trap); 2580 PerlProc_signal(signo, oldsig); 2581 if (sig_trapped) 2582 PerlProc_kill(PerlProc_getpid(), signo); 2583 return oldsig; 2584 } 2585 2586 int 2587 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2588 { 2589 *save = PerlProc_signal(signo, handler); 2590 return (*save == SIG_ERR) ? -1 : 0; 2591 } 2592 2593 int 2594 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2595 { 2596 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0; 2597 } 2598 2599 #endif /* !HAS_SIGACTION */ 2600 2601 /* VMS' my_pclose() is in VMS.c; same with OS/2 */ 2602 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) 2603 I32 2604 Perl_my_pclose(pTHX_ PerlIO *ptr) 2605 { 2606 Sigsave_t hstat, istat, qstat; 2607 int status; 2608 SV **svp; 2609 Pid_t pid; 2610 Pid_t pid2; 2611 bool close_failed; 2612 int saved_errno; 2613 #ifdef VMS 2614 int saved_vaxc_errno; 2615 #endif 2616 #ifdef WIN32 2617 int saved_win32_errno; 2618 #endif 2619 2620 LOCK_FDPID_MUTEX; 2621 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); 2622 UNLOCK_FDPID_MUTEX; 2623 pid = SvIVX(*svp); 2624 SvREFCNT_dec(*svp); 2625 *svp = &PL_sv_undef; 2626 #ifdef OS2 2627 if (pid == -1) { /* Opened by popen. */ 2628 return my_syspclose(ptr); 2629 } 2630 #endif 2631 if ((close_failed = (PerlIO_close(ptr) == EOF))) { 2632 saved_errno = errno; 2633 #ifdef VMS 2634 saved_vaxc_errno = vaxc$errno; 2635 #endif 2636 #ifdef WIN32 2637 saved_win32_errno = GetLastError(); 2638 #endif 2639 } 2640 #ifdef UTS 2641 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ 2642 #endif 2643 rsignal_save(SIGHUP, SIG_IGN, &hstat); 2644 rsignal_save(SIGINT, SIG_IGN, &istat); 2645 rsignal_save(SIGQUIT, SIG_IGN, &qstat); 2646 do { 2647 pid2 = wait4pid(pid, &status, 0); 2648 } while (pid2 == -1 && errno == EINTR); 2649 rsignal_restore(SIGHUP, &hstat); 2650 rsignal_restore(SIGINT, &istat); 2651 rsignal_restore(SIGQUIT, &qstat); 2652 if (close_failed) { 2653 SETERRNO(saved_errno, saved_vaxc_errno); 2654 return -1; 2655 } 2656 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); 2657 } 2658 #endif /* !DOSISH */ 2659 2660 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) 2661 I32 2662 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) 2663 { 2664 SV *sv; 2665 SV** svp; 2666 char spid[TYPE_CHARS(int)]; 2667 2668 if (!pid) 2669 return -1; 2670 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) 2671 if (pid > 0) { 2672 sprintf(spid, "%"IVdf, (IV)pid); 2673 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); 2674 if (svp && *svp != &PL_sv_undef) { 2675 *statusp = SvIVX(*svp); 2676 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); 2677 return pid; 2678 } 2679 } 2680 else { 2681 HE *entry; 2682 2683 hv_iterinit(PL_pidstatus); 2684 if ((entry = hv_iternext(PL_pidstatus))) { 2685 pid = atoi(hv_iterkey(entry,(I32*)statusp)); 2686 sv = hv_iterval(PL_pidstatus,entry); 2687 *statusp = SvIVX(sv); 2688 sprintf(spid, "%"IVdf, (IV)pid); 2689 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); 2690 return pid; 2691 } 2692 } 2693 #endif 2694 #ifdef HAS_WAITPID 2695 # ifdef HAS_WAITPID_RUNTIME 2696 if (!HAS_WAITPID_RUNTIME) 2697 goto hard_way; 2698 # endif 2699 return PerlProc_waitpid(pid,statusp,flags); 2700 #endif 2701 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) 2702 return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); 2703 #endif 2704 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) 2705 hard_way: 2706 { 2707 I32 result; 2708 if (flags) 2709 Perl_croak(aTHX_ "Can't do waitpid with flags"); 2710 else { 2711 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) 2712 pidgone(result,*statusp); 2713 if (result < 0) 2714 *statusp = -1; 2715 } 2716 return result; 2717 } 2718 #endif 2719 } 2720 #endif /* !DOSISH || OS2 || WIN32 */ 2721 2722 void 2723 /*SUPPRESS 590*/ 2724 Perl_pidgone(pTHX_ Pid_t pid, int status) 2725 { 2726 register SV *sv; 2727 char spid[TYPE_CHARS(int)]; 2728 2729 sprintf(spid, "%"IVdf, (IV)pid); 2730 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE); 2731 (void)SvUPGRADE(sv,SVt_IV); 2732 SvIVX(sv) = status; 2733 return; 2734 } 2735 2736 #if defined(atarist) || defined(OS2) || defined(DJGPP) 2737 int pclose(); 2738 #ifdef HAS_FORK 2739 int /* Cannot prototype with I32 2740 in os2ish.h. */ 2741 my_syspclose(PerlIO *ptr) 2742 #else 2743 I32 2744 Perl_my_pclose(pTHX_ PerlIO *ptr) 2745 #endif 2746 { 2747 /* Needs work for PerlIO ! */ 2748 FILE *f = PerlIO_findFILE(ptr); 2749 I32 result = pclose(f); 2750 #if defined(DJGPP) 2751 result = (result << 8) & 0xff00; 2752 #endif 2753 PerlIO_releaseFILE(ptr,f); 2754 return result; 2755 } 2756 #endif 2757 2758 void 2759 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count) 2760 { 2761 register I32 todo; 2762 register const char *frombase = from; 2763 2764 if (len == 1) { 2765 register const char c = *from; 2766 while (count-- > 0) 2767 *to++ = c; 2768 return; 2769 } 2770 while (count-- > 0) { 2771 for (todo = len; todo > 0; todo--) { 2772 *to++ = *from++; 2773 } 2774 from = frombase; 2775 } 2776 } 2777 2778 U32 2779 Perl_cast_ulong(pTHX_ NV f) 2780 { 2781 long along; 2782 2783 #if CASTFLAGS & 2 2784 # define BIGDOUBLE 2147483648.0 2785 if (f >= BIGDOUBLE) 2786 return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000; 2787 #endif 2788 if (f >= 0.0) 2789 return (unsigned long)f; 2790 along = (long)f; 2791 return (unsigned long)along; 2792 } 2793 # undef BIGDOUBLE 2794 2795 /* Unfortunately, on some systems the cast_uv() function doesn't 2796 work with the system-supplied definition of ULONG_MAX. The 2797 comparison (f >= ULONG_MAX) always comes out true. It must be a 2798 problem with the compiler constant folding. 2799 2800 In any case, this workaround should be fine on any two's complement 2801 system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your 2802 ccflags. 2803 --Andy Dougherty <doughera@lafcol.lafayette.edu> 2804 */ 2805 2806 /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead 2807 of LONG_(MIN/MAX). 2808 -- Kenneth Albanowski <kjahds@kjahds.com> 2809 */ 2810 2811 #ifndef MY_UV_MAX 2812 # define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1) 2813 #endif 2814 2815 I32 2816 Perl_cast_i32(pTHX_ NV f) 2817 { 2818 if (f >= I32_MAX) 2819 return (I32) I32_MAX; 2820 if (f <= I32_MIN) 2821 return (I32) I32_MIN; 2822 return (I32) f; 2823 } 2824 2825 IV 2826 Perl_cast_iv(pTHX_ NV f) 2827 { 2828 if (f >= IV_MAX) { 2829 UV uv; 2830 2831 if (f >= (NV)UV_MAX) 2832 return (IV) UV_MAX; 2833 uv = (UV) f; 2834 return (IV)uv; 2835 } 2836 if (f <= IV_MIN) 2837 return (IV) IV_MIN; 2838 return (IV) f; 2839 } 2840 2841 UV 2842 Perl_cast_uv(pTHX_ NV f) 2843 { 2844 if (f >= MY_UV_MAX) 2845 return (UV) MY_UV_MAX; 2846 if (f < 0) { 2847 IV iv; 2848 2849 if (f < IV_MIN) 2850 return (UV)IV_MIN; 2851 iv = (IV) f; 2852 return (UV) iv; 2853 } 2854 return (UV) f; 2855 } 2856 2857 #ifndef HAS_RENAME 2858 I32 2859 Perl_same_dirent(pTHX_ char *a, char *b) 2860 { 2861 char *fa = strrchr(a,'/'); 2862 char *fb = strrchr(b,'/'); 2863 struct stat tmpstatbuf1; 2864 struct stat tmpstatbuf2; 2865 SV *tmpsv = sv_newmortal(); 2866 2867 if (fa) 2868 fa++; 2869 else 2870 fa = a; 2871 if (fb) 2872 fb++; 2873 else 2874 fb = b; 2875 if (strNE(a,b)) 2876 return FALSE; 2877 if (fa == a) 2878 sv_setpv(tmpsv, "."); 2879 else 2880 sv_setpvn(tmpsv, a, fa - a); 2881 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0) 2882 return FALSE; 2883 if (fb == b) 2884 sv_setpv(tmpsv, "."); 2885 else 2886 sv_setpvn(tmpsv, b, fb - b); 2887 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0) 2888 return FALSE; 2889 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && 2890 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; 2891 } 2892 #endif /* !HAS_RENAME */ 2893 2894 NV 2895 Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen) 2896 { 2897 register char *s = start; 2898 register NV rnv = 0.0; 2899 register UV ruv = 0; 2900 register bool seenb = FALSE; 2901 register bool overflowed = FALSE; 2902 2903 for (; len-- && *s; s++) { 2904 if (!(*s == '0' || *s == '1')) { 2905 if (*s == '_' && len && *retlen 2906 && (s[1] == '0' || s[1] == '1')) 2907 { 2908 --len; 2909 ++s; 2910 } 2911 else if (seenb == FALSE && *s == 'b' && ruv == 0) { 2912 /* Disallow 0bbb0b0bbb... */ 2913 seenb = TRUE; 2914 continue; 2915 } 2916 else { 2917 if (ckWARN(WARN_DIGIT)) 2918 Perl_warner(aTHX_ WARN_DIGIT, 2919 "Illegal binary digit '%c' ignored", *s); 2920 break; 2921 } 2922 } 2923 if (!overflowed) { 2924 register UV xuv = ruv << 1; 2925 2926 if ((xuv >> 1) != ruv) { 2927 overflowed = TRUE; 2928 rnv = (NV) ruv; 2929 if (ckWARN_d(WARN_OVERFLOW)) 2930 Perl_warner(aTHX_ WARN_OVERFLOW, 2931 "Integer overflow in binary number"); 2932 } 2933 else 2934 ruv = xuv | (*s - '0'); 2935 } 2936 if (overflowed) { 2937 rnv *= 2; 2938 /* If an NV has not enough bits in its mantissa to 2939 * represent an UV this summing of small low-order numbers 2940 * is a waste of time (because the NV cannot preserve 2941 * the low-order bits anyway): we could just remember when 2942 * did we overflow and in the end just multiply rnv by the 2943 * right amount. */ 2944 rnv += (*s - '0'); 2945 } 2946 } 2947 if (!overflowed) 2948 rnv = (NV) ruv; 2949 if ( ( overflowed && rnv > 4294967295.0) 2950 #if UVSIZE > 4 2951 || (!overflowed && ruv > 0xffffffff ) 2952 #endif 2953 ) { 2954 if (ckWARN(WARN_PORTABLE)) 2955 Perl_warner(aTHX_ WARN_PORTABLE, 2956 "Binary number > 0b11111111111111111111111111111111 non-portable"); 2957 } 2958 *retlen = s - start; 2959 return rnv; 2960 } 2961 2962 NV 2963 Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen) 2964 { 2965 register char *s = start; 2966 register NV rnv = 0.0; 2967 register UV ruv = 0; 2968 register bool overflowed = FALSE; 2969 2970 for (; len-- && *s; s++) { 2971 if (!(*s >= '0' && *s <= '7')) { 2972 if (*s == '_' && len && *retlen 2973 && (s[1] >= '0' && s[1] <= '7')) 2974 { 2975 --len; 2976 ++s; 2977 } 2978 else { 2979 /* Allow \octal to work the DWIM way (that is, stop scanning 2980 * as soon as non-octal characters are seen, complain only iff 2981 * someone seems to want to use the digits eight and nine). */ 2982 if (*s == '8' || *s == '9') { 2983 if (ckWARN(WARN_DIGIT)) 2984 Perl_warner(aTHX_ WARN_DIGIT, 2985 "Illegal octal digit '%c' ignored", *s); 2986 } 2987 break; 2988 } 2989 } 2990 if (!overflowed) { 2991 register UV xuv = ruv << 3; 2992 2993 if ((xuv >> 3) != ruv) { 2994 overflowed = TRUE; 2995 rnv = (NV) ruv; 2996 if (ckWARN_d(WARN_OVERFLOW)) 2997 Perl_warner(aTHX_ WARN_OVERFLOW, 2998 "Integer overflow in octal number"); 2999 } 3000 else 3001 ruv = xuv | (*s - '0'); 3002 } 3003 if (overflowed) { 3004 rnv *= 8.0; 3005 /* If an NV has not enough bits in its mantissa to 3006 * represent an UV this summing of small low-order numbers 3007 * is a waste of time (because the NV cannot preserve 3008 * the low-order bits anyway): we could just remember when 3009 * did we overflow and in the end just multiply rnv by the 3010 * right amount of 8-tuples. */ 3011 rnv += (NV)(*s - '0'); 3012 } 3013 } 3014 if (!overflowed) 3015 rnv = (NV) ruv; 3016 if ( ( overflowed && rnv > 4294967295.0) 3017 #if UVSIZE > 4 3018 || (!overflowed && ruv > 0xffffffff ) 3019 #endif 3020 ) { 3021 if (ckWARN(WARN_PORTABLE)) 3022 Perl_warner(aTHX_ WARN_PORTABLE, 3023 "Octal number > 037777777777 non-portable"); 3024 } 3025 *retlen = s - start; 3026 return rnv; 3027 } 3028 3029 NV 3030 Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen) 3031 { 3032 register char *s = start; 3033 register NV rnv = 0.0; 3034 register UV ruv = 0; 3035 register bool seenx = FALSE; 3036 register bool overflowed = FALSE; 3037 char *hexdigit; 3038 3039 for (; len-- && *s; s++) { 3040 hexdigit = strchr((char *) PL_hexdigit, *s); 3041 if (!hexdigit) { 3042 if (*s == '_' && len && *retlen && s[1] 3043 && (hexdigit = strchr((char *) PL_hexdigit, s[1]))) 3044 { 3045 --len; 3046 ++s; 3047 } 3048 else if (seenx == FALSE && *s == 'x' && ruv == 0) { 3049 /* Disallow 0xxx0x0xxx... */ 3050 seenx = TRUE; 3051 continue; 3052 } 3053 else { 3054 if (ckWARN(WARN_DIGIT)) 3055 Perl_warner(aTHX_ WARN_DIGIT, 3056 "Illegal hexadecimal digit '%c' ignored", *s); 3057 break; 3058 } 3059 } 3060 if (!overflowed) { 3061 register UV xuv = ruv << 4; 3062 3063 if ((xuv >> 4) != ruv) { 3064 overflowed = TRUE; 3065 rnv = (NV) ruv; 3066 if (ckWARN_d(WARN_OVERFLOW)) 3067 Perl_warner(aTHX_ WARN_OVERFLOW, 3068 "Integer overflow in hexadecimal number"); 3069 } 3070 else 3071 ruv = xuv | ((hexdigit - PL_hexdigit) & 15); 3072 } 3073 if (overflowed) { 3074 rnv *= 16.0; 3075 /* If an NV has not enough bits in its mantissa to 3076 * represent an UV this summing of small low-order numbers 3077 * is a waste of time (because the NV cannot preserve 3078 * the low-order bits anyway): we could just remember when 3079 * did we overflow and in the end just multiply rnv by the 3080 * right amount of 16-tuples. */ 3081 rnv += (NV)((hexdigit - PL_hexdigit) & 15); 3082 } 3083 } 3084 if (!overflowed) 3085 rnv = (NV) ruv; 3086 if ( ( overflowed && rnv > 4294967295.0) 3087 #if UVSIZE > 4 3088 || (!overflowed && ruv > 0xffffffff ) 3089 #endif 3090 ) { 3091 if (ckWARN(WARN_PORTABLE)) 3092 Perl_warner(aTHX_ WARN_PORTABLE, 3093 "Hexadecimal number > 0xffffffff non-portable"); 3094 } 3095 *retlen = s - start; 3096 return rnv; 3097 } 3098 3099 char* 3100 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags) 3101 { 3102 char *xfound = Nullch; 3103 char *xfailed = Nullch; 3104 char tmpbuf[MAXPATHLEN]; 3105 register char *s; 3106 I32 len; 3107 int retval; 3108 #if defined(DOSISH) && !defined(OS2) && !defined(atarist) 3109 # define SEARCH_EXTS ".bat", ".cmd", NULL 3110 # define MAX_EXT_LEN 4 3111 #endif 3112 #ifdef OS2 3113 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL 3114 # define MAX_EXT_LEN 4 3115 #endif 3116 #ifdef VMS 3117 # define SEARCH_EXTS ".pl", ".com", NULL 3118 # define MAX_EXT_LEN 4 3119 #endif 3120 /* additional extensions to try in each dir if scriptname not found */ 3121 #ifdef SEARCH_EXTS 3122 char *exts[] = { SEARCH_EXTS }; 3123 char **ext = search_ext ? search_ext : exts; 3124 int extidx = 0, i = 0; 3125 char *curext = Nullch; 3126 #else 3127 # define MAX_EXT_LEN 0 3128 #endif 3129 3130 /* 3131 * If dosearch is true and if scriptname does not contain path 3132 * delimiters, search the PATH for scriptname. 3133 * 3134 * If SEARCH_EXTS is also defined, will look for each 3135 * scriptname{SEARCH_EXTS} whenever scriptname is not found 3136 * while searching the PATH. 3137 * 3138 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search 3139 * proceeds as follows: 3140 * If DOSISH or VMSISH: 3141 * + look for ./scriptname{,.foo,.bar} 3142 * + search the PATH for scriptname{,.foo,.bar} 3143 * 3144 * If !DOSISH: 3145 * + look *only* in the PATH for scriptname{,.foo,.bar} (note 3146 * this will not look in '.' if it's not in the PATH) 3147 */ 3148 tmpbuf[0] = '\0'; 3149 3150 #ifdef VMS 3151 # ifdef ALWAYS_DEFTYPES 3152 len = strlen(scriptname); 3153 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { 3154 int hasdir, idx = 0, deftypes = 1; 3155 bool seen_dot = 1; 3156 3157 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ; 3158 # else 3159 if (dosearch) { 3160 int hasdir, idx = 0, deftypes = 1; 3161 bool seen_dot = 1; 3162 3163 hasdir = (strpbrk(scriptname,":[</") != Nullch) ; 3164 # endif 3165 /* The first time through, just add SEARCH_EXTS to whatever we 3166 * already have, so we can check for default file types. */ 3167 while (deftypes || 3168 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) 3169 { 3170 if (deftypes) { 3171 deftypes = 0; 3172 *tmpbuf = '\0'; 3173 } 3174 if ((strlen(tmpbuf) + strlen(scriptname) 3175 + MAX_EXT_LEN) >= sizeof tmpbuf) 3176 continue; /* don't search dir with too-long name */ 3177 strcat(tmpbuf, scriptname); 3178 #else /* !VMS */ 3179 3180 #ifdef DOSISH 3181 if (strEQ(scriptname, "-")) 3182 dosearch = 0; 3183 if (dosearch) { /* Look in '.' first. */ 3184 char *cur = scriptname; 3185 #ifdef SEARCH_EXTS 3186 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ 3187 while (ext[i]) 3188 if (strEQ(ext[i++],curext)) { 3189 extidx = -1; /* already has an ext */ 3190 break; 3191 } 3192 do { 3193 #endif 3194 DEBUG_p(PerlIO_printf(Perl_debug_log, 3195 "Looking for %s\n",cur)); 3196 if (PerlLIO_stat(cur,&PL_statbuf) >= 0 3197 && !S_ISDIR(PL_statbuf.st_mode)) { 3198 dosearch = 0; 3199 scriptname = cur; 3200 #ifdef SEARCH_EXTS 3201 break; 3202 #endif 3203 } 3204 #ifdef SEARCH_EXTS 3205 if (cur == scriptname) { 3206 len = strlen(scriptname); 3207 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) 3208 break; 3209 cur = strcpy(tmpbuf, scriptname); 3210 } 3211 } while (extidx >= 0 && ext[extidx] /* try an extension? */ 3212 && strcpy(tmpbuf+len, ext[extidx++])); 3213 #endif 3214 } 3215 #endif 3216 3217 #ifdef MACOS_TRADITIONAL 3218 if (dosearch && !strchr(scriptname, ':') && 3219 (s = PerlEnv_getenv("Commands"))) 3220 #else 3221 if (dosearch && !strchr(scriptname, '/') 3222 #ifdef DOSISH 3223 && !strchr(scriptname, '\\') 3224 #endif 3225 && (s = PerlEnv_getenv("PATH"))) 3226 #endif 3227 { 3228 bool seen_dot = 0; 3229 3230 PL_bufend = s + strlen(s); 3231 while (s < PL_bufend) { 3232 #ifdef MACOS_TRADITIONAL 3233 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, 3234 ',', 3235 &len); 3236 #else 3237 #if defined(atarist) || defined(DOSISH) 3238 for (len = 0; *s 3239 # ifdef atarist 3240 && *s != ',' 3241 # endif 3242 && *s != ';'; len++, s++) { 3243 if (len < sizeof tmpbuf) 3244 tmpbuf[len] = *s; 3245 } 3246 if (len < sizeof tmpbuf) 3247 tmpbuf[len] = '\0'; 3248 #else /* ! (atarist || DOSISH) */ 3249 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, 3250 ':', 3251 &len); 3252 #endif /* ! (atarist || DOSISH) */ 3253 #endif /* MACOS_TRADITIONAL */ 3254 if (s < PL_bufend) 3255 s++; 3256 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) 3257 continue; /* don't search dir with too-long name */ 3258 #ifdef MACOS_TRADITIONAL 3259 if (len && tmpbuf[len - 1] != ':') 3260 tmpbuf[len++] = ':'; 3261 #else 3262 if (len 3263 #if defined(atarist) || defined(__MINT__) || defined(DOSISH) 3264 && tmpbuf[len - 1] != '/' 3265 && tmpbuf[len - 1] != '\\' 3266 #endif 3267 ) 3268 tmpbuf[len++] = '/'; 3269 if (len == 2 && tmpbuf[0] == '.') 3270 seen_dot = 1; 3271 #endif 3272 (void)strcpy(tmpbuf + len, scriptname); 3273 #endif /* !VMS */ 3274 3275 #ifdef SEARCH_EXTS 3276 len = strlen(tmpbuf); 3277 if (extidx > 0) /* reset after previous loop */ 3278 extidx = 0; 3279 do { 3280 #endif 3281 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); 3282 retval = PerlLIO_stat(tmpbuf,&PL_statbuf); 3283 if (S_ISDIR(PL_statbuf.st_mode)) { 3284 retval = -1; 3285 } 3286 #ifdef SEARCH_EXTS 3287 } while ( retval < 0 /* not there */ 3288 && extidx>=0 && ext[extidx] /* try an extension? */ 3289 && strcpy(tmpbuf+len, ext[extidx++]) 3290 ); 3291 #endif 3292 if (retval < 0) 3293 continue; 3294 if (S_ISREG(PL_statbuf.st_mode) 3295 && cando(S_IRUSR,TRUE,&PL_statbuf) 3296 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL) 3297 && cando(S_IXUSR,TRUE,&PL_statbuf) 3298 #endif 3299 ) 3300 { 3301 xfound = tmpbuf; /* bingo! */ 3302 break; 3303 } 3304 if (!xfailed) 3305 xfailed = savepv(tmpbuf); 3306 } 3307 #ifndef DOSISH 3308 if (!xfound && !seen_dot && !xfailed && 3309 (PerlLIO_stat(scriptname,&PL_statbuf) < 0 3310 || S_ISDIR(PL_statbuf.st_mode))) 3311 #endif 3312 seen_dot = 1; /* Disable message. */ 3313 if (!xfound) { 3314 if (flags & 1) { /* do or die? */ 3315 Perl_croak(aTHX_ "Can't %s %s%s%s", 3316 (xfailed ? "execute" : "find"), 3317 (xfailed ? xfailed : scriptname), 3318 (xfailed ? "" : " on PATH"), 3319 (xfailed || seen_dot) ? "" : ", '.' not in PATH"); 3320 } 3321 scriptname = Nullch; 3322 } 3323 if (xfailed) 3324 Safefree(xfailed); 3325 scriptname = xfound; 3326 } 3327 return (scriptname ? savepv(scriptname) : Nullch); 3328 } 3329 3330 #ifndef PERL_GET_CONTEXT_DEFINED 3331 3332 void * 3333 Perl_get_context(void) 3334 { 3335 #if defined(USE_THREADS) || defined(USE_ITHREADS) 3336 # ifdef OLD_PTHREADS_API 3337 pthread_addr_t t; 3338 if (pthread_getspecific(PL_thr_key, &t)) 3339 Perl_croak_nocontext("panic: pthread_getspecific"); 3340 return (void*)t; 3341 # else 3342 # ifdef I_MACH_CTHREADS 3343 return (void*)cthread_data(cthread_self()); 3344 # else 3345 return (void*)pthread_getspecific(PL_thr_key); 3346 # endif 3347 # endif 3348 #else 3349 return (void*)NULL; 3350 #endif 3351 } 3352 3353 void 3354 Perl_set_context(void *t) 3355 { 3356 #if defined(USE_THREADS) || defined(USE_ITHREADS) 3357 # ifdef I_MACH_CTHREADS 3358 cthread_set_data(cthread_self(), t); 3359 # else 3360 if (pthread_setspecific(PL_thr_key, t)) 3361 Perl_croak_nocontext("panic: pthread_setspecific"); 3362 # endif 3363 #endif 3364 } 3365 3366 #endif /* !PERL_GET_CONTEXT_DEFINED */ 3367 3368 #ifdef USE_THREADS 3369 3370 #ifdef FAKE_THREADS 3371 /* Very simplistic scheduler for now */ 3372 void 3373 schedule(void) 3374 { 3375 thr = thr->i.next_run; 3376 } 3377 3378 void 3379 Perl_cond_init(pTHX_ perl_cond *cp) 3380 { 3381 *cp = 0; 3382 } 3383 3384 void 3385 Perl_cond_signal(pTHX_ perl_cond *cp) 3386 { 3387 perl_os_thread t; 3388 perl_cond cond = *cp; 3389 3390 if (!cond) 3391 return; 3392 t = cond->thread; 3393 /* Insert t in the runnable queue just ahead of us */ 3394 t->i.next_run = thr->i.next_run; 3395 thr->i.next_run->i.prev_run = t; 3396 t->i.prev_run = thr; 3397 thr->i.next_run = t; 3398 thr->i.wait_queue = 0; 3399 /* Remove from the wait queue */ 3400 *cp = cond->next; 3401 Safefree(cond); 3402 } 3403 3404 void 3405 Perl_cond_broadcast(pTHX_ perl_cond *cp) 3406 { 3407 perl_os_thread t; 3408 perl_cond cond, cond_next; 3409 3410 for (cond = *cp; cond; cond = cond_next) { 3411 t = cond->thread; 3412 /* Insert t in the runnable queue just ahead of us */ 3413 t->i.next_run = thr->i.next_run; 3414 thr->i.next_run->i.prev_run = t; 3415 t->i.prev_run = thr; 3416 thr->i.next_run = t; 3417 thr->i.wait_queue = 0; 3418 /* Remove from the wait queue */ 3419 cond_next = cond->next; 3420 Safefree(cond); 3421 } 3422 *cp = 0; 3423 } 3424 3425 void 3426 Perl_cond_wait(pTHX_ perl_cond *cp) 3427 { 3428 perl_cond cond; 3429 3430 if (thr->i.next_run == thr) 3431 Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread"); 3432 3433 New(666, cond, 1, struct perl_wait_queue); 3434 cond->thread = thr; 3435 cond->next = *cp; 3436 *cp = cond; 3437 thr->i.wait_queue = cond; 3438 /* Remove ourselves from runnable queue */ 3439 thr->i.next_run->i.prev_run = thr->i.prev_run; 3440 thr->i.prev_run->i.next_run = thr->i.next_run; 3441 } 3442 #endif /* FAKE_THREADS */ 3443 3444 MAGIC * 3445 Perl_condpair_magic(pTHX_ SV *sv) 3446 { 3447 MAGIC *mg; 3448 3449 SvUPGRADE(sv, SVt_PVMG); 3450 mg = mg_find(sv, 'm'); 3451 if (!mg) { 3452 condpair_t *cp; 3453 3454 New(53, cp, 1, condpair_t); 3455 MUTEX_INIT(&cp->mutex); 3456 COND_INIT(&cp->owner_cond); 3457 COND_INIT(&cp->cond); 3458 cp->owner = 0; 3459 LOCK_CRED_MUTEX; /* XXX need separate mutex? */ 3460 mg = mg_find(sv, 'm'); 3461 if (mg) { 3462 /* someone else beat us to initialising it */ 3463 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ 3464 MUTEX_DESTROY(&cp->mutex); 3465 COND_DESTROY(&cp->owner_cond); 3466 COND_DESTROY(&cp->cond); 3467 Safefree(cp); 3468 } 3469 else { 3470 sv_magic(sv, Nullsv, 'm', 0, 0); 3471 mg = SvMAGIC(sv); 3472 mg->mg_ptr = (char *)cp; 3473 mg->mg_len = sizeof(cp); 3474 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ 3475 DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, 3476 "%p: condpair_magic %p\n", thr, sv));) 3477 } 3478 } 3479 return mg; 3480 } 3481 3482 SV * 3483 Perl_sv_lock(pTHX_ SV *osv) 3484 { 3485 MAGIC *mg; 3486 SV *sv = osv; 3487 3488 LOCK_SV_LOCK_MUTEX; 3489 if (SvROK(sv)) { 3490 sv = SvRV(sv); 3491 } 3492 3493 mg = condpair_magic(sv); 3494 MUTEX_LOCK(MgMUTEXP(mg)); 3495 if (MgOWNER(mg) == thr) 3496 MUTEX_UNLOCK(MgMUTEXP(mg)); 3497 else { 3498 while (MgOWNER(mg)) 3499 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); 3500 MgOWNER(mg) = thr; 3501 DEBUG_S(PerlIO_printf(Perl_debug_log, 3502 "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", 3503 PTR2UV(thr), PTR2UV(sv));) 3504 MUTEX_UNLOCK(MgMUTEXP(mg)); 3505 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); 3506 } 3507 UNLOCK_SV_LOCK_MUTEX; 3508 return sv; 3509 } 3510 3511 /* 3512 * Make a new perl thread structure using t as a prototype. Some of the 3513 * fields for the new thread are copied from the prototype thread, t, 3514 * so t should not be running in perl at the time this function is 3515 * called. The use by ext/Thread/Thread.xs in core perl (where t is the 3516 * thread calling new_struct_thread) clearly satisfies this constraint. 3517 */ 3518 struct perl_thread * 3519 Perl_new_struct_thread(pTHX_ struct perl_thread *t) 3520 { 3521 #if !defined(PERL_IMPLICIT_CONTEXT) 3522 struct perl_thread *thr; 3523 #endif 3524 SV *sv; 3525 SV **svp; 3526 I32 i; 3527 3528 sv = newSVpvn("", 0); 3529 SvGROW(sv, sizeof(struct perl_thread) + 1); 3530 SvCUR_set(sv, sizeof(struct perl_thread)); 3531 thr = (Thread) SvPVX(sv); 3532 #ifdef DEBUGGING 3533 memset(thr, 0xab, sizeof(struct perl_thread)); 3534 PL_markstack = 0; 3535 PL_scopestack = 0; 3536 PL_savestack = 0; 3537 PL_retstack = 0; 3538 PL_dirty = 0; 3539 PL_localizing = 0; 3540 Zero(&PL_hv_fetch_ent_mh, 1, HE); 3541 PL_efloatbuf = (char*)NULL; 3542 PL_efloatsize = 0; 3543 #else 3544 Zero(thr, 1, struct perl_thread); 3545 #endif 3546 3547 thr->oursv = sv; 3548 init_stacks(); 3549 3550 PL_curcop = &PL_compiling; 3551 thr->interp = t->interp; 3552 thr->cvcache = newHV(); 3553 thr->threadsv = newAV(); 3554 thr->specific = newAV(); 3555 thr->errsv = newSVpvn("", 0); 3556 thr->flags = THRf_R_JOINABLE; 3557 MUTEX_INIT(&thr->mutex); 3558 3559 JMPENV_BOOTSTRAP; 3560 3561 PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */ 3562 PL_restartop = 0; 3563 3564 PL_statname = NEWSV(66,0); 3565 PL_errors = newSVpvn("", 0); 3566 PL_maxscream = -1; 3567 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); 3568 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); 3569 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); 3570 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); 3571 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); 3572 PL_regindent = 0; 3573 PL_reginterp_cnt = 0; 3574 PL_lastscream = Nullsv; 3575 PL_screamfirst = 0; 3576 PL_screamnext = 0; 3577 PL_reg_start_tmp = 0; 3578 PL_reg_start_tmpl = 0; 3579 PL_reg_poscache = Nullch; 3580 3581 /* parent thread's data needs to be locked while we make copy */ 3582 MUTEX_LOCK(&t->mutex); 3583 3584 #ifdef PERL_FLEXIBLE_EXCEPTIONS 3585 PL_protect = t->Tprotect; 3586 #endif 3587 3588 PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ 3589 PL_defstash = t->Tdefstash; /* XXX maybe these should */ 3590 PL_curstash = t->Tcurstash; /* always be set to main? */ 3591 3592 PL_tainted = t->Ttainted; 3593 PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ 3594 PL_nrs = newSVsv(t->Tnrs); 3595 PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv; 3596 PL_last_in_gv = Nullgv; 3597 PL_ofslen = t->Tofslen; 3598 PL_ofs = savepvn(t->Tofs, PL_ofslen); 3599 PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); 3600 PL_chopset = t->Tchopset; 3601 PL_bodytarget = newSVsv(t->Tbodytarget); 3602 PL_toptarget = newSVsv(t->Ttoptarget); 3603 if (t->Tformtarget == t->Ttoptarget) 3604 PL_formtarget = PL_toptarget; 3605 else 3606 PL_formtarget = PL_bodytarget; 3607 3608 /* Initialise all per-thread SVs that the template thread used */ 3609 svp = AvARRAY(t->threadsv); 3610 for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) { 3611 if (*svp && *svp != &PL_sv_undef) { 3612 SV *sv = newSVsv(*svp); 3613 av_store(thr->threadsv, i, sv); 3614 sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1); 3615 DEBUG_S(PerlIO_printf(Perl_debug_log, 3616 "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", 3617 (IV)i, t, thr)); 3618 } 3619 } 3620 thr->threadsvp = AvARRAY(thr->threadsv); 3621 3622 MUTEX_LOCK(&PL_threads_mutex); 3623 PL_nthreads++; 3624 thr->tid = ++PL_threadnum; 3625 thr->next = t->next; 3626 thr->prev = t; 3627 t->next = thr; 3628 thr->next->prev = thr; 3629 MUTEX_UNLOCK(&PL_threads_mutex); 3630 3631 /* done copying parent's state */ 3632 MUTEX_UNLOCK(&t->mutex); 3633 3634 #ifdef HAVE_THREAD_INTERN 3635 Perl_init_thread_intern(thr); 3636 #endif /* HAVE_THREAD_INTERN */ 3637 return thr; 3638 } 3639 #endif /* USE_THREADS */ 3640 3641 #if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) 3642 /* 3643 * This hack is to force load of "huge" support from libm.a 3644 * So it is in perl for (say) POSIX to use. 3645 * Needed for SunOS with Sun's 'acc' for example. 3646 */ 3647 NV 3648 Perl_huge(void) 3649 { 3650 # if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) 3651 return HUGE_VALL; 3652 # endif 3653 return HUGE_VAL; 3654 } 3655 #endif 3656 3657 #ifdef PERL_GLOBAL_STRUCT 3658 struct perl_vars * 3659 Perl_GetVars(pTHX) 3660 { 3661 return &PL_Vars; 3662 } 3663 #endif 3664 3665 char ** 3666 Perl_get_op_names(pTHX) 3667 { 3668 return PL_op_name; 3669 } 3670 3671 char ** 3672 Perl_get_op_descs(pTHX) 3673 { 3674 return PL_op_desc; 3675 } 3676 3677 char * 3678 Perl_get_no_modify(pTHX) 3679 { 3680 return (char*)PL_no_modify; 3681 } 3682 3683 U32 * 3684 Perl_get_opargs(pTHX) 3685 { 3686 return PL_opargs; 3687 } 3688 3689 PPADDR_t* 3690 Perl_get_ppaddr(pTHX) 3691 { 3692 return &PL_ppaddr; 3693 } 3694 3695 #ifndef HAS_GETENV_LEN 3696 char * 3697 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) 3698 { 3699 char *env_trans = PerlEnv_getenv(env_elem); 3700 if (env_trans) 3701 *len = strlen(env_trans); 3702 return env_trans; 3703 } 3704 #endif 3705 3706 3707 MGVTBL* 3708 Perl_get_vtbl(pTHX_ int vtbl_id) 3709 { 3710 MGVTBL* result = Null(MGVTBL*); 3711 3712 switch(vtbl_id) { 3713 case want_vtbl_sv: 3714 result = &PL_vtbl_sv; 3715 break; 3716 case want_vtbl_env: 3717 result = &PL_vtbl_env; 3718 break; 3719 case want_vtbl_envelem: 3720 result = &PL_vtbl_envelem; 3721 break; 3722 case want_vtbl_sig: 3723 result = &PL_vtbl_sig; 3724 break; 3725 case want_vtbl_sigelem: 3726 result = &PL_vtbl_sigelem; 3727 break; 3728 case want_vtbl_pack: 3729 result = &PL_vtbl_pack; 3730 break; 3731 case want_vtbl_packelem: 3732 result = &PL_vtbl_packelem; 3733 break; 3734 case want_vtbl_dbline: 3735 result = &PL_vtbl_dbline; 3736 break; 3737 case want_vtbl_isa: 3738 result = &PL_vtbl_isa; 3739 break; 3740 case want_vtbl_isaelem: 3741 result = &PL_vtbl_isaelem; 3742 break; 3743 case want_vtbl_arylen: 3744 result = &PL_vtbl_arylen; 3745 break; 3746 case want_vtbl_glob: 3747 result = &PL_vtbl_glob; 3748 break; 3749 case want_vtbl_mglob: 3750 result = &PL_vtbl_mglob; 3751 break; 3752 case want_vtbl_nkeys: 3753 result = &PL_vtbl_nkeys; 3754 break; 3755 case want_vtbl_taint: 3756 result = &PL_vtbl_taint; 3757 break; 3758 case want_vtbl_substr: 3759 result = &PL_vtbl_substr; 3760 break; 3761 case want_vtbl_vec: 3762 result = &PL_vtbl_vec; 3763 break; 3764 case want_vtbl_pos: 3765 result = &PL_vtbl_pos; 3766 break; 3767 case want_vtbl_bm: 3768 result = &PL_vtbl_bm; 3769 break; 3770 case want_vtbl_fm: 3771 result = &PL_vtbl_fm; 3772 break; 3773 case want_vtbl_uvar: 3774 result = &PL_vtbl_uvar; 3775 break; 3776 #ifdef USE_THREADS 3777 case want_vtbl_mutex: 3778 result = &PL_vtbl_mutex; 3779 break; 3780 #endif 3781 case want_vtbl_defelem: 3782 result = &PL_vtbl_defelem; 3783 break; 3784 case want_vtbl_regexp: 3785 result = &PL_vtbl_regexp; 3786 break; 3787 case want_vtbl_regdata: 3788 result = &PL_vtbl_regdata; 3789 break; 3790 case want_vtbl_regdatum: 3791 result = &PL_vtbl_regdatum; 3792 break; 3793 #ifdef USE_LOCALE_COLLATE 3794 case want_vtbl_collxfrm: 3795 result = &PL_vtbl_collxfrm; 3796 break; 3797 #endif 3798 case want_vtbl_amagic: 3799 result = &PL_vtbl_amagic; 3800 break; 3801 case want_vtbl_amagicelem: 3802 result = &PL_vtbl_amagicelem; 3803 break; 3804 case want_vtbl_backref: 3805 result = &PL_vtbl_backref; 3806 break; 3807 } 3808 return result; 3809 } 3810 3811 #if !defined(FFLUSH_NULL) && defined(HAS__FWALK) 3812 static int S_fflush(FILE *fp); 3813 3814 static int 3815 S_fflush(FILE *fp) 3816 { 3817 return fflush(fp); 3818 } 3819 #endif 3820 3821 I32 3822 Perl_my_fflush_all(pTHX) 3823 { 3824 #if defined(FFLUSH_NULL) 3825 return PerlIO_flush(NULL); 3826 #else 3827 # if defined(HAS__FWALK) 3828 /* undocumented, unprototyped, but very useful BSDism */ 3829 extern void _fwalk(int (*)(FILE *)); 3830 _fwalk(&S_fflush); 3831 return 0; 3832 # else 3833 long open_max = -1; 3834 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) 3835 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX 3836 open_max = PERL_FFLUSH_ALL_FOPEN_MAX; 3837 # else 3838 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) 3839 open_max = sysconf(_SC_OPEN_MAX); 3840 # else 3841 # ifdef FOPEN_MAX 3842 open_max = FOPEN_MAX; 3843 # else 3844 # ifdef OPEN_MAX 3845 open_max = OPEN_MAX; 3846 # else 3847 # ifdef _NFILE 3848 open_max = _NFILE; 3849 # endif 3850 # endif 3851 # endif 3852 # endif 3853 # endif 3854 if (open_max > 0) { 3855 long i; 3856 for (i = 0; i < open_max; i++) 3857 if (STDIO_STREAM_ARRAY[i]._file >= 0 && 3858 STDIO_STREAM_ARRAY[i]._file < open_max && 3859 STDIO_STREAM_ARRAY[i]._flag) 3860 PerlIO_flush(&STDIO_STREAM_ARRAY[i]); 3861 return 0; 3862 } 3863 # endif 3864 SETERRNO(EBADF,RMS$_IFI); 3865 return EOF; 3866 # endif 3867 #endif 3868 } 3869 3870 NV 3871 Perl_my_atof(pTHX_ const char* s) 3872 { 3873 NV x = 0.0; 3874 #ifdef USE_LOCALE_NUMERIC 3875 if ((PL_hints & HINT_LOCALE) && PL_numeric_local) { 3876 NV y; 3877 3878 Perl_atof2(s, x); 3879 SET_NUMERIC_STANDARD(); 3880 Perl_atof2(s, y); 3881 SET_NUMERIC_LOCAL(); 3882 if ((y < 0.0 && y < x) || (y > 0.0 && y > x)) 3883 return y; 3884 } 3885 else 3886 Perl_atof2(s, x); 3887 #else 3888 Perl_atof2(s, x); 3889 #endif 3890 return x; 3891 } 3892 3893 void 3894 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) 3895 { 3896 char *vile; 3897 I32 warn_type; 3898 char *func = 3899 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */ 3900 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ 3901 PL_op_desc[op]; 3902 char *pars = OP_IS_FILETEST(op) ? "" : "()"; 3903 char *type = OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ? 3904 "socket" : "filehandle"; 3905 char *name = NULL; 3906 3907 if (io && IoTYPE(io) == IoTYPE_CLOSED) { 3908 vile = "closed"; 3909 warn_type = WARN_CLOSED; 3910 } 3911 else { 3912 vile = "unopened"; 3913 warn_type = WARN_UNOPENED; 3914 } 3915 3916 if (gv && isGV(gv)) { 3917 SV *sv = sv_newmortal(); 3918 gv_efullname4(sv, gv, Nullch, FALSE); 3919 name = SvPVX(sv); 3920 } 3921 3922 if (name && *name) { 3923 Perl_warner(aTHX_ warn_type, 3924 "%s%s on %s %s %s", func, pars, vile, type, name); 3925 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3926 Perl_warner(aTHX_ warn_type, 3927 "\t(Are you trying to call %s%s on dirhandle %s?)\n", 3928 func, pars, name); 3929 } 3930 else { 3931 Perl_warner(aTHX_ warn_type, 3932 "%s%s on %s %s", func, pars, vile, type); 3933 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3934 Perl_warner(aTHX_ warn_type, 3935 "\t(Are you trying to call %s%s on dirhandle?)\n", 3936 func, pars); 3937 } 3938 } 3939 3940 #ifdef EBCDIC 3941 /* in ASCII order, not that it matters */ 3942 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; 3943 3944 int 3945 Perl_ebcdic_control(pTHX_ int ch) 3946 { 3947 if (ch > 'a') { 3948 char *ctlp; 3949 3950 if (islower(ch)) 3951 ch = toupper(ch); 3952 3953 if ((ctlp = strchr(controllablechars, ch)) == 0) { 3954 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); 3955 } 3956 3957 if (ctlp == controllablechars) 3958 return('\177'); /* DEL */ 3959 else 3960 return((unsigned char)(ctlp - controllablechars - 1)); 3961 } else { /* Want uncontrol */ 3962 if (ch == '\177' || ch == -1) 3963 return('?'); 3964 else if (ch == '\157') 3965 return('\177'); 3966 else if (ch == '\174') 3967 return('\000'); 3968 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */ 3969 return('\036'); 3970 else if (ch == '\155') 3971 return('\037'); 3972 else if (0 < ch && ch < (sizeof(controllablechars) - 1)) 3973 return(controllablechars[ch+1]); 3974 else 3975 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF); 3976 } 3977 } 3978 #endif 3979