util.c

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