1 /* util.c 2 * 3 * Copyright (c) 1991-1997, 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 #include "perl.h" 17 18 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) 19 #include <signal.h> 20 #endif 21 22 #ifndef SIG_ERR 23 # define SIG_ERR ((Sighandler_t) -1) 24 #endif 25 26 /* XXX If this causes problems, set i_unistd=undef in the hint file. */ 27 #ifdef I_UNISTD 28 # include <unistd.h> 29 #endif 30 31 #ifdef I_VFORK 32 # include <vfork.h> 33 #endif 34 35 /* Put this after #includes because fork and vfork prototypes may 36 conflict. 37 */ 38 #ifndef HAS_VFORK 39 # define vfork fork 40 #endif 41 42 #ifdef I_FCNTL 43 # include <fcntl.h> 44 #endif 45 #ifdef I_SYS_FILE 46 # include <sys/file.h> 47 #endif 48 49 #ifdef I_SYS_WAIT 50 # include <sys/wait.h> 51 #endif 52 53 #define FLUSH 54 55 #ifdef LEAKTEST 56 static void xstat _((void)); 57 #endif 58 59 #ifndef MYMALLOC 60 61 /* paranoid version of 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 safemalloc(size) 71 MEM_SIZE size; 72 { 73 Malloc_t ptr; 74 #ifdef HAS_64K_LIMIT 75 if (size > 0xffff) { 76 PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; 77 my_exit(1); 78 } 79 #endif /* HAS_64K_LIMIT */ 80 #ifdef DEBUGGING 81 if ((long)size < 0) 82 croak("panic: malloc"); 83 #endif 84 ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ 85 #if !(defined(I286) || defined(atarist)) 86 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); 87 #else 88 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); 89 #endif 90 if (ptr != Nullch) 91 return ptr; 92 else if (nomemok) 93 return Nullch; 94 else { 95 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; 96 my_exit(1); 97 } 98 /*NOTREACHED*/ 99 } 100 101 /* paranoid version of realloc */ 102 103 Malloc_t 104 saferealloc(where,size) 105 Malloc_t where; 106 MEM_SIZE size; 107 { 108 Malloc_t ptr; 109 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) 110 Malloc_t realloc(); 111 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ 112 113 #ifdef HAS_64K_LIMIT 114 if (size > 0xffff) { 115 PerlIO_printf(PerlIO_stderr(), 116 "Reallocation too large: %lx\n", size) FLUSH; 117 my_exit(1); 118 } 119 #endif /* HAS_64K_LIMIT */ 120 if (!where) 121 croak("Null realloc"); 122 #ifdef DEBUGGING 123 if ((long)size < 0) 124 croak("panic: realloc"); 125 #endif 126 ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */ 127 128 #if !(defined(I286) || defined(atarist)) 129 DEBUG_m( { 130 PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++); 131 PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); 132 } ) 133 #else 134 DEBUG_m( { 135 PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++); 136 PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); 137 } ) 138 #endif 139 140 if (ptr != Nullch) 141 return ptr; 142 else if (nomemok) 143 return Nullch; 144 else { 145 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; 146 my_exit(1); 147 } 148 /*NOTREACHED*/ 149 } 150 151 /* safe version of free */ 152 153 Free_t 154 safefree(where) 155 Malloc_t where; 156 { 157 #if !(defined(I286) || defined(atarist)) 158 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",where,an++)); 159 #else 160 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",where,an++)); 161 #endif 162 if (where) { 163 /*SUPPRESS 701*/ 164 free(where); 165 } 166 } 167 168 /* safe version of calloc */ 169 170 Malloc_t 171 safecalloc(count, size) 172 MEM_SIZE count; 173 MEM_SIZE size; 174 { 175 Malloc_t ptr; 176 177 #ifdef HAS_64K_LIMIT 178 if (size * count > 0xffff) { 179 PerlIO_printf(PerlIO_stderr(), 180 "Allocation too large: %lx\n", size * count) FLUSH; 181 my_exit(1); 182 } 183 #endif /* HAS_64K_LIMIT */ 184 #ifdef DEBUGGING 185 if ((long)size < 0 || (long)count < 0) 186 croak("panic: calloc"); 187 #endif 188 size *= count; 189 ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ 190 #if !(defined(I286) || defined(atarist)) 191 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); 192 #else 193 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); 194 #endif 195 if (ptr != Nullch) { 196 memset((void*)ptr, 0, size); 197 return ptr; 198 } 199 else if (nomemok) 200 return Nullch; 201 else { 202 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; 203 my_exit(1); 204 } 205 /*NOTREACHED*/ 206 } 207 208 #endif /* !MYMALLOC */ 209 210 #ifdef LEAKTEST 211 212 #define ALIGN sizeof(long) 213 214 Malloc_t 215 safexmalloc(x,size) 216 I32 x; 217 MEM_SIZE size; 218 { 219 register Malloc_t where; 220 221 where = safemalloc(size + ALIGN); 222 xcount[x]++; 223 where[0] = x % 100; 224 where[1] = x / 100; 225 return where + ALIGN; 226 } 227 228 Malloc_t 229 safexrealloc(where,size) 230 Malloc_t where; 231 MEM_SIZE size; 232 { 233 register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN); 234 return new + ALIGN; 235 } 236 237 void 238 safexfree(where) 239 Malloc_t where; 240 { 241 I32 x; 242 243 if (!where) 244 return; 245 where -= ALIGN; 246 x = where[0] + 100 * where[1]; 247 xcount[x]--; 248 safefree(where); 249 } 250 251 Malloc_t 252 safexcalloc(x,count,size) 253 I32 x; 254 MEM_SIZE count; 255 MEM_SIZE size; 256 { 257 register Malloc_t where; 258 259 where = safexmalloc(x, size * count + ALIGN); 260 xcount[x]++; 261 memset((void*)where + ALIGN, 0, size * count); 262 where[0] = x % 100; 263 where[1] = x / 100; 264 return where + ALIGN; 265 } 266 267 static void 268 xstat() 269 { 270 register I32 i; 271 272 for (i = 0; i < MAXXCOUNT; i++) { 273 if (xcount[i] > lastxcount[i]) { 274 PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); 275 lastxcount[i] = xcount[i]; 276 } 277 } 278 } 279 280 #endif /* LEAKTEST */ 281 282 /* copy a string up to some (non-backslashed) delimiter, if any */ 283 284 char * 285 delimcpy(to, toend, from, fromend, delim, retlen) 286 register char *to; 287 register char *toend; 288 register char *from; 289 register char *fromend; 290 register int delim; 291 I32 *retlen; 292 { 293 register I32 tolen; 294 for (tolen = 0; from < fromend; from++, tolen++) { 295 if (*from == '\\') { 296 if (from[1] == delim) 297 from++; 298 else { 299 if (to < toend) 300 *to++ = *from; 301 tolen++; 302 from++; 303 } 304 } 305 else if (*from == delim) 306 break; 307 if (to < toend) 308 *to++ = *from; 309 } 310 if (to < toend) 311 *to = '\0'; 312 *retlen = tolen; 313 return from; 314 } 315 316 /* return ptr to little string in big string, NULL if not found */ 317 /* This routine was donated by Corey Satten. */ 318 319 char * 320 instr(big, little) 321 register char *big; 322 register char *little; 323 { 324 register char *s, *x; 325 register I32 first; 326 327 if (!little) 328 return big; 329 first = *little++; 330 if (!first) 331 return big; 332 while (*big) { 333 if (*big++ != first) 334 continue; 335 for (x=big,s=little; *s; /**/ ) { 336 if (!*x) 337 return Nullch; 338 if (*s++ != *x++) { 339 s--; 340 break; 341 } 342 } 343 if (!*s) 344 return big-1; 345 } 346 return Nullch; 347 } 348 349 /* same as instr but allow embedded nulls */ 350 351 char * 352 ninstr(big, bigend, little, lend) 353 register char *big; 354 register char *bigend; 355 char *little; 356 char *lend; 357 { 358 register char *s, *x; 359 register I32 first = *little; 360 register char *littleend = lend; 361 362 if (!first && little >= littleend) 363 return big; 364 if (bigend - big < littleend - little) 365 return Nullch; 366 bigend -= littleend - little++; 367 while (big <= bigend) { 368 if (*big++ != first) 369 continue; 370 for (x=big,s=little; s < littleend; /**/ ) { 371 if (*s++ != *x++) { 372 s--; 373 break; 374 } 375 } 376 if (s >= littleend) 377 return big-1; 378 } 379 return Nullch; 380 } 381 382 /* reverse of the above--find last substring */ 383 384 char * 385 rninstr(big, bigend, little, lend) 386 register char *big; 387 char *bigend; 388 char *little; 389 char *lend; 390 { 391 register char *bigbeg; 392 register char *s, *x; 393 register I32 first = *little; 394 register char *littleend = lend; 395 396 if (!first && little >= littleend) 397 return bigend; 398 bigbeg = big; 399 big = bigend - (littleend - little++); 400 while (big >= bigbeg) { 401 if (*big-- != first) 402 continue; 403 for (x=big+2,s=little; s < littleend; /**/ ) { 404 if (*s++ != *x++) { 405 s--; 406 break; 407 } 408 } 409 if (s >= littleend) 410 return big+1; 411 } 412 return Nullch; 413 } 414 415 /* 416 * Set up for a new ctype locale. 417 */ 418 void 419 perl_new_ctype(newctype) 420 char *newctype; 421 { 422 #ifdef USE_LOCALE_CTYPE 423 424 int i; 425 426 for (i = 0; i < 256; i++) { 427 if (isUPPER_LC(i)) 428 fold_locale[i] = toLOWER_LC(i); 429 else if (isLOWER_LC(i)) 430 fold_locale[i] = toUPPER_LC(i); 431 else 432 fold_locale[i] = i; 433 } 434 435 #endif /* USE_LOCALE_CTYPE */ 436 } 437 438 /* 439 * Set up for a new collation locale. 440 */ 441 void 442 perl_new_collate(newcoll) 443 char *newcoll; 444 { 445 #ifdef USE_LOCALE_COLLATE 446 447 if (! newcoll) { 448 if (collation_name) { 449 ++collation_ix; 450 Safefree(collation_name); 451 collation_name = NULL; 452 collation_standard = TRUE; 453 collxfrm_base = 0; 454 collxfrm_mult = 2; 455 } 456 return; 457 } 458 459 if (! collation_name || strNE(collation_name, newcoll)) { 460 ++collation_ix; 461 Safefree(collation_name); 462 collation_name = savepv(newcoll); 463 collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); 464 465 { 466 /* 2: at most so many chars ('a', 'b'). */ 467 /* 50: surely no system expands a char more. */ 468 #define XFRMBUFSIZE (2 * 50) 469 char xbuf[XFRMBUFSIZE]; 470 Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE); 471 Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE); 472 SSize_t mult = fb - fa; 473 if (mult < 1) 474 croak("strxfrm() gets absurd"); 475 collxfrm_base = (fa > mult) ? (fa - mult) : 0; 476 collxfrm_mult = mult; 477 } 478 } 479 480 #endif /* USE_LOCALE_COLLATE */ 481 } 482 483 /* 484 * Set up for a new numeric locale. 485 */ 486 void 487 perl_new_numeric(newnum) 488 char *newnum; 489 { 490 #ifdef USE_LOCALE_NUMERIC 491 492 if (! newnum) { 493 if (numeric_name) { 494 Safefree(numeric_name); 495 numeric_name = NULL; 496 numeric_standard = TRUE; 497 numeric_local = TRUE; 498 } 499 return; 500 } 501 502 if (! numeric_name || strNE(numeric_name, newnum)) { 503 Safefree(numeric_name); 504 numeric_name = savepv(newnum); 505 numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); 506 numeric_local = TRUE; 507 } 508 509 #endif /* USE_LOCALE_NUMERIC */ 510 } 511 512 void 513 perl_set_numeric_standard() 514 { 515 #ifdef USE_LOCALE_NUMERIC 516 517 if (! numeric_standard) { 518 setlocale(LC_NUMERIC, "C"); 519 numeric_standard = TRUE; 520 numeric_local = FALSE; 521 } 522 523 #endif /* USE_LOCALE_NUMERIC */ 524 } 525 526 void 527 perl_set_numeric_local() 528 { 529 #ifdef USE_LOCALE_NUMERIC 530 531 if (! numeric_local) { 532 setlocale(LC_NUMERIC, numeric_name); 533 numeric_standard = FALSE; 534 numeric_local = TRUE; 535 } 536 537 #endif /* USE_LOCALE_NUMERIC */ 538 } 539 540 541 /* 542 * Initialize locale awareness. 543 */ 544 int 545 perl_init_i18nl10n(printwarn) 546 int printwarn; 547 { 548 int ok = 1; 549 /* returns 550 * 1 = set ok or not applicable, 551 * 0 = fallback to C locale, 552 * -1 = fallback to C locale failed 553 */ 554 555 #ifdef USE_LOCALE 556 557 #ifdef USE_LOCALE_CTYPE 558 char *curctype = NULL; 559 #endif /* USE_LOCALE_CTYPE */ 560 #ifdef USE_LOCALE_COLLATE 561 char *curcoll = NULL; 562 #endif /* USE_LOCALE_COLLATE */ 563 #ifdef USE_LOCALE_NUMERIC 564 char *curnum = NULL; 565 #endif /* USE_LOCALE_NUMERIC */ 566 char *lc_all = getenv("LC_ALL"); 567 char *lang = getenv("LANG"); 568 bool setlocale_failure = FALSE; 569 570 #ifdef LOCALE_ENVIRON_REQUIRED 571 572 /* 573 * Ultrix setlocale(..., "") fails if there are no environment 574 * variables from which to get a locale name. 575 */ 576 577 bool done = FALSE; 578 579 #ifdef LC_ALL 580 if (lang) { 581 if (setlocale(LC_ALL, "")) 582 done = TRUE; 583 else 584 setlocale_failure = TRUE; 585 } 586 if (!setlocale_failure) 587 #endif /* LC_ALL */ 588 { 589 #ifdef USE_LOCALE_CTYPE 590 if (! (curctype = setlocale(LC_CTYPE, 591 (!done && (lang || getenv("LC_CTYPE"))) 592 ? "" : Nullch))) 593 setlocale_failure = TRUE; 594 #endif /* USE_LOCALE_CTYPE */ 595 #ifdef USE_LOCALE_COLLATE 596 if (! (curcoll = setlocale(LC_COLLATE, 597 (!done && (lang || getenv("LC_COLLATE"))) 598 ? "" : Nullch))) 599 setlocale_failure = TRUE; 600 #endif /* USE_LOCALE_COLLATE */ 601 #ifdef USE_LOCALE_NUMERIC 602 if (! (curnum = setlocale(LC_NUMERIC, 603 (!done && (lang || getenv("LC_NUMERIC"))) 604 ? "" : Nullch))) 605 setlocale_failure = TRUE; 606 #endif /* USE_LOCALE_NUMERIC */ 607 } 608 609 #else /* !LOCALE_ENVIRON_REQUIRED */ 610 611 #ifdef LC_ALL 612 613 if (! setlocale(LC_ALL, "")) 614 setlocale_failure = TRUE; 615 else { 616 #ifdef USE_LOCALE_CTYPE 617 curctype = setlocale(LC_CTYPE, Nullch); 618 #endif /* USE_LOCALE_CTYPE */ 619 #ifdef USE_LOCALE_COLLATE 620 curcoll = setlocale(LC_COLLATE, Nullch); 621 #endif /* USE_LOCALE_COLLATE */ 622 #ifdef USE_LOCALE_NUMERIC 623 curnum = setlocale(LC_NUMERIC, Nullch); 624 #endif /* USE_LOCALE_NUMERIC */ 625 } 626 627 #else /* !LC_ALL */ 628 629 #ifdef USE_LOCALE_CTYPE 630 if (! (curctype = setlocale(LC_CTYPE, ""))) 631 setlocale_failure = TRUE; 632 #endif /* USE_LOCALE_CTYPE */ 633 #ifdef USE_LOCALE_COLLATE 634 if (! (curcoll = setlocale(LC_COLLATE, ""))) 635 setlocale_failure = TRUE; 636 #endif /* USE_LOCALE_COLLATE */ 637 #ifdef USE_LOCALE_NUMERIC 638 if (! (curnum = setlocale(LC_NUMERIC, ""))) 639 setlocale_failure = TRUE; 640 #endif /* USE_LOCALE_NUMERIC */ 641 642 #endif /* LC_ALL */ 643 644 #endif /* !LOCALE_ENVIRON_REQUIRED */ 645 646 if (setlocale_failure) { 647 char *p; 648 bool locwarn = (printwarn > 1 || 649 printwarn && 650 (!(p = getenv("PERL_BADLANG")) || atoi(p))); 651 652 if (locwarn) { 653 #ifdef LC_ALL 654 655 PerlIO_printf(PerlIO_stderr(), 656 "perl: warning: Setting locale failed.\n"); 657 658 #else /* !LC_ALL */ 659 660 PerlIO_printf(PerlIO_stderr(), 661 "perl: warning: Setting locale failed for the categories:\n\t"); 662 #ifdef USE_LOCALE_CTYPE 663 if (! curctype) 664 PerlIO_printf(PerlIO_stderr(), "LC_CTYPE "); 665 #endif /* USE_LOCALE_CTYPE */ 666 #ifdef USE_LOCALE_COLLATE 667 if (! curcoll) 668 PerlIO_printf(PerlIO_stderr(), "LC_COLLATE "); 669 #endif /* USE_LOCALE_COLLATE */ 670 #ifdef USE_LOCALE_NUMERIC 671 if (! curnum) 672 PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC "); 673 #endif /* USE_LOCALE_NUMERIC */ 674 PerlIO_printf(PerlIO_stderr(), "\n"); 675 676 #endif /* LC_ALL */ 677 678 PerlIO_printf(PerlIO_stderr(), 679 "perl: warning: Please check that your locale settings:\n"); 680 681 PerlIO_printf(PerlIO_stderr(), 682 "\tLC_ALL = %c%s%c,\n", 683 lc_all ? '"' : '(', 684 lc_all ? lc_all : "unset", 685 lc_all ? '"' : ')'); 686 687 { 688 char **e; 689 for (e = environ; *e; e++) { 690 if (strnEQ(*e, "LC_", 3) 691 && strnNE(*e, "LC_ALL=", 7) 692 && (p = strchr(*e, '='))) 693 PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n", 694 (int)(p - *e), *e, p + 1); 695 } 696 } 697 698 PerlIO_printf(PerlIO_stderr(), 699 "\tLANG = %c%s%c\n", 700 lang ? '"' : '(', 701 lang ? lang : "unset", 702 lang ? '"' : ')'); 703 704 PerlIO_printf(PerlIO_stderr(), 705 " are supported and installed on your system.\n"); 706 } 707 708 #ifdef LC_ALL 709 710 if (setlocale(LC_ALL, "C")) { 711 if (locwarn) 712 PerlIO_printf(PerlIO_stderr(), 713 "perl: warning: Falling back to the standard locale (\"C\").\n"); 714 ok = 0; 715 } 716 else { 717 if (locwarn) 718 PerlIO_printf(PerlIO_stderr(), 719 "perl: warning: Failed to fall back to the standard locale (\"C\").\n"); 720 ok = -1; 721 } 722 723 #else /* ! LC_ALL */ 724 725 if (0 726 #ifdef USE_LOCALE_CTYPE 727 || !(curctype || setlocale(LC_CTYPE, "C")) 728 #endif /* USE_LOCALE_CTYPE */ 729 #ifdef USE_LOCALE_COLLATE 730 || !(curcoll || setlocale(LC_COLLATE, "C")) 731 #endif /* USE_LOCALE_COLLATE */ 732 #ifdef USE_LOCALE_NUMERIC 733 || !(curnum || setlocale(LC_NUMERIC, "C")) 734 #endif /* USE_LOCALE_NUMERIC */ 735 ) 736 { 737 if (locwarn) 738 PerlIO_printf(PerlIO_stderr(), 739 "perl: warning: Cannot fall back to the standard locale (\"C\").\n"); 740 ok = -1; 741 } 742 743 #endif /* ! LC_ALL */ 744 745 #ifdef USE_LOCALE_CTYPE 746 curctype = setlocale(LC_CTYPE, Nullch); 747 #endif /* USE_LOCALE_CTYPE */ 748 #ifdef USE_LOCALE_COLLATE 749 curcoll = setlocale(LC_COLLATE, Nullch); 750 #endif /* USE_LOCALE_COLLATE */ 751 #ifdef USE_LOCALE_NUMERIC 752 curnum = setlocale(LC_NUMERIC, Nullch); 753 #endif /* USE_LOCALE_NUMERIC */ 754 } 755 756 #ifdef USE_LOCALE_CTYPE 757 perl_new_ctype(curctype); 758 #endif /* USE_LOCALE_CTYPE */ 759 760 #ifdef USE_LOCALE_COLLATE 761 perl_new_collate(curcoll); 762 #endif /* USE_LOCALE_COLLATE */ 763 764 #ifdef USE_LOCALE_NUMERIC 765 perl_new_numeric(curnum); 766 #endif /* USE_LOCALE_NUMERIC */ 767 768 #endif /* USE_LOCALE */ 769 770 return ok; 771 } 772 773 /* Backwards compatibility. */ 774 int 775 perl_init_i18nl14n(printwarn) 776 int printwarn; 777 { 778 return perl_init_i18nl10n(printwarn); 779 } 780 781 #ifdef USE_LOCALE_COLLATE 782 783 /* 784 * mem_collxfrm() is a bit like strxfrm() but with two important 785 * differences. First, it handles embedded NULs. Second, it allocates 786 * a bit more memory than needed for the transformed data itself. 787 * The real transformed data begins at offset sizeof(collationix). 788 * Please see sv_collxfrm() to see how this is used. 789 */ 790 char * 791 mem_collxfrm(s, len, xlen) 792 const char *s; 793 STRLEN len; 794 STRLEN *xlen; 795 { 796 char *xbuf; 797 STRLEN xalloc, xin, xout; 798 799 /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */ 800 /* the +1 is for the terminating NUL. */ 801 802 xalloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1; 803 New(171, xbuf, xalloc, char); 804 if (! xbuf) 805 goto bad; 806 807 *(U32*)xbuf = collation_ix; 808 xout = sizeof(collation_ix); 809 for (xin = 0; xin < len; ) { 810 SSize_t xused; 811 812 for (;;) { 813 xused = strxfrm(xbuf + xout, s + xin, xalloc - xout); 814 if (xused == -1) 815 goto bad; 816 if (xused < xalloc - xout) 817 break; 818 xalloc = (2 * xalloc) + 1; 819 Renew(xbuf, xalloc, char); 820 if (! xbuf) 821 goto bad; 822 } 823 824 xin += strlen(s + xin) + 1; 825 xout += xused; 826 827 /* Embedded NULs are understood but silently skipped 828 * because they make no sense in locale collation. */ 829 } 830 831 xbuf[xout] = '\0'; 832 *xlen = xout - sizeof(collation_ix); 833 return xbuf; 834 835 bad: 836 Safefree(xbuf); 837 *xlen = 0; 838 return NULL; 839 } 840 841 #endif /* USE_LOCALE_COLLATE */ 842 843 void 844 fbm_compile(sv) 845 SV *sv; 846 { 847 register unsigned char *s; 848 register unsigned char *table; 849 register U32 i; 850 register U32 len = SvCUR(sv); 851 I32 rarest = 0; 852 U32 frequency = 256; 853 854 if (len > 255) 855 return; /* can't have offsets that big */ 856 Sv_Grow(sv,len+258); 857 table = (unsigned char*)(SvPVX(sv) + len + 1); 858 s = table - 2; 859 for (i = 0; i < 256; i++) { 860 table[i] = len; 861 } 862 i = 0; 863 while (s >= (unsigned char*)(SvPVX(sv))) 864 { 865 if (table[*s] == len) 866 table[*s] = i; 867 s--,i++; 868 } 869 sv_upgrade(sv, SVt_PVBM); 870 sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ 871 SvVALID_on(sv); 872 873 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ 874 for (i = 0; i < len; i++) { 875 if (freq[s[i]] < frequency) { 876 rarest = i; 877 frequency = freq[s[i]]; 878 } 879 } 880 BmRARE(sv) = s[rarest]; 881 BmPREVIOUS(sv) = rarest; 882 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); 883 } 884 885 char * 886 fbm_instr(big, bigend, littlestr) 887 unsigned char *big; 888 register unsigned char *bigend; 889 SV *littlestr; 890 { 891 register unsigned char *s; 892 register I32 tmp; 893 register I32 littlelen; 894 register unsigned char *little; 895 register unsigned char *table; 896 register unsigned char *olds; 897 register unsigned char *oldlittle; 898 899 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { 900 STRLEN len; 901 char *l = SvPV(littlestr,len); 902 if (!len) 903 return (char*)big; 904 return ninstr((char*)big,(char*)bigend, l, l + len); 905 } 906 907 littlelen = SvCUR(littlestr); 908 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ 909 if (littlelen > bigend - big) 910 return Nullch; 911 little = (unsigned char*)SvPVX(littlestr); 912 s = bigend - littlelen; 913 if (*s == *little && memEQ((char*)s,(char*)little,littlelen)) 914 return (char*)s; /* how sweet it is */ 915 else if (bigend[-1] == '\n' && little[littlelen-1] != '\n' 916 && s > big) { 917 s--; 918 if (*s == *little && memEQ((char*)s,(char*)little,littlelen)) 919 return (char*)s; 920 } 921 return Nullch; 922 } 923 table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1); 924 if (--littlelen >= bigend - big) 925 return Nullch; 926 s = big + littlelen; 927 oldlittle = little = table - 2; 928 if (s < bigend) { 929 top2: 930 /*SUPPRESS 560*/ 931 if (tmp = table[*s]) { 932 #ifdef POINTERRIGOR 933 if (bigend - s > tmp) { 934 s += tmp; 935 goto top2; 936 } 937 #else 938 if ((s += tmp) < bigend) 939 goto top2; 940 #endif 941 return Nullch; 942 } 943 else { 944 tmp = littlelen; /* less expensive than calling strncmp() */ 945 olds = s; 946 while (tmp--) { 947 if (*--s == *--little) 948 continue; 949 s = olds + 1; /* here we pay the price for failure */ 950 little = oldlittle; 951 if (s < bigend) /* fake up continue to outer loop */ 952 goto top2; 953 return Nullch; 954 } 955 return (char *)s; 956 } 957 } 958 return Nullch; 959 } 960 961 char * 962 screaminstr(bigstr, littlestr) 963 SV *bigstr; 964 SV *littlestr; 965 { 966 register unsigned char *s, *x; 967 register unsigned char *big; 968 register I32 pos; 969 register I32 previous; 970 register I32 first; 971 register unsigned char *little; 972 register unsigned char *bigend; 973 register unsigned char *littleend; 974 975 if ((pos = screamfirst[BmRARE(littlestr)]) < 0) 976 return Nullch; 977 little = (unsigned char *)(SvPVX(littlestr)); 978 littleend = little + SvCUR(littlestr); 979 first = *little++; 980 previous = BmPREVIOUS(littlestr); 981 big = (unsigned char *)(SvPVX(bigstr)); 982 bigend = big + SvCUR(bigstr); 983 while (pos < previous) { 984 if (!(pos += screamnext[pos])) 985 return Nullch; 986 } 987 #ifdef POINTERRIGOR 988 do { 989 if (big[pos-previous] != first) 990 continue; 991 for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { 992 if (x >= bigend) 993 return Nullch; 994 if (*s++ != *x++) { 995 s--; 996 break; 997 } 998 } 999 if (s == littleend) 1000 return (char *)(big+pos-previous); 1001 } while ( pos += screamnext[pos] ); 1002 #else /* !POINTERRIGOR */ 1003 big -= previous; 1004 do { 1005 if (big[pos] != first) 1006 continue; 1007 for (x=big+pos+1,s=little; s < littleend; /**/ ) { 1008 if (x >= bigend) 1009 return Nullch; 1010 if (*s++ != *x++) { 1011 s--; 1012 break; 1013 } 1014 } 1015 if (s == littleend) 1016 return (char *)(big+pos); 1017 } while ( pos += screamnext[pos] ); 1018 #endif /* POINTERRIGOR */ 1019 return Nullch; 1020 } 1021 1022 I32 1023 ibcmp(s1, s2, len) 1024 char *s1, *s2; 1025 register I32 len; 1026 { 1027 register U8 *a = (U8 *)s1; 1028 register U8 *b = (U8 *)s2; 1029 while (len--) { 1030 if (*a != *b && *a != fold[*b]) 1031 return 1; 1032 a++,b++; 1033 } 1034 return 0; 1035 } 1036 1037 I32 1038 ibcmp_locale(s1, s2, len) 1039 char *s1, *s2; 1040 register I32 len; 1041 { 1042 register U8 *a = (U8 *)s1; 1043 register U8 *b = (U8 *)s2; 1044 while (len--) { 1045 if (*a != *b && *a != fold_locale[*b]) 1046 return 1; 1047 a++,b++; 1048 } 1049 return 0; 1050 } 1051 1052 /* copy a string to a safe spot */ 1053 1054 char * 1055 savepv(sv) 1056 char *sv; 1057 { 1058 register char *newaddr; 1059 1060 New(902,newaddr,strlen(sv)+1,char); 1061 (void)strcpy(newaddr,sv); 1062 return newaddr; 1063 } 1064 1065 /* same thing but with a known length */ 1066 1067 char * 1068 savepvn(sv, len) 1069 char *sv; 1070 register I32 len; 1071 { 1072 register char *newaddr; 1073 1074 New(903,newaddr,len+1,char); 1075 Copy(sv,newaddr,len,char); /* might not be null terminated */ 1076 newaddr[len] = '\0'; /* is now */ 1077 return newaddr; 1078 } 1079 1080 /* the SV for form() and mess() is not kept in an arena */ 1081 1082 static SV * 1083 mess_alloc() 1084 { 1085 SV *sv; 1086 XPVMG *any; 1087 1088 /* Create as PVMG now, to avoid any upgrading later */ 1089 New(905, sv, 1, SV); 1090 Newz(905, any, 1, XPVMG); 1091 SvFLAGS(sv) = SVt_PVMG; 1092 SvANY(sv) = (void*)any; 1093 SvREFCNT(sv) = 1 << 30; /* practically infinite */ 1094 return sv; 1095 } 1096 1097 #ifdef I_STDARG 1098 char * 1099 form(const char* pat, ...) 1100 #else 1101 /*VARARGS0*/ 1102 char * 1103 form(pat, va_alist) 1104 const char *pat; 1105 va_dcl 1106 #endif 1107 { 1108 va_list args; 1109 #ifdef I_STDARG 1110 va_start(args, pat); 1111 #else 1112 va_start(args); 1113 #endif 1114 if (!mess_sv) 1115 mess_sv = mess_alloc(); 1116 sv_vsetpvfn(mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); 1117 va_end(args); 1118 return SvPVX(mess_sv); 1119 } 1120 1121 char * 1122 mess(pat, args) 1123 const char *pat; 1124 va_list *args; 1125 { 1126 SV *sv; 1127 static char dgd[] = " during global destruction.\n"; 1128 1129 if (!mess_sv) 1130 mess_sv = mess_alloc(); 1131 sv = mess_sv; 1132 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); 1133 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { 1134 if (dirty) 1135 sv_catpv(sv, dgd); 1136 else { 1137 if (curcop->cop_line) 1138 sv_catpvf(sv, " at %_ line %ld", 1139 GvSV(curcop->cop_filegv), (long)curcop->cop_line); 1140 if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) { 1141 bool line_mode = (RsSIMPLE(rs) && 1142 SvLEN(rs) == 1 && *SvPVX(rs) == '\n'); 1143 sv_catpvf(sv, ", <%s> %s %ld", 1144 last_in_gv == argvgv ? "" : GvNAME(last_in_gv), 1145 line_mode ? "line" : "chunk", 1146 (long)IoLINES(GvIOp(last_in_gv))); 1147 } 1148 sv_catpv(sv, ".\n"); 1149 } 1150 } 1151 return SvPVX(sv); 1152 } 1153 1154 #ifdef I_STDARG 1155 OP * 1156 die(const char* pat, ...) 1157 #else 1158 /*VARARGS0*/ 1159 OP * 1160 die(pat, va_alist) 1161 const char *pat; 1162 va_dcl 1163 #endif 1164 { 1165 va_list args; 1166 char *message; 1167 I32 oldrunlevel = runlevel; 1168 int was_in_eval = in_eval; 1169 HV *stash; 1170 GV *gv; 1171 CV *cv; 1172 1173 /* We have to switch back to mainstack or die_where may try to pop 1174 * the eval block from the wrong stack if die is being called from a 1175 * signal handler. - dkindred@cs.cmu.edu */ 1176 if (curstack != mainstack) { 1177 dSP; 1178 SWITCHSTACK(curstack, mainstack); 1179 } 1180 1181 #ifdef I_STDARG 1182 va_start(args, pat); 1183 #else 1184 va_start(args); 1185 #endif 1186 message = mess(pat, &args); 1187 va_end(args); 1188 1189 if (diehook) { 1190 /* sv_2cv might call croak() */ 1191 SV *olddiehook = diehook; 1192 ENTER; 1193 SAVESPTR(diehook); 1194 diehook = Nullsv; 1195 cv = sv_2cv(olddiehook, &stash, &gv, 0); 1196 LEAVE; 1197 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1198 dSP; 1199 SV *msg; 1200 1201 ENTER; 1202 msg = newSVpv(message, 0); 1203 SvREADONLY_on(msg); 1204 SAVEFREESV(msg); 1205 1206 PUSHMARK(sp); 1207 XPUSHs(msg); 1208 PUTBACK; 1209 perl_call_sv((SV*)cv, G_DISCARD); 1210 1211 LEAVE; 1212 } 1213 } 1214 1215 restartop = die_where(message); 1216 if ((!restartop && was_in_eval) || oldrunlevel > 1) 1217 JMPENV_JUMP(3); 1218 return restartop; 1219 } 1220 1221 #ifdef I_STDARG 1222 void 1223 croak(const char* pat, ...) 1224 #else 1225 /*VARARGS0*/ 1226 void 1227 croak(pat, va_alist) 1228 char *pat; 1229 va_dcl 1230 #endif 1231 { 1232 va_list args; 1233 char *message; 1234 HV *stash; 1235 GV *gv; 1236 CV *cv; 1237 1238 #ifdef I_STDARG 1239 va_start(args, pat); 1240 #else 1241 va_start(args); 1242 #endif 1243 message = mess(pat, &args); 1244 va_end(args); 1245 if (diehook) { 1246 /* sv_2cv might call croak() */ 1247 SV *olddiehook = diehook; 1248 ENTER; 1249 SAVESPTR(diehook); 1250 diehook = Nullsv; 1251 cv = sv_2cv(olddiehook, &stash, &gv, 0); 1252 LEAVE; 1253 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1254 dSP; 1255 SV *msg; 1256 1257 ENTER; 1258 msg = newSVpv(message, 0); 1259 SvREADONLY_on(msg); 1260 SAVEFREESV(msg); 1261 1262 PUSHMARK(sp); 1263 XPUSHs(msg); 1264 PUTBACK; 1265 perl_call_sv((SV*)cv, G_DISCARD); 1266 1267 LEAVE; 1268 } 1269 } 1270 if (in_eval) { 1271 restartop = die_where(message); 1272 JMPENV_JUMP(3); 1273 } 1274 PerlIO_puts(PerlIO_stderr(),message); 1275 (void)PerlIO_flush(PerlIO_stderr()); 1276 my_failure_exit(); 1277 } 1278 1279 void 1280 #ifdef I_STDARG 1281 warn(const char* pat,...) 1282 #else 1283 /*VARARGS0*/ 1284 warn(pat,va_alist) 1285 const char *pat; 1286 va_dcl 1287 #endif 1288 { 1289 va_list args; 1290 char *message; 1291 HV *stash; 1292 GV *gv; 1293 CV *cv; 1294 1295 #ifdef I_STDARG 1296 va_start(args, pat); 1297 #else 1298 va_start(args); 1299 #endif 1300 message = mess(pat, &args); 1301 va_end(args); 1302 1303 if (warnhook) { 1304 /* sv_2cv might call warn() */ 1305 SV *oldwarnhook = warnhook; 1306 ENTER; 1307 SAVESPTR(warnhook); 1308 warnhook = Nullsv; 1309 cv = sv_2cv(oldwarnhook, &stash, &gv, 0); 1310 LEAVE; 1311 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1312 dSP; 1313 SV *msg; 1314 1315 ENTER; 1316 msg = newSVpv(message, 0); 1317 SvREADONLY_on(msg); 1318 SAVEFREESV(msg); 1319 1320 PUSHMARK(sp); 1321 XPUSHs(msg); 1322 PUTBACK; 1323 perl_call_sv((SV*)cv, G_DISCARD); 1324 1325 LEAVE; 1326 return; 1327 } 1328 } 1329 PerlIO_puts(PerlIO_stderr(),message); 1330 #ifdef LEAKTEST 1331 DEBUG_L(xstat()); 1332 #endif 1333 (void)PerlIO_flush(PerlIO_stderr()); 1334 } 1335 1336 #ifndef VMS /* VMS' my_setenv() is in VMS.c */ 1337 #ifndef WIN32 1338 void 1339 my_setenv(nam,val) 1340 char *nam, *val; 1341 { 1342 register I32 i=setenv_getix(nam); /* where does it go? */ 1343 1344 if (environ == origenviron) { /* need we copy environment? */ 1345 I32 j; 1346 I32 max; 1347 char **tmpenv; 1348 1349 /*SUPPRESS 530*/ 1350 for (max = i; environ[max]; max++) ; 1351 New(901,tmpenv, max+2, char*); 1352 for (j=0; j<max; j++) /* copy environment */ 1353 tmpenv[j] = savepv(environ[j]); 1354 tmpenv[max] = Nullch; 1355 environ = tmpenv; /* tell exec where it is now */ 1356 } 1357 if (!val) { 1358 Safefree(environ[i]); 1359 while (environ[i]) { 1360 environ[i] = environ[i+1]; 1361 i++; 1362 } 1363 return; 1364 } 1365 if (!environ[i]) { /* does not exist yet */ 1366 Renew(environ, i+2, char*); /* just expand it a bit */ 1367 environ[i+1] = Nullch; /* make sure it's null terminated */ 1368 } 1369 else 1370 Safefree(environ[i]); 1371 New(904, environ[i], strlen(nam) + strlen(val) + 2, char); 1372 #ifndef MSDOS 1373 (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ 1374 #else 1375 /* MS-DOS requires environment variable names to be in uppercase */ 1376 /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but 1377 * some utilities and applications may break because they only look 1378 * for upper case strings. (Fixed strupr() bug here.)] 1379 */ 1380 strcpy(environ[i],nam); strupr(environ[i]); 1381 (void)sprintf(environ[i] + strlen(nam),"=%s",val); 1382 #endif /* MSDOS */ 1383 } 1384 1385 #else /* if WIN32 */ 1386 1387 void 1388 my_setenv(nam,val) 1389 char *nam, *val; 1390 { 1391 1392 #ifdef USE_WIN32_RTL_ENV 1393 1394 register char *envstr; 1395 STRLEN namlen = strlen(nam); 1396 STRLEN vallen; 1397 char *oldstr = environ[setenv_getix(nam)]; 1398 1399 /* putenv() has totally broken semantics in both the Borland 1400 * and Microsoft CRTLs. They either store the passed pointer in 1401 * the environment without making a copy, or make a copy and don't 1402 * free it. And on top of that, they dont free() old entries that 1403 * are being replaced/deleted. This means the caller must 1404 * free any old entries somehow, or we end up with a memory 1405 * leak every time my_setenv() is called. One might think 1406 * one could directly manipulate environ[], like the UNIX code 1407 * above, but direct changes to environ are not allowed when 1408 * calling putenv(), since the RTLs maintain an internal 1409 * *copy* of environ[]. Bad, bad, *bad* stink. 1410 * GSAR 97-06-07 1411 */ 1412 1413 if (!val) { 1414 if (!oldstr) 1415 return; 1416 val = ""; 1417 vallen = 0; 1418 } 1419 else 1420 vallen = strlen(val); 1421 New(904, envstr, namlen + vallen + 3, char); 1422 (void)sprintf(envstr,"%s=%s",nam,val); 1423 (void)putenv(envstr); 1424 if (oldstr) 1425 Safefree(oldstr); 1426 #ifdef _MSC_VER 1427 Safefree(envstr); /* MSVCRT leaks without this */ 1428 #endif 1429 1430 #else /* !USE_WIN32_RTL_ENV */ 1431 1432 /* The sane way to deal with the environment. 1433 * Has these advantages over putenv() & co.: 1434 * * enables us to store a truly empty value in the 1435 * environment (like in UNIX). 1436 * * we don't have to deal with RTL globals, bugs and leaks. 1437 * * Much faster. 1438 * Why you may want to enable USE_WIN32_RTL_ENV: 1439 * * environ[] and RTL functions will not reflect changes, 1440 * which might be an issue if extensions want to access 1441 * the env. via RTL. This cuts both ways, since RTL will 1442 * not see changes made by extensions that call the Win32 1443 * functions directly, either. 1444 * GSAR 97-06-07 1445 */ 1446 SetEnvironmentVariable(nam,val); 1447 1448 #endif 1449 } 1450 1451 #endif /* WIN32 */ 1452 1453 I32 1454 setenv_getix(nam) 1455 char *nam; 1456 { 1457 register I32 i, len = strlen(nam); 1458 1459 for (i = 0; environ[i]; i++) { 1460 if ( 1461 #ifdef WIN32 1462 strnicmp(environ[i],nam,len) == 0 1463 #else 1464 strnEQ(environ[i],nam,len) 1465 #endif 1466 && environ[i][len] == '=') 1467 break; /* strnEQ must come first to avoid */ 1468 } /* potential SEGV's */ 1469 return i; 1470 } 1471 1472 #endif /* !VMS */ 1473 1474 #ifdef UNLINK_ALL_VERSIONS 1475 I32 1476 unlnk(f) /* unlink all versions of a file */ 1477 char *f; 1478 { 1479 I32 i; 1480 1481 for (i = 0; unlink(f) >= 0; i++) ; 1482 return i ? 0 : -1; 1483 } 1484 #endif 1485 1486 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) 1487 char * 1488 my_bcopy(from,to,len) 1489 register char *from; 1490 register char *to; 1491 register I32 len; 1492 { 1493 char *retval = to; 1494 1495 if (from - to >= 0) { 1496 while (len--) 1497 *to++ = *from++; 1498 } 1499 else { 1500 to += len; 1501 from += len; 1502 while (len--) 1503 *(--to) = *(--from); 1504 } 1505 return retval; 1506 } 1507 #endif 1508 1509 #ifndef HAS_MEMSET 1510 void * 1511 my_memset(loc,ch,len) 1512 register char *loc; 1513 register I32 ch; 1514 register I32 len; 1515 { 1516 char *retval = loc; 1517 1518 while (len--) 1519 *loc++ = ch; 1520 return retval; 1521 } 1522 #endif 1523 1524 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) 1525 char * 1526 my_bzero(loc,len) 1527 register char *loc; 1528 register I32 len; 1529 { 1530 char *retval = loc; 1531 1532 while (len--) 1533 *loc++ = 0; 1534 return retval; 1535 } 1536 #endif 1537 1538 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) 1539 I32 1540 my_memcmp(s1,s2,len) 1541 char *s1; 1542 char *s2; 1543 register I32 len; 1544 { 1545 register U8 *a = (U8 *)s1; 1546 register U8 *b = (U8 *)s2; 1547 register I32 tmp; 1548 1549 while (len--) { 1550 if (tmp = *a++ - *b++) 1551 return tmp; 1552 } 1553 return 0; 1554 } 1555 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ 1556 1557 #if defined(I_STDARG) || defined(I_VARARGS) 1558 #ifndef HAS_VPRINTF 1559 1560 #ifdef USE_CHAR_VSPRINTF 1561 char * 1562 #else 1563 int 1564 #endif 1565 vsprintf(dest, pat, args) 1566 char *dest; 1567 const char *pat; 1568 char *args; 1569 { 1570 FILE fakebuf; 1571 1572 fakebuf._ptr = dest; 1573 fakebuf._cnt = 32767; 1574 #ifndef _IOSTRG 1575 #define _IOSTRG 0 1576 #endif 1577 fakebuf._flag = _IOWRT|_IOSTRG; 1578 _doprnt(pat, args, &fakebuf); /* what a kludge */ 1579 (void)putc('\0', &fakebuf); 1580 #ifdef USE_CHAR_VSPRINTF 1581 return(dest); 1582 #else 1583 return 0; /* perl doesn't use return value */ 1584 #endif 1585 } 1586 1587 #endif /* HAS_VPRINTF */ 1588 #endif /* I_VARARGS || I_STDARGS */ 1589 1590 #ifdef MYSWAP 1591 #if BYTEORDER != 0x4321 1592 short 1593 #ifndef CAN_PROTOTYPE 1594 my_swap(s) 1595 short s; 1596 #else 1597 my_swap(short s) 1598 #endif 1599 { 1600 #if (BYTEORDER & 1) == 0 1601 short result; 1602 1603 result = ((s & 255) << 8) + ((s >> 8) & 255); 1604 return result; 1605 #else 1606 return s; 1607 #endif 1608 } 1609 1610 long 1611 #ifndef CAN_PROTOTYPE 1612 my_htonl(l) 1613 register long l; 1614 #else 1615 my_htonl(long l) 1616 #endif 1617 { 1618 union { 1619 long result; 1620 char c[sizeof(long)]; 1621 } u; 1622 1623 #if BYTEORDER == 0x1234 1624 u.c[0] = (l >> 24) & 255; 1625 u.c[1] = (l >> 16) & 255; 1626 u.c[2] = (l >> 8) & 255; 1627 u.c[3] = l & 255; 1628 return u.result; 1629 #else 1630 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) 1631 croak("Unknown BYTEORDER\n"); 1632 #else 1633 register I32 o; 1634 register I32 s; 1635 1636 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { 1637 u.c[o & 0xf] = (l >> s) & 255; 1638 } 1639 return u.result; 1640 #endif 1641 #endif 1642 } 1643 1644 long 1645 #ifndef CAN_PROTOTYPE 1646 my_ntohl(l) 1647 register long l; 1648 #else 1649 my_ntohl(long l) 1650 #endif 1651 { 1652 union { 1653 long l; 1654 char c[sizeof(long)]; 1655 } u; 1656 1657 #if BYTEORDER == 0x1234 1658 u.c[0] = (l >> 24) & 255; 1659 u.c[1] = (l >> 16) & 255; 1660 u.c[2] = (l >> 8) & 255; 1661 u.c[3] = l & 255; 1662 return u.l; 1663 #else 1664 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) 1665 croak("Unknown BYTEORDER\n"); 1666 #else 1667 register I32 o; 1668 register I32 s; 1669 1670 u.l = l; 1671 l = 0; 1672 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { 1673 l |= (u.c[o & 0xf] & 255) << s; 1674 } 1675 return l; 1676 #endif 1677 #endif 1678 } 1679 1680 #endif /* BYTEORDER != 0x4321 */ 1681 #endif /* MYSWAP */ 1682 1683 /* 1684 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. 1685 * If these functions are defined, 1686 * the BYTEORDER is neither 0x1234 nor 0x4321. 1687 * However, this is not assumed. 1688 * -DWS 1689 */ 1690 1691 #define HTOV(name,type) \ 1692 type \ 1693 name (n) \ 1694 register type n; \ 1695 { \ 1696 union { \ 1697 type value; \ 1698 char c[sizeof(type)]; \ 1699 } u; \ 1700 register I32 i; \ 1701 register I32 s; \ 1702 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ 1703 u.c[i] = (n >> s) & 0xFF; \ 1704 } \ 1705 return u.value; \ 1706 } 1707 1708 #define VTOH(name,type) \ 1709 type \ 1710 name (n) \ 1711 register type n; \ 1712 { \ 1713 union { \ 1714 type value; \ 1715 char c[sizeof(type)]; \ 1716 } u; \ 1717 register I32 i; \ 1718 register I32 s; \ 1719 u.value = n; \ 1720 n = 0; \ 1721 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ 1722 n += (u.c[i] & 0xFF) << s; \ 1723 } \ 1724 return n; \ 1725 } 1726 1727 #if defined(HAS_HTOVS) && !defined(htovs) 1728 HTOV(htovs,short) 1729 #endif 1730 #if defined(HAS_HTOVL) && !defined(htovl) 1731 HTOV(htovl,long) 1732 #endif 1733 #if defined(HAS_VTOHS) && !defined(vtohs) 1734 VTOH(vtohs,short) 1735 #endif 1736 #if defined(HAS_VTOHL) && !defined(vtohl) 1737 VTOH(vtohl,long) 1738 #endif 1739 1740 /* VMS' my_popen() is in VMS.c, same with OS/2. */ 1741 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) 1742 PerlIO * 1743 my_popen(cmd,mode) 1744 char *cmd; 1745 char *mode; 1746 { 1747 int p[2]; 1748 register I32 this, that; 1749 register I32 pid; 1750 SV *sv; 1751 I32 doexec = strNE(cmd,"-"); 1752 1753 #ifdef OS2 1754 if (doexec) { 1755 return my_syspopen(cmd,mode); 1756 } 1757 #endif 1758 if (pipe(p) < 0) 1759 return Nullfp; 1760 this = (*mode == 'w'); 1761 that = !this; 1762 if (doexec && tainting) { 1763 taint_env(); 1764 taint_proper("Insecure %s%s", "EXEC"); 1765 } 1766 while ((pid = (doexec?vfork():fork())) < 0) { 1767 if (errno != EAGAIN) { 1768 close(p[this]); 1769 if (!doexec) 1770 croak("Can't fork"); 1771 return Nullfp; 1772 } 1773 sleep(5); 1774 } 1775 if (pid == 0) { 1776 GV* tmpgv; 1777 1778 #define THIS that 1779 #define THAT this 1780 close(p[THAT]); 1781 if (p[THIS] != (*mode == 'r')) { 1782 dup2(p[THIS], *mode == 'r'); 1783 close(p[THIS]); 1784 } 1785 if (doexec) { 1786 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 1787 int fd; 1788 1789 #ifndef NOFILE 1790 #define NOFILE 20 1791 #endif 1792 for (fd = maxsysfd + 1; fd < NOFILE; fd++) 1793 close(fd); 1794 #endif 1795 do_exec(cmd); /* may or may not use the shell */ 1796 _exit(1); 1797 } 1798 /*SUPPRESS 560*/ 1799 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) 1800 sv_setiv(GvSV(tmpgv), (IV)getpid()); 1801 forkprocess = 0; 1802 hv_clear(pidstatus); /* we have no children */ 1803 return Nullfp; 1804 #undef THIS 1805 #undef THAT 1806 } 1807 do_execfree(); /* free any memory malloced by child on vfork */ 1808 close(p[that]); 1809 if (p[that] < p[this]) { 1810 dup2(p[this], p[that]); 1811 close(p[this]); 1812 p[this] = p[that]; 1813 } 1814 sv = *av_fetch(fdpid,p[this],TRUE); 1815 (void)SvUPGRADE(sv,SVt_IV); 1816 SvIVX(sv) = pid; 1817 forkprocess = pid; 1818 return PerlIO_fdopen(p[this], mode); 1819 } 1820 #else 1821 #if defined(atarist) || defined(DJGPP) 1822 FILE *popen(); 1823 PerlIO * 1824 my_popen(cmd,mode) 1825 char *cmd; 1826 char *mode; 1827 { 1828 /* Needs work for PerlIO ! */ 1829 /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */ 1830 return popen(PerlIO_exportFILE(cmd, 0), mode); 1831 } 1832 #endif 1833 1834 #endif /* !DOSISH */ 1835 1836 #ifdef DUMP_FDS 1837 dump_fds(s) 1838 char *s; 1839 { 1840 int fd; 1841 struct stat tmpstatbuf; 1842 1843 PerlIO_printf(PerlIO_stderr(),"%s", s); 1844 for (fd = 0; fd < 32; fd++) { 1845 if (Fstat(fd,&tmpstatbuf) >= 0) 1846 PerlIO_printf(PerlIO_stderr()," %d",fd); 1847 } 1848 PerlIO_printf(PerlIO_stderr(),"\n"); 1849 } 1850 #endif 1851 1852 #ifndef HAS_DUP2 1853 int 1854 dup2(oldfd,newfd) 1855 int oldfd; 1856 int newfd; 1857 { 1858 #if defined(HAS_FCNTL) && defined(F_DUPFD) 1859 if (oldfd == newfd) 1860 return oldfd; 1861 close(newfd); 1862 return fcntl(oldfd, F_DUPFD, newfd); 1863 #else 1864 #define DUP2_MAX_FDS 256 1865 int fdtmp[DUP2_MAX_FDS]; 1866 I32 fdx = 0; 1867 int fd; 1868 1869 if (oldfd == newfd) 1870 return oldfd; 1871 close(newfd); 1872 /* good enough for low fd's... */ 1873 while ((fd = dup(oldfd)) != newfd && fd >= 0) { 1874 if (fdx >= DUP2_MAX_FDS) { 1875 close(fd); 1876 fd = -1; 1877 break; 1878 } 1879 fdtmp[fdx++] = fd; 1880 } 1881 while (fdx > 0) 1882 close(fdtmp[--fdx]); 1883 return fd; 1884 #endif 1885 } 1886 #endif 1887 1888 1889 #ifdef HAS_SIGACTION 1890 1891 Sighandler_t 1892 rsignal(signo, handler) 1893 int signo; 1894 Sighandler_t handler; 1895 { 1896 struct sigaction act, oact; 1897 1898 act.sa_handler = handler; 1899 sigemptyset(&act.sa_mask); 1900 act.sa_flags = 0; 1901 #ifdef SA_RESTART 1902 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 1903 #endif 1904 if (sigaction(signo, &act, &oact) == -1) 1905 return SIG_ERR; 1906 else 1907 return oact.sa_handler; 1908 } 1909 1910 Sighandler_t 1911 rsignal_state(signo) 1912 int signo; 1913 { 1914 struct sigaction oact; 1915 1916 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) 1917 return SIG_ERR; 1918 else 1919 return oact.sa_handler; 1920 } 1921 1922 int 1923 rsignal_save(signo, handler, save) 1924 int signo; 1925 Sighandler_t handler; 1926 Sigsave_t *save; 1927 { 1928 struct sigaction act; 1929 1930 act.sa_handler = handler; 1931 sigemptyset(&act.sa_mask); 1932 act.sa_flags = 0; 1933 #ifdef SA_RESTART 1934 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 1935 #endif 1936 return sigaction(signo, &act, save); 1937 } 1938 1939 int 1940 rsignal_restore(signo, save) 1941 int signo; 1942 Sigsave_t *save; 1943 { 1944 return sigaction(signo, save, (struct sigaction *)NULL); 1945 } 1946 1947 #else /* !HAS_SIGACTION */ 1948 1949 Sighandler_t 1950 rsignal(signo, handler) 1951 int signo; 1952 Sighandler_t handler; 1953 { 1954 return signal(signo, handler); 1955 } 1956 1957 static int sig_trapped; 1958 1959 static 1960 Signal_t 1961 sig_trap(signo) 1962 int signo; 1963 { 1964 sig_trapped++; 1965 } 1966 1967 Sighandler_t 1968 rsignal_state(signo) 1969 int signo; 1970 { 1971 Sighandler_t oldsig; 1972 1973 sig_trapped = 0; 1974 oldsig = signal(signo, sig_trap); 1975 signal(signo, oldsig); 1976 if (sig_trapped) 1977 kill(getpid(), signo); 1978 return oldsig; 1979 } 1980 1981 int 1982 rsignal_save(signo, handler, save) 1983 int signo; 1984 Sighandler_t handler; 1985 Sigsave_t *save; 1986 { 1987 *save = signal(signo, handler); 1988 return (*save == SIG_ERR) ? -1 : 0; 1989 } 1990 1991 int 1992 rsignal_restore(signo, save) 1993 int signo; 1994 Sigsave_t *save; 1995 { 1996 return (signal(signo, *save) == SIG_ERR) ? -1 : 0; 1997 } 1998 1999 #endif /* !HAS_SIGACTION */ 2000 2001 /* VMS' my_pclose() is in VMS.c; same with OS/2 */ 2002 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) 2003 I32 2004 my_pclose(ptr) 2005 PerlIO *ptr; 2006 { 2007 Sigsave_t hstat, istat, qstat; 2008 int status; 2009 SV **svp; 2010 int pid; 2011 bool close_failed; 2012 int saved_errno; 2013 #ifdef VMS 2014 int saved_vaxc_errno; 2015 #endif 2016 2017 svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE); 2018 pid = (int)SvIVX(*svp); 2019 SvREFCNT_dec(*svp); 2020 *svp = &sv_undef; 2021 #ifdef OS2 2022 if (pid == -1) { /* Opened by popen. */ 2023 return my_syspclose(ptr); 2024 } 2025 #endif 2026 if ((close_failed = (PerlIO_close(ptr) == EOF))) { 2027 saved_errno = errno; 2028 #ifdef VMS 2029 saved_vaxc_errno = vaxc$errno; 2030 #endif 2031 } 2032 #ifdef UTS 2033 if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ 2034 #endif 2035 rsignal_save(SIGHUP, SIG_IGN, &hstat); 2036 rsignal_save(SIGINT, SIG_IGN, &istat); 2037 rsignal_save(SIGQUIT, SIG_IGN, &qstat); 2038 do { 2039 pid = wait4pid(pid, &status, 0); 2040 } while (pid == -1 && errno == EINTR); 2041 rsignal_restore(SIGHUP, &hstat); 2042 rsignal_restore(SIGINT, &istat); 2043 rsignal_restore(SIGQUIT, &qstat); 2044 if (close_failed) { 2045 SETERRNO(saved_errno, saved_vaxc_errno); 2046 return -1; 2047 } 2048 return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status)); 2049 } 2050 #endif /* !DOSISH */ 2051 2052 #if !defined(DOSISH) || defined(OS2) 2053 I32 2054 wait4pid(pid,statusp,flags) 2055 int pid; 2056 int *statusp; 2057 int flags; 2058 { 2059 SV *sv; 2060 SV** svp; 2061 char spid[TYPE_CHARS(int)]; 2062 2063 if (!pid) 2064 return -1; 2065 if (pid > 0) { 2066 sprintf(spid, "%d", pid); 2067 svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE); 2068 if (svp && *svp != &sv_undef) { 2069 *statusp = SvIVX(*svp); 2070 (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); 2071 return pid; 2072 } 2073 } 2074 else { 2075 HE *entry; 2076 2077 hv_iterinit(pidstatus); 2078 if (entry = hv_iternext(pidstatus)) { 2079 pid = atoi(hv_iterkey(entry,(I32*)statusp)); 2080 sv = hv_iterval(pidstatus,entry); 2081 *statusp = SvIVX(sv); 2082 sprintf(spid, "%d", pid); 2083 (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); 2084 return pid; 2085 } 2086 } 2087 #ifdef HAS_WAITPID 2088 # ifdef HAS_WAITPID_RUNTIME 2089 if (!HAS_WAITPID_RUNTIME) 2090 goto hard_way; 2091 # endif 2092 return waitpid(pid,statusp,flags); 2093 #endif 2094 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) 2095 return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); 2096 #endif 2097 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) 2098 hard_way: 2099 { 2100 I32 result; 2101 if (flags) 2102 croak("Can't do waitpid with flags"); 2103 else { 2104 while ((result = wait(statusp)) != pid && pid > 0 && result >= 0) 2105 pidgone(result,*statusp); 2106 if (result < 0) 2107 *statusp = -1; 2108 } 2109 return result; 2110 } 2111 #endif 2112 } 2113 #endif /* !DOSISH */ 2114 2115 void 2116 /*SUPPRESS 590*/ 2117 pidgone(pid,status) 2118 int pid; 2119 int status; 2120 { 2121 register SV *sv; 2122 char spid[TYPE_CHARS(int)]; 2123 2124 sprintf(spid, "%d", pid); 2125 sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE); 2126 (void)SvUPGRADE(sv,SVt_IV); 2127 SvIVX(sv) = status; 2128 return; 2129 } 2130 2131 #if defined(atarist) || defined(OS2) || defined(DJGPP) 2132 int pclose(); 2133 #ifdef HAS_FORK 2134 int /* Cannot prototype with I32 2135 in os2ish.h. */ 2136 my_syspclose(ptr) 2137 #else 2138 I32 2139 my_pclose(ptr) 2140 #endif 2141 PerlIO *ptr; 2142 { 2143 /* Needs work for PerlIO ! */ 2144 FILE *f = PerlIO_findFILE(ptr); 2145 I32 result = pclose(f); 2146 PerlIO_releaseFILE(ptr,f); 2147 return result; 2148 } 2149 #endif 2150 2151 void 2152 repeatcpy(to,from,len,count) 2153 register char *to; 2154 register char *from; 2155 I32 len; 2156 register I32 count; 2157 { 2158 register I32 todo; 2159 register char *frombase = from; 2160 2161 if (len == 1) { 2162 todo = *from; 2163 while (count-- > 0) 2164 *to++ = todo; 2165 return; 2166 } 2167 while (count-- > 0) { 2168 for (todo = len; todo > 0; todo--) { 2169 *to++ = *from++; 2170 } 2171 from = frombase; 2172 } 2173 } 2174 2175 #ifndef CASTNEGFLOAT 2176 U32 2177 cast_ulong(f) 2178 double f; 2179 { 2180 long along; 2181 2182 #if CASTFLAGS & 2 2183 # define BIGDOUBLE 2147483648.0 2184 if (f >= BIGDOUBLE) 2185 return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000; 2186 #endif 2187 if (f >= 0.0) 2188 return (unsigned long)f; 2189 along = (long)f; 2190 return (unsigned long)along; 2191 } 2192 # undef BIGDOUBLE 2193 #endif 2194 2195 #ifndef CASTI32 2196 2197 /* Unfortunately, on some systems the cast_uv() function doesn't 2198 work with the system-supplied definition of ULONG_MAX. The 2199 comparison (f >= ULONG_MAX) always comes out true. It must be a 2200 problem with the compiler constant folding. 2201 2202 In any case, this workaround should be fine on any two's complement 2203 system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your 2204 ccflags. 2205 --Andy Dougherty <doughera@lafcol.lafayette.edu> 2206 */ 2207 2208 /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead 2209 of LONG_(MIN/MAX). 2210 -- Kenneth Albanowski <kjahds@kjahds.com> 2211 */ 2212 2213 #ifndef MY_UV_MAX 2214 # define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1) 2215 #endif 2216 2217 I32 2218 cast_i32(f) 2219 double f; 2220 { 2221 if (f >= I32_MAX) 2222 return (I32) I32_MAX; 2223 if (f <= I32_MIN) 2224 return (I32) I32_MIN; 2225 return (I32) f; 2226 } 2227 2228 IV 2229 cast_iv(f) 2230 double f; 2231 { 2232 if (f >= IV_MAX) 2233 return (IV) IV_MAX; 2234 if (f <= IV_MIN) 2235 return (IV) IV_MIN; 2236 return (IV) f; 2237 } 2238 2239 UV 2240 cast_uv(f) 2241 double f; 2242 { 2243 if (f >= MY_UV_MAX) 2244 return (UV) MY_UV_MAX; 2245 return (UV) f; 2246 } 2247 2248 #endif 2249 2250 #ifndef HAS_RENAME 2251 I32 2252 same_dirent(a,b) 2253 char *a; 2254 char *b; 2255 { 2256 char *fa = strrchr(a,'/'); 2257 char *fb = strrchr(b,'/'); 2258 struct stat tmpstatbuf1; 2259 struct stat tmpstatbuf2; 2260 SV *tmpsv = sv_newmortal(); 2261 2262 if (fa) 2263 fa++; 2264 else 2265 fa = a; 2266 if (fb) 2267 fb++; 2268 else 2269 fb = b; 2270 if (strNE(a,b)) 2271 return FALSE; 2272 if (fa == a) 2273 sv_setpv(tmpsv, "."); 2274 else 2275 sv_setpvn(tmpsv, a, fa - a); 2276 if (Stat(SvPVX(tmpsv), &tmpstatbuf1) < 0) 2277 return FALSE; 2278 if (fb == b) 2279 sv_setpv(tmpsv, "."); 2280 else 2281 sv_setpvn(tmpsv, b, fb - b); 2282 if (Stat(SvPVX(tmpsv), &tmpstatbuf2) < 0) 2283 return FALSE; 2284 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && 2285 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; 2286 } 2287 #endif /* !HAS_RENAME */ 2288 2289 UV 2290 scan_oct(start, len, retlen) 2291 char *start; 2292 I32 len; 2293 I32 *retlen; 2294 { 2295 register char *s = start; 2296 register UV retval = 0; 2297 bool overflowed = FALSE; 2298 2299 while (len && *s >= '0' && *s <= '7') { 2300 register UV n = retval << 3; 2301 if (!overflowed && (n >> 3) != retval) { 2302 warn("Integer overflow in octal number"); 2303 overflowed = TRUE; 2304 } 2305 retval = n | (*s++ - '0'); 2306 len--; 2307 } 2308 if (dowarn && len && (*s == '8' || *s == '9')) 2309 warn("Illegal octal digit ignored"); 2310 *retlen = s - start; 2311 return retval; 2312 } 2313 2314 UV 2315 scan_hex(start, len, retlen) 2316 char *start; 2317 I32 len; 2318 I32 *retlen; 2319 { 2320 register char *s = start; 2321 register UV retval = 0; 2322 bool overflowed = FALSE; 2323 char *tmp; 2324 2325 while (len-- && *s && (tmp = strchr(hexdigit, *s))) { 2326 register UV n = retval << 4; 2327 if (!overflowed && (n >> 4) != retval) { 2328 warn("Integer overflow in hex number"); 2329 overflowed = TRUE; 2330 } 2331 retval = n | (tmp - hexdigit) & 15; 2332 s++; 2333 } 2334 *retlen = s - start; 2335 return retval; 2336 } 2337 2338 2339 #ifdef HUGE_VAL 2340 /* 2341 * This hack is to force load of "huge" support from libm.a 2342 * So it is in perl for (say) POSIX to use. 2343 * Needed for SunOS with Sun's 'acc' for example. 2344 */ 2345 double 2346 Perl_huge() 2347 { 2348 return HUGE_VAL; 2349 } 2350 #endif 2351