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