util.c

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