util.c

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