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