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